Quicklisp のメモ

Quicklisp を使ってみたときのメモ。

私の環境が Debian パッケージの SBCL がインストールされている環境で clbuid の SBCL を使っている関係か、いくつが問題があったのでメモしておく。

#|
ASDF could not load sb-posix because Not an absolute pathname #P"~/.clc/systems/".
なんていうエラーがでた。
これは Debian の common-lisp-controller がおかしい（？）ような気がするので、
次のようにファイルを2つほど削除する。

% cd /etc/common-lisp/source-registry.conf.d
% sudo rm 02-common-lisp-controller-userdir.conf common-lisp-controller-userdir.conf


~/.emacs で slime-setup に slime-asdf があると asdf-utilities がないと怒られたので、
slime-asdf はコメントアウトした。

    (slime-setup '(slime-repl
                   ;;slime-asdf
                   slime-fancy
                   slime-indentation
                   slime-references
                   slime-tramp
                   slime-banner))
|#


;; インストール
(load "/tmp/quicklisp.lisp")
(quicklisp-quickstart:install)
(ql:add-to-init-file)

#|
(ql:add-to-init-file) で ~/.sbclrc に次が追加される。
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
                                       (user-homedir-pathname))))
  (when (probe-file quicklisp-init)
    (load quicklisp-init)))
|#


#|
あとは個人的なプロジェクトも追加したいのだけど、

You will be able to make your own private repositories of Quicklisp software (called dists), but it's not documented right now.

の意味がよく分からない。
|#

cl-twitter で OAuth

cl-twitter で OAuth ってこれどあってるのか？

いきなり cl-twitter へのパッチ。

~/letter/lisp/clbuild/source/cl-twitter% darcs whatsnew
hunk ./elements.lisp 32
-        (record-type-args name args)
+        (record-type-args ',name args)
hunk ./twitter.lisp 49
-                                 url access-token (oauth:token-consumer (twitter-user-access-token *twitter-user*))
+                                 url access-token
+                                  :consumer-token (oauth:token-consumer (or access-token
+                                                                            (twitter-user-access-token *twitter-user*)))
+;;                                  :consumer-token (oauth:token-consumer (or (getf (getf args :auth) :oauth)
+;;                                                                            (twitter-user-access-token *twitter-user*)))
hunk ./twitter.lisp 154
-                                      (oauth:token-consumer request-token)
-                                      request-token))
+                                       request-token
+                                      :consumer-token (oauth:token-consumer request-token)))

OAuth するために http://twitter.com/apps で consumer key と consumer secret を取得する。その後、次のコードで動かせた。

#|
http://twitter.com/apps で consumer key と consumer secret を取得する
|#
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :cl-twitter))

(defpackage :try-cl-twitter
  (:use :cl))

(in-package :try-cl-twitter)

(setf twit::*consumer-key* "aaaaaaaaaaaaaaaaaa"
      twit::*consumer-secret* "bbbbbbbbbbbbbbbbbbbbbbbbbbbb")

(setf (values url request-token)
      (twit:oauth-make-twitter-authorization-uri))
;; => #<PURI:URI http://twitter.com/oauth/authorize?&oauth_token=ccccccccccccccccccccccccccc>
;;#<CL-OAUTH:REQUEST-TOKEN
;;  :CONSUMER #<CL-OAUTH:CONSUMER-TOKEN
;;  :KEY "aaaaaaaaaaaaaaaaaa"
;;  :SECRET "bbbbbbbbbbbbbbbbbbbbbbbbbbbb"
;;  :USER-DATA NIL
;;  :LAST-TIMESTAMP 0>
;;  :KEY "ccccccccccccccccccccccccccc"
;;  :SECRET "ddddddddddddddddddddddddddddddddd"
;;  :USER-DATA (("oauth_callback_confirmed" . "true"))
;;  :CALLBACK-URI NIL
;;  :VERIFICATION-CODE "verification_code"
;;  :AUTHORIZED-P NIL>

