/html.arc
Unknown | 443 lines | 361 code | 82 blank | 0 comment | 0 complexity | eb97075d185b8095f4aace69c7f82f48 MD5 | raw file
1; HTML Utils. 2 3 4(def color (r g b) 5 (with (c (table) 6 f (fn (x) (if (< x 0) 0 (> x 255) 255 x))) 7 (= (c 'r) (f r) (c 'g) (f g) (c 'b) (f b)) 8 c)) 9 10(def dehex (str) (errsafe (coerce str 'int 16))) 11 12(defmemo hex>color (str) 13 (and (is (len str) 6) 14 (with (r (dehex (cut str 0 2)) 15 g (dehex (cut str 2 4)) 16 b (dehex (cut str 4 6))) 17 (and r g b 18 (color r g b))))) 19 20(defmemo gray (n) (color n n n)) 21 22(= white (gray 255) 23 black (gray 0) 24 linkblue (color 0 0 190) 25 orange (color 255 102 0) 26 darkred (color 180 0 0) 27 darkblue (color 0 0 120) 28 ) 29 30(= opmeths* (table)) 31 32(mac opmeth args 33 `(opmeths* (list ,@args))) 34 35(mac attribute (tag opt f) 36 `(= (opmeths* (list ',tag ',opt)) ,f)) 37 38(= hexreps (table)) 39 40(for i 0 255 (= (hexreps i) 41 (let s (coerce i 'string 16) 42 (if (is (len s) 1) (+ "0" s) s)))) 43 44(defmemo hexrep (col) 45 (+ (hexreps (col 'r)) (hexreps (col 'g)) (hexreps (col 'b)))) 46 47(def opcolor (key val) 48 (w/uniq gv 49 `(whenlet ,gv ,val 50 (pr ,(string " " key "=#") (hexrep ,gv))))) 51 52(def opstring (key val) 53 `(aif ,val (pr ,(+ " " key "=\"") it #\"))) 54 55(def opnum (key val) 56 `(aif ,val (pr ,(+ " " key "=") it))) 57 58(def opsym (key val) 59 `(pr ,(+ " " key "=") ,val)) 60 61(def opsel (key val) 62 `(if ,val (pr " selected"))) 63 64(def opcheck (key val) 65 `(if ,val (pr " checked"))) 66 67(def opesc (key val) 68 `(awhen ,val 69 (pr ,(string " " key "=\"")) 70 (if (isa it 'string) (pr-escaped it) (pr it)) 71 (pr #\"))) 72 73; need to escape more? =? 74 75(def pr-escaped (x) 76 (each c x 77 (pr (case c #\< "<" 78 #\> ">" 79 #\" """ 80 #\& "&" 81 c)))) 82 83(attribute a href opstring) 84(attribute a rel opstring) 85(attribute a class opstring) 86(attribute a id opsym) 87(attribute a onclick opstring) 88(attribute a onmouseout opstring) 89(attribute a onmouseover opstring) 90(attribute body alink opcolor) 91(attribute body bgcolor opcolor) 92(attribute body leftmargin opnum) 93(attribute body link opcolor) 94(attribute body marginheight opnum) 95(attribute body marginwidth opnum) 96(attribute body topmargin opnum) 97(attribute body vlink opcolor) 98(attribute div id opstring) 99(attribute div name opstring) 100(attribute div class opstring) 101(attribute div onclick opstring) 102(attribute div onmouseout opstring) 103(attribute div onmouseover opstring) 104(attribute font color opcolor) 105(attribute font face opstring) 106(attribute font size opnum) 107(attribute form action opstring) 108(attribute form method opsym) 109(attribute form id opstring) 110(attribute form name opstring) 111(attribute form onsubmit opstring) 112(attribute form enctype opstring) 113(attribute img align opsym) 114(attribute img border opnum) 115(attribute img height opnum) 116(attribute img width opnum) 117(attribute img vspace opnum) 118(attribute img hspace opnum) 119(attribute img src opstring) 120(attribute img id opsym) 121(attribute img alt opstring) 122(attribute input name opstring) 123(attribute input id opstring) 124(attribute input size opnum) 125(attribute input type opsym) 126(attribute input value opesc) 127(attribute input checked opcheck) 128(attribute input onclick opstring) 129(attribute input onblur opstring) 130(attribute input class opstring) 131(attribute select name opstring) 132(attribute option selected opsel) 133(attribute table bgcolor opcolor) 134(attribute table border opnum) 135(attribute table cellpadding opnum) 136(attribute table cellspacing opnum) 137(attribute table width opstring) 138(attribute table id opstring) 139(attribute textarea cols opnum) 140(attribute textarea id opstring) 141(attribute textarea name opstring) 142(attribute textarea rows opnum) 143(attribute textarea wrap opsym) 144(attribute td align opsym) 145(attribute td bgcolor opcolor) 146(attribute td colspan opnum) 147(attribute td rowspan opnum) 148(attribute td width opnum) 149(attribute td height opnum) 150(attribute td valign opsym) 151(attribute td class opstring) 152(attribute tr bgcolor opcolor) 153(attribute tr valign opsym) 154(attribute tr height opnum) 155(attribute tr class opstring) 156(attribute tr onclick opstring) 157(attribute tr id opstring) 158(attribute hr color opcolor) 159(attribute script type opstring) 160(attribute span class opstring) 161(attribute span align opstring) 162(attribute span id opsym) 163(attribute rss version opstring) 164 165 166(mac gentag args (start-tag args)) 167 168(mac tag (spec . body) 169 `(do ,(start-tag spec) 170 ,@body 171 ,(end-tag spec))) 172 173(mac tag-if (test spec . body) 174 `(if ,test 175 (tag ,spec ,@body) 176 (do ,@body))) 177 178(def start-tag (spec) 179 (if (atom spec) 180 `(pr ,(string "<" spec ">")) 181 (let opts (tag-options (car spec) (pair (cdr spec))) 182 (if (all [isa _ 'string] opts) 183 `(pr ,(string "<" (car spec) (apply string opts) ">")) 184 `(do (pr ,(string "<" (car spec))) 185 ,@(map (fn (opt) 186 (if (isa opt 'string) 187 `(pr ,opt) 188 opt)) 189 opts) 190 (pr ">")))))) 191 192(def end-tag (spec) 193 `(pr ,(string "</" (carif spec) ">"))) 194 195(def literal (x) 196 (case (type x) 197 sym (in x nil t) 198 cons (caris x 'quote) 199 t)) 200 201; Returns a list whose elements are either strings, which can 202; simply be printed out, or expressions, which when evaluated 203; generate output. 204 205(def tag-options (spec options) 206 (if (no options) 207 '() 208 (let ((opt val) . rest) options 209 (let meth (if (is opt 'style) opstring (opmeth spec opt)) 210 (if meth 211 (if val 212 (cons (if (precomputable-tagopt val) 213 (tostring (eval (meth opt val))) 214 (meth opt val)) 215 (tag-options spec rest)) 216 (tag-options spec rest)) 217 (do 218 (pr "<!-- ignoring " opt " for " spec "-->") 219 (tag-options spec rest))))))) 220 221(def precomputable-tagopt (val) 222 (and (literal val) 223 (no (and (is (type val) 'string) (find #\@ val))))) 224 225(def br ((o n 1)) 226 (repeat n (pr "<br>")) 227 (prn)) 228 229(def br2 () (prn "<br><br>")) 230 231(mac center body `(tag center ,@body)) 232(mac underline body `(tag u ,@body)) 233(mac tab body `(tag (table border 0) ,@body)) 234(mac tr body `(tag tr ,@body)) 235 236(let pratoms (fn (body) 237 (if (or (no body) 238 (all [and (acons _) (isnt (car _) 'quote)] 239 body)) 240 body 241 `((pr ,@body)))) 242 243 (mac td body `(tag td ,@(pratoms body))) 244 (mac trtd body `(tr (td ,@(pratoms body)))) 245 (mac tdr body `(tag (td align 'right) ,@(pratoms body))) 246 (mac tdcolor (col . body) `(tag (td bgcolor ,col) ,@(pratoms body))) 247) 248 249(mac row args 250 `(tr ,@(map [list 'td _] args))) 251 252(mac prrow args 253 (w/uniq g 254 `(tr ,@(map (fn (a) 255 `(let ,g ,a 256 (if (number ,g) 257 (tdr (pr ,g)) 258 (td (pr ,g))))) 259 args)))) 260 261(mac prbold body `(tag b (pr ,@body))) 262 263(def para args 264 (gentag p) 265 (when args (apply pr args))) 266 267(def menu (name items (o sel nil)) 268 (tag (select name name) 269 (each i items 270 (tag (option selected (is i sel)) 271 (pr i))))) 272 273(mac whitepage body 274 `(tag html 275 (tag (body bgcolor white alink linkblue) ,@body))) 276 277(def errpage args (whitepage (apply prn args))) 278 279(def blank-url () "s.gif") 280 281; Could memoize these. 282 283; If h = 0, doesn't affect table column widths in some Netscapes. 284 285(def hspace (n) (gentag img src (blank-url) height 1 width n)) 286(def vspace (n) (gentag img src (blank-url) height n width 0)) 287(def vhspace (h w) (gentag img src (blank-url) height h width w)) 288 289(mac new-hspace (n) 290 (if (number n) 291 `(pr ,(string "<span style=\"padding-left:" n "px\" />")) 292 `(pr "<span style=\"padding-left:" ,n "px\" />"))) 293 294;(def spacerow (h) (tr (td (vspace h)))) 295 296(def spacerow (h) (pr "<tr style=\"height:" h "px\"></tr>")) 297 298; For use as nested table. 299 300(mac zerotable body 301 `(tag (table border 0 cellpadding 0 cellspacing 0) 302 ,@body)) 303 304; was `(tag (table border 0 cellpadding 0 cellspacing 7) ,@body) 305 306(mac sptab body 307 `(tag (table style "border-spacing: 7px 0px;") ,@body)) 308 309(mac widtable (w . body) 310 `(tag (table width ,w) (tr (td ,@body)))) 311 312(def cellpr (x) (pr (or x " "))) 313 314(def but ((o text "submit") (o name nil)) 315 (gentag input type 'submit name name value text)) 316 317(def submit ((o val "submit")) 318 (gentag input type 'submit value val)) 319 320(def buts (name . texts) 321 (if (no texts) 322 (but) 323 (do (but (car texts) name) 324 (each text (cdr texts) 325 (pr " ") 326 (but text name))))) 327 328(mac spanrow (n . body) 329 `(tr (tag (td colspan ,n) ,@body))) 330 331(mac form (action . body) 332 `(tag (form method "post" action ,action) ,@body)) 333 334(mac textarea (name rows cols . body) 335 `(tag (textarea name ,name rows ,rows cols ,cols) ,@body)) 336 337(def input (name (o val "") (o size 10)) 338 (gentag input type 'text name name value val size size)) 339 340(mac inputs args 341 `(tag (table border 0) 342 ,@(map (fn ((name label len text)) 343 (w/uniq (gl gt) 344 `(let ,gl ,len 345 (tr (td (pr ',label ":")) 346 (if (isa ,gl 'cons) 347 (td (textarea ',name (car ,gl) (cadr ,gl) 348 (let ,gt ,text (if ,gt (pr ,gt))))) 349 (td (gentag input type ',(if (is label 'password) 350 'password 351 'text) 352 name ',name 353 size ,len 354 value ,text))))))) 355 (tuples args 4)))) 356 357(def single-input (label name chars btext (o pwd)) 358 (pr label) 359 (gentag input type (if pwd 'password 'text) name name size chars) 360 (sp) 361 (submit btext)) 362 363(mac cdata body 364 `(do (pr "<![CDATA[") 365 ,@body 366 (pr "]]>"))) 367 368(def eschtml (str) 369 (tostring 370 (each c str 371 (pr (case c #\< "<" 372 #\> ">" 373 #\" """ 374 #\' "'" 375 #\& "&" 376 c))))) 377 378(def esc-tags (str) 379 (tostring 380 (each c str 381 (pr (case c #\< "<" 382 #\> ">" 383 #\& "&" 384 c))))) 385 386(def nbsp () (pr " ")) 387 388(def link (text (o dest text) (o color)) 389 (tag (a href dest) 390 (tag-if color (font color color) 391 (pr text)))) 392 393(def underlink (text (o dest text)) 394 (tag (a href dest) (tag u (pr text)))) 395 396(def striptags (s) 397 (let intag nil 398 (tostring 399 (each c s 400 (if (is c #\<) (set intag) 401 (is c #\>) (wipe intag) 402 (no intag) (pr c)))))) 403 404(def clean-url (u) 405 (rem [in _ #\" #\' #\< #\>] u)) 406 407(def shortlink (url) 408 (unless (or (no url) (< (len url) 7)) 409 (link (cut url 7) url))) 410 411; this should be one regexp 412 413(def parafy (str) 414 (let ink nil 415 (tostring 416 (each c str 417 (pr c) 418 (unless (whitec c) (set ink)) 419 (when (is c #\newline) 420 (unless ink (pr "<p>")) 421 (wipe ink)))))) 422 423(mac spanclass (name . body) 424 `(tag (span class ',name) ,@body)) 425 426(def pagemessage (text) 427 (when text (prn text) (br2))) 428 429; Could be stricter. Memoized because looking for chars in Unicode 430; strings is terribly inefficient in Mzscheme. 431 432(defmemo valid-url (url) 433 (and (len> url 10) 434 (or (begins url "http://") 435 (begins url "https://")) 436 (~find [in _ #\< #\> #\" #\'] url))) 437 438(mac fontcolor (c . body) 439 (w/uniq g 440 `(let ,g ,c 441 (if ,g 442 (tag (font color ,g) ,@body) 443 (do ,@body)))))