WiLiKiシステムのメインスクリプトwiliki.scm。このスクリプトは長いので、関数ごとに何が行われているか、その機能は何に使われるのかを見て行く。
(define-module wiliki (use srfi-1) (use srfi-2) ;and-let* (use srfi-11) (use srfi-13) (use text.html-lite) (use text.tree) (use text.tr) (use util.list) (use www.cgi) (use rfc.uri) (use dbm) (use gauche.charconv) (use gauche.version) (use gauche.parameter) (use gauche.sequence) (use wiliki.mcatalog) (export <wiliki> wiliki-main))
define-moduleで、wilikiというモジュールのインターフェースを定義。
モジュールは*load-path*にあれば良いので、モジュールをバージョンアップすることで、上のCGIプログラムを書き直さずにWiLiKiシステムのバージョンアップができる。
最後のexportは、このモジュールがエクスポートするシンボルの指定。ここでwiliki-mainがエクスポートされ、上のwiliki.cgiで使われている。
(select-module wiliki)
select-moduleにより、カレントモジュールを指定する。これ以降のScheme式は、モジュールwilikiに属することになる。
;; Load extra code only when needed. (autoload dbm.gdbm <gdbm>) (autoload "wiliki/macro" handle-reader-macro handle-writer-macro handle-virtual-page virtual-page?) (autoload "wiliki/rss" rss-page) (autoload "wiliki/pasttime" how-long-since)
autoloadは、第2引数以降に指定されたシンボルが評価されようとしたときに、第1引数に指定されたモジュール(モジュール名のシンボルか、ファイル名の文字列)がロードされる。すなわち、必要となったときに必要とされるものをロードするということ。
;; Version check. (when (version<? (gauche-version) "0.6.7.1") (print (tree->string `(,(cgi-header) ,(html:html (html:head (html:title "Error"))) ,(html:body "Gauche 0.6.7.1 or later is required.")))) (exit 0))
gauche-versionが0.6.7.1より小さい場合は、エラーページを表示して終了。
;; Some constants (define *recent-changes* " %recent-changes") (define *lwp-version* "1.0") ; lightweight protocol version (define $$ gettext)
;; Parameters (define page-format-history (make-parameter '())) (define wiliki (make-parameter #f)) ;current instance (define lang (make-parameter #f)) ;current language (define db (make-parameter #f)) ;current database
パラメータは、状態を持つ手続きといえる。手続きとしての機能は、引数が与えられるとそれを自身の値としてセットし、引数が与えられなければ現在持っている値を返す。グローバル変数のようなものとして使える。
ここまでに定義された定数と変数は以下のとおり。
名前 | 定数 or 変数 | 値(初期値) |
*recent-changes* | 定数 | %recent-changes |
*lwp-version* | 定数 | 1.0 |
$$ | 定数 | gettext |
page-format-history | 変数 | () |
wiliki | 変数 | #f |
lang | 変数 | #f |
db | 変数 | #f |
(define (current-formatting-page) (let1 hist (page-format-history) (if (null? hist) #f (car hist))))
current-formatting-pageは、page-format-historyが空リストなら#fを返し、空リストでなければそのcarを返す。この場合のcarは、(分かったら後で追記)。
;; Class <wiliki> ------------------------------------------ ;; A main data structure that holds run-time information. ;; Available as the value of the parameter wiliki in ;; almost all locations. (define-class <wiliki> () ((db-path :accessor db-path-of :init-keyword :db-path :init-value "wikidata.dbm") (db-type :accessor db-type-of :init-keyword :db-type :initform <gdbm>) (title :accessor title-of :init-keyword :title :init-value "WiLiKi") (top-page :accessor top-page-of :init-keyword :top-page :init-value "TopPage") (language :accessor language-of :init-keyword :language :init-value 'jp) (charsets :accessor charsets-of :init-keyword :charsets :init-value ()) (editable? :accessor editable? :init-keyword :editable? :init-value #t) (style-sheet :accessor style-sheet-of :init-keyword :style-sheet :init-value #f) (image-urls :accessor image-urls-of :init-keyword :image-urls :init-value ()) (description :accessor description-of :init-keyword :description :init-value "WiLiKi, a Wiki engine written in Scheme") (server-name :accessor server-name-of :init-keyword :server-name :init-form (or (sys-getenv "SERVER_NAME") "localhost")) (script-name :accessor script-name-of :init-keyword :script-name :init-form (or (sys-getenv "SCRIPT_NAME") "wiliki.cgi")) ))
クラスwilikiの定義。コメントによると、パラメータwilikiの値として、ほぼ全ての場所から利用可能とのこと。
(クラス名を囲む<、>は、クラス名であることを強調するだけのもので、クラス名は<クラス名>である必要はない。)(ですよね?)
クラス名の後の()は、スーパークラスがないことを示す。
クラス名の定義に続く部分はいわゆるインスタンス変数の定義。Schemeではスロットと呼ぶ。
分かりやすさのために表にしてみる。
スロットの名前 | アクセッサ | 初期化する際の識別キーワード | 初期値 |
db-path | db-path-of | :db-path | wikidata.dbm |
db-type | db-type-of | :db-type | <gdbm> |
title | title-of | :title | WiLiKi |
top-page | top-page-of | :top-page | TopPage |
language | language-of | :language | 'jp |
charsets | charsets-of | :charsets | () |
editable? | editable? | editable? | #t |
style-sheet | style-sheet-of | :style-sheet | #f |
image-urls | image-urls-of | :image-urls | () |
description | description-of | :description | WiLiKi, a Wiki engine written in Scheme |
server-name | server-name-of | :server-name | (sys-getenv "SERVER_NAME")かlocalhost |
script-name | script-name-of | :script-name | (sys-getenv "SCRIPT_NAME")かwiliki.cgi |
(define (cgi-name-of wiliki) (sys-basename (script-name-of wiliki)))
cgi-name-ofは、WiLiKiのCGIスクリプトのファイル名を返す。これは、wiliki.cgiの名前は任意に変えられるためである。複数のWiLiKiの運用が参考になる。
(define (%url-format full? fmt args) (let ((self (wiliki)) (fstr #`"?,|fmt|&l=,(lang)")) (string-append (if full? #`"http://,(server-name-of self),(script-name-of self)" (cgi-name-of self)) (if (null? args) fstr (apply format #f fstr (map uri-encode-string args))))))
%url-formatは、string-appendによって結合された文字列を返す。
string-appendで結合される部分文字列は最大2つで、
uri-encode-stringは、いわゆるURLエンコードを行う。
(define (url fmt . args) (%url-format #f fmt args)) (define (url-full fmt . args) (%url-format #t fmt args))
urlとurl-fullは、上の%url-formatの第1引数、つまり仮引数full?に#tを与えるか#fを与えるかが違う。
(define (language-link pagename) (receive (target label) (case (lang) ((jp) (values 'en "->English")) (else (values 'jp "->Japanese"))) (html:a :href #`",(cgi-name-of (wiliki))?,|pagename|&l=,|target|" "[" (html-escape-string label) "]")))
receiveは、caseから返された多値(この場合は2つ)を仮引数の(target label)に束縛して、html:aに渡す。
つまり、language-linkは、langの値によって('en "->English")か('jp "->Japanese")を、ハイパーリンクアンカーを表現するHTMLのAタグを構成する。
langが(jp)の場合は('en "->English")が渡され、<a href="wiliki.cgiのURL?ページの名前&l=en">[URLエンコードされた"->English"]</a>を返す。このページの右上にも表示されている。
;; Macros -----------------------------------------
(define (expand-writer-macros content) (with-string-io content (lambda () (port-for-each (lambda (line) (display (regexp-replace-all #/\[\[($\w+)\]\]/ line (lambda (m) (tree->string (handle-writer-macro (m 1)))))) (newline)) read-line))))
with-string-ioは、contentを入力ポートとしてlambda式を実行し、その結果の文字列を返す。port-for-eachでは、reader(ここではread-line)で読み込まれる各処理対象に対して、手続きを実行する。
つまり、このlambda式の内容は、contentを入力ポートして、そこからread-lineで読んだ行それぞれに対して、[[$ワード文字]]という正規表現にマッチした部分を、(handle-writer-macro (m 1))の戻り値であるテキストツリーを文字列に変換したもので置換する。(m 1)は、正規表現[[$ワード文字]]にマッチしたマッチオブジェクトの1つ目のマッチ文字列を表している、つまり、ワード文字である。handle-writer-macroがこのワード文字をどのように処理するか(どんな値が返されるのか)は、macro.scmに書かれている。
;; Character conv --------------------------------- ;; input conversion - get data from outside world (define (cv-in str) (ces-convert str "*JP"))
手続きcv-inは、内部でces-convertを使い、CES推測アルゴリズム名*JPの指示により入力のエンコーディングを推測し、ネイティブエンコーディングに変換した文字列(あるいはバイト列(不完全な文字列))を返します。
;; output conversion - put data to outside world, according to charsets spec (define (cv-out str) (ces-convert str (symbol->string (gauche-character-encoding)) (output-charset)))
手続きcv-outは、文字列をoutput-charsetに変換した文字列を返します。output-charsetは次で定義されています。
(define (output-charset) (or (and-let* (((wiliki)) (p (assoc (lang) (charsets-of (wiliki)))) ((symbol? (cdr p)))) (cdr p)) "EUC-JP")) ;; this is a fallback.
手続きoutput-charsetは、wilikiオブジェクトが存在して、そのアクセッサcharsets-ofが返す(連想)リストからキーが(lang)である値のcdrがシンボルであれば、それを返します。そうでなければ、"EUC-JP"を返します。
;; CGI processing --------------------------------- (define (html-page head-elements . body-elements) ;; NB: cgi-header should be able to handle extra header fields. ;; for now, I add extra headers manually. `("Content-Style-Type: text/css\n" ,(cgi-header :content-type #`"text/html; charset=,(output-charset)") ,(html-doctype :type :transitional) ,(html:html (html:head head-elements (or (and-let* ((w (wiliki)) (ss (style-sheet-of w))) (html:link :rel "stylesheet" :href ss :type "text/css")) ;; default "<style type=\"text/css\"> body { background-color: #eeeedd }</style>")) (html:body body-elements))))
手続きhtml-pageは、HTMLの<head>に入れる要素と、<body>に入れる要素を 受け取り、カスタマイズされたHTTPヘッダと、HTMLの<head>にCSSへのリンクを入れて、 ページをフォーマットする。
HTTPヘッダは次のように出力される。
Content-Style-Type: text/css Content-Type: text/html; charset=EUC-JP (一例)
HTMLの<head>には、引数として渡される<head>の要素に加えて、CSSが指定されていれば、 それが<link>要素にフォーマットされて挿入される。CSSが指定されていない場合は、 デフォルト値として、バックグラウンドを#eeeeddにするだけのスタイルシートタグが 挿入される。
HTMLの<body>には、引数として渡される<body>の要素をそのままフォーマットする。
(define (error-page e) (html-page (html:title ",(title-of (wiliki)): Error") (list (html:h1 "Error") (html:p (html-escape-string (ref e 'message))))) )
手続きerror-pageは、引数として渡されるエラー用オブジェクトから、シンボル messageに対応する値を取り出し、エラーページを生成する。
(define (redirect-page key) (cons "Status: 302 Moved\n" (cgi-header :location (url "~a" key))))
手続きredirect-pageは、引数keyに与えられたURLへリダイレクトするHTTPヘッダを 返す。
(define (conflict-page page pagename content donttouch) (format-page (string-append (title-of (wiliki))": "($$ "Update Conflict")) `(,($$ "<p>It seems that somebody has updated this page while you're editing. The most recent content is shown below.</p>") ,(html:hr) ,(colored-box (html:pre (html-escape-string (content-of page)))) ,(html:hr) ,($$ "<p>The following shows what you are about to submit. Please re-edit the content and submit again.</p>") ,(edit-form #t pagename content (mtime-of page) donttouch) ) :show-edit? #f))
手続きconflict-pageは、$$(gettext)を多用している。ページの上半分には、 引数として与えられた<page>オブジェクトの:contentを色づけされたボックスに<pre> 要素として表示し、下半分には、CGIパラメータ経由のcontentを編集用にテキストエリアで 表示する。
(define (cmd-view pagename) ;; NB: see the comment in format-wiki-name about the order of ;; wdb-get and virtual-page? check. (cond ((wdb-get (db) pagename) => (cut format-page pagename <>)) ((virtual-page? pagename) (format-page pagename (handle-virtual-page pagename) :show-edit? #f)) ((equal? pagename (top-page-of (wiliki))) (let ((toppage (make <page> :key pagename :mtime (sys-time)))) (wdb-put! (db) (top-page-of (wiliki)) toppage) (format-page (top-page-of (wiliki)) toppage))) ((or (string-index pagename #[\s\[\]]) (string-prefix? "$" pagename)) (error "Invalid page name" pagename)) (else (format-page (string-append ($$ "Nonexistent page: ") pagename) `(,(html:p ($$ "Create a new page: ") (format-wiki-name pagename))) :show-edit? #f)) ))
(define (edit-form preview? pagename content mtime donttouch) (define (buttons) (if preview? `(,(html:input :type "submit" :name "preview" :value ($$ "Preview")) ,(html:input :type "submit" :name "commit" :value ($$ "Commit without preview"))) `(,(html:input :type "submit" :name "preview" :value ($$ "Preview again")) ,(html:input :type "submit" :name "commit" :value ($$ "Commit"))))) (define (donttouch-checkbox) `(,(apply html:input :type "checkbox" :name "donttouch" :value "on" (if donttouch '(:checked #t) '())) ,($$ "Don't update 'Recent Changes'"))) (html:form :method "POST" :action (cgi-name-of (wiliki)) (buttons) (donttouch-checkbox) (html:br) (html:input :type "hidden" :name "c" :value "c") (html:input :type "hidden" :name "p" :value pagename) (html:input :type "hidden" :name "l" :value (lang)) (html:input :type "hidden" :name "mtime" :value mtime) (html:textarea :name "content" :rows 40 :cols 80 (html-escape-string content)) (html:br) (buttons) (html:br) ($$ "<h2>Text Formatting Rules</h2> <p>No HTML.</p> <p>A line begins with \";;\" doesn't appear in the output (comment).</p> <p>A line begins with \"~\" is treated as if it is continued from the previous line, except comments. (line continuation).</p> <p>Empty line to separating paragraphs (<p>) <p>\"<tt>- </tt>\", \"<tt>-- </tt>\" and \"<tt>--- </tt>\" ... at the beginning of a line for an item of unordered list (<ul>). Put a space after dash(es).</p> <p>\"<tt># </tt>\", \"<tt>## </tt>\", \"<tt>### </tt>\" ... at the beginning of a line for an item of ordered list (<ol>). Put a space after dot(s).</p> <p>A line with only \"<tt>----</tt>\" is <hr>.</p> <p>\"<tt>:item:description</tt>\" at the beginning of a line is <dl>. The item includes all colons but the last one. If you want to include a colon in the description, put it in the next line.</p> <p><tt>Name?</tt> to make \"Name\" a WikiName. Note that a simple mixed-case word doesn't become a WikiName. \"Name\" beginning with \"$\" has special meanings (e.g. \"2003/03/09 17:39:08 PST\" is replaced for the time at the editing.)</p> <p>A URL-like string beginning with \"<tt>http:</tt>\" becomes a link. \"<tt>[URL name]</tt>\" becomes a <tt>name</tt> that linked to <tt>URL</tt>.</p> <p>Surround words by two single quotes (<tt>foo</tt>) to emphasize.</p> <p>Surround words by three single quotes (<tt>foo</tt>) to emphasize more.</p> <p>\"<tt>*</tt>\", \"<tt>**</tt>\" and \"<tt>***</tt>\"' ... at the beginning of a line is a header. Put a space after the asterisk(s).</p> <p>Whitespace(s) at the beginning of line for preformatted text.</p> <p>A line of \"{{{\" starts verbatim text, which ends with a line of \"}}}\". No formatting is done in verbatim text. Even comments and line continuation don't have effect.</p> <p>A line begins with \"||\" and also ends with \"||\" becomes a row of a table. Consecutive rows forms a table. Inside a row, \"||\" delimits columns.</p> <p>\"
\" is replaced for \"<br>\".</p> <p>If you want to use special characters at the beginning of line, put six consecutive single quotes. It emphasizes a null string, so it's effectively nothing.</p>") ))
(define (cmd-edit pagename) (unless (editable? (wiliki)) (errorf "Can't edit the page ~s: the database is read-only" pagename)) (let ((page (wdb-get (db) pagename #t))) (format-page pagename (edit-form #t pagename (content-of page) (mtime-of page) #f) :show-edit? #f)))
(define (cmd-preview pagename content mtime donttouch) (let ((page (wdb-get (db) pagename #t))) (if (or (not (mtime-of page)) (eqv? (mtime-of page) mtime)) (format-page (format #f ($$ "Preview of ~a") pagename) `(,(colored-box (format-content (make <page> :key pagename :content content))) ,(html:hr) ,(edit-form #f pagename content mtime donttouch)) :show-edit? #f) (conflict-page page pagename content donttouch) )))
(define (cmd-commit-edit pagename content mtime donttouch) (unless (editable? (wiliki)) (errorf "Can't edit the page ~s: the database is read-only" pagename)) (let ((p (wdb-get (db) pagename #t)) (now (sys-time))) (if (or (not (mtime-of p)) (eqv? (mtime-of p) mtime)) (if (string-every #[\s] content) (begin (set! (content-of p) "") (wdb-delete! (db) pagename) (redirect-page (top-page-of (wiliki)))) (begin (set! (mtime-of p) now) (set! (content-of p) (expand-writer-macros content)) (wdb-put! (db) pagename p :donttouch donttouch) (redirect-page pagename))) (conflict-page p pagename content donttouch) ) ))
(define (cmd-all) (format-page (string-append (title-of (wiliki))": "($$ "All Pages")) (html:ul (map (lambda (k) (html:li (wikiname-anchor k))) (sort (wdb-map (db) (lambda (k v) k)) string<?))) :page-id "c=a" :show-edit? #f :show-all? #f))
(define (cmd-recent-changes) (format-page (string-append (title-of (wiliki))": "($$ "Recent Changes")) (html:table (map (lambda (p) (html:tr (html:td (format-time (cdr p))) (html:td "(" (how-long-since (cdr p)) " ago)") (html:td (wikiname-anchor (car p))))) (wdb-recent-changes (db)))) :page-id "c=r" :show-edit? #f :show-recent-changes? #f))
format-pageのシグネチャは、(format-page title page . args)。
titleは、"WiLiKiのタイトル: 最近の更新"。
pageは、(wdb-recent-changes (db))の各戻り値をフォーマットしたHTMLテーブル。
(define (cmd-search key) (format-page (string-append (title-of (wiliki))": "($$ "Search results")) (html:ul (map (lambda (p) (html:li (wikiname-anchor (car p)) (or (and-let* ((mtime (get-keyword :mtime (cdr p) #f))) #`"(,(how-long-since mtime))") ""))) (wdb-search-content (db) key))) :page-id (format #f "c=s&key=~a" (html-escape-string key)) :show-edit? #f))
format-pageのシグネチャは、(format-page title page . args)。
titleは、"WiLiKiのタイトル: 検索結果"。
pageは、ulによるリスト。リストの内容は、(wdb-search-content (db) key)の各返り値 のcarをwikiname-anchorしたものと、そのcdrが:mtimeを持っていれば (how-long-since mtime)、持っていなければ何もなし。
(define (cmd-lwp-view key) (let ((page (wdb-get (db) key #f))) `(,(cgi-header :content-type #`"text/plain; charset=,(output-charset)") ,#`"title: ,|key|\n" ,#`"wiliki-lwp-version: ,|*lwp-version*|\n" ,(if page `(,#`"mtime: ,(mtime-of page)\n" "\n" ,(content-of page)) `(,#`"mtime: 0\n" "\n")))))
手続きcmd-lwp-viewは、与えられたkeyに対応するデータをデータベースから 取り出し、HTTPヘッダだけを返す。そのHTTPヘッダは次のようなもの。
Content-Type: text/plain; charset=EUC-JP (一例) title: key wiliki-lwp-version: 1.0 (wiliki.scmの先頭で定義されている) ---(条件分岐: pageがあれば) mtime: pageの:mtime pageの:content ---(pageがなければ) mtime: 0
;; Entry ------------------------------------------ (define-method wiliki-main ((self <wiliki>)) (cgi-main (lambda (param) (let ((pagename (cond ((null? param) (top-page-of self)) ((eq? (cadar param) #t) (cv-in (caar param))) (else (cgi-get-parameter "p" param :default (top-page-of self) :convert cv-in)))) (command (cgi-get-parameter "c" param)) (language (cgi-get-parameter "l" param :convert string->symbol))) (parameterize ((wiliki self) (lang (or language (language-of self)))) (cgi-output-character-encoding (output-charset)) (textdomain (lang)) (with-db (lambda () (cond ;; command may #t if we're looking at the page named "c". ((or (not command) (eq? command #t)) (cmd-view pagename)) ((equal? command "lv") (cmd-lwp-view pagename)) ((equal? command "e") (cmd-edit pagename)) ((equal? command "a") (cmd-all)) ((equal? command "r") (cmd-recent-changes)) ((equal? command "s") (cmd-search (cgi-get-parameter "key" param :convert cv-in))) ((equal? command "c") ((if (cgi-get-parameter "commit" param :default #f) cmd-commit-edit cmd-preview) pagename (cgi-get-parameter "content" param :convert cv-in) (cgi-get-parameter "mtime" param :convert x->integer :default 0) (cgi-get-parameter "donttouch" param :default #f))) ((equal? command "rss") (rss-page (db))) (else (error "Unknown command" command)))))) )) :merge-cookies #t :on-error error-page))
クラスメソッドとして定義。これは、wiliki.cgiで呼ばれる唯一の手続き。
本体の実行前に、let式でローカル変数を定義、続いてparameterizeで以降使用する変数を 定義している。
let式で定義されるローカル変数
本体の先頭で出力エンコーディングをoutput-charsetの戻り値にセット。
手続きtextdomainは、wiliki.mcatalogで定義されている。
手続きwith-dbは、このwiliki.scmの上のほうで定義されている。
次の行のpagenameは何だろう?その前のif文の評価結果として手続きが実行されるが、 それへの引数に当てられるということだろう。これはすごいな。ということで、以下の 引数を取って、cmd-commit-editかcmd-previewが実行される。
で、cgi-mainへのキーワード引数:merge-cookiesと:on-errorが指定されている。
とても勉強になります。
WiLiKi-0.5ではcgi-mainがだいぶん変わっていますね。この新しいバージョンでは、(with-db thunk .rwmode)のthunkに対して、DBでの処理ではなくて、html-pageを渡しているように思うのですが。。ちょっと理解できませんでした。
;; Convenient wrapper (define (with-db thunk . rwmode) (wiliki-with-db (db-path-of (wiliki)) (db-type-of (wiliki)) thunk :rwmode (get-optional rwmode :read))) (define-method wiliki-main ((self <wiliki>)) (cgi-main (lambda (param) (let ((pagename (get-page-name self param)) (command (cgi-get-parameter "c" param)) (language (cgi-get-parameter "l" param :convert string->symbol))) (parameterize ((wiliki self) (lang (or language (language-of self)))) (cgi-output-character-encoding (output-charset)) (textdomain (lang)) (cond ;; command may #t if we're looking at the page named "c". ((or (not command) (eq? command #t)) (with-db (cut cmd-view pagename))) ((equal? command "lv") (with-db (cut cmd-lwp-view pagename))) ((equal? command "e") (with-db (cut cmd-edit pagename))) ((equal? command "a") (with-db cmd-all)) (略)
(define (cmd-all) (html-page (make <wiliki-page> (略)