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