--- gforth/wf.fs 2001/07/17 14:21:21 1.4 +++ gforth/wf.fs 2001/07/23 13:16:11 1.7 @@ -21,6 +21,8 @@ s" " tag-option $! : href= ( addr u -- ) s" href" opt ; : src= ( addr u -- ) s" src" opt ; : alt= ( addr u -- ) s" alt" opt ; +: width= ( addr u -- ) s" width" opt ; +: height= ( addr u -- ) s" height" opt ; : align= ( addr u -- ) s" align" opt ; : mailto: ( addr u -- ) s' href="mailto:' tag-option $+! tag-option $+! s' "' tag-option $+! ; @@ -41,6 +43,65 @@ Variable envs 10 0 [DO] 0 , [LOOP] : -envs envs @ 0 ?DO -env cr LOOP ; : >env ( addr u -- ) +env env env? ; +\ alignment + +: >align ( c -- ) + CASE + 'l OF s" left" align= ENDOF + 'r OF s" right" align= ENDOF + 'c OF s" center" align= ENDOF + '< OF s" left" align= ENDOF + '> OF s" right" align= ENDOF + '| OF s" center" align= ENDOF + ENDCASE ; + +\ image handling + +Create imgbuf $20 allot + +Create pngsig $89 c, $50 c, $4E c, $47 c, $0D c, $0A c, $1A c, $0A c, +Create jfif $FF c, $D8 c, $FF c, $E0 c, $00 c, $10 c, $4A c, $46 c, + $49 c, $46 c, + +: b@ ( addr -- x ) 0 swap 4 bounds ?DO 8 lshift I c@ + LOOP ; +: bw@ ( addr -- x ) 0 swap 2 bounds ?DO 8 lshift I c@ + LOOP ; + +: gif? ( -- flag ) + s" GIF89a" imgbuf over compare 0= + s" GIF87a" imgbuf over compare 0= or ; +: gif-size ( -- w h ) + imgbuf 6 + c@ imgbuf 7 + c@ 8 lshift + + imgbuf 8 + c@ imgbuf 9 + c@ 8 lshift + ; + +: png? ( -- flag ) + pngsig 8 imgbuf over compare 0= ; +: png-size ( -- w h ) + imgbuf $10 + b@ imgbuf $14 + b@ ; + +: jpg? ( -- flag ) + jfif 10 imgbuf over compare 0= ; +: jpg-size ( fd -- w h ) >r + 2. BEGIN + 2dup r@ reposition-file throw + imgbuf $10 r@ read-file throw 0<> + imgbuf bw@ $FFC0 <> and WHILE + imgbuf 2 + bw@ 2 + 0 d+ REPEAT + 2drop imgbuf 5 + bw@ imgbuf 7 + bw@ rdrop ; + +: img-size ( fd -- w h ) >r + gif? IF gif-size rdrop EXIT THEN + jpg? IF r> jpg-size EXIT THEN + png? IF png-size rdrop EXIT THEN + 0 0 ; + +: .img-size ( addr u -- ) + r/o open-file throw >r + imgbuf $20 r@ read-file throw drop + r@ img-size + r> close-file throw + ?dup IF 0 <# #S #> width= THEN + ?dup IF 0 <# #S #> height= THEN ; + \ link creation Variable link @@ -49,18 +110,28 @@ Variable iconpath Variable do-size -: link-icon? ( -- ) - link $@ '. $split link-suffix $! 2drop s" .*" link-suffix $+! +: alt-suffix ( -- ) + link-suffix $@len 2 - link-suffix $!len + s" [" link-suffix 0 $ins + s" ]" link-suffix $+! + link-suffix $@ alt= ; + +: get-icon ( addr u -- ) iconpath @ IF 2drop EXIT THEN + link-suffix $! s" .*" link-suffix $+! s" icons" open-dir throw >r BEGIN pad $100 r@ read-dir throw WHILE pad swap 2dup link-suffix $@ filename-match IF s" icons/" iconpath $! iconpath $+! - iconpath $@ src= s" img" tag true + iconpath $@ 2dup .img-size src= + alt-suffix s" img" tag true ELSE 2drop false THEN - UNTIL ELSE drop THEN \ ELSE '( emit link-suffix $@ 2 - type ') emit THEN + UNTIL ELSE drop THEN r> close-dir throw ; +: link-icon? ( -- ) iconpath @ IF iconpath $off THEN + link '. ['] get-icon $iter ; + : link-size? ( -- ) do-size @ 0= ?EXIT link $@ r/o open-file IF drop EXIT THEN >r r@ file-size throw $400 um/mod nip ." (" 0 u.r ." k)" @@ -77,7 +148,9 @@ Variable do-size link-size? ; : .img ( -- ) '{ parse type '} parse '| $split - dup IF 2swap alt= ELSE 2drop THEN src= s" img" tag ; + dup IF 2swap alt= ELSE 2drop THEN + tag-option $@len >r over c@ >align tag-option $@len r> = 1+ /string + 2dup .img-size src= s" img" tag ; \ line handling @@ -86,18 +159,25 @@ Variable do-size >r r@ parse type r> parse 2swap tagged ; -: .bold ( -- ) s" b" '* parse-tag ; -: .em ( -- ) s" em" '_ parse-tag ; +: .text ( -- ) >in @ >r char drop + source r@ /string >in @ r> - nip type ; -: do-word ( char -- ) - CASE - '* OF .bold ENDOF - '_ OF .em ENDOF - '[ OF .link ENDOF - '{ OF .img ENDOF - >in @ >r char drop - source r@ /string >in @ r> - nip type - ENDCASE ; +Create do-words $100 0 [DO] ' .text , [LOOP] + +: bind-char ( xt -- ) char cells do-words + ! ; + +: char>tag ( -- ) char >r +:noname bl sword postpone SLiteral r@ postpone Literal + postpone parse-tag postpone ; r> cells do-words + ! ; + +char>tag * b +char>tag _ em +char>tag # code + +' .link bind-char [ +' .img bind-char { + +: do-word ( char -- ) cells do-words + perform ; : parse-line ( -- ) BEGIN char? do-word source nip >in @ = UNTIL ; @@ -144,27 +224,25 @@ definitions Variable table-format Variable table# -: |tag table-format $@ table# @ /string drop c@ - CASE - 'l OF s" left" align= ENDOF - 'r OF s" right" align= ENDOF - 'c OF s" center" align= ENDOF - ENDCASE >env 1 table# +! ; +: |tag table-format $@ table# @ /string drop c@ >align + >env 1 table# +! ; : |d table# @ IF -env THEN s" td" |tag ; : |h table# @ IF -env THEN s" th" |tag ; : |line s" tr" >env table# off ; : line| -env -env cr ; +: next-char ( -- char ) source drop >in @ + c@ ; + longtags set-current : <| s" table" >env bl sword table-format $! ; : |> -env ; : +| |line BEGIN - |h '| parse-to char? '+ = UNTIL line| ; + |h '| parse-to next-char '+ = UNTIL line| ; : -| |line BEGIN - |d '| parse-to char? '- = UNTIL line| ; + |d '| parse-to next-char '- = UNTIL line| ; definitions @@ -203,14 +281,29 @@ Variable mail-name \ top word +: parse" ( -- addr u ) '" parse 2drop '" parse ; + : maintainer - bl sword mail $! '" parse 2drop '" parse mail-name $! ; + bl sword mail $! parse" mail-name $! ; + +Variable style$ +: style> style$ @ 0= IF s" " style$ $! THEN style$ $@ tag-option $! ; +: >style tag-option $@ style$ $! s" " tag-option $! ; + +: style style> opt >style ; +: background ( -- ) parse" s" background" style ; +: text ( -- ) parse" s" text" style ; + warnings @ warnings off +: link ( -- ) parse" s" link" style ; + warnings ! +: vlink ( -- ) parse" s" vlink" style ; +: marginheight ( -- ) parse" s" marginheight" style ; : wf ( -- ) outfile-id >r bl sword r/w create-file throw to outfile-id - '" parse 2drop '" parse .title - +env s" body" env + parse" .title + +env style> s" body" env env? ['] parse-section catch .trailer outfile-id close-file throw r> to outfile-id