2007/08/30

[Common Lisp] メソッドを削除する

CLOS でメソッドを削除するには find-method でメソッドを検索し、remove-method でジェネリックファンクションから検索したメソッドを削除します。

(defclass a ()
())

(defmethod foo ((a a) arg)
(declare (ignore arg))
(format t " foo primary.~%"))

(defmethod foo :before ((a a) arg)
(declare (ignore arg))
(format t "foo before."))

(foo (make-instance 'a) "arg") ; foo before. foo primary.

(let* ((generic-function (symbol-function 'foo))
(method (find-method generic-function
'(:before) (list (find-class 'a) t))))
(remove-method generic-function method))

(foo (make-instance 'a) "arg") ; foo primary.

2007/08/28

Common Lisp でニコニコ動画ダウンローダー

ニコニコ動画ダウンローダー を Common Lisp で。
手頃な url-decode が見つからなかったので、hunchentoot を使ってしまいました。何かいいのがないのかしら。

(eval-when (:load-toplevel :compile-toplevel :execute)
(require :drakma)
(use-package :drakma)
(require :hunchentoot) ; for url-decode
(require :series))

(defun get-video (video-id)
(let ((parameters (with-open-file (in (merge-pathnames #p".nicovideo.lisp" (user-homedir-pathname)))
(read in)))
(cookie-jar (make-instance 'cookie-jar)))
(http-request "https://secure.nicovideo.jp/secure/login?site=niconico"
:method :post
:parameters parameters
:cookie-jar cookie-jar)
(http-request (format nil "http://www.nicovideo.jp/watch/~a" video-id)
:cookie-jar cookie-jar)
(cl-ppcre:register-groups-bind ((#'hunchentoot:url-decode url))
("(?:^|&)url=([^&]+)"
(http-request (format nil "http://www.nicovideo.jp/api/getflv?v=~a" video-id)
:cookie-jar cookie-jar))
(with-open-stream (in (http-request url :cookie-jar cookie-jar :want-stream t))
(with-open-file (out (concatenate 'string video-id ".flv")
:direction :output :if-exists :supersede :element-type '(unsigned-byte 8))
(series:collect-stream out (series:scan-stream in #'read-byte) #'write-byte))))))

#| ~/.nicovideo.lisp は次のようなファイル
(("mail" . "user@example.com")
("password" . "password"))
|#

;;(get-video "sm927967")

2007/08/22

昼休み

道に迷った。
もう帰ってこれないかと思った。
あぶなかった。

2007/08/21

[Common Lisp] Weblocks

Weblocks は Common Lisp の Web フレームワークです。
ちょっと触った感じでは、簡単に色々のことをやってくれそうです。
また、後でいじってみますが、まずは最初のページが表示されるところまで

;; darcs get http://common-lisp.net/project/cl-weblocks/darcs/cl-weblocks
;;(require :asdf-install)
;;(loop for i in '(:closer-mop :metatilities :hunchentoot :cl-who :cl-ppcre :cl-json :puri :rt :tinaa :md5 :cl-fad :fare-matcher) do (asdf-install:install i))

(eval-when (:load-toplevel :compile-toplevel :execute)
(loop for path in '(#p"scripts/" #p"src/" #p"test/")
do (pushnew (merge-pathnames
path #p"/Users/ancient/letter/lisp/weblocks/cl-weblocks/")
asdf:*central-registry* :test #'equal))
(require :weblocks))

(weblocks:start-weblocks)

(weblocks:defwebapp 'our-application)

(defun init-user-session (comp)
(setf (weblocks:composite-widgets comp)
(list "あいう")))

(weblocks:reset-sessions)

asdf:*central-registry* へのパス追加も eval-when の中でやらなければだめでした。

2007/08/20

[Common Lisp] PostgreSQL に Postmodern でアクセスする

Common Lisp で DB アクセスするなら CLSQL が定番ですが、PostgreSQL 限定ならよりかゆいところに手がとどく Postmodern がおすすめです。
text タイプやオートナンバ等が使えます。

#|
sudo -u postgres createuser -P
ancient/password
|#


(eval-when (:load-toplevel :compile-toplevel :execute)
(require :postmodern))

(defparameter *db* "ancient")
(defparameter *user* "ancient")
(defparameter *passwd* "password")
(defparameter *host* "localhost")

(postmodern:with-connection (*db* *user* *passwd* *host*)

(print (postmodern:query "select 'あ'")) ; query

(postmodern:deftable table1 () ; defclass と似た感じでテーブル定義
((field1 :accessor field1 :type string :initarg :field1))
(:class-name table1)
(:auto-id t)) ; オートナンバ

(defmethod print-object ((table1 table1) stream)
(print-unreadable-object (table1 stream :type t :identity t)
(format stream "~a: ~a" (postmodern:get-id table1) (field1 table1))))

(ignore-errors
(postmodern:drop-table 'table1)) ; テーブル削除(エラーは無視)
(postmodern:create-table 'table1) ; テーブル作成

(loop for i from 1 to 5
do (postmodern:save-dao ; インサート
(make-instance 'table1 :field1 (format nil "あいう~a" i))))

(let ((x (postmodern:get-dao 'table1 3))) ; プライマリキーで select
(print x)
(setf (field1 x) "修正")
(postmodern:save-dao x)) ; 更新

(let ((x (car (postmodern:select-dao 'table1 (:= 'field1 "修正")))))
(print x)
(postmodern:delete-dao x)) ; 削除

(print (postmodern:query "select * from table1"))
)

ところで Emacs の htmlize を使ってみました。

2007/08/15

OpenMCL でシェルスクリプトするために

SBCL では ~/.sbclrc にシェルスクリプトのためのコードを追加する方法がマニュアルに記述してありました。
OpenMCL でも同様に ~/openmcl-init.lisp に書こうかと思いましたが、Lisp を起動するシェルスクリプトを書いた方がいいかと思いました。
$ cat ~/local/bin/run-lisp


#!/bin/sh
~/opt/local/lib/ccl/scripts/openmcl --eval '(set-dispatch-macro-character #\# #\! (lambda (stream char arg) (declare (ignore char arg)) (read-line stream)))' --load $@ --eval '(quit)'

[Common Lisp][UCW] 簡単な TODO リストアプリケーションを作ってみる

UCW で簡単なアプリケーションを作成してみます。
TODO の一覧表示、新規作成と完了ができるアプリケーションです。
あまり継続を活用できいない気がしますが、そのあたりは最初のアプリということで… UCW のサンプルに Wiki アプリがあったので、今度それを見て勉強してみましょう。

まずはいつもどおりの UCW の start.lisp のロードからエントリポイントの作成です。

続いて todo クラスを定義します。
作成した todo を *todo* に保管するために、initialize-instance :after で id の設定と *todo* への push を行っています。
こうしておけば普通に make-instance するだけで、todo のインスタンスは *todo* に保管されるようになります。もっとも、今回は永続化は行っていませんので Lisp を再起動すれば消えてしまいますが。

ビューでは body スロットも持った top-window を定義し、各機能毎に body スロットにリスト表示コンポーネント、新規作成コンポーネントが設定されるようにします。top-window がテンプレート的な役割を果します。初期状態は :component todo-list-view により一覧が表示されます。

ということで、ソースは次のようになりました。


;; ucw がロードされていなければロードする。
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (find-package :ucw)
;; UCW の start.lisp をロードする。パスは環境にあわせて修正してください。
(load "/Users/ancient/letter/lisp/ucw/ucw-boxset/start.lisp")))

(in-package :it.bese.ucw-user)

(defvar *todo-list-application*
(make-instance 'cookie-session-application
:url-prefix "/todo/" ; / で終ること
:charset :utf-8 ; 文字コードを UTF-8 に設定
:debug-on-error t) ; エラー時にはデバッガを起動
"アプリケーションの作成。")

;; アプリケーションをサーバに登録する。
(register-application *default-server* *todo-list-application*)

;; エントリポイントの作成。http://localhost:8080/todo/index.ucw
(defentry-point "index.ucw" (:application *todo-list-application*)
()
(call 'top-window))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; モデル
(defvar *todo* nil "TODO を保管するリスト")

(defvar *todo-id-counter* 0 "TODO の id カウンタ")

(defclass todo ()
((id :accessor id)
(content :initarg :content :accessor content)
(done :initform nil :accessor done))
(:documentation "TODO クラス"))

(defmethod initialize-instance :after ((todo todo) &rest initargs)
"id を設定して *todo* に保存する。"
(declare (ignore initargs))
(setf (id todo) (incf *todo-id-counter*))
(push todo *todo*))

(defmethod print-object ((todo todo) stream)
"debug のために"
(print-unreadable-object (todo stream :type t :identity t)
(format stream "~a: ~a" (id todo) (content todo))))

(defun find-todo (id)
"id をもとに TODO を取得します。"
(find id *todo* :key #'id))

(defun delete-todo (id)
"id をもとに TODO を削除します。"
(setf *todo* (delete id *todo* :key #'id)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ビュー
(defcomponent top-window (simple-window-component)
((body :initarg :body
:accessor body
:component todo-list-view))
(:default-initargs :title "TODO リスト")
(:documentation "トップウィンドウ。
body に一覧や編集のコンポーネントをセットして画面表示を行う。"))

(defmethod render ((top top-window))
(<:h1 "TODO リスト")
;; body の表示
(render (body top)))

(defcomponent todo-list-view ()
()
(:documentation "TODO の一覧コンポーネント"))

(defmethod render ((self todo-list-view))
"TODO の一覧を表示する。"
(<ucw:a :action (call 'todo-create-view) "新規作成")
(<:table
:border 1
(<:tr (<:th "完了") (<:th "TODO") (<:th "削除"))
(loop for each in *todo*
do (let* ((todo each)
(id (id todo)))
(<:tr
(<:td (<:as-html
(if (done todo)
"済"
(<ucw:a
:action (done-todo-action self todo)
"完了する"))))
(<:td (<:as-html (content todo)))
(<:td (<ucw:a :action (delete-todo-action self id)
"削除する")))))))

(defaction done-todo-action ((self todo-list-view) todo)
"TODO を完了する。"
(setf (done todo) t))

(defaction delete-todo-action ((self todo-list-view) id)
"TODO を1件削除する。"
(delete-todo id))

(defcomponent todo-create-view ()
((content
:accessor content
:initform (make-instance 'string-field)))
(:documentation "TODO を新規作成するためのコンポーネント"))

(defmethod render ((self todo-create-view))
"TODO 新規作成画面"
(<ucw:form
:action (create-todo self)
"TODO" (render (content self))
(<:submit :value "新規作成"))
(<ucw:a :action (ok self) "キャンセル"))

(defaction create-todo ((self todo-create-view))
"画面からの入力により TODO を新規作成する。"
(make-instance 'todo :content (value (content self)))
(ok self))

2007/08/14

[Common Lisp] OpenMCL でデフォルトの external-format を設定する方法

OpenMCL でデフォルトの external-format を設定する方法。
~/openmcl-init.lisp


;;;; external-format
(setf ccl::*default-external-format*
(ccl::normalize-external-format :unix :utf-8))

2007/08/10

メーラ

メールにラベルが付けられるみたいに、メモも付けられたらいいのにな。
このメールには何を調査していつまでに返信する、みたいなメモを。

鎌倉花火大会

仕事帰りに行ってみましょう。

行ってきました。
今回は空をおおいつくすような大きな花火はなかったように思います。
でも、いままでなかったような線の細いシャープできらびやかな花火がありとても美しかったです。

2007/08/08

[Common Lisp][UCW] フォームの値取得と入力チェック

UCW でフォームからの値取得と入力チェックを行ってみます。

top-window コンポーネントに name スロットを定義します。
name スロットは string-field のインスタンスに初期化します。
その string-field インスタンス生成時に :validators によって必須チェックをしこみます。

入力チェックは top-window-submit アクションの中で行います。
validp メソッドによりコンポーネントのスロットに :validators で指定してあったチェック処理が実行されます。
validp は (values エラーの有無 ((スロット1 . validator1) (スロット2 . validator2))) のような多値を返します。ここからエラーの有無を判定し、エラーメッセージを取得します。
エラーがなければ、top-window の name から value メソッドで入力された値を取得し、next-page を call するときの引数にそれを渡して画面遷移します。
エラーがあれば top-window の message にエラーメッセージを設定します。

バリデーションのあたりはまだ洗練されていな感じです。
他に何かよい方法があるのでしょうか?


;; ucw がロードされていなければロードする。
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (find-package :ucw)
;; UCW の start.lisp をロードする。パスは環境にあわせて修正してください。
(load "/home/ancient/letter/lisp/ucw/ucw-boxset/start.lisp")))

(in-package :it.bese.ucw-user)

(defvar *hello-form-application*
(make-instance 'cookie-session-application
:url-prefix "/hello-form/" ; / で終ること
:debug-on-error t) ; エラー時にはデバッガを起動
"アプリケーションの作成。")

;; アプリケーションをサーバに登録する。
(register-application *default-server* *hello-form-application*)

;; エントリポイントの作成。http://localhost:8080/hello-form/index.ucw
(defentry-point "index.ucw" (:application *hello-form-application*)
()
;; トップページの無限ループ
(loop (call 'top-window)))

(defcomponent top-window (simple-window-component)
((name
:accessor name
:initform (make-instance
'string-field
:validators `(,(make-instance 'not-empty-validator
:message "名前を入力してください。")))
:documentation "必須入力チェックを行なう。")
(messages :initform nil :accessor messages
:documentation "入力エラー時のメッセージを保持するために"))
(:default-initargs :title "トップページ")
(:documentation "最初のページです。入力フォームがあります。"))

(defmethod render ((self top-window))
"入力フォームを表示します。"
;; エラーメッセージの表示
(when (messages self)
(<:ul (dolist (message (messages self))
(<:li (<:b (<:as-html message))))))
;; フォームの表示
(<ucw:form :action (top-window-submit self)
(<:div "名前" (render (name self))
(<:submit))))

(defaction top-window-submit ((self top-window))
"入力チェックを行い、次のページに遷移します。"
(setf (messages self) nil)
(multiple-value-bind (validp faileds) (validp self)
(if validp
(call 'next-page :name (value (name self)))
(setf (messages self)
(mapcar #'(lambda (arg)
(ucw::message (cdr arg)))
faileds)))))

(defcomponent next-page (simple-window-component)
((name :initarg :name :accessor name))
(:default-initargs :title "次のページです")
(:documentation "前のページの入力を表示するためのページです。"))

(defmethod render ((self next-page))
"前のページで入力した name を表示します。"
(<:p (<:as-html (name self)))
(<ucw:a :action (ok self) "最初のページに戻る"))

VMware Player でビープを鳴らなくし、ホットキーを Alt+Ctrl+Shift にする設定

VMware Player でビープを鳴らなくし、ホットキーを Alt+Ctrl+Shift にする設定
c:\Documents and Settings\ユーザ\Application Data\VMware\preferences.ini
mks.noBeep = "TRUE"
pref.hotkey.shift = "TRUE"

Meadow の tramp で zsh のリモートにつなぐ

~/.zshrc に次の1行を追記。
[ $TERM = "dumb" ] && unsetopt zle

putty であらかじめ TERM が dumb になるセッションを作成。
ホスト名のかわりにそのセッション名で Meadow からアクセス。

emacs22 ベースなら ~/.emacs は次の2行のみ
(pushnew "C:/usr/local/lib/putty" exec-path)
(setq tramp-default-method "plink")

[Common Lisp] Common Lisp と日本語と文字コード

Common Lisp と日本語と文字コード 非常にすばらしいです。
すばらしいページに感謝。

ぼんぼり祭

今日はぼんぼり祭のようです。
仕事帰りによってみようかな。

よってみた。
ねことカマキリがよかった。

2007/08/07

[Emacs] Emacs で uim を無効にする

~/.Xresources に


Emacs*useXIM: false

家のマシンが壊れました

土曜日の夕方、家のマシンの電源を入れたら、ものすごい勢いでファンが回ったままいつまでたっても起動しません。BIOS画面すら表示されません。
箱を開けてひととりのコネクタを抜き差ししたのですが復活せず。
困りました。

2007/08/05

[Common Lisp] Windows の SBCL で asdf-install を動かす

Windows の SBCL では asdf-install が動きません。
問題点はシンボリックリンク、tar に渡すパス、tar の出力の取得の3つです。
シンボリックリンクについては ~/.sbcl/site の下の拡張子が asd であるファイルを検索する関数を作成し、asdf:*system-definition-search-functions* に追加しました。
tar に渡すパスは、頭のドライブレターとコロンをとって \ を / に置き換えました。
tar の出力の取得は run-program で直に string output stream に出力せずに、プロセスのアウトプットストリームを自前で読んで string output stream に出力するようにしました。
これで cl-ppcre のインストールが成功するようになったのですが、uffi や usocket はどこかでハングしてしまいました。
tar の出力の取得まわりかと思いつつも、眠いので今日はここまで。
次のコードを ~/.sbclrc に書いておけば、(asdf-install:install :cl-ppcre) で cl-ppcre がインストールできるはずです。


(require :asdf)

(in-package :asdf)

(defun win-sysdef-search (system)
(let ((home (MERGE-PATHNAMES ".sbcl/site/" (USER-HOMEDIR-PATHNAME))))
(let* ((name (coerce-name system))
(home (truename home))
(files (directory
(merge-pathnames
(make-pathname :directory `(:relative :wild)
:name name
:type "asd"
:case :local
:version :newest)
home))))
(dolist (file files)
(when (probe-file file)
(return-from win-sysdef-search file))))))

(pushnew 'win-sysdef-search asdf:*system-definition-search-functions*)

(require :asdf-install)

(in-package :asdf-install)

(labels ((cyg-path (win-path)
(cl:substitute #\/ #\\ (cl:subseq (namestring win-path) 2)))
(tar (args)
(with-output-to-string (o)
(let ((process (sb-ext:run-program *tar-program*
args
:search t
:wait nil
:output :stream)))
(prog1 (loop for l = (read-line (process-output process) nil nil)
while l
do (write-line l o))
(process-wait process)
(process-close process))))))

(defun get-tar-directory (packagename)
(let* ((tar (tar (list "-tzf" (cyg-path packagename))))
(first-line (subseq tar 0 (position #\newline tar))))
(if (find #\/ first-line)
(subseq first-line 0 (position #\/ first-line))
first-line)))

(defun untar-package (source packagename)
(tar (list "-C" (cyg-path source)
"-xzvf" (cyg-path packagename)))))

2007/08/03

[Common Lisp][UCW] 継続によるページ遷移

前回のハローワールドアプリケーションにもう1ページ追加し、ページ遷移をしてみます。
defentry-point で loop を使い2つのページを call します。
各ページでは <ucw:a でリンクを作成し、その action で ok を呼びます。
ok は call の戻りになります。
hello-world-window からの ok は次の next-page を呼び出し、next-page からの ok は loop により再度 hello-world-window を呼び出し、それがぐるぐるまわります。
継続を使ったページ制御です。


;; ucw がロードされていなければロードする。
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (find-package :ucw)
;; UCW の start.lisp をロードする。
(load "/home/ancient/letter/lisp/ucw/ucw-boxset/start.lisp")))

;; ucw のユーザ用パッケージ。
;; 簡単なアプリケーションならこのパッケージを使うのが簡便。
(in-package :it.bese.ucw-user)

;; アプリケーションの作成。
(defvar *hello-world-application*
(make-instance 'cookie-session-application
;; http://localhost:8080/hello/ でこのアプリケーションの
;; アクセスできるようにする。
:url-prefix "/hello/" ; / で終ること
))

;; アプリケーションをサーバに登録する。
(register-application *default-server* *hello-world-application*)

;; エントリポイントの作成。
;; http://localhost:8080/hello/index.ucw で
;; hello-world-window の render メソッドが呼ばれる。
(defentry-point "index.ucw" (:application *hello-world-application*)
()
;; 1ページ目と2ページ目をループする。
(loop
;; ハローワールドのページ
(call 'hello-world-window)
;; 次のページ
(call 'next-page)))

;; hello-world-window の定義。
;; simple-window-component を継承する。
(defcomponent hello-world-window (simple-window-component)
()
(:default-initargs :title "ハローワールド")) ; title の設定。

;; 表示用のメソッドの定義
(defmethod render ((hello hello-world-window))
(<:p "ハローワールド")
(<ucw:a :action (ok hello) "次のページへ"))

;; 次のページを定義する。
(defcomponent next-page (simple-window-component)
()
(:default-initargs :title "次のページです"))

;; 次のページの表示
(defmethod render ((self next-page))
(<:p "次のページに遷移しました。")
(<ucw:a :action (ok self) "最初のページに戻る"))

サーカス

サーカスを見てきました。
猫とはわりと足を踏み外しやすい生き物なのでしょうか?