Common Lisp で css を書く時に #000 などどう書けばいいか悩んでいたけど、バックスラッシュでエスケープすればいい、という結論にたどりついた。
そんなわけでやっと書けた。 https://github.com/quek/info.read-eval-print.css
(in-package :info.read-eval-print.css) (with-output-to-string (*css-output*) (css `((\#foo :color \#ccc (.bar :margin 1px 2px 0 0 :font-size 12px)) (a\:hover :color yellow)))) ;;⇒ "#foo{color:#ccc;} ;; #foo .bar{margin:1px 2px 0 0;font-size:12px;} ;; a:hover{color:yellow;}"
Slime では C-c C-c でカーソル位置の defun などをコンパイルする。それと同じように C-c C-f でカーソル位置の FiveAM テストを実行したかったので書いてみた。
(defun slime-fiveam-debug-test ()
"fiveam:debug!"
(interactive)
(slime-interactive-eval
(format "(fiveam:debug! %s)" (slime-defun-at-point))))
(define-key slime-mode-map
[(control ?c) (control ?f)] 'slime-fiveam-debug-test)
ちゃんと動く?
cl:read と cl:read-preserving-whitespace を上書いちゃいえばできるはずなのでやってみた。
(defvar *cl-read* #'cl:read)
(defvar *cl-read-preserving-whitespace* #'cl:read-preserving-whitespace)
(defvar *readtable-hash* (make-hash-table))
(defmacro with-package-readtable (&body body)
`(let ((*readtable* (gethash *package* *readtable-hash* *readtable*)))
,@body))
(sb-ext:without-package-locks
(defun read (&optional (stream *standard-input*)
(eof-error-p t)
(eof-value nil)
(recursive-p nil))
"Read the next Lisp value from STREAM, and return it."
(with-package-readtable
(funcall *cl-read* stream eof-error-p eof-value recursive-p)))
(defun read-preserving-whitespace (&optional (stream *standard-input*)
(eof-error-p t)
(eof-value nil)
(recursive-p nil))
"Read from STREAM and return the value read, preserving any whitespace
that followed the object."
(with-package-readtable
(funcall *cl-read-preserving-whitespace*
stream
eof-error-p
eof-value
recursive-p))))
(defmacro set-package-readtable (package readtable)
"package の readtable を指定する。"
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (gethash (find-package ,package) *readtable-hash*)
,readtable)))
(defmacro clear-package-readtable (package)
"package の readtable を指定を解除する。"
`(eval-when (:compile-toplevel :load-toplevel :execute)
(remhash (find-package ,package) *readtable-hash*)))
package をキーに *readtable* を束縛して元の read, read-preserving-whitespace を呼ぶ。
(defpackage :foo
(:use :cl))
(defpackage :bar
(:use :cl))
(info.read-eval-print.read:set-package-readtable
:bar
;; お好みの readtable をご用意ください
(info.read-eval-print.read.triple-quote:make-readtable))
(in-package :foo)
(list """#,(+ 1 2)""")
;;⇒ ("" "#,(+ 1 2)" "")
(in-package :bar)
(list """#,(+ 1 2)""")
;;⇒ ("3")
(info.read-eval-print.read:clear-package-readtable :bar)
(list """#,(+ 1 2)""")
;;⇒ ("" "#,(+ 1 2)" "")
cl:read と cl:read-preserving-whitespace を上書くという邪道なことをやっているので Slime でも思ったとおり動いてくれる。
(ql:quickload :info.read-eval-print.sed)
(ql:quickload :trivial-shell)
(use-package :info.read-eval-print.sed)
(let ((odd-total 0)
(even-total 0))
(with-input-from-string (in (trivial-shell:shell-command "ls -l /tmp"))
(sed (:in in :n t)
(when ($ 5)
(let (($5 (parse-integer ($ 5))))
(if (oddp (parse-integer ($ 2)))
(incf odd-total $5)
(incf even-total $5))))))
(values odd-total even-total))
Common Lisp でサーバプログラムを書いている時、エラーは (handler-case ... (error (e) ...) って感じで全てにぎりつぶしたい。
でも、そうすると開発中はデバッガ起動しなくて困る。
どうしよう・・・ということで Hunchentoot のソース読んでみた。 with-simple-restart で invoke-debugger をかこめばいいみたい。
次のようにすると変数1つでデバッガの起動するしないを切り替えられるんだね。
(defvar *invoke-debugger-p* t)
(defun my-debugger (e)
(when *invoke-debugger-p*
(with-simple-restart (continue "Return from here.")
(invoke-debugger e))))
(defmacro with-debugger (&body body)
`(handler-bind ((error #'my-debugger))
,@body))
;; サーバのループ処理イメージ
(loop for socket = (accept)
do (handler-case
(with-debugger (call socket))
(error (e)
(error-handle e))))
*invoke-debugger-p* を t にしておけばエラー発生時にデバッガがあがる。そのデバッガで Continue リスタートを選べば handler-case により error-handle がちゃんと呼ばれる。
invoke-debugger はそのままだと処理が戻らないから with-simple-restart でかこんであげるってことだね。
Common Lisp といえばマクロ。マクロのいきつく先といえばコードウォーカー。ということで hu.dwim.walker というコードウォーカ一を使ってみた。
使い方としては次のような感じ。
cl-json を使うと次のように JSON をデコードできる。
(json:decode-json-from-string "{\"a\": 1, \"b\": {\"bb\": 2}, \"c\": 3}")
;;⇒ ((:A . 1) (:B (:BB . 2)) (:C . 3))
これに対する assoc をちまち書きたくないので、シンボル1つで次のように展開されるマクロを書いてみる。
@a ⇒ (ASSOC "A" '((:A . 1) (:B (:BB . 2)) (:C . 3)) :TEST #'STRING-EQUAL)
@b.bb ⇒ (CDR (ASSOC "BB"
(CDR (ASSOC "B" '((:A . 1) (:B (:BB . 2)) (:C . 3)) :TEST #'STRING-EQUAL))
:TEST #'STRING-EQUAL))
これだけなら S式を単純に置換していくだけでも可能だけど
となるとコードウォーカーが必要になる。
ちゃんとしたドキュメントとかないようなので、テストやソースを見ながら書いたのがこれ。
(ql:quickload "hu.dwim.walker")
(ql:quickload "cl-json")
(ql:quickload "split-sequence")
(defun symbol-to-assoc-form (symbol decoded)
(let ((names (split-sequence:split-sequence #\. (subseq (symbol-name symbol) 1))))
(hu.dwim.walker:walk-form
(reduce (lambda (acc x)
`(cdr (assoc ,x ,acc :test #'string-equal)))
names
:initial-value decoded))))
(defun free-and-@-p (form)
(and (typep form 'hu.dwim.walker:free-variable-reference-form)
(char= #\@ (char (symbol-name (hu.dwim.walker:name-of form)) 0))))
(defun walk-with-json-body (decoded form env)
(let* ((walked (hu.dwim.walker:walk-form form
:environment (hu.dwim.walker:make-walk-environment env)))
(walked (hu.dwim.walker:rewrite-ast
walked
(lambda (parent field form)
(declare (ignore parent field))
(if (free-and-@-p form)
(symbol-to-assoc-form (hu.dwim.walker:name-of form) decoded)
form)))))
(hu.dwim.walker:unwalk-form walked)))
(defmacro with-json (json &body body &environment env)
(let ((decoded (gensym)))
`(let ((,decoded (json:decode-json-from-string ,json)))
,@(mapcar (lambda (form)
(walk-with-json-body decoded form env))
body))))
;; @a と @b.bb は json の値 1, 2 に @c は let の 999 になる。
;; with-json がネストしてても問題ない。
(with-json "{\"a\": 1, \"b\": {\"bb\": 2}, \"c\": 3}"
(let ((@c 999))
(list @a @b.bb @c
(with-json "{\"a\": 10, \"b\": {\"bb\": 20}, \"c\": 30}"
(let ((@c 9990))
(list @a @b.bb @c))))))
;;⇒ (1 2 999 (10 20 9990))
cl-mongo があるのは知っていましたが、それでも Common Lisp の MongoDB ドライバを作ってみました。
Quicklisp には入ってません。
いろいろ足りないかもしれませんが、とりあえず動きます。仕事でログ解析に使ったりしています。
;; 他にも https://github.com/quek/ の下にある何かが必要かも・・・
(eval-when (:compile-toplevel :load-toplevel :execute)
;; https://github.com/quek/info.read-eval-print.bson
(ql:quickload :info.read-eval-print.bson)
;; https://github.com/quek/info.read-eval-print.mongo
(ql:quickload :info.read-eval-print.mongo))
(defpackage :mongo
(:use :cl)
;; SBCL の local-nicknames を使ってみたりする。これいいよね。
(:local-nicknames (:m :info.read-eval-print.mongo)
(:b :info.read-eval-print.bson)))
(in-package :mongo)
(defvar *connection* (m:connect "localhost:27017"))
;;⇒ *CONNECTION*
(defvar *db* (m:db *connection* "test"))
;;⇒ *DB*
(defvar *foo* (m:collection *db* "foo"))
;;⇒ *FOO*
;; 登録する
(loop for i from 1 to 10
do (m:insert *foo* (b:bson :a "hello" :b i)))
(m:insert *foo* (b:bson :a "world" :b 1))
;; 検索する。Series を使う。
(series:collect (m:scan-mongo *foo* nil))
;;⇒ ({"_id": ObjectId("51734E4BCF15ED0A74C21E61"), "a": "hello", "b": 1}
;; {"_id": ObjectId("51734E4BCF15ED0A74C21E62"), "a": "hello", "b": 2}
;; {"_id": ObjectId("51734E4BCF15ED0A74C21E63"), "a": "hello", "b": 3}
;; {"_id": ObjectId("51734E4BCF15ED0A74C21E64"), "a": "hello", "b": 4}
;; {"_id": ObjectId("51734E4BCF15ED0A74C21E65"), "a": "hello", "b": 5}
;; {"_id": ObjectId("51734E4BCF15ED0A74C21E66"), "a": "hello", "b": 6}
;; {"_id": ObjectId("51734E4BCF15ED0A74C21E67"), "a": "hello", "b": 7}
;; {"_id": ObjectId("51734E4BCF15ED0A74C21E68"), "a": "hello", "b": 8}
;; {"_id": ObjectId("51734E4BCF15ED0A74C21E69"), "a": "hello", "b": 9}
;; {"_id": ObjectId("51734E4BCF15ED0A74C21E6A"), "a": "hello", "b": 10}
;; {"_id": ObjectId("51734E4DCF15ED0A74C21E6B"), "a": "world", "b": 1})
(series:collect (m:scan-mongo *foo* (b:bson (m:$< :b 3) :a "hello")))
;;⇒ ({"_id": ObjectId("51734E4BCF15ED0A74C21E61"), "a": "hello", "b": 1}
;; {"_id": ObjectId("51734E4BCF15ED0A74C21E62"), "a": "hello", "b": 2})
oauth2 は https://github.com/Neronus/oauth2 を使う。
(defpackage oauth2.test.google-analytics
(:use :cl :oauth2))
(in-package oauth2.test.google-analytics)
(defparameter *token*
(oauth2::string->token ""
:refresh-token "your refresh token"
:scope "https://www.googleapis.com/auth/analytics.readonly"))
(defparameter *refreshed-token*
(oauth2:refresh-token "https://accounts.google.com/o/oauth2/token" *token*
:method :post
:scope "https://www.googleapis.com/auth/analytics.readonly"
:other `(("client_id" . "your client id")
("client_secret" . "your client secret"))))
(let ((drakma:*text-content-types* '(("application" . "json"))))
(json:decode-json-from-string
(request-resource "https://www.googleapis.com/analytics/v3/data/ga"
*refreshed-token*
:parameters ' (("ids" . "ga:999999999")
("metrics" . "ga:pageviews")
("dimensions" . "ga:pagePath")
("start-date" . "2013-01-01")
("end-date" . "2013-01-03")))))
これはいい。
http://www.sbcl.org/manual/index.html#Package_002dLocal-Nicknames
CL-USER> (defpackage :foo.bar.baz (:use :cl))
#<PACKAGE "FOO.BAR.BAZ">
CL-USER> (defparameter foo.bar.baz::foo 1)
FBZ::FOO
CL-USER> (defpackage :aaa (:use :cl))
#<PACKAGE "AAA">
CL-USER> (defpackage :bbb (:use :cl))
#<PACKAGE "BBB">
CL-USER> (sb-ext:add-package-local-nickname :fbz :foo.bar.baz :aaa)
#<PACKAGE "AAA">
CL-USER> (in-package :aaa)
#<PACKAGE "AAA">
AAA> fbz::foo
1
AAA> (in-package :bbb)
#<PACKAGE "BBB">
BBB> fbz::foo
; Evaluation aborted on #<SB-INT:SIMPLE-READER-PACKAGE-ERROR "Package ~A does not exist." {1005DE7C93}>.
BBB> (sb-ext:add-package-local-nickname :fbz :foo.bar.baz)
#<PACKAGE "BBB">
BBB> fbz::foo
1
最近 Common Lisp で MongoDB のドライバを書いたりしている。
restart-bind とか使ってカッコよく再接続したいのだけど、 try catch のエラーハンドリングから生長できない・・・
(defmacro with-reconnect-around (connection &key (max-retry-count 10) (retry-sleep 3))
(let ((retry-count (gensym "retry-count")))
`(loop for ,retry-count from 0
do (handler-case (progn
(unless (zerop ,retry-count)
(establish-connection ,connection))
(return (call-next-method)))
(error (e)
(when (< ,max-retry-count ,retry-count)
(signal e))
(warn "reconnecting... ~a" e)
(sleep ,retry-sleep)
(close ,connection))))))
(defmethod send :around ((self replica-set) op size function)
(with-reconnect-around self))
(defmethod send ((connection connection) op size function)
送信処理...)
このあたりを読んで、勉強しましょ。
cl-mongo を series で
(defun order-kv (order)
(cond ((null order)
nil)
((atom order)
(cl-mongo:kv order 1))
(t
(apply #'cl-mongo:kv
(mapcar (lambda (x)
(if (atom x)
(cl-mongo:kv x 1)
(cl-mongo:kv (car x)
(if (eq :desc (cadr x)) -1 1))))
order)))))
(series::defS scan-mongo (collection query &key (skip 0) (limit 0) order)
"scan mongoDB collection."
(series::fragl
;; args
((collection) (query) (skip) (limit) (order))
;; rets
((doc t))
;; aux
((doc t) (cursor t) (count integer))
;; alt
()
;; prolog
((setq count 0)
(setq cursor (cl-mongo:db.find
collection
(aif (order-kv order)
(cl-mongo:kv (cl-mongo:kv "query" query)
(cl-mongo:kv "orderby" it))
query)
:skip skip
:limit limit)))
;; body
(L
(setq doc (pop (cadr cursor)))
(unless doc
(push nil (cadr cursor))
(if (zerop (cl-mongo::db.iterator cursor))
(go series::end)
(progn
(incf count (nth 7 (car cursor)))
(if (and (plusp limit) (<= limit count))
(go series::end)
(progn
(setq cursor (cl-mongo:db.iter cursor :limit (- limit count)))
(pop (cadr cursor))
(go L)))))))
;; epilog
((cl-mongo:db.stop cursor))
;; wraprs
()
;; impure
nil))
として
(iterate ((doc (scan-mongo "logs.app" (cl-mongo:$> "_id" last-id))))
(foo doc))
な感じ。
Common Lisp で Amazon Glacier
https://github.com/quek/info.read-eval-print.aws.glacier
できた気するので、今度バックアップデータをアップロードしてみる。
たぶんアップロード時の description にファイル名とか日時とかサイズとか入れといた方がいい気がする。
(ql:quickload :info.read-eval-print.aws.glacier)
(in-package #:info.read-eval-print.aws.glacier)
(load "~/.info.read-eval-print.aws.glacier.lisp")
(list-vaults)
(create-vault "test-vault")
(describe-vault "test-vault")
(upload-archive "test-vault" "/tmp/a.txt" :description "upload-archive")
(upload-archive-multipart "test-vault" "~/archive/apache-solr-4.0.0-src.tgz" :description "multipart")
(list-jobs "test-vault")
(initiate-job "test-vault" :type :inventory-retrieval)
;⇒ "JOBID_EXAMPLEQUXFCTf0xdkZJxIri2id7ijxCKvnpBOCQL0mPIdiCkhjphjphjpdq9f0AAOaIcZm_"
(describe-job "test-vault" "JOBID_EXAMPLEQUXFCTf0xdkZJxIri2id7ijxCKvnpBOCQL0mPIdiCkhjphjphjpdq9f0AAOaIcZm_")
(get-job-output "test-vault" "JOBID_EXAMPLEQUXFCTf0xdkZJxIri2id7ijxCKvnpBOCQL0mPIdiCkhjphjphjpdq9f0AAOaIcZm_")
;; ファイルに保存する
(with-open-stream (in (get-job-output-stream "test-vault" "JOBID_EXAMPLEQUXFCTf0xdkZJxIri2id7ijxCKvnpBOCQL0mPIdiCkhjphjphjpdq9f0AAOaIcZm_"))
(with-open-file (out "/tmp/job-out" :direction :output :if-exists :supersede
:element-type '(unsigned-byte 8))
(alexandria:copy-stream in out :element-type '(unsigned-byte 8))))
ダウンロード時は :element-type '(unsigned-byte 8) を指定すること。
CL-WHO を使えばいいのだけど、デフォルトでエスケープされないのと、 Compojure の tag#id.class という書き方がうらやましかったで作った。
https://github.com/quek/info.read-eval-print.html
(html (:ul#foo.bar.baz
(loop for i from 1 to 3
do (html (:ul :data-value i (format nil "<~a>" i))))))
で次の出力になる。
<ul id="foo" class="bar baz">
<ul data-value="1">
<1>
</ul>
<ul data-value="2">
<2>
</ul>
<ul data-value="3">
<3>
</ul>
</ul>
CL-WHO を使っていた会社のブログをこれで書きなおしてやった。
こんな感じ。多値は。。。
(defgeneric scan% (thing &key &allow-other-keys))
(series::defS scan* (thing &rest args)
"generic scan."
(cl:let ((scan% `(scan% ,thing ,@args)))
(series::fragl
;; args
((thing t)
(scan% function))
;; rets
((value t))
;; aux
((value t)
(f function))
;; alt
()
;; prolog
((setq f scan%))
;; body
((multiple-value-bind (v p) (funcall f)
(unless p
(go series::end))
(setq value v)))
;; epilog
()
;; wraprs
()
;; impure
nil)))
(defmethod scan% ((ting list) &key)
(let ((x ting))
(lambda ()
(if x
(let ((car (car x)))
(setf x (cdr x))
(values car t))
(values nil nil)))))
(defmethod scan% ((thing array) &key (start 0) end)
(let ((i start)
(end (or end (length thing))))
(lambda ()
(if (= i end)
(values nil nil)
(let ((v (aref thing i)))
(incf i)
(values v t))))))
#|
(collect (scan* #(1 2 3)))
;⇒ (1 2 3)
(collect (scan* #(1 2 3) :start 1 :end 2))
;⇒ (2)
(defstruct st
(value 'a)
(next nil))
(defmethod scan% ((st st) &key)
(lambda ()
(if st
(let ((x st))
(setf st (st-next st))
(values x t))
(values nil nil))))
(let ((st (make-st :value 1 :next (make-st :value 2 :next (make-st :value 3)))))
(collect (st-value (scan* st))))
;⇒ (1 2 3)
|#
(load "~/quicklisp/setup.lisp")
(let* ((*standard-output* (make-broadcast-stream))
(*error-output* *standard-output*))
(ql:quickload :series))
(use-package :series)
(write-string
(collect 'string (scan-stream *standard-input* #'read-char)))
yarn:~% echo "hello\nworld" | sbcl --script /tmp/a.lisp
hello
world
昨日の Common Lisp から Skype を使う を sbcl —script でやるならこんな感じかな。
(load "~/quicklisp/setup.lisp")
(let* ((*standard-output* (make-broadcast-stream))
(*error-output* *standard-output*))
(ql:quickload :dbus))
(use-package :dbus)
(with-open-bus (bus (session-server-addresses))
(with-introspected-object (skype
bus
"/com/Skype"
"com.Skype.API")
(flet ((skype (command)
(skype "com.Skype.API" "Invoke" command)))
(skype "NAME FromCommonLisp")
(skype "PROTOCOL 8")
;; #xxx... はチャットルームの ID
(skype (format nil "CHATMESSAGE #xxxxxxx/$yyyyyyy;9999aaaa9999 ~a"
(second sb-ext:*posix-argv*))))))
sbcl --script skype.lisp "hello"
Common Lisp になら、あるんじゃないかなと思ったら、やっぱりあった。
(not (zerop (logand event-mask isys:epollin)))
は
(logtest event-mask isys:epollin)
http://www.lispworks.com/documentation/HyperSpec/Body/f_logtes.htm
http://www.lispworks.com/documentation/HyperSpec/Body/c_number.htm このへんは知らないのいっぱいある。
https://github.com/quek/info.read-eval-print.httpd
(info.read-eval-print.httpd:start (make-instance 'info.read-eval-print.httpd:server))
ab -n 10000 -c 10 'http://localhost:1958/sbcl-doc/html/index.html'
Linux + SBCL にべったりで GET に対してファイルを返せるだけ。
システムコールばかりなので性能は悪くない感じ。
満足して実装したい衝動が消えちゃう。。。
https://github.com/quek/info.read-eval-print.active-record
(establish-connection)
(defrecord prefecture ()
()
(:has-many :facilities))
(defrecord facility ()
()
(:belongs-to :prefecture)
(:has-many :experiences :as :experiencable))
(defrecord experience ()
()
(:belongs-to :experiencable :polymorphic t))
(let ((facilities (with-ar (facility)
(where "name like ?" "%水族館")
(where :publish 1)
(order :name)
(get-list))))
(values
(mapcar #'name-of facilities)
(name-of (prefecture-of (car facilities)))))
(facilities-of (with-ar (prefecture)
(where "id = 1")
(get-first)))
(experiences-of (with-ar (facility)
(get-first)))
(experiencable-of (with-ar (experience)
(get-first)))
(with-ar (facility)
(joins :prefecture)
(where :prefectures.name "鳥取県")
(get-list))
ときどき Active Record を Common Lisp で実装したくなる。それでひっかかるものの一つがメソッドチェーン。
Ralis の Active Record Query Interface や jQuery や S2JDBC とか、メソッドチェーン多いよね。でも、Common Lisp だとメソッドチェーンはやりにくい。
リーダマクロという手はあるが、 Common Lisp らしくスペシャル変数と with 系マクロでいきたいと思う。
こんな感じになる。
(with-ar (facility)
(where "name like ?" "%水族館")
(when only-published-p
(where :publish 1))
(order :name)
(get-list))
with-ar でかこんで、後は普通に関数呼び出し。メソッドチェーンは条件分岐があるとめんどうだけで、普通の関数呼び出しだから when や if の条件分岐とかも間に入れられる。
次のような defvar と defmacro だけで簡単にできちゃう。
(defvar *association* nil "association")
(defmacro with-ar ((table) &body body)
`(let ((*association* (ensure-association ,table)))
,@body))
好きな言語がスペシャル変数とマクロのある言語でよかった。