;; url にブラウザでアクセスし PIN コードを↓に設定
(setf (oauth::request-token-verification-code request-token) "5512017")

;; request-token から access-token を
(twit:oauth-authenticate-user (oauth:token-key request-token))
;; => #<TWITTER-USER 'quek'>

(twit::twitter-user-access-token (twit::get-user "quek"))
;; => #<CL-OAUTH:ACCESS-TOKEN
;;  :CONSUMER #<CL-OAUTH:CONSUMER-TOKEN
;;  :KEY "aaaaaaaaaaaaaaaaaa"
;;  :SECRET "bbbbbbbbbbbbbbbbbbbbbbbbbbbb"
;;  :USER-DATA NIL
;;  :LAST-TIMESTAMP 0>
;;  :KEY "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee"
;;  :SECRET "ffffffffffffffffffffffffffffffff"
;;  :USER-DATA (("user_id" . "4344931") ("screen_name" . "quek"))
;;  :SESSION-HANDLE NIL
;;  :EXPIRES NIL
;;  :AUTHORIZATION-EXPIRES NIL
;;  :ORIGIN-URI "http://twitter.com/oauth/access_token">

;; 以上で、アクセストークンが取得できた。



;; 次からは consumer key, consumer secret, access-token key, access-token secret で
(setf access-token (oauth:make-access-token
                            :consumer (oauth:make-consumer-token
                                       :key "aaaaaaaaaaaaaaaaaa"
                                       :secret "bbbbbbbbbbbbbbbbbbbbbbbbbbbb")
                            :key "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee"
                            :secret "ffffffffffffffffffffffffffffffff"))

(setf twit:*twitter-user* (twit:twitter-op :user-show :id "quek" :auth (list :oauth access-token)))
;; => #<TWITTER-USER 'quek'>

(setf (twit::twitter-user-access-token twit:*twitter-user*) access-token)q

(twit:friends-timeline)

(twit:update "まみむめも♪")

あってる気がしない。もっとスマートな方法は？

cl-typesetting で日本語出力

ちょっと前のことだけど cl-typesetting（CL-PDF）で日本語出力できるようにしてみた。

http://github.com/quek/cl-pdf-jp

かろうじて日本語フォントが使える程度だけど、ないよりはましでしょ？

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :cl-typesetting))

(defpackage :try-cl-typesetting
    (:use :cl :typeset))

(in-package :try-cl-typesetting)

