1: \ wiki forth
2:
3: require string.fs
4:
5: \ tag handling
6:
7: : .' '' parse postpone SLiteral postpone type ; immediate
8: : s' '' parse postpone SLiteral ; immediate
9:
10: Variable tag-option
11: s" " tag-option $!
12:
13: : tag ( addr u -- ) '< emit type tag-option $@ type '> emit
14: s" " tag-option $! ;
15: : /tag ( addr u -- ) '< emit '/ emit type '> emit ;
16: : tagged ( addr1 u1 addr2 u2 -- ) 2dup 2>r tag type 2r> /tag ;
17:
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 ;
23: : alt= ( addr u -- ) s" alt" opt ;
24: : width= ( addr u -- ) s" width" opt ;
25: : height= ( addr u -- ) s" height" opt ;
26: : align= ( addr u -- ) s" align" opt ;
27: : mailto: ( addr u -- ) s' href="mailto:' tag-option $+!
28: tag-option $+! s' "' tag-option $+! ;
29:
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 ;
44: : >env ( addr u -- ) +env env env? ;
45:
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:
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:
105: \ link creation
106:
107: Variable link
108: Variable link-suffix
109: Variable iconpath
110:
111: Variable do-size
112:
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:
119: : get-icon ( addr u -- ) iconpath @ IF 2drop EXIT THEN
120: link-suffix $! s" .*" link-suffix $+!
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
125: IF s" icons/" iconpath $! iconpath $+!
126: iconpath $@ 2dup .img-size src=
127: alt-suffix s" img" tag true
128: ELSE 2drop false THEN
129: UNTIL ELSE drop THEN
130: r> close-dir throw ;
131:
132: : link-icon? ( -- ) iconpath @ IF iconpath $off THEN
133: link '. ['] get-icon $iter ;
134:
135: : link-size? ( -- ) do-size @ 0= ?EXIT
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:
140: : link-options ( addr u -- addr' u' )
141: do-size off
142: over c@ '% = over 0> and IF do-size on 1 /string THEN ;
143:
144: : .link ( -- ) '[ parse type '] parse '| $split
145: link-options link $!
146: link $@len 0= IF 2dup link $! s" .html" link $+! THEN
147: link-icon? link $@ href= s" a" tagged
148: link-size? ;
149:
150: : .img ( -- ) '{ parse type '} parse '| $split
151: dup IF 2swap alt= ELSE 2drop THEN
152: tag-option $@len >r over c@ >align tag-option $@len r> = 1+ /string
153: 2dup .img-size src= s" img" tag ;
154:
155: \ line handling
156:
157: : char? ( -- c ) >in @ char swap >in ! ;
158: : parse-tag ( addr u char -- )
159: >r r@ parse type
160: r> parse 2swap tagged ;
161:
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 + ! ;
172:
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 ;
181:
182: : parse-line ( -- )
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 ;
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:
207: : --- cr s" hr" tag cr ;
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 ;
214: : <* s" center" >env ;
215: : >> -env ;
216: : *> -env ;
217: : . end-sec on ;
218: : \ postpone \ ;
219:
220: definitions
221:
222: \ Table
223:
224: Variable table-format
225: Variable table#
226:
227: : |tag table-format $@ table# @ /string drop c@ >align
228: >env 1 table# +! ;
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:
234: : next-char ( -- char ) source drop >in @ + c@ ;
235:
236: longtags set-current
237:
238: : <| s" table" >env bl sword table-format $! ;
239: : |> -env ;
240: : +| |line
241: BEGIN
242: |h '| parse-to next-char '+ = UNTIL line| ;
243: : -| |line
244: BEGIN
245: |d '| parse-to next-char '- = UNTIL line| ;
246:
247: definitions
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
264: s" html" >env s" head" >env
265: .' <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">' cr
266: s" title" tagged cr
267: -env ;
268:
269: \ HTML trailer
270:
271: Variable mail
272: Variable mail-name
273:
274: : .trailer
275: s" address" >env s" center" >env
276: ." Last modified: " time&date rot 0 u.r swap 1-
277: s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type
278: 0 u.r ." by "
279: mail $@ mailto: mail-name $@ s" a" tagged
280: -envs ;
281:
282: \ top word
283:
284: : parse" ( -- addr u ) '" parse 2drop '" parse ;
285:
286: : maintainer
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 ;
301:
302: : wf ( -- )
303: outfile-id >r
304: bl sword r/w create-file throw to outfile-id
305: parse" .title
306: +env style> s" body" env env?
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:
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 ;
330:
331: : >field ' >body @ cells postpone Literal postpone + ; immediate
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>