File:  [gforth] / gforth / wf.fs
Revision 1.1: download - view: text, annotated - select for diffs
Mon Jul 16 14:59:51 2001 UTC (18 years, 3 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added first version of a Wiki in Forth

    1: \ wiki forth
    2: 
    3: require string.fs
    4: 
    5: \ tag handling
    6: 
    7: : .' '' parse postpone SLiteral postpone type ; immediate
    8: 
    9: : tag ( addr u -- ) '< emit type '> emit ;
   10: : /tag ( addr u -- ) '< emit '/ emit type '> emit ;
   11: 
   12: \ environment handling
   13: 
   14: Variable oldenv
   15: Variable envs 10 0 [DO] 0 , [LOOP]
   16: 
   17: : env$ ( -- addr ) envs dup @ 1+ cells + ;
   18: : env ( addr u -- ) env$ $! ;
   19: : env? ( -- ) envs @ oldenv @
   20:     2dup > IF  env$ $@ tag  THEN
   21:     2dup < IF  env$ cell+ $@ /tag  env$ cell+ $off  THEN
   22:     drop oldenv ! ;
   23: : +env  1 envs +! ;
   24: : -env -1 envs +! env? ;
   25: : -envs envs @ 0 ?DO  -env cr  LOOP ;
   26: 
   27: \ link creation
   28: 
   29: Variable link
   30: Variable link-suffix
   31: 
   32: : link-icon? ( -- )
   33:     link $@ '. $split link-suffix $! 2drop s" .*" link-suffix $+!
   34:     s" icons" open-dir throw >r
   35:     BEGIN
   36: 	pad $100 r@ read-dir throw  WHILE
   37: 	pad swap 2dup link-suffix $@ filename-match
   38: 	IF  .' <img src="icons/' type .' ">'  true
   39: 	ELSE  2drop  false  THEN
   40:     UNTIL  ELSE  '( emit link-suffix $@ 2 - type ') emit  THEN
   41:     r> close-dir throw ;
   42: 
   43: : link-size? ( -- )
   44:     link $@ r/o open-file IF  drop  EXIT  THEN >r
   45:     r@ file-size throw $400 um/mod nip ."  (" 0 u.r ." k)"
   46:     r> close-file throw ;
   47: 
   48: : .link ( -- )  '[ parse type '] parse '| $split link $!
   49:     link $@len 0= IF  2dup link $! s" .html" link $+!  THEN
   50:     link-icon? .' <a href="' link $@ type .' ">' type s" a" /tag
   51:     link-size? ;
   52: 
   53: \ line handling
   54: 
   55: : parse-tag ( addr u char -- )
   56:     >r r@ parse type
   57:     2dup tag r> parse type /tag ;
   58: 
   59: : .bold ( -- )  s" b" '* parse-tag ;
   60: : .em   ( -- )  s" em" '_ parse-tag ;
   61: 
   62: : parse-line ( -- )
   63:     BEGIN  >in @ >r char r> >in !
   64: 	CASE
   65: 	    '* OF .bold ENDOF
   66: 	    '_ OF .em   ENDOF
   67: 	    '[ OF .link ENDOF
   68: 	    >in @ >r char drop
   69: 	    source r@ /string >in @ r> - nip type
   70: 	ENDCASE
   71: 	source nip >in @ = UNTIL ;
   72: 
   73: \ paragraph handling
   74: 
   75: : parse-par ( -- )
   76:     BEGIN  parse-line cr refill  WHILE
   77: 	source nip 0= UNTIL  THEN ;
   78: 
   79: : par ( addr u -- ) env? 2dup tag parse-par /tag cr cr ;
   80: : line ( addr u -- ) env? 2dup tag parse-line /tag cr cr ;
   81: 
   82: \ handle global tags
   83: 
   84: wordlist constant longtags
   85: 
   86: Variable end-sec
   87: 
   88: longtags set-current
   89: 
   90: : --- s" hr" tag ;
   91: : * s" h1" line ;
   92: : ** s" h2" line ;
   93: : *** s" h3" line ;
   94: : - s" ul" env s" li" par ;
   95: : + s" ol" env s" li" par ;
   96: : << +env ;
   97: : >> -env ;
   98: : . end-sec on ;
   99: : \ postpone \ ;
  100: 
  101: definitions
  102: 
  103: \ parse a section
  104: 
  105: : refill-loop ( -- )  end-sec off
  106:     BEGIN  refill  WHILE  >in off
  107: 	bl sword find-name
  108: 	?dup IF  name>int execute
  109: 	ELSE  source nip IF  >in off s" p" par  THEN  THEN
  110: 	end-sec @ UNTIL  THEN ;
  111: : parse-section ( -- )
  112:     get-order  longtags 1 set-order  refill-loop set-order ;
  113: 
  114: \ HTML head
  115: 
  116: : .title ( addr u -- )
  117:     .' <!doctype html public "-//w3c//dtd html 4.0 transitional//en">' cr
  118:     s" html" +env env env?
  119:     s" head" +env env env?
  120:     .'   <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">' cr
  121:     s" title" tag type s" title" /tag cr
  122:     -env ;
  123: 
  124: \ HTML trailer
  125: 
  126: Variable mail
  127: Variable mail-name
  128: 
  129: : .trailer
  130:     s" address" tag
  131:     ." Changed last on " time&date rot 0 u.r swap 1-
  132:     s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type
  133:     0 u.r
  134:     .'  by <a href="mailto:' mail $@ type .' ">' mail-name $@ type s" a" /tag
  135:     s" address" /tag
  136:     -envs ;
  137: 
  138: \ top word
  139: 
  140: : maintainer
  141:     bl sword mail $! '" parse 2drop '" parse mail-name $! ;
  142: 
  143: : wf ( -- )
  144:     outfile-id >r
  145:     bl sword r/w create-file throw to outfile-id
  146:     '" parse 2drop '" parse .title
  147:     +env s" body" env
  148:     ['] parse-section catch .trailer
  149:     outfile-id close-file throw
  150:     r> to outfile-id
  151:     dup 0< IF  throw  ELSE  drop  THEN ;
  152: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>