commit 607e161b71e7b8cc2fc5808dab5dad2f606e0a1f
Author: tomas <tomas@logand.com>
Date: Thu, 22 Jul 2010 19:35:00 +0200
Initial commit
Diffstat:
| A | picowiki.css | | | 62 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | picowiki.l | | | 531 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
2 files changed, 593 insertions(+), 0 deletions(-)
diff --git a/picowiki.css b/picowiki.css
@@ -0,0 +1,62 @@
+a.e {
+ text-decoration: none;
+ border-bottom: thin dotted gray;
+}
+a.i:hover {
+ background-color: #ffa;
+}
+a.a {
+ border-left: thin dotted red;
+ padding-left: 0.3em;
+}
+body hr {
+ border: 0;
+ color: blue;
+ background-color: blue;
+ height: 1px;
+}
+.page hr {
+ border: none;
+ border-top: dashed thin blue;
+ color: white;
+ background-color: white;
+ height: 1px;
+}
+.page table {
+ border: thin solid black;
+ border-collapse: collapse;
+}
+.page td {
+ border: thin solid black;
+}
+.page pre {
+ border-left: thin dotted;
+ padding-left: 1em;
+}
+.lisp {
+ border-left: thin dotted;
+ padding-left: 1em;
+}
+.lisp a {
+ font-weight: bold;
+ text-decoration: none;
+ background-color: #ffa;
+}
+.lisp .str {
+ color: green;
+}
+.ref {
+ font-weight: bold;
+ text-decoration: none;
+ background-color: #ffa;
+}
+.changes ul {
+ list-style-type: none;
+}
+.all ul {
+ list-style-type: none;
+}
+.menu {
+ margin-top: 0em;
+ margin-bottom: 0em;
+}
diff --git a/picowiki.l b/picowiki.l
@@ -0,0 +1,531 @@
+#!/home/thlavaty/picolisp/bin/picolisp /home/thlavaty/picolisp/lib.l
+# -*- picolisp -*-
+
+(setq *Dir "/home/thlavaty/public_html/picoWiki")
+(setq *Host "logand.com") # TODO remove this
+
+(load "@ext.l" "@lib/http.l" "@lib/xhtml.l" "@lib/form.l" "@lib/xml.l")
+
+(off *JS)
+
+(de <b> Prg
+ (tag 'b NIL 2 Prg))
+
+(de <sub> Prg
+ (tag 'sub NIL 2 Prg))
+
+(de <sup> Prg
+ (tag 'sup NIL 2 Prg))
+
+(de <legend> Prg
+ (tag 'legend NIL 2 Prg))
+
+(de <href2> (Attr Str Url JS)
+ (let *Style Attr
+ (<href> Str Url JS)))
+
+(de <form> (Method Url . Prg)
+ (tag 'form (list (cons 'method Method) (cons 'action Url)) 2 Prg))
+
+(de _markupWord ()
+ (pack (make (until (or (eof) (member (peek) '("\\" "<" " " "^I" "^M" "^J")))
+ (link (char))))))
+
+(de _markupSpace ()
+ (let (N 0 S 0)
+ (until (or (eof) (not (member (peek) '(NIL " " "^I" "^M" "^J"))))
+ (let C (char)
+ (ifn (= C "^J")
+ (unless (= C "^M")
+ (inc 'S))
+ (inc 'N)
+ (zero S))))
+ (cons N S)))
+
+(de _markupCmd ()
+ (char)
+ (case (peek)
+ ("\\" (char))
+ ("\<" (char))
+ ("\~" (char) (cons 'nbsp NIL))
+ ("="
+ (case (till " ^I^M^J" T)
+ ("=" T)
+ ("==" (cons 'hr NIL))))
+ ("{"
+ (char)
+ (prog1
+ (cons 'lnk
+ (make
+ (while (till "} ^I^M^J" T)
+ (link @)
+ (skip))))
+ (char)))
+# (T
+# (case (till "{" T)
+# ("b" (cons 'b (till "}" T)))))
+))
+
+(de _markupXml (End)
+ (char)
+ (let? C (till ">" T)
+ (char)
+ (unless (= C End)
+ (if (member C '("pre" "lisp"))
+ (cons C (prog1 (till "<" T) (till ">") (char)))
+ (cons C (_markup (pack "/" C)))))))
+
+(de _markup (End)
+ (let Space (member (peek) '(" " "^I" "^M" "^J"))
+ (skip)
+ (let Eop NIL
+ (make # paragraphs
+ (until (or Eop (eof))
+ (when (make # words
+ (while (and (not Eop)
+ (case (peek)
+ ("\\"
+ (let? X (_markupCmd)
+ (when Space (link NIL))
+ (link X)))
+ ("<"
+ (let X (_markupXml End)
+ (ifn X
+ (nil (on Eop))
+ (when Space (link NIL))
+ (link X))))
+ (T
+ (let? X (_markupWord)
+ (when Space (link NIL))
+ (link X))))
+ (let X (_markupSpace)
+ (setq Space (or (< 0 (cdr X))
+ (= 1 (car X))))
+ (< (car X) 2)))))
+ (link @)))))))
+
+(setq *Xref
+ (mapcar pack '(new sym str char name sp? pat? fun? all intern extern ==== loc box? str? ext? touch zap length size format chop pack glue pad align center text wrap pre? sub? low? upp? lowc uppc fold val getd set setq def de dm recur undef redef daemon patch xchg on off onOff zero one default expr subr let let? use accu push push1 pop cut del queue fifo idx lup cache locale dirname
+ put get prop ; =: : :: putl getl wipe meta
+ atom pair lst? num? sym? flg? sp? pat? fun? box? str? ext? bool not == n== = <> =0 =T n0 nT < <= > >= match
+ + - * / % */ ** inc dec >> lt0 ge0 gt0 abs bit? & | x| sqrt seed rand max min length size accu format pad oct hex fmt64 money
+ car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr cadddr cddddr nth con cons conc circ rot list need full make made chain link yoke copy mix append delete delq replace insert remove place strip split reverse flip trim clip head tail stem fin last member memq mmeq sect diff index offset assoc asoq rank sort uniq group length size val set xchg push push1 pop cut queue fifo idx balance get fill apply
+ load args next arg rest pass quote as pid lit eval run macro curry def de dm recur recurse undef box new type isa method meth send try super extra with bind job let let? use and or nand nor xor bool not nil t prog prog1 prog2 if if2 ifn when unless cond nond case state while until loop do at for catch throw finally ! e $ sys call tick ipid opid kill quit task fork pipe later timeout bye
+ apply pass maps map mapc maplist mapcar mapcon mapcan filter seek find pick cnt sum maxi mini fish by
+ path in ipid out opid pipe ctl any sym str load hear tell key poll peek char skip eol eof from till line format scl read print println printsp prin prinl msg space beep tab flush rewind rd pr wr rpc wait sync echo info file dir lines open close port listen accept host connect nagle udp rc pretty pp show view here prEval mail
+ *Class class dm rel var var: new type isa method meth send try object extend super extra with This
+ pool journal id seq lieu lock begin commit rollback mark free dbck rel dbs dbs+ db: fmt64 tree root fetch store count leaf minKey maxKey genKey useKey init step scan iter prune zapTree chkTree db aux collect
+ be goal prove -> unify ?
+ pretty pp show loc debug vi ld trace lint lintAll fmt64
+ argv opt gc raw alarm protect heap env up stk date time usec stamp dat$ $dat datSym datStr strDat expDat day week ultimo tim$ $tim telStr expTel locale allowed allow pwd cd chdir ctty info dir dirname call tick kill quit task fork pipe timeout mail test bye
+ NIL *OS *DB T *Solo *PPid *Pid @ @@ @@@ This *Dbg *Zap *Scl *Class *Dbs *Run *Hup *Sig1 *Sig2 ^ *Err *Rst *Msg *Uni *Led *Adr *Allow *Fork *Bye)))
+
+(de xtok (L)
+ (when (member (car L) '("(" " " "^I" "^J" "^M"))
+ (let L (cdr L)
+ (make
+ (until (or (not L) (member (car L) '(")" " " "^I" "^J" "^M")))
+ (link (car L))
+ (setq L (cdr L)))))))
+
+(de xref (L)
+ (let? Tok (xtok L)
+ (let Tok2 (pack Tok)
+ (when (member Tok2 *Xref)
+ (cons
+ Tok2
+ (pack "http://www.software-lab.de/ref"
+ (cond
+ ((= "*" (car Tok))
+ (uppc (cadr Tok)))
+ ((member (lowc (car Tok))
+ (chop "abcdefghijklmnopqrstuvwxyz"))
+ (uppc (car Tok)))
+ (T "_"))
+ ".html#" Tok))))))
+
+(de markupLisp (B)
+ (let X (chop B)
+ (while X
+ (ifn (xref X)
+ (ht:Prin (pop 'X))
+ (prin (pop 'X))
+ (<href> (car @) (cdr @))
+ (do (length (car @)) (pop 'X))))))
+
+# ((pre? "blog:" (car B))
+# (let (BB1 (pack (cddr (car B)) " " (glue " " (cdr B)))
+# BB2 (glue " " B))
+# (<href2> 'i BB1 (pack "?" BB2))
+# (prin "<sup>β</sup>")))
+(de <ilink> (Page)
+ (if (info (pageFile Page))
+ (<href2> 'i Page (pack "?" Page))
+ (ht:Prin Page)
+ (<href2> 'i "?" (pack "?@" Page))))
+
+(de markup (Lst Par)
+ (for (I . P) Lst
+ (unless Par
+ (prin "<p>"))
+ (for (J . M) P
+ (if (atom M)
+ (cond
+ ((=T M) (prin "<br/>"))
+ ((not M) (prin " "))
+ (T (ht:Prin M)))
+ (let (H (car M) B (cdr M))
+ (case H
+ (lnk
+ (cond
+ ((pre? "http://" (car B))
+ (<href2> 'e (or (glue " " (cdr B)) (car B)) (car B)))
+ (T
+ (<ilink> (glue " " B)))))
+ (nbsp (<nbsp>))
+ (hr (<hr>))
+ (("ul" "ol")
+ (prin "<" H ">")
+ (for Li (car B)
+ (when (= "li" (car Li))
+ (prin "<li>")
+ (markup (cdr Li) (< (length (cdr Li)) 2))
+ (prin "</li>")))
+ (prin "</" H ">"))
+ ("table"
+ (prin "<" H ">")
+ (for R (car B)
+ (when (= "tr" (car R))
+ (prin "<tr>")
+ (for C (cadr R)
+ (when (= "td" (car C))
+ (prin "<td>")
+ (markup (cdr C) (< (length (cdr C)) 2))
+ (prin "</td>")))
+ (prin "</tr>")))
+ (prin "</" H ">"))
+ (("h2" "h3" "b" "u")
+ (prin "<" H ">")
+ (markup B T)
+ (prin "</" H ">"))
+ ("pre"
+ (prin "<" H ">")
+ (ht:Prin B)
+ (prin "</" H ">"))
+ ("lisp"
+ (prin "<pre class=\"lisp\">")
+ (markupLisp B)
+ (prin "</pre>"))
+ ))))
+ (unless Par
+ (prin "</p>"))))
+
+(de renderView (Page)
+ (<div> 'page
+ (<h1> NIL (ht:Prin Page))
+ (let F (pageFile Page)
+ (if (info F)
+ (in F (markup (_markup)))
+ (<p> NIL "The page does not exist yet. "
+ (<href> "Create the page now." (pageUrl Page 'edit)))))))
+
+(de readChanges (F)
+ (let L NIL
+ (in F
+ (until (eof)
+ (match '("\"" @D "\"" " "
+ "\"" @T "\"" " "
+ "\"" @N "\"" " "
+ "\"" @P "\"" " "
+ @V " "
+ "\"" @C "\"") (line))
+ (push 'L (mapcar pack (list @D @T @N @P @V @C)))))
+ L))
+
+(de renderChanges (Page)
+ (<div> '((class . "page changes"))
+ (<h1> NIL Page)
+ (let F (pageFile Page)
+ (ifn (info F)
+ (<p> NIL "No changes have been made yet.")
+ (let L (readChanges F)
+ (for D (group L)
+ (<p> NIL
+ (ht:Prin (httpDate2 (strDat (car D))))
+ (<ul> NIL
+ (for C (cdr D)
+ (let (@T (car C)
+ @N (cadr C)
+ @P (caddr C)
+ @V (cadddr C)
+ @C (car (cddddr C)))
+ (<li> NIL
+ (ht:Prin @T)
+ " " (<ilink> @P)
+ " " (ht:Prin @V)
+ ": " (ht:Prin @C)
+ " -- " (<ilink> @N))))))))))))
+
+(de httpDate2 (Dat Tim)
+ (let D (date Dat)
+ (pack
+ (day Dat *Day) ", "
+ (pad 2 (caddr D)) " "
+ (get *Mon (cadr D)) " "
+ (car D)
+ (when Tim " ")
+ (when Tim (tim$ Tim T))
+ (when Tim " GMT" ) ) ))
+
+(de rssItem (@D I)
+ (when (match '(@T @N @P @V @C) I)
+ (setq @T (car @T))
+ (setq @N (car @N))
+ (setq @P (car @P))
+ (setq @V (car @V))
+ (setq @C (car @C))
+ (list 'item NIL
+ (list 'title NIL
+ (pack (httpDate2 (strDat @D)) " " @P " " @V ": " @C
+ (when @N (pack " -- " @N))))
+ (list 'pubDate NIL (httpDate2 (strDat @D) ($tim @T)))
+ (list 'link NIL
+ (pack "http://" *Host "/picoWiki?"
+ (ht:Fmt (pack (cdr (chop (pageUrl @P 'view))))))))))
+
+(de rss (Page)
+ (httpHead "text/xml; charset=utf-8" 0)
+ (ht:Out *Chunked
+ (xml? T)
+ (xml
+ (list 'rss '((version . "0.92"))
+ (make
+ (link 'channel NIL
+ '(title NIL "picoWiki Changes")
+ (list 'link NIL (pack "http://" *Host "/picoWiki?Changes"))
+ '(description NIL "picoWiki Changes"))
+ (let F (pageFile "Changes")
+ (when (info F)
+ (let L (readChanges F)
+ (for D (group L) # by date
+ (for DD (by caddr group (cdr D)) # by page
+ (let N (length DD)
+ (link
+ (rssItem (car D)
+ (if (< 1 N)
+ (list
+ (caar DD)
+ NIL
+ (car (cddar DD))
+ (cadr (cddar DD))
+ (pack N " changes"))
+ (car DD)))))))))))))))
+
+(de renderEdit (Page)
+ (<form> "post" (pageUrl Page 'edit)
+ (<h1> NIL (ht:Prin "Edit '" Page "' page"))
+ (let *T (readPage Page)
+ (<area> 78 20 '*T))
+ (<p> NIL
+ (<b> ,"Summary of changes:") " " (<field> 40 '*S))
+ (<p> NIL
+ (<b> ,"Captcha (enter the word 'pico' here):") " "
+ (<field> 10 '*C))
+ (<p> NIL
+ (<b> ,"Your name:") " " (<field> 40 '*N))
+ (<p> NIL
+ (<check> '*R)
+ (<b> ,"Check this box to fill in your name automatically next time")
+ ," (uses a cookie)")
+ (<p> NIL
+ (<submit> "Preview")
+ (<reset> "Reset")
+ (<href> ,"View page" (pageUrl Page 'view)))))
+
+(de mktemp ()
+ (in (list "mktemp" "/tmp/picoWiki.XXXXXX")
+ (line T)))
+
+(de renderPreview (Page)
+ (<form> "post" (pageUrl Page 'edit)
+ (<div> 'page
+ (<h1> NIL (ht:Prin "Preview '" Page "' page"))
+ (let F (mktemp)
+ (out F (prin *T))
+ (in F (markup (_markup)))
+ (call "rm" "-f" F)))
+ (<p> NIL
+ (<hidden> '*T *T)
+ (<hidden> '*S *S)
+ (<hidden> '*C *C)
+ (<hidden> '*N *N)
+ (<hidden> '*R *R)
+ (<hidden> '*P T)
+ (<submit> "Save")
+ (<href> ,"View page" (pageUrl Page 'view)))))
+
+(de render (Page Edit Preview)
+ (case Page
+ ("rss" (rss))
+ (T
+ (let F (pageFile Page)
+ (html
+ 0 # TODO allow caching (if Edit 0 (* 60 60 24 1)) # 1 day
+ (pack "picoWiki: " Page)
+ (pack "http://" *Host "/picoWiki/picoWiki.css") NIL
+ #==
+ (<form> "post"
+ (<div> NIL
+ (pageUrl Page 'search)
+ "picoWiki: the picoLisp Wiki"
+ " | " (<href2> 'i "Home" (pageUrl NIL 'view))
+ " " (<href2> 'i "Changes" (pageUrl "Changes" 'view))
+ " " (<href2> 'i "Formatting" (pageUrl "Formatting" 'view))
+ " " (<href2> 'i "Sandbox" (pageUrl "Sandbox" 'view))
+ " " (<field> 20 '*Q) (<submit> "Search")))
+ (<hr>)
+ (case Page
+ ("Changes" (renderChanges Page))
+ (T (if Edit
+ (if Preview
+ (renderPreview Page)
+ (renderEdit Page))
+ (renderView Page))))
+ (<hr>)
+ (<p> NIL
+ "This page is linked from:"
+ (for P (grep Page)
+ (unless (= P Page)
+ (prin " ") (<href2> 'i P (pageUrl P 'view)))))
+ (<p> NIL
+ (when (editablePage Page)
+ (<href> ,"Edit page" (pageUrl Page 'edit)))
+ (when (info F)
+ (when (editablePage Page)
+ (prin " | "))
+ (<href> ,"View source" (pageUrl Page 'source))
+ (prin " | Revisions: ")
+ (let (V (latestVersion Page)
+ C V)
+ (for N '(9 8 7 6 5 4 3 2 1 0)
+ (let W (- V N)
+ (when (< 0 W)
+ (prin " ")
+ (if (= W C)
+ (<b> W)
+ (prin W)))))))
+ (prin " | ")
+ (<href> ,"RSS" (pageUrl "rss" 'view))
+ (<sup>
+ (<href2> 'e "V"
+ (pack "http://feedvalidator.org/check.cgi?url="
+ "http://" *Host "/picoWiki" (pageUrl "rss" 'view))))
+ (prin " XHTML")
+ (<sup>
+ (<href2> 'e "V"
+ (pack "http://validator.w3.org/check?uri="
+ "http://" *Host "/picoWiki" (pageUrl Page 'view)))))
+ (<p> NIL
+ "picoWiki pages can be edited by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively"))))))
+
+(de grep (Page)
+ (chdir (pageFile)
+ (in (list "sh" "-c" (pack "grep '\{" Page "}' *.txt"))
+ (let X NIL
+ (until (eof)
+ (push1 'X
+ (pack (reverse (cddddr (reverse (car (split (line) ":"))))))))
+ X))))
+
+(de latestVersion (Page)
+ (let? F (pageFile Page)
+ (when (info F)
+ (in (list "rlog" "-h" F)
+ (catch 'version
+ (until (eof)
+ (let L (line)
+ (when (match '("h" "e" "a" "d" ":" " " "1" "." @N) L)
+ (throw 'version (format (pack @N)))))))))))
+
+(de post ()
+ (mapcar '((X) (split X "=")) (split (in NIL (till NIL)) "&")))
+
+(de _htDecode (L)
+ (ht:Pack (replace L "+" " ")))
+
+(de pageFile (Page)
+ (if Page
+ (pack *Dir "/pages/" Page ".txt")
+ (pack *Dir "/pages")))
+
+(de readPage (Page)
+ (let F (pageFile Page)
+ (when (info F)
+ (in F (till NIL T)))))
+
+(de rcsOut (F)
+ (when (info F)
+ (call "sh" "-c" (pack "co -l '" F "'"))))
+
+(de rcsIn (F Msg)
+ (when (info F)
+ (call "sh" "-c" (pack "ci -u -m'" Msg "' '" F "'"))))
+
+(de editablePage (Page)
+ (not (member Page '("Changes" "rss"))))
+
+(de writePage (Page Text Msg Name)
+ (let V (latestVersion Page)
+ (let F (pageFile Page)
+ (rcsOut F)
+ (out F (prin Text))
+ (rcsIn F Msg))
+ (let V2 (latestVersion Page)
+ (unless (= V V2)
+ (let F (pageFile "Changes")
+ (rcsOut F)
+ (out (pack "+" F)
+ (println (datStr (date)) (tim$ (time T) T) Name Page V2 Msg))
+ (rcsIn F "upd"))))))
+
+(de pageUrl (Page Mode)
+ (case Mode
+ (source (pack "/picoWiki/pages/" Page ".txt"))
+ (view (pack "?" Page))
+ (edit (pack "?@" Page))
+ (search "?~")))
+
+(de cookies ()
+ (mapcar '((X) (mapcar pack (split (chop X) "=")))
+ (mapcar pack (split (chop (sys "HTTP_COOKIE")) ";"))))
+
+(let (M (sys "REQUEST_METHOD")
+ Q (sys "QUERY_STRING")
+ C (cookies)
+ P (or (if (pre? "@" Q) (pack (cdr (chop Q))) Q) "picoWiki")
+ E (pre? "@" Q))
+ (setq P (_htDecode (chop P)))
+ (let? N (cadr (find '((X) (= (car X) "picoWiki.n")) C))
+ (setq *N N)
+ (on *R))
+ (ifn (= "POST" M)
+ (render P E)
+ (for X (post)
+ (case (pack (car X))
+ ("*T" (setq *T (_htDecode (cadr X))))
+ ("*S" (setq *S (_htDecode (cadr X))))
+ ("*C" (setq *C (_htDecode (cadr X))))
+ ("*N" (setq *N (_htDecode (cadr X))))
+ ("*R" (setq *R (_htDecode (cadr X))))
+ ("*Q" (setq *Q (_htDecode (cadr X))))
+ ("*P" (setq *P (_htDecode (cadr X))))))
+ (ifn (and *T *S (= "pico" *C) *N)
+ (render P E)
+ (ifn *P
+ (prog
+ (cookie "picoWiki.n" (when *R *N))
+ (render P E T))
+ (writePage P *T *S *N)
+ (redirect "?" P)))))
+
+(bye)
