Annotation of gforth/wf.fs, revision 1.7
1.1 pazsan 1: \ wiki forth
2:
3: require string.fs
4:
5: \ tag handling
6:
7: : .' '' parse postpone SLiteral postpone type ; immediate
1.3 pazsan 8: : s' '' parse postpone SLiteral ; immediate
1.1 pazsan 9:
1.3 pazsan 10: Variable tag-option
11: s" " tag-option $!
12:
13: : tag ( addr u -- ) '< emit type tag-option $@ type '> emit
14: s" " tag-option $! ;
1.1 pazsan 15: : /tag ( addr u -- ) '< emit '/ emit type '> emit ;
1.2 pazsan 16: : tagged ( addr1 u1 addr2 u2 -- ) 2dup 2>r tag type 2r> /tag ;
1.1 pazsan 17:
1.3 pazsan 18: : opt ( addr u opt u -- ) s" " tag-option $+!
19: tag-option $+! s' ="' tag-option $+! tag-option $+!
20: s' "' tag-option $+! ;
21: : href= ( addr u -- ) s" href" opt ;
22: : src= ( addr u -- ) s" src" opt ;
1.4 pazsan 23: : alt= ( addr u -- ) s" alt" opt ;
1.7 ! pazsan 24: : width= ( addr u -- ) s" width" opt ;
! 25: : height= ( addr u -- ) s" height" opt ;
1.3 pazsan 26: : align= ( addr u -- ) s" align" opt ;
27: : mailto: ( addr u -- ) s' href="mailto:' tag-option $+!
28: tag-option $+! s' "' tag-option $+! ;
29:
1.1 pazsan 30: \ environment handling
31:
32: Variable oldenv
33: Variable envs 10 0 [DO] 0 , [LOOP]
34:
35: : env$ ( -- addr ) envs dup @ 1+ cells + ;
36: : env ( addr u -- ) env$ $! ;
37: : env? ( -- ) envs @ oldenv @
38: 2dup > IF env$ $@ tag THEN
39: 2dup < IF env$ cell+ $@ /tag env$ cell+ $off THEN
40: drop oldenv ! ;
41: : +env 1 envs +! ;
42: : -env -1 envs +! env? ;
43: : -envs envs @ 0 ?DO -env cr LOOP ;
1.2 pazsan 44: : >env ( addr u -- ) +env env env? ;
1.1 pazsan 45:
1.6 pazsan 46: \ alignment
47:
48: : >align ( c -- )
49: CASE
50: 'l OF s" left" align= ENDOF
51: 'r OF s" right" align= ENDOF
52: 'c OF s" center" align= ENDOF
53: '< OF s" left" align= ENDOF
54: '> OF s" right" align= ENDOF
55: '| OF s" center" align= ENDOF
56: ENDCASE ;
57:
1.7 ! pazsan 58: \ image handling
! 59:
! 60: Create imgbuf $20 allot
! 61:
! 62: Create pngsig $89 c, $50 c, $4E c, $47 c, $0D c, $0A c, $1A c, $0A c,
! 63: Create jfif $FF c, $D8 c, $FF c, $E0 c, $00 c, $10 c, $4A c, $46 c,
! 64: $49 c, $46 c,
! 65:
! 66: : b@ ( addr -- x ) 0 swap 4 bounds ?DO 8 lshift I c@ + LOOP ;
! 67: : bw@ ( addr -- x ) 0 swap 2 bounds ?DO 8 lshift I c@ + LOOP ;
! 68:
! 69: : gif? ( -- flag )
! 70: s" GIF89a" imgbuf over compare 0=
! 71: s" GIF87a" imgbuf over compare 0= or ;
! 72: : gif-size ( -- w h )
! 73: imgbuf 6 + c@ imgbuf 7 + c@ 8 lshift +
! 74: imgbuf 8 + c@ imgbuf 9 + c@ 8 lshift + ;
! 75:
! 76: : png? ( -- flag )
! 77: pngsig 8 imgbuf over compare 0= ;
! 78: : png-size ( -- w h )
! 79: imgbuf $10 + b@ imgbuf $14 + b@ ;
! 80:
! 81: : jpg? ( -- flag )
! 82: jfif 10 imgbuf over compare 0= ;
! 83: : jpg-size ( fd -- w h ) >r
! 84: 2. BEGIN
! 85: 2dup r@ reposition-file throw
! 86: imgbuf $10 r@ read-file throw 0<>
! 87: imgbuf bw@ $FFC0 <> and WHILE
! 88: imgbuf 2 + bw@ 2 + 0 d+ REPEAT
! 89: 2drop imgbuf 5 + bw@ imgbuf 7 + bw@ rdrop ;
! 90:
! 91: : img-size ( fd -- w h ) >r
! 92: gif? IF gif-size rdrop EXIT THEN
! 93: jpg? IF r> jpg-size EXIT THEN
! 94: png? IF png-size rdrop EXIT THEN
! 95: 0 0 ;
! 96:
! 97: : .img-size ( addr u -- )
! 98: r/o open-file throw >r
! 99: imgbuf $20 r@ read-file throw drop
! 100: r@ img-size
! 101: r> close-file throw
! 102: ?dup IF 0 <# #S #> width= THEN
! 103: ?dup IF 0 <# #S #> height= THEN ;
! 104:
1.1 pazsan 105: \ link creation
106:
107: Variable link
108: Variable link-suffix
1.3 pazsan 109: Variable iconpath
1.1 pazsan 110:
1.2 pazsan 111: Variable do-size
112:
1.7 ! pazsan 113: : alt-suffix ( -- )
! 114: link-suffix $@len 2 - link-suffix $!len
! 115: s" [" link-suffix 0 $ins
! 116: s" ]" link-suffix $+!
! 117: link-suffix $@ alt= ;
! 118:
1.6 pazsan 119: : get-icon ( addr u -- ) iconpath @ IF 2drop EXIT THEN
120: link-suffix $! s" .*" link-suffix $+!
1.1 pazsan 121: s" icons" open-dir throw >r
122: BEGIN
123: pad $100 r@ read-dir throw WHILE
124: pad swap 2dup link-suffix $@ filename-match
1.3 pazsan 125: IF s" icons/" iconpath $! iconpath $+!
1.7 ! pazsan 126: iconpath $@ 2dup .img-size src=
! 127: alt-suffix s" img" tag true
1.1 pazsan 128: ELSE 2drop false THEN
1.6 pazsan 129: UNTIL ELSE drop THEN
1.1 pazsan 130: r> close-dir throw ;
131:
1.6 pazsan 132: : link-icon? ( -- ) iconpath @ IF iconpath $off THEN
133: link '. ['] get-icon $iter ;
134:
1.2 pazsan 135: : link-size? ( -- ) do-size @ 0= ?EXIT
1.1 pazsan 136: link $@ r/o open-file IF drop EXIT THEN >r
137: r@ file-size throw $400 um/mod nip ." (" 0 u.r ." k)"
138: r> close-file throw ;
139:
1.2 pazsan 140: : link-options ( addr u -- addr' u' )
1.3 pazsan 141: do-size off
142: over c@ '% = over 0> and IF do-size on 1 /string THEN ;
1.2 pazsan 143:
144: : .link ( -- ) '[ parse type '] parse '| $split
145: link-options link $!
1.1 pazsan 146: link $@len 0= IF 2dup link $! s" .html" link $+! THEN
1.3 pazsan 147: link-icon? link $@ href= s" a" tagged
1.1 pazsan 148: link-size? ;
149:
1.4 pazsan 150: : .img ( -- ) '{ parse type '} parse '| $split
1.6 pazsan 151: dup IF 2swap alt= ELSE 2drop THEN
152: tag-option $@len >r over c@ >align tag-option $@len r> = 1+ /string
1.7 ! pazsan 153: 2dup .img-size src= s" img" tag ;
1.4 pazsan 154:
1.1 pazsan 155: \ line handling
156:
1.4 pazsan 157: : char? ( -- c ) >in @ char swap >in ! ;
1.1 pazsan 158: : parse-tag ( addr u char -- )
159: >r r@ parse type
1.2 pazsan 160: r> parse 2swap tagged ;
1.1 pazsan 161:
1.6 pazsan 162: : .text ( -- ) >in @ >r char drop
163: source r@ /string >in @ r> - nip type ;
164:
165: Create do-words $100 0 [DO] ' .text , [LOOP]
166:
167: : bind-char ( xt -- ) char cells do-words + ! ;
168:
169: : char>tag ( -- ) char >r
170: :noname bl sword postpone SLiteral r@ postpone Literal
171: postpone parse-tag postpone ; r> cells do-words + ! ;
1.1 pazsan 172:
1.6 pazsan 173: char>tag * b
174: char>tag _ em
175: char>tag # code
176:
177: ' .link bind-char [
178: ' .img bind-char {
179:
180: : do-word ( char -- ) cells do-words + perform ;
1.4 pazsan 181:
1.1 pazsan 182: : parse-line ( -- )
1.4 pazsan 183: BEGIN char? do-word source nip >in @ = UNTIL ;
184:
185: : parse-to ( char -- ) >r
186: BEGIN char? dup r@ <> WHILE
187: do-word source nip >in @ = UNTIL ELSE drop THEN
188: r> parse type ;
1.1 pazsan 189:
190: \ paragraph handling
191:
192: : parse-par ( -- )
193: BEGIN parse-line cr refill WHILE
194: source nip 0= UNTIL THEN ;
195:
196: : par ( addr u -- ) env? 2dup tag parse-par /tag cr cr ;
197: : line ( addr u -- ) env? 2dup tag parse-line /tag cr cr ;
198:
199: \ handle global tags
200:
201: wordlist constant longtags
202:
203: Variable end-sec
204:
205: longtags set-current
206:
1.3 pazsan 207: : --- cr s" hr" tag cr ;
1.1 pazsan 208: : * s" h1" line ;
209: : ** s" h2" line ;
210: : *** s" h3" line ;
211: : - s" ul" env s" li" par ;
212: : + s" ol" env s" li" par ;
213: : << +env ;
1.3 pazsan 214: : <* s" center" >env ;
1.1 pazsan 215: : >> -env ;
1.3 pazsan 216: : *> -env ;
1.1 pazsan 217: : . end-sec on ;
218: : \ postpone \ ;
219:
220: definitions
1.3 pazsan 221:
222: \ Table
223:
224: Variable table-format
225: Variable table#
226:
1.6 pazsan 227: : |tag table-format $@ table# @ /string drop c@ >align
228: >env 1 table# +! ;
1.3 pazsan 229: : |d table# @ IF -env THEN s" td" |tag ;
230: : |h table# @ IF -env THEN s" th" |tag ;
231: : |line s" tr" >env table# off ;
232: : line| -env -env cr ;
233:
1.5 pazsan 234: : next-char ( -- char ) source drop >in @ + c@ ;
235:
1.3 pazsan 236: longtags set-current
237:
238: : <| s" table" >env bl sword table-format $! ;
239: : |> -env ;
240: : +| |line
241: BEGIN
1.5 pazsan 242: |h '| parse-to next-char '+ = UNTIL line| ;
1.3 pazsan 243: : -| |line
244: BEGIN
1.5 pazsan 245: |d '| parse-to next-char '- = UNTIL line| ;
1.3 pazsan 246:
247: definitions
1.1 pazsan 248:
249: \ parse a section
250:
251: : refill-loop ( -- ) end-sec off
252: BEGIN refill WHILE >in off
253: bl sword find-name
254: ?dup IF name>int execute
255: ELSE source nip IF >in off s" p" par THEN THEN
256: end-sec @ UNTIL THEN ;
257: : parse-section ( -- )
258: get-order longtags 1 set-order refill-loop set-order ;
259:
260: \ HTML head
261:
262: : .title ( addr u -- )
263: .' <!doctype html public "-//w3c//dtd html 4.0 transitional//en">' cr
1.2 pazsan 264: s" html" >env s" head" >env
1.1 pazsan 265: .' <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">' cr
1.2 pazsan 266: s" title" tagged cr
1.1 pazsan 267: -env ;
268:
269: \ HTML trailer
270:
271: Variable mail
272: Variable mail-name
273:
274: : .trailer
1.2 pazsan 275: s" address" >env s" center" >env
276: ." Last modified: " time&date rot 0 u.r swap 1-
1.1 pazsan 277: s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type
1.3 pazsan 278: 0 u.r ." by "
279: mail $@ mailto: mail-name $@ s" a" tagged
1.1 pazsan 280: -envs ;
281:
282: \ top word
283:
1.6 pazsan 284: : parse" ( -- addr u ) '" parse 2drop '" parse ;
285:
1.1 pazsan 286: : maintainer
1.6 pazsan 287: bl sword mail $! parse" mail-name $! ;
288:
289: Variable style$
290: : style> style$ @ 0= IF s" " style$ $! THEN style$ $@ tag-option $! ;
291: : >style tag-option $@ style$ $! s" " tag-option $! ;
292:
293: : style style> opt >style ;
294: : background ( -- ) parse" s" background" style ;
295: : text ( -- ) parse" s" text" style ;
296: warnings @ warnings off
297: : link ( -- ) parse" s" link" style ;
298: warnings !
299: : vlink ( -- ) parse" s" vlink" style ;
300: : marginheight ( -- ) parse" s" marginheight" style ;
1.1 pazsan 301:
302: : wf ( -- )
303: outfile-id >r
304: bl sword r/w create-file throw to outfile-id
1.6 pazsan 305: parse" .title
306: +env style> s" body" env env?
1.1 pazsan 307: ['] parse-section catch .trailer
308: outfile-id close-file throw
309: r> to outfile-id
310: dup 0< IF throw ELSE drop THEN ;
311:
1.2 pazsan 312: \ simple text data base
313:
314: : get-rest ( addr -- ) 0 parse -trailing rot $! ;
315:
316: Variable last-entry
317: Variable field#
318:
319: : table: ( xt n -- ) Create , , 1 field# !
320: DOES> 2@ >in @ >r longtags set-current
321: Create definitions swap , r> >in !
322: here last-entry !
323: dup 0 DO 0 , LOOP
324: 1 DO s" " last-entry @ I cells + $! LOOP
325: last-entry @ get-rest
326: DOES> dup cell+ swap perform ;
327:
328: : field: Create field# @ , 1 field# +!
329: DOES> @ cells last-entry @ + get-rest ;
1.3 pazsan 330:
331: : >field ' >body @ cells postpone Literal postpone + ; immediate
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>