;; Formatting html --------------------------------
(define (format-time time) (if time (sys-strftime "%Y/%m/%d %T %Z" (sys-localtime time)) "-"))
手続きformat-timeは、ローカルタイムを"%Y/%m/%d %T %Z"の形式で表す文字列を返します。timeが#fならば、"-"を返します。
(define (colored-box content) (html:table :width "100%" :cellpadding 5 (html:tr (html:td :class "preview" :bgcolor "#eeddaa" content))))
手続きcolored-boxは、以下のようなHTMLを生成します。
<table width="100%" cellpadding="5"> <tr> <td class="preview" bgcolor="#eeddaa">content</td> </tr> </table>
(define (inter-wiki-name-prefix head) (and-let* ((page (wdb-get (db) "InterWikiName")) (rx (string->regexp #`"^:,|head|:(\\S+)"))) (call-with-input-string (content-of page) (lambda (p) (let loop ((line (read-line p))) (cond ((eof-object? line) #f) ((rx line) => (cut <> 1)) (else (loop (read-line p)))))))))
手続きinter-wiki-name-prefixは、データベース中の"InterWikiName"というキーに対応する値から作られるpageオブジェクトの内容に、引数headを含んだ正規表現にマッチする行があるかどうかを調べ、あれば文字列を返す。
ローカル変数pageは、wdb-getに与えられたキー(この場合、"InterWikiName")に対応するデータから作られたpageオブジェクト。
ローカル変数rxは、引数headを埋め込んだ正規表現オブジェクト。その文字列表現は、"^:headの内容:(\S+)"。意味は、:で始まり、直後にheadの内容があり、:が続き、スペースで無い文字が1つ以上あるもの。
これら2つのローカル変数を持って、pageの:contentを入力ポートとし、一行ずつ読み込みながら、その行が、
この手続きでは、マッチオブジェクトからのデータなどを蓄積したり出力したりしていないので、どこかの手続きの中でラップして使われるのかな?
(define (wikiname-anchor wikiname) ;; assumes wikiname already exist in the db. (html:a :href (url "~a" (cv-out wikiname)) (html-escape-string wikiname)))
コメントにあるとおり、wikinameがdbに存在することを仮定している。 次のようなHTMLを返す。
<a href="wikinameをoutput-charsetに変換後URLエンコーディングした文字列"> wikinameをHTMLエスケープした文字列</a>
(define (reader-macro-wiki-name? name)
(cond ((string-prefix? "$$" name)
(handle-reader-macro name))
((or (string-index name #[\s])
(string-prefix? "$" name))
;;invalid wiki name
#`",(html-escape-string name)?")
(else #f)))
手続きreader-macro-wiki-name?は、引数nameが、
name | 結果 |
"$$somename" | (handle-reader-macro somename)が呼ばれる |
"some name"など | "some name"をHTMLエスケープして二重大括弧で囲んだもの |
"$somename"など | "$somename"をHTMLエスケープして二重大括弧で囲んだもの |
"somename"など | #f |
(define (inter-wiki-name? name) (receive (head after) (string-scan name ":" 'both) (or (and head (and-let* ((inter-prefix (inter-wiki-name-prefix head))) (values inter-prefix after))) (values #f #f))))
手続きinter-wiki-name?は、nameがInterWikiNameとして登録されているかを調べ、登録されていれば、:head:nameの、headとname(上のvalues文では、それぞれinter-prefixとafter)を返す。登録されていなければ、#fを2つ返す。
string-scanは、nameの中から:を探して、その前と後にある文字列を返し、receiveによりそれらをheadをafterに束縛する。そして、headが存在して(真)、かつ(inter-wiki-name-prefix head)が#fを返さなければ、(values inter-prefix after)が2つの値を返すことができ、and-let*は成功し、andは真を返すので、そこでorの評価が止まる。andのどれかが#fを返すと、orの2番目の式に制御が移り、#fが2つ返される。
(define (format-wiki-name name) (receive (prefix inner) (inter-wiki-name? name) (cond ((reader-macro-wiki-name? name)) (prefix (tree->string (html:a :href (format #f "http://~a~a" prefix (uri-encode-string (cv-out inner))) (html-escape-string name)))) ((or (wdb-exists? (db) name) (virtual-page? name)) (tree->string (wikiname-anchor name))) (else (tree->string `(,(html-escape-string name) ,(html:a :href (url "p=~a&c=e" (cv-out name)) "?")))))))
receiveにより、prefixとinnerに、nameを解析して得たInterWikiNameの名前を分解した文字列が束縛される。
condでは、
;; Find wiki name in the line. ;; Correctly deal with nested "" and "?"'s. (define (format-line line) ;; parse to next "" or "?" (define (token s) (cond ((#/\[\[|\]\]/ s) => (lambda (m) (values (m 'before) (m) (m 'after)))) (else (values s #f #f)))) ;; return <str in paren> and <the rest of string> (define (find-closer s level in) (receive (pre tok post) (token s) (cond ((not tok) (values #f (tree->string (cons "[[" (reverse (cons pre in)))))) ((string=? tok "[[") (find-closer post (+ level 1) (list* "[[" pre in))) ((= level 0) (values (tree->string (reverse (cons pre in))) post)) (else (find-closer post (- level 1) (list* "]]" pre in)))))) (list (let loop ((s line)) (receive (pre post) (string-scan s "[[" 'both) (if pre (cons (format-parts pre) (receive (wikiname rest) (find-closer post 0 '()) (if wikiname (cons (format-wiki-name wikiname) (loop rest)) (list rest)))) (format-parts s)))) "\n") )
サンプルデータを与えて処理を考える。一般的なのは、1行の中にWiKiNameが1つある場合。 例えば、以下のようなデータを読み込む場合を考える。
これが[[ WiKiName ]]です。
まず、
(receive (pre post) (string-scan s "[[" 'both)
により、preに"これが"、postに"WikiName]]です。"が束縛される。次のif文ではpreは真 なので、この下に定義されているformat-partsでpreを処理した結果と、なにやらまた 入り組んだ処理の結果がconsされて戻される。
その入り組んだ処理では、まず(find-closer post 0 '())の戻り値を束縛することから始まる。 find-closerは2つの値を返す。find-closerの呼び出しは、変数の中身を記述すると、
(find-closer "WiKiName]]です。" 0 '())
となる。find-closerでは、仮引数sに"WikiName]]です。"、levelに0、inに'()が 束縛される。find-closerの中では、まずローカル変数pre、tok、postに(token s)の 結果が束縛される。(token s)の戻り値はここでは、("WikiName" "]]" "です。")となる。 これを以ってfind-closerのcond節に入っていくと、マッチする条件は(= level 0)である。 すると、このfind-closer呼び出しは、次のようになる。
(values (tree->string (reverse (cons pre in))) post) (values (tree->string (reverse (cons "WiKiName" '()))) "です。") (values (tree->string (reverse ("WiKiName"))) "です。") ==> "WiKiName" "です。"
これが、(receive (wikiname rest)で受け取られ、wikinameが真ならば、 (format-wiki-name wikiname)と(loop rest)がconsされたものが返る。 ここでは、wikinameは真なので、(format-wiki-name wikiname)で、"WiKiName"が wikinameとしてフォーマットされる。一方、(loop rest)は、最初のreceiveが(#f #f)を 受け取るので、if文が偽となり、(format-parts s)が実行される。
(define (format-parts line) (define (uri line) (regexp-replace-all #/(\[)?(http|https|ftp):(\/\/[^\/?#\s]*)?([^?#\s]*(\?[^#\s]*)?(#\S*)?)(\s([^\]]+)\])?/ line (lambda (match) ;; NB: If a server name is not given, we omit the protocol scheme in ;; href attribute, so that the same page would work on both ;; http and https access. (Patch from YAEGASHI Takeshi). (let* ((scheme (match 2)) (server (match 3)) (path (match 4)) (openp (match 1)) (name (match 8)) (url (if server #`",|scheme|:,|server|,|path|" path))) ;; NB: url is already HTML-escaped. we can't use ;; (html:a :href url url) here, for it will escape the first URL ;; again. (if (and openp name) (format #f "<a href=\"~a\">~a</a>" url name) (format #f "~a<a href=\"~a\">~a:~a~a</a>" (if openp "[" "") url scheme (or server "") path)))))) (define (bold line) (regexp-replace-all #/([^']*)/ line "<strong>\\1</strong>")) (define (italic line) (regexp-replace-all #/([^']*)/ line "<em>\\1</em>")) (define (nl line) (regexp-replace-all #/
/ line "<br>")) (uri (nl (italic (bold (html-escape-string line))))))
手続きformat-partsは、引数で与えられたlineにあるフォーマット指示子を、 実際のHTMLタグに置き換える。ここで扱うのは、HTMLリンク、ボールド、イタリック、 空行の場合の<br>。
;; Read lines from generator and format them. (define (format-lines generator) ;; Common states: ;; ctx - context (stack of tags to be closed) ;; id - counter for heading anchors ;; r - reverse list of results (define (loop line ctx id r) (cond ((eof-object? line) (finish (ctag ctx) r)) ((string-null? line) (loop (generator) '(p) id (list* "\n<p>" (ctag ctx) r))) ((string=? "----" line) (loop (generator) '() id (list* "<hr>" (ctag ctx) r))) ((string=? "{{{" line) (pre* (generator) id (list* "<pre>" (ctag ctx) r))) ((and (string-prefix? " " line) (or (null? ctx) (equal? ctx '(p)))) (pre line id (list* "<pre>" (ctag ctx) r))) ((rxmatch #/^(\*\**) / line) => (lambda (m) (let* ((hfn (ref `(,html:h2 ,html:h3 ,html:h4 ,html:h5) (- (h-level m) 1) html:h6)) (anchor (cut html:a :name <> <>))) (loop (generator) '() (+ id 1) (list* (hfn (anchor id (format-line (m 'after)))) (ctag ctx) r))))) ((rxmatch #/^(--*) / line) => (lambda (m) (list-item m (h-level m) 'ul ctx id r))) ((rxmatch #/^(##*) / line) => (lambda (m) (list-item m (h-level m) 'ol ctx id r))) ((rxmatch #/^:(.*):([^:]*)$/ line) => (lambda (m) (loop (generator) '(dl) id (cons `(,@(if (equal? ctx '(dl)) '() `(,(ctag ctx) "<dl>")) "<dt>" ,(format-line (m 1)) "<dd>" ,(format-line (m 2))) r)))) ((rxmatch #/^\|\|(.*)\|\|$/ line) => (lambda (m) (table (m 1) id (list* "<table class=\"inbody\" border=1 cellspacing=0>" (ctag ctx) r)))) ((null? ctx) (loop (generator) '(p) id (list* (format-line line) "<p>" r))) (else (loop (generator) ctx id (cons (format-line line) r))) )) (define (finish ctx r) (cons (reverse! r) ctx)) (define (otag ctx) (map (lambda (t) #`"<,|t|>") ctx)) (define (ctag ctx) (map (lambda (t) #`"</,|t|>") ctx)) (define (h-level matcher) ;; level of headings (- (rxmatch-end matcher 1) (rxmatch-start matcher 1))) (define (pre line id r) (cond ((eof-object? line) (finish '("</pre>") r)) ((string-prefix? " " line) (pre (generator) id (list* "\n" (string-tr (tree->string (format-line line)) "\n" " ") r))) (else (loop line '() id (cons "</pre>" r))))) (define (pre* line id r) (cond ((eof-object? line) (finish '("</pre>") r)) ((string=? line "}}}") (loop (generator) '() id (cons "</pre>" r))) (else (pre* (generator) id (list* "\n" (html-escape-string line) r))))) (define (table body id r) (let1 r (cons (html:tr :class "inbody" (map (lambda (seg) (html:td :class "inbody" (format-line seg))) (string-split body "||"))) r) (let1 next (generator) (cond ((eof-object? next) (finish '("</table>") r)) ((rxmatch #/^\|\|(.*)\|\|$/ next) => (lambda (m) (table (m 1) id r))) (else (loop next '() id (cons "</table>\n" r))))))) (define (list-item match level ltag ctx id r) (let*-values (((line) (rxmatch-after match)) ((pre ctx) (if (equal? ctx '(p)) (values ctx '()) (values '() ctx))) ((cur) (length ctx))) (cond ((< cur level) (loop (generator) `(,@(make-list (- level cur) ltag) ,@ctx) id (list* (format-line line) "<li>" (otag (make-list (- level cur) ltag)) (ctag pre) r))) ((> cur level) (loop (generator) (drop ctx (- cur level)) id (list* (format-line line) "<li>" (ctag (take ctx (- cur level))) r))) (else (loop (generator) ctx id (list* (format-line line) "<li>" r)))))) (loop (generator) '() 0 '()))
手続きformat-linesは、引数で与えられたgeneratorから受け取った行をフォーマット する。これは、この後で定義されているformat-contentの最後で、
(format-lines (make-line-fetcher p))
として呼び出されている。
;; Create a generator method. ;; NB: it's kind of ugly that the generator should switch the verbatim mode ;; looking at "{{{", but it makes the parser (format-lines) much simpler. (define (make-line-fetcher port) (let ((buf (read-line port)) (verbatim #f) (finish (lambda (r) (if (null? (cdr r)) (car r) (string-concatenate-reverse r)))) ) (lambda () (if (eof-object? buf) buf (let loop ((next (read-line port)) (r (list buf))) (set! buf next) (cond ((eof-object? next) (finish r)) (verbatim (when (string=? "}}}" next) (set! verbatim #f)) (finish r)) ((string=? "{{{" next) (set! verbatim #t) (finish r)) ((string-prefix? "~" next) (loop (read-line port) (cons (string-drop next 1) r))) ((string-prefix? ";;" next) (loop (read-line port) r)) (else (finish r))) ))) ))
コメントに注意として、「ジェネレータが"{{{"を見つけたらverbatimモードにスイッチする ので醜いが、パーサ(format-lines)はよりシンプルになる」とあります。
擬似コードで考える。
make-line-fetcher ポート let buf ポートから1行読む verbatim #f finish rを取る手続き rのcdrが空リストなら rのcarを返す r(リスト)をreverseしてから連結する メイン処理(引数なし) bufがeofなら bufを返す loop バインディング next ポートからの次の行 r bufをリストにしたもの bufにnextを束縛 cond nextがeofなら、finish r verbatimが#tなら、 nextが"}}}"と等しければ、verbatimを#fにし、finish r nextが"{{{"と等しければ、verbatimを#tにし、finish r nextが"~"で始まっていれば、 次の行と、nextの最初の一文字を削除したものをrにconsしたものを引数にloop nextが";;"で始まっていれば、次の行とrを引数にループ いずれでもなければ、finish r
つまり、手続きmake-line-fetcherは、与えられたポートを読み込んで、 最終的には文字列を返す。その文字列は、処理本体中でリストrに溜められた要素を 逆順にして連結したもの。
ほげほげ {{{ ふがふが }}} ||むにゃむにゃ ~||のものも|| うまうま
という内容のページを処理する場合を例にとって、処理の流れを追ってみる。
rはloopに入るときに、読み込んだ1行、bufをリストにしたもの。ということは、1行の文字列を1つの要素とするリストである。ここでは、("ほげほげ")。
cond節の中で、bufは"ほげほげ"、nextは"{{{"。最初に真を返す条件は、3番目の「 nextが"{{{"と等しければ、verbatimを#tにし、finish r」。finish rのrは、("ほげほげ") なので、そのcdrは()であり、rのcar、つまり"ほげほげ"を返す。これで、手続き make-line-fetcherは抜けてしまう。
次にmake-line-fetcherが呼ばれたときは、cond節の中では、verbatimは#tで、 bufが"ふがふが"、nextが"}}}"、rは("ふがふが")。ここでは2番目の「verbatimが#tなら」 が真を返すので、対応する「nextが"}}}"と等しければ、verbatimを#fにし、finish r」と 処理される。
次にmake-line-fetcherが呼ばれたときは、cond節の中では、verbatimは#fで、 bufが"||むにゃむにゃ||"、nextは"~||のものも||"、rは("||むにゃむにゃ")。
この場合、cond節で真となる条件は、「nextが"~"で始まっていれば」なので、対応する 「次の行と、nextの最初の一文字を削除したものをrにconsしたものを引数にloop」が 処理される。次の行は"うまうま"で、これが次回のloopのnext(cond節ではbuf)、「next("~|| のものも||")の最初の一文字を削除したもの、"||のものも||"を、r、("||むにゃむにゃ") にconsすると、("||のものも||" "||むにゃむにゃ")になり、次のloopが呼ばれる。
次のloopでは、nextがeofなので、finish r。rのcdrは("||むにゃむにゃ")で()では ないので、rをreverseして連結する。つまり、("||むにゃむにゃ" "||のものも||") -> "||むにゃむにゃ||のものも||"が返る。
(define (format-content page) (if (member page (page-format-history) (lambda (p1 p2) (string=? (key-of p1) (key-of p2)))) ;; loop in $$include chain detected ">>>$$include loop detected<<<" (parameterize ((page-format-history (cons page (page-format-history)))) (call-with-input-string (content-of page) (lambda (p) (with-port-locking p (lambda () (format-lines (make-line-fetcher p)))))))) )
引数pageがpage-format-historyのメンバならば(比較式は、keyが同じかどうか)、 文字列">>>$$include loop detected<<<"。そうでなければ、page-format-historyに pageをconsして、ページの内容を入力ポートとし、さらにそのポートをロックして、 make-line-fetcherの返り値をformat-linesする。make-line-fetcherは、"{{{"や"}}}"や、 行継続の"~"を検査しながら、(文字面ではなく、編集者の)意味的な1行を読み取りながら、 1行ずつ返してくる。
(define (format-footer page) (if (mtime-of page) `(,(html:hr) ,(html:div :align "right" ($$ "Last modified : ") (format-time (mtime-of page)))) '()))
手続きformat-footerは、ページの最後に<page>オブジェクトの:mtimeを 表示する。
(define (format-page title page . args)
(let* ((wlki (wiliki))
(show-edit? (and (editable? wlki)
(get-keyword :show-edit? args #t)))
(show-all? (get-keyword :show-all? args #t))
(show-recent-changes? (get-keyword :show-recent-changes? args #t))
(show-search-box? (get-keyword :show-search-box? args #t))
(page-id (get-keyword :page-id args title))
(content (if (is-a? page <page>)
(list (format-content page)
(format-footer page))
page)))
(html-page
(html:title (html-escape-string title))
(html:h1 (if (is-a? page <page>)
(html:a :href (url "c=s&key=~a?" title)
(html-escape-string title))
(html-escape-string title)))
(html:div
:align "right"
(html:form
:method "POST" :action (cgi-name-of wlki)
(html:input :type "hidden" :name "c" :value "s")
(language-link page-id)
(cond-list
((not (string=? title (top-page-of wlki)))
(html:a :href (cgi-name-of wlki) ($$ "[Top Page]")))
(show-edit?
(html:a :href (url "p=~a&c=e" title) ($$ "[Edit]")))
(show-all?
(html:a :href (url "c=a") ($$ "[All Pages]")))
(show-recent-changes?
(html:a :href (url "c=r") ($$ "[Recent Changes]")))
(show-search-box?
`("[" ,($$ "Search:")
,(html:input :type "text" :name "key" :size 10)
"]")))
))
(html:hr)
content)))
手続きformat-pageは、ページ右上のWiKiリンクを表示し、その下に内容を 表示する。
ページ右上のWiKiリンクは、HTML FORMで、それぞれ以下のような判定を行いつつ 表示する。まず、hiddenなinputで、c=sを書き出す。次にlanguage-link。 次の部分は、util.listのcond-listを使っているので、cond-listに 含まれるそれぞれの節が真の場合は、対応する式の結果がリストに追加される。
判定 | リストに追加されるもの |
WiLiKiの:top-pageと今表示しようとするページのタイトルが同じではないかどうか | (同じではない場合)WiLiKiのトップページへのリンク |
show-edit? | 編集用リンク。CGIパラメータは、p=ページ名&c=e。 |
show-all? | 全てのページへのリンク。CGIパラメータは、c=a。 |
show-recent-changes? | 最近の更新リンク。CGIパラメータは、c=r。 |
show-search-box? | 検索ボックス。CGIパラメータは、key=[text]。 |
これらの判定は、その前のlet*式で、以下のように束縛されている。
判定 | 内容 |
show-edit? | WiLiKiが編集可能ならば、#t。(editable? wlki)と(get-keyword :show-edit? args #t)のandになっているが、後者はフォールバックが#tなので必ず#tに評価される。なぜこのような書き方をしているのだろう? |
show-all? | これも(get-keyword :show-all? args #t)となっており、これはかならず#tに評価されるはず。 |
show-recent-changes? | これも上と同様。#t。 |
show-search-box? | これも同様。#t。 |
その他、let*式で定義されているローカル変数には次のようなものがある。
WiLiKi-0.5では、SXMLを利用するために大幅に書き換えられていますね。
(define (fmt-content page) (define (do-fmt content) (call-with-input-string content (lambda (p) (with-port-locking p (cut fmt-lines (make-line-scanner p)))))) (cond ((string? page) (do-fmt page)) ((is-a? page <wiliki-page>) (if (wiliki:page-circular? page) ;; loop in $$include chain detected `(p ">>>$$include loop detected<<<") (parameterize ((page-stack (cons page (page-stack)))) (if (string? (ref page 'content)) (do-fmt (ref page 'content)) (ref page 'content))))) (else page)))
(define-class <wiliki-page> () (;; title - Page title. For persistent pages, this is set to ;; the same value as the database key. (title :init-value #f :init-keyword :title) ;; key - Database key. For transient pages, this is #f. (key :init-value #f :init-keyword :key) ;; command - A URL parameters to reproduce this page. Only meaningful ;; for transient pages. (command :init-value #f :init-keyword :command) ;; content - Either a wiliki-marked-up string or SXML. (content :init-value "" :init-keyword :content) ;; creation and modification times, and users (users not used now). (ctime :init-value (sys-time) :init-keyword :ctime) (cuser :init-value #f :init-keyword :cuser) (mtime :init-value #f :init-keyword :mtime) (muser :init-value #f :init-keyword :muser) ))
(define-class <wiliki-formatter> () (;; The following slots are only for compatibility to the code ;; written with WiLiKi-0.5_pre2. ;; They won't be supported officially in future versions; use ;; subclassing & methods instead. (bracket :init-keyword :bracket :init-value (lambda (name) (list #`"[[,|name|]]"))) (macro :init-keyword :macro :init-value (lambda (expr context) `("##" ,(write-to-string expr)))) (time :init-keyword :time :init-value (lambda (time) (x->string time))) (body :init-keyword :body :init-value (lambda (page opts) (fmt-body page opts))) (header :init-keyword :header :init-value (lambda (page opts) '())) (footer :init-keyword :footer :init-value (lambda (page opts) '())) (content :init-keyword :content :init-value (lambda (page opts) (fmt-content page))) (head-elements :init-keyword :head-elements :init-value (lambda (page opts) '())) ))