--- gforth/wf.fs 2004/07/18 13:31:06 1.26 +++ gforth/wf.fs 2005/01/04 22:09:04 1.31 @@ -1,6 +1,6 @@ \ wiki forth -\ Copyright (C) 2003 Free Software Foundation, Inc. +\ Copyright (C) 2003,2004 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -34,6 +34,9 @@ require string.fs \ character recoding +[IFDEF] maxascii $100 to maxascii 8-bit-io [THEN] +\ UTF-8 IO fails with .type: + : .type ( addr u -- ) bounds ?DO I c@ case @@ -47,10 +50,15 @@ require string.fs Variable indentlevel Variable tag-option +Variable tag-class s" " tag-option $! +s" " tag-class $! -: tag ( addr u -- ) '< emit type tag-option $@ type '> emit - s" " tag-option $! ; +: tag ( addr u -- ) '< emit type + tag-class $@len IF .\" class=\"" tag-class $@ type '" emit THEN + tag-option $@ type + '> emit + s" " tag-option $! s" " tag-class $! ; : tag/ ( addr u -- ) s" /" tag-option $+! tag ; : /tag ( addr u -- ) '< emit '/ emit type '> emit ; : tagged ( addr1 u1 addr2 u2 -- ) 2dup 2>r tag .type 2r> /tag ; @@ -59,6 +67,7 @@ s" " tag-option $! tag-option $+! s' ="' tag-option $+! tag-option $+! s' "' tag-option $+! ; : n>string ( n -- addr u ) 0 <# #S #> ; +: xy>string ( x y -- ) swap 0 <# #S 'x hold 2drop 0 #S 's hold #> ; : opt# ( n opt u -- ) rot n>string 2swap opt ; : href= ( addr u -- ) s" href" opt ; : id= ( addr u -- ) s" id" opt ; @@ -67,7 +76,9 @@ s" " tag-option $! : width= ( n -- ) s" width" opt# ; : height= ( n -- ) s" height" opt# ; : align= ( addr u -- ) s" align" opt ; -: class= ( addr u -- ) s" class" opt ; +: class= ( addr u -- ) + tag-class $@len IF s" " tag-class $+! THEN + tag-class $+! ; : indent= ( -- ) indentlevel @ 0 <# #S 'p hold #> class= ; : mailto: ( addr u -- ) s' href="mailto:' tag-option $+! @@ -126,6 +137,8 @@ Variable taligned \ image handling +wordlist Constant img-sizes + Create imgbuf $20 allot Create pngsig $89 c, $50 c, $4E c, $47 c, $0D c, $0A c, $1A c, $0A c, @@ -161,15 +174,52 @@ Create jfif $FF c, $D8 c, $FF c, $E0 c gif? IF gif-size rdrop EXIT THEN jpg? IF r> jpg-size EXIT THEN png? IF png-size rdrop EXIT THEN - 0 0 ; + 0 0 rdrop ; + +3 set-precision + +: f.size ( r -- ) + f$ dup >r 0<= + IF '0 emit + ELSE scratch r@ min type r@ precision - zeros THEN + '. emit r@ negate zeros + scratch r> 0 max /string 0 max -zeros type ; + +: size-does> ( -- ) DOES> ( -- ) + ." img." dup body> >name .name + 2@ ." { width: " + s>d d>f 13.8e f/ f.size ." em; height: " + s>d d>f 13.8e f/ f.size ." em; }" cr ; + +: size-css ( file< > -- ) + outfile-id >r + bl sword r/w create-file throw to outfile-id + img-sizes wordlist-id + BEGIN @ dup WHILE + dup name>int execute + REPEAT drop + outfile-id close-file throw + r> to outfile-id + dup 0< IF throw ELSE drop THEN ; + +: size-class ( x y addr u -- x y ) + 2dup class= + 2dup img-sizes search-wordlist IF drop 2drop + ELSE + get-current >r img-sizes set-current + nextname Create 2dup , , size-does> + r> set-current + THEN ; : .img-size ( addr u -- ) r/o open-file IF drop EXIT THEN >r imgbuf $20 r@ read-file throw drop r@ img-size r> close-file throw + 2dup or IF 2dup xy>string size-class THEN ?dup IF width= THEN - ?dup IF height= THEN ; + ?dup IF height= THEN +; \ link creation @@ -177,16 +227,22 @@ Variable link Variable link-sig Variable link-suffix Variable iconpath +Variable icon-prefix +Variable icon-tmp Variable do-size Variable do-icon Defer parse-line -: .img ( addr u -- ) dup >r '| -$split dup r> = IF 2swap THEN +: .img ( addr u -- ) + dup >r '@ -$split dup r> = IF 2swap 2drop + ELSE 2swap icon-tmp $! icon-prefix $@ icon-tmp $+! icon-tmp $+! + icon-tmp $@ THEN + dup >r '| -$split dup r> = IF 2swap THEN dup IF 2swap alt= ELSE 2drop THEN - tag-option $@len >r over c@ >align tag-option $@len r> = 1+ /string - tag-option $@len >r over c@ >border tag-option $@len r> = 1+ /string + tag-class $@len >r over c@ >align tag-class $@len r> = 1+ /string + tag-class $@len >r over c@ >border tag-class $@len r> = 1+ /string 2dup .img-size src= s" img" tag/ ; : >img ( -- ) '{ parse type '} parse .img ; @@ -198,11 +254,11 @@ Defer parse-line : get-icon ( addr u -- ) iconpath @ IF 2drop EXIT THEN link-suffix $! s" .*" link-suffix $+! - s" icons" open-dir throw >r + icon-prefix $@ open-dir throw >r BEGIN pad $100 r@ read-dir throw WHILE pad swap 2dup link-suffix $@ filename-match - IF s" icons/" iconpath $! iconpath $+! + IF icon-prefix $@ iconpath $! s" /" iconpath $+! iconpath $+! iconpath $@ 2dup .img-size src= '- >border alt-suffix s" img" tag/ true ELSE 2drop false THEN @@ -228,7 +284,7 @@ Defer parse-line link-sig $@ r/o open-file IF drop EXIT THEN close-file throw ." (" link-sig $@ href= s" a" tag - s" |-icons/sig.gif" .img ." sig" s" /a" tag ." )" ; + s" |-@/sig.gif" .img ." sig" s" /a" tag ." )" ; : link-warn? ( -- ) \ local links only link $@ ': scan nip ?EXIT @@ -332,7 +388,8 @@ wordlist Constant autoreplacements \ paragraph handling : parse-par ( -- ) - BEGIN parse-line+ cr refill WHILE + BEGIN + parse-line+ cr refill WHILE source nip 0= UNTIL THEN ; : par ( addr u -- ) env? @@ -399,17 +456,17 @@ Variable toc-index $@ .img swap IF case - 2 of s" ^]|-icons/arrow_up.jpg" .img endof + 2 of s" ^]|-@/arrow_up.jpg" .img endof 3 of - r@ 0= IF s" *]|-icons/circle.jpg" - ELSE s" v]|-icons/arrow_down.jpg" THEN .img endof + r@ 0= IF s" *]|-@/circle.jpg" + ELSE s" v]|-@/arrow_down.jpg" THEN .img endof endcase ELSE case - 0 of s" ^]|-icons/arrow_up.jpg" .img endof - 1 of s" >]|-icons/arrow_right.jpg" .img endof - 2 of s" *]|-icons/circle.jpg" .img endof - 3 of s" v]|-icons/arrow_down.jpg" .img endof + 0 of s" ^]|-@/arrow_up.jpg" .img endof + 1 of s" >]|-@/arrow_right.jpg" .img endof + 2 of s" *]|-@/circle.jpg" .img endof + 3 of s" v]|-@/arrow_down.jpg" .img endof endcase THEN s" a" /tag rdrop ." " @@ -543,7 +600,7 @@ definitions ELSE source nip IF >in off s" p" par THEN THEN ; : parse-section ( -- ) end-sec off BEGIN refill WHILE - section-par end-sec @ UNTIL THEN ; + section-par end-sec @ UNTIL THEN ; \ HTML head @@ -565,6 +622,7 @@ Variable css-file \ HTML trailer +Variable public-key Variable mail Variable mail-name Variable orig-date @@ -579,15 +637,24 @@ Variable orig-date orig-date @ IF ." Created " orig-date $@ type ." . " THEN .lastmod ." by " - s" Mail|icons/mail.gif" .img mail $@ mailto: mail-name $@ s" a" tagged + s" Mail|@/mail.gif" .img mail $@ mailto: mail-name $@ s" a" tagged + public-key @ IF + public-key $@ href= s" a" tag + s" PGP key|@/gpg.asc.gif" .img s" a" /tag + THEN -envs ; \ top word : maintainer ( -- ) '< sword -trailing mail-name $! '> sword mail $! ; +: pgp-key ( -- ) + bl sword -trailing public-key $! ; : created ( -- ) bl sword orig-date $! ; +: icons + bl sword icon-prefix $! ; +icons icons Variable style$ : style> style$ @ 0= IF s" " style$ $! THEN style$ $@ tag-option $! ;