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> (略)