(defun hello (&optional (file #P"/tmp/hello.pdf"))
  (pdf:with-document ()
    (pdf:with-page ()
      (pdf:with-outline-level ("Example" (pdf:register-page-reference))
        (pdf:set-line-width 0.1)
        (let ((content
               (compile-text ()
                 (vspace 100)
                 (paragraph (:h-align :left :font "GothicBBB-Medium" :font-size 40 :color '(0.0 0 0.8))
                   "ばーあ。羊は「かる」。ばーばー羊。永い羊。ばーばー羊。永い羊。ばーばー羊。永い羊。ばーばー羊。永い羊。"
                   :eol
                   (vspace 2)
                   (hrule :dy 1)
                   (with-style (:font "Times-Italic" :font-size 26)
                     "The cool Common Lisp typesetting system")
                   (vspace 50)
                   (with-style (:font "Ryumin-Light" :font-size 30)
                     "こんにちは、市民！ばくです。")
                   (with-style (:font "Times-Roman" :font-size 30)
                     "Hello World!")
                   (with-style (:font "GothicBBB-Medium" :font-size 30)
                     "こんにちは、市民！ばくです。")
                   (with-style (:font "Ryumin-Light" :font-size 30)
                     "こんにちは、市民！ばくです。")
                   (vspace 50)
                   (with-style (:font "Helvetica" :font-size 12)
                     "hello" (typeset::dotted-hfill) "4.2" :eol
                     "hello world" (typeset::dotted-hfill) "4.2.4.2"))
                 (paragraph (:h-align :justified :font "Helvetica" :font-size 12 :color '(0.0 0 0.0))
                   "hello" (typeset::dotted-hfill) "4.2" :eol
                   "hello world" (typeset::dotted-hfill) "4.2.4.2")
                 (vspace 50)
                 (paragraph (:h-align :justified :font "Helvetica" :font-size 12 :color '(0.0 0 0.0))
                   "hello" (typeset::dotted-hfill :pattern-spacing 0.6) "4.2" :eol
                   "hello world" (typeset::dotted-hfill :pattern-spacing 0.6) "4.2.4.2")
                 (vspace 50)
                 (paragraph (:h-align :justified :font "Helvetica" :font-size 12 :color '(0.0 0 0.0))
                   "hello" (typeset::dotted-hfill :char-pattern ".+" :pattern-spacing 0) "4.2" :eol
                   "hello world" (typeset::dotted-hfill :char-pattern ".+" :pattern-spacing 0) "4.2.4.2"))))
          (typeset::draw-block content 20 800 545 700))))
    (pdf:write-document file))
  (asdf:run-shell-command (format nil "evince ~a" file)))

CLSQL で MySQL につなぐ

いつも忘れるのでメモ。

#|
cffi ではなく uffi を使うこと。
|#
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :clsql))

(defpackage :clsqlを使う
  (:use :cl :clsql :clsql-sys))

(in-package :clsqlを使う)

(defun test ()
  (connect '("localhost" "blog_development" "root" "") :database-type :mysql)
  (execute-command "set character_set_client='utf8'")
  (execute-command "set character_set_connection='utf8'")
  (execute-command "set character_set_results='utf8'")
  (print (query "show variables like 'char%'"))
  (print (query "select * from posts"))
  (disconnect))

#|
disconnect でエラーになったので

diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp
index eef9f42..76803e9 100644
--- a/db-mysql/mysql-sql.lisp
+++ b/db-mysql/mysql-sql.lisp
@@ -219,7 +219,8 @@

 (defmethod database-disconnect ((database mysql-database))
   (mysql-close (database-mysql-ptr database))
-  (setf (database-mysql-ptr database) nil)
+  ;;(setf (database-mysql-ptr database) nil)
+  (setf (database-mysql-ptr database) (uffi:make-null-pointer 'mysql-mysql))
   t)

 (defmethod database-execute-command (sql-expression (database mysql-database))
|#

Common Lisp でメール送信

g000001 さんに元となるソースコードをもらって、 Common Lisp でメール送信するする関数を書いてみた。

cl-smtp を使ったけど、その内部で使われている FLEXI-STREAMS が iso-2022-jp に対応していない。そこは適当にだまくらかした。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (asdf:oos 'asdf:load-op :trivial-shell)
  (asdf:oos 'asdf:load-op :cl-smtp))

(defpackage :メール送信
  (:use :cl))

(in-package :メール送信)

(defun encode-subject (subject)
  (let ((subject (trivial-shell:shell-command
                  "nkf -M"
                  :input (trivial-shell:shell-command
                          "nkf -j"
                          :input subject))))
    (subseq subject 0 (1- (length subject)))))
;; (encode-subject "あいう")

(defun encode-message (message)
  (trivial-shell:shell-command "nkf -j"
                               :input (format nil "~a~%" message)))
;; (encode-message "あいう")

;; flexi-streams をだます。
(pushnew '(:iso-2022-jp . :utf-8) flex::+name-map+ :test #'equal)

(defun send-mail (host from to subject message)
  (let ((subject (encode-subject subject))
        (message (encode-message message)))
    (cl-smtp:send-email host from to subject message
                        :external-format :iso-2022-jp
                        :extra-headers '(("Content-Transfer-Encoding" "7bit")))))
#|
(send-mail "localhost" "read.eval.print+from@gmail.com" "read.eval.print+to@gmail.com" "テスト" "テストです。")
|#

(series::install) して (declare (optimizable-series-function)) する

(series::install) して (declare (optimizable-series-function)) すると下のコードのようにおもしろいことがおきる。

(series::install) で defun は SERIES::DEFUN になり、 (declare (optimizable-series-function)) で SERIES::DEFUN したものは、マクロ展開されてしまう。

始めて collect-xxx 系をマクロ展開してみたときの驚きは忘れられない。

(series::install)

(defun scan-string-bytes (string &optional (external-format :default))
  (declare (optimizable-series-function))
  (scan (sb-ext:string-to-octets string :external-format external-format)))

(scan-string-bytes "あいう")
;; => #Z(227 129 130 227 129 132 227 129 134)

(functionp #'scan-string-bytes)
;; => T
(macro-function 'scan-string-bytes)
;; => NIL
(macroexpand-1 '(scan-string-bytes "あいう"))
;; => (SCAN-STRING-BYTES "あいう")
;; NIL

(collect-first (scan-string-bytes "あいう"))
;; => 227

(macroexpand-1 '(collect-first (scan-string-bytes "あいう")))
;; => (COMMON-LISP:LET* ((#:OUT-940
;;                    (STRING-TO-OCTETS "あいう" :EXTERNAL-FORMAT :DEFAULT)))
;;  (COMMON-LISP:LET (#:ELEMENTS-941
;;                    #:LISTPTR-938
;;                    #:TEMP-937
;;                    (#:LIMIT-936 0)
;;                    (#:INDEX-935 -1)
;;                    #:LSTP-934
;;                    (#:ITEM-933 NIL))
;;    (DECLARE (TYPE LIST #:LISTPTR-938)
;;             (TYPE SERIES::VECTOR-INDEX+ #:LIMIT-936)
;;             (TYPE SERIES::-VECTOR-INDEX #:INDEX-935)
;;             (TYPE BOOLEAN #:LSTP-934)
;;             (TYPE (SERIES::NULL-OR T) #:ITEM-933))
;;    (LOCALLY
;;     (DECLARE (TYPE ARRAY #:TEMP-937))
;;     (IF (SETQ #:LSTP-934 (LISTP #:OUT-940))
;;         (SETQ #:LISTPTR-938 #:OUT-940
;;               #:TEMP-937 #())
;;         (LOCALLY
;;          (DECLARE (TYPE ARRAY #:OUT-940))
;;          (SETQ #:TEMP-937 #:OUT-940)
;;          (SETQ #:LIMIT-936
;;                  (SERIES::ARRAY-FILL-POINTER-OR-TOTAL-SIZE #:OUT-940))))
;;     (TAGBODY
;;      #:LL-947
;;       (IF #:LSTP-934
;;           (PROGN
;;            (IF (ENDP #:LISTPTR-938)
;;                (GO SERIES::END))
;;            (SETQ #:ELEMENTS-941 (CAR #:LISTPTR-938))
;;            (SETQ #:LISTPTR-938 (CDR #:LISTPTR-938)))
;;           (PROGN
;;            (INCF #:INDEX-935)
;;            (LOCALLY
;;             (DECLARE (TYPE ARRAY #:OUT-940)
;;                      (TYPE SERIES::VECTOR-INDEX #:INDEX-935))
;;             (IF (>= #:INDEX-935 #:LIMIT-936)
;;                 (GO SERIES::END))
;;             (SETQ #:ELEMENTS-941
;;                     (THE SERIES::*TYPE*
;;                          (ROW-MAJOR-AREF #:OUT-940 #:INDEX-935))))))
;;       (SETQ #:ITEM-933 #:ELEMENTS-941)
;;      SERIES::END)
;;     #:ITEM-933)))
;;T

-

毎日ブログを書いてみようかな、と思ったので、書いてみる。内容よりも継続することを重視で。

たいていの言語には単項演算子の - と二項演算子の - の2つがある。 Common Lisp には関数の - が1つだけある。

(- 3)
;; => -3
(- 3 2)
;; => 1

;; (- 3) は油断するとこんなふうに書いてしまう。
(- 0 3)
;; => -3