#xyzzy の curl バインディング (PoC)

gistfile1.lisp

;; xyzzy の curl バインディング (PoC)
;;
;; http://curl.haxx.se/
;; http://www.gknw.net/mirror/curl/win32/curl-7.23.1-ssl-sspi-zlib-static-bin-w32.zip

;; curl.h
(defconstant CURLOPTTYPE_LONG          0)
(defconstant CURLOPTTYPE_OBJECTPOINT   10000)
(defconstant CURLOPTTYPE_FUNCTIONPOINT 20000)
(defconstant CURLOPTTYPE_OFF_T         30000)

(defmacro CINIT (name type number)
  (flet ((mksym (&rest args)
           (intern (format nil "~{~A~}" args))))
    `(defconstant ,(mksym "CURLOPT_" name) (+ ,(mksym "CURLOPTTYPE_" type) ,number))))

(CINIT FILE OBJECTPOINT 1)
(CINIT URL  OBJECTPOINT 2)
(CINIT WRITEFUNCTION FUNCTIONPOINT 11)
(CINIT FOLLOWLOCATION LONG 52)

(defconstant CURLOPT_WRITEDATA CURLOPT_FILE)

;; easy.h
(c:define-dll-entry (c:void *)
  curl_easy_init ()
  "libcurl")

(c:define-dll-entry (c:void *)
  curl_easy_setopt ((c:void *)
                    c:int
                    (c:void *))
  "libcurl")

(c:define-dll-entry
  c:int
  curl_easy_perform ((c:void *))
  "libcurl")

(c:define-dll-entry
  c:void
  curl_easy_cleanup ((c:void *))
  "libcurl")

;; stdio.h
(c:define-dll-entry
  (c:void *)
  fopen ((c:char *) (c:char *))
  "msvcrt")

(c:define-dll-entry
  c:int
  fclose ((c:void *))
  "msvcrt")


(defmacro with-curl-easy ((var) &body body)
  `(let ((,var (curl_easy_init)))
     (unwind-protect
         (progn ,@body)
       (curl_easy_cleanup ,var))))
(setf (get 'with-curl-easy 'ed:lisp-indent-hook) 1)

(defmacro with-open-file-handle ((var filename mode) &body body)
  `(let ((,var (fopen (si:make-string-chunk ,filename)
                      (si:make-string-chunk ,mode))))
     (unwind-protect
         (progn ,@body)
       (fclose ,var))))
(setf (get 'with-open-file-handle 'ed:lisp-indent-hook) 1)


(defvar *curl-write-function-impl*)
;; size_t fwrite(const void *buf, size_t size, size_t n, FILE *fp);
(c:defun-c-callable
  c:size_t
  curl-write-function (((c:void *) buf)
                       (c:size_t size)
                       (c:size_t n)
                       ((c:void *) data))
  (if *curl-write-function-impl*
      (funcall *curl-write-function-impl*
               buf size n data)
    0))

(defmacro with-curl-write-function ((content) write-form &body body)
  (alexandria:with-gensyms (buf size n data bytes)
    `(let ((*curl-write-function-impl*
            #'(lambda (,buf ,size ,n ,data)
                (let ((,bytes (* ,size ,n)))
                  (let ((,content (when (and (not (zerop ,buf))
                                             (not (zerop ,bytes)))
                                    (si:unpack-string (si:make-chunk nil ,bytes nil ,buf)
                                                      0 ,bytes nil))))
                    (let ((r (progn ,write-form)))
                      (if (integerp r)
                          r
                        ,bytes)))))))
       (curl_easy_setopt curl CURLOPT_WRITEFUNCTION #'curl-write-function)
       ,@body)))
(setf (get 'with-curl-write-function 'ed:lisp-indent-hook) 2)

(defun curl-get (url)
  (with-curl-easy (curl)
    (curl_easy_setopt curl CURLOPT_URL (si:make-string-chunk url))
    (curl_easy_setopt curl CURLOPT_WRITEDATA 0)
    (with-output-to-string (s)
      (with-curl-write-function (content)
          (princ content s)
        (curl_easy_perform curl)))))


(defun curl-download (url path)
  (with-curl-easy (curl)
    (curl_easy_setopt curl CURLOPT_URL (si:make-string-chunk url))
    (with-open-file-handle (file path "wb")
      (curl_easy_setopt curl CURLOPT_WRITEDATA file)
      (curl_easy_setopt curl CURLOPT_FOLLOWLOCATION 1)
      (curl_easy_perform curl))))



;;; test

;; sjis
(curl-get "http://www.jsdlab.co.jp/~kamei/")

;; utf-8
(ed::convert-encoding-to-internal
 *encoding-utf8n*
 (curl-get "http://www.yahoo.co.jp/"))

;; euc-jp
(ed::convert-encoding-to-internal
 *encoding-euc-jp*
 (curl-get "http://d.hatena.ne.jp/miyamuko/"))

(curl-download "http://www.jsdlab.co.jp/~kamei/cgi-bin/download.cgi"
               "c:/xyzzy-0.2.2.235.tar.gz")

; 同期型なのでダウンロードが完了するまで返ってこない
; もちろん Ctrl-g も効かない
; (curl-download "http://cdimage.debian.org/debian-cd/6.0.3/multi-arch/iso-cd/debian-6.0.3-amd64-i386-netinst.iso"
;                "c:/debian-6.0.3-amd64-i386-netinst.iso")