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: : align= ( addr u -- ) s" align" opt ;
25: : mailto: ( addr u -- ) s' href="mailto:' tag-option $+!
26: tag-option $+! s' "' tag-option $+! ;
27:
28: \ environment handling
29:
30: Variable oldenv
31: Variable envs 10 0 [DO] 0 , [LOOP]
32:
33: : env$ ( -- addr ) envs dup @ 1+ cells + ;
34: : env ( addr u -- ) env$ $! ;
35: : env? ( -- ) envs @ oldenv @
36: 2dup > IF env$ $@ tag THEN
37: 2dup < IF env$ cell+ $@ /tag env$ cell+ $off THEN
38: drop oldenv ! ;
39: : +env 1 envs +! ;
40: : -env -1 envs +! env? ;
41: : -envs envs @ 0 ?DO -env cr LOOP ;
42: : >env ( addr u -- ) +env env env? ;
43:
44: \ alignment
45:
46: : >align ( c -- )
47: CASE
48: 'l OF s" left" align= ENDOF
49: 'r OF s" right" align= ENDOF
50: 'c OF s" center" align= ENDOF
51: '< OF s" left" align= ENDOF
52: '> OF s" right" align= ENDOF
53: '| OF s" center" align= ENDOF
54: ENDCASE ;
55:
56: \ link creation
57:
58: Variable link
59: Variable link-suffix
60: Variable iconpath
61:
62: Variable do-size
63:
64: : get-icon ( addr u -- ) iconpath @ IF 2drop EXIT THEN
65: link-suffix $! s" .*" link-suffix $+!
66: s" icons" open-dir throw >r
67: BEGIN
68: pad $100 r@ read-dir throw WHILE
69: pad swap 2dup link-suffix $@ filename-match
70: IF s" icons/" iconpath $! iconpath $+!
71: iconpath $@ src= s" img" tag true
72: ELSE 2drop false THEN
73: UNTIL ELSE drop THEN
74: r> close-dir throw ;
75:
76: : link-icon? ( -- ) iconpath @ IF iconpath $off THEN
77: link '. ['] get-icon $iter ;
78:
79: : link-size? ( -- ) do-size @ 0= ?EXIT
80: link $@ r/o open-file IF drop EXIT THEN >r
81: r@ file-size throw $400 um/mod nip ." (" 0 u.r ." k)"
82: r> close-file throw ;
83:
84: : link-options ( addr u -- addr' u' )
85: do-size off
86: over c@ '% = over 0> and IF do-size on 1 /string THEN ;
87:
88: : .link ( -- ) '[ parse type '] parse '| $split
89: link-options link $!
90: link $@len 0= IF 2dup link $! s" .html" link $+! THEN
91: link-icon? link $@ href= s" a" tagged
92: link-size? ;
93:
94: : .img ( -- ) '{ parse type '} parse '| $split
95: dup IF 2swap alt= ELSE 2drop THEN
96: tag-option $@len >r over c@ >align tag-option $@len r> = 1+ /string
97: src= s" img" tag ;
98:
99: \ line handling
100:
101: : char? ( -- c ) >in @ char swap >in ! ;
102: : parse-tag ( addr u char -- )
103: >r r@ parse type
104: r> parse 2swap tagged ;
105:
106: : .text ( -- ) >in @ >r char drop
107: source r@ /string >in @ r> - nip type ;
108:
109: Create do-words $100 0 [DO] ' .text , [LOOP]
110:
111: : bind-char ( xt -- ) char cells do-words + ! ;
112:
113: : char>tag ( -- ) char >r
114: :noname bl sword postpone SLiteral r@ postpone Literal
115: postpone parse-tag postpone ; r> cells do-words + ! ;
116:
117: char>tag * b
118: char>tag _ em
119: char>tag # code
120:
121: ' .link bind-char [
122: ' .img bind-char {
123:
124: : do-word ( char -- ) cells do-words + perform ;
125:
126: : parse-line ( -- )
127: BEGIN char? do-word source nip >in @ = UNTIL ;
128:
129: : parse-to ( char -- ) >r
130: BEGIN char? dup r@ <> WHILE
131: do-word source nip >in @ = UNTIL ELSE drop THEN
132: r> parse type ;
133:
134: \ paragraph handling
135:
136: : parse-par ( -- )
137: BEGIN parse-line cr refill WHILE
138: source nip 0= UNTIL THEN ;
139:
140: : par ( addr u -- ) env? 2dup tag parse-par /tag cr cr ;
141: : line ( addr u -- ) env? 2dup tag parse-line /tag cr cr ;
142:
143: \ handle global tags
144:
145: wordlist constant longtags
146:
147: Variable end-sec
148:
149: longtags set-current
150:
151: : --- cr s" hr" tag cr ;
152: : * s" h1" line ;
153: : ** s" h2" line ;
154: : *** s" h3" line ;
155: : - s" ul" env s" li" par ;
156: : + s" ol" env s" li" par ;
157: : << +env ;
158: : <* s" center" >env ;
159: : >> -env ;
160: : *> -env ;
161: : . end-sec on ;
162: : \ postpone \ ;
163:
164: definitions
165:
166: \ Table
167:
168: Variable table-format
169: Variable table#
170:
171: : |tag table-format $@ table# @ /string drop c@ >align
172: >env 1 table# +! ;
173: : |d table# @ IF -env THEN s" td" |tag ;
174: : |h table# @ IF -env THEN s" th" |tag ;
175: : |line s" tr" >env table# off ;
176: : line| -env -env cr ;
177:
178: : next-char ( -- char ) source drop >in @ + c@ ;
179:
180: longtags set-current
181:
182: : <| s" table" >env bl sword table-format $! ;
183: : |> -env ;
184: : +| |line
185: BEGIN
186: |h '| parse-to next-char '+ = UNTIL line| ;
187: : -| |line
188: BEGIN
189: |d '| parse-to next-char '- = UNTIL line| ;
190:
191: definitions
192:
193: \ parse a section
194:
195: : refill-loop ( -- ) end-sec off
196: BEGIN refill WHILE >in off
197: bl sword find-name
198: ?dup IF name>int execute
199: ELSE source nip IF >in off s" p" par THEN THEN
200: end-sec @ UNTIL THEN ;
201: : parse-section ( -- )
202: get-order longtags 1 set-order refill-loop set-order ;
203:
204: \ HTML head
205:
206: : .title ( addr u -- )
207: .' <!doctype html public "-//w3c//dtd html 4.0 transitional//en">' cr
208: s" html" >env s" head" >env
209: .' <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">' cr
210: s" title" tagged cr
211: -env ;
212:
213: \ HTML trailer
214:
215: Variable mail
216: Variable mail-name
217:
218: : .trailer
219: s" address" >env s" center" >env
220: ." Last modified: " time&date rot 0 u.r swap 1-
221: s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type
222: 0 u.r ." by "
223: mail $@ mailto: mail-name $@ s" a" tagged
224: -envs ;
225:
226: \ top word
227:
228: : parse" ( -- addr u ) '" parse 2drop '" parse ;
229:
230: : maintainer
231: bl sword mail $! parse" mail-name $! ;
232:
233: Variable style$
234: : style> style$ @ 0= IF s" " style$ $! THEN style$ $@ tag-option $! ;
235: : >style tag-option $@ style$ $! s" " tag-option $! ;
236:
237: : style style> opt >style ;
238: : background ( -- ) parse" s" background" style ;
239: : text ( -- ) parse" s" text" style ;
240: warnings @ warnings off
241: : link ( -- ) parse" s" link" style ;
242: warnings !
243: : vlink ( -- ) parse" s" vlink" style ;
244: : marginheight ( -- ) parse" s" marginheight" style ;
245:
246: : wf ( -- )
247: outfile-id >r
248: bl sword r/w create-file throw to outfile-id
249: parse" .title
250: +env style> s" body" env env?
251: ['] parse-section catch .trailer
252: outfile-id close-file throw
253: r> to outfile-id
254: dup 0< IF throw ELSE drop THEN ;
255:
256: \ simple text data base
257:
258: : get-rest ( addr -- ) 0 parse -trailing rot $! ;
259:
260: Variable last-entry
261: Variable field#
262:
263: : table: ( xt n -- ) Create , , 1 field# !
264: DOES> 2@ >in @ >r longtags set-current
265: Create definitions swap , r> >in !
266: here last-entry !
267: dup 0 DO 0 , LOOP
268: 1 DO s" " last-entry @ I cells + $! LOOP
269: last-entry @ get-rest
270: DOES> dup cell+ swap perform ;
271:
272: : field: Create field# @ , 1 field# +!
273: DOES> @ cells last-entry @ + get-rest ;
274:
275: : >field ' >body @ cells postpone Literal postpone + ; immediate
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to wf.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth