📄 xhtml.l
字号:
# 30dec07abu# (c) Software Lab. Alexander Burger# *JS *Style *Menu *Tab *ID(mapc allow '(*Menu *Tab *ID))(default *Menu 0 *Tab 1)(de htPrin (Prg Ofs) (default Ofs 1) (for X Prg (if (atom X) (ht:Prin (eval X Ofs)) (eval X Ofs) ) ) )(de htStyle (Attr) (cond ((atom Attr) (prin " class=\"") (ht:Prin Attr) (prin "\"") ) ((and (atom (car Attr)) (atom (cdr Attr))) (prin " " (car Attr) "=\"") (ht:Prin (cdr Attr)) (prin "\"") ) (T (mapc htStyle Attr)) ) )(de dfltCss (Cls) (htStyle (cond ((not *Style) Cls) ((atom *Style) (pack *Style " " Cls)) ((and (atom (car *Style)) (atom (cdr *Style))) (list Cls *Style) ) ((find atom *Style) (replace *Style @ (pack @ " " Cls)) ) (T (cons Cls *Style)) ) ) )(de tag (Nm Attr Ofs Prg) (prin '< Nm) (and Attr (htStyle @)) (prin '>) (if (atom Prg) (ht:Prin (eval Prg Ofs)) (for X Prg (if (atom X) (ht:Prin (eval X Ofs)) (eval X Ofs) ) ) ) (prinl "</" Nm '>) )(de <tag> (Nm Attr . Prg) (tag Nm Attr 2 Prg) )(de style ("X" "Prg") (let *Style (nond ("X" *Style) (*Style "X") ((pair "X") (cond ((atom *Style) (pack *Style " " "X")) ((and (atom (car *Style)) (atom (cdr *Style))) (list "X" *Style) ) ((find atom *Style) (replace *Style @ (pack @ " " "X")) ) (T (cons "X" *Style)) ) ) ((or (pair (car "X")) (pair (cdr "X"))) (cond ((atom *Style) (list *Style "X")) ((and (atom (car *Style)) (atom (cdr *Style))) (if (= (car "X") (car *Style)) "X" (list *Style "X") ) ) (T (cons "X" (delete (assoc (car "X") *Style) *Style)) ) ) ) (NIL "X") ) (and (up 2 @)) (run "Prg") ) )(de <style> ("X" . "Prg") (style "X" "Prg") )(de nonblank (Str) (or Str `(pack (char 160) (char 160))) )### XHTML output ###(de html (Upd Ttl Css Attr . Prg) (httpHead NIL Upd) (ht:Out *Chunked ## (xml? T) (prinl "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">") (prinl "<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"" (or *Lang "en") "\" lang=\"" (or *Lang "en") "\">" ) (prinl "<head>") (and Ttl (<tag> 'title NIL Ttl)) (and *Host *Port (prinl "<base href=\"" (baseHRef) "\"/>")) (when Css (if (atom Css) ("css" Css) (mapc "css" Css)) ) (mapc javascript *JS) (prinl "</head>") (tag 'body Attr 2 Prg) (prinl "</html>") ) )(de "css" (Css) (prinl "<link rel=\"stylesheet\" href=\"" (srcUrl Css) "\" type=\"text/css\"/>" ) )(de javascript (JS) (when *JS (prinl "<script src=\"" (srcUrl JS) "\" type=\"text/javascript\"></script>" ) ) )(de <div> (Attr . Prg) (tag 'div Attr 2 Prg) )(de <span> (Attr . Prg) (tag 'span Attr 2 Prg) )(de <br> Prg (htPrin Prg 2) (prinl "<br/>") )(de ---- () (prinl "<br/><br/>") )(de <hr> () (prinl "<hr/>") )(de <nbsp> (N) (do (or N 1) (prin " ")) )(de <small> Prg (tag 'small NIL 2 Prg) )(de <big> Prg (tag 'big NIL 2 Prg) )(de <em> Prg (tag 'em NIL 2 Prg) )(de <strong> Prg (tag 'strong NIL 2 Prg) )(de <h1> (Attr . Prg) (tag 'h1 Attr 2 Prg) )(de <h2> (Attr . Prg) (tag 'h2 Attr 2 Prg) )(de <h3> (Attr . Prg) (tag 'h3 Attr 2 Prg) )(de <h4> (Attr . Prg) (tag 'h4 Attr 2 Prg) )(de <h5> (Attr . Prg) (tag 'h5 Attr 2 Prg) )(de <h6> (Attr . Prg) (tag 'h6 Attr 2 Prg) )(de <p> (Attr . Prg) (tag 'p Attr 2 Prg) )(de <pre> (Attr . Prg) (tag 'pre Attr 2 Prg) )(de <ol> (Attr . Prg) (tag 'ol Attr 2 Prg) )(de <ul> (Attr . Prg) (tag 'ul Attr 2 Prg) )(de <li> (Attr . Prg) (tag 'li Attr 2 Prg) )(de <href> (Str Url JS) (prin "<a href=\"" (sesId Url) "\"") (and *JS JS (prin " onclick=\"" JS ";\"")) (and *Style (htStyle @)) (prin '>) (ht:Prin Str) (prin "</a>") )(de <img> (Src Alt Url DX DY) (and Url (prin "<a href=\"" (sesId Url) "\">")) (prin "<img src=\"" (sesId Src) "\" alt=\"" Alt "\"") (and DX (prin " width=\"" DX "\"")) (and DY (prin " height=\"" DY "\"")) (and *Style (htStyle @)) (prin "/>") (and Url (prin "</a>")) )(de <this> (Var Val . Prg) (prin "<a href=\"" (sesId *Url) '? Var '= (ht:Fmt Val) "\"") (and *Style (htStyle @)) (prin '>) (htPrin Prg 2) (prin "</a>") )(de <table> (Attr Ttl "Head" . Prg) (tag 'table Attr 1 (quote (and Ttl (tag 'caption NIL 1 Ttl)) (when (find cdr "Head") (tag 'tr NIL 1 (quote (for X "Head" (tag 'th (car X) 2 (cdr X)) ) ) ) ) (htPrin Prg 2) ) ) )(de <row> (Cls . Prg) (tag 'tr NIL 1 (quote (let (L Prg H (up "Head")) (while L (let (X (pop 'L) C (pack Cls (and Cls (caar H) " ") (caar H)) N 1) (while (== '- (car L)) (inc 'N) (pop 'L) (pop 'H) ) (setq C (if2 C (> N 1) (list C (cons 'colspan N)) C (cons 'colspan N) ) ) (tag 'td (if (== 'align (car (pop 'H))) (list '(align . right) C) C ) 1 (quote (if (atom X) (ht:Prin (eval X 1)) (eval X 1) ) ) ) ) ) ) ) ) )(de <th> (Attr . Prg) (tag 'th Attr 2 Prg) )(de <tr> (Attr . Prg) (tag 'tr Attr 2 Prg) )(de <td> (Attr . Prg) (tag 'td Attr 2 Prg) )(de <grid> (X . Lst) (tag 'table 'grid 1 (quote (while Lst (tag 'tr NIL 1 (quote (use X (let L (and (sym? X) (chop X)) (do (or (num? X) (length X)) (tag 'td (cond ((pair X) (pop 'X)) ((= "." (pop 'L)) 'align) ) 1 (quote (if (atom (car Lst)) (ht:Prin (eval (pop 'Lst) 1)) (eval (pop 'Lst) 1) ) ) ) ) ) ) ) ) ) ) ) )(de <spread> Lst (<table> '(width . "100%") NIL '((norm) (align)) (<row> NIL (eval (car Lst) 1) (run (cdr Lst) 1) ) ) )(de <tip> ("Str" . "Prg") (style (cons 'title "Str") "Prg") )# Menus(de urlMT (Url Menu Tab Id) (pack Url '? "*Menu=+" Menu "&*Tab=+" Tab "&*ID=" (ht:Fmt Id)) )(de <menu> Lst (let (M 1 N 1 E 2 U) (recur (Lst N E) (<ul> NIL (for L Lst (nond ((car L) (<li> NIL (htPrin (cdr L) 2)))⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -