( Title: Write a index.html file from user input File: mkindexfile.fs Author: David N. Williams Version: 0.4.4 License: LGPL Starting date: August 18, 2002 Version 0.4.0: August 23, 2002 Version 0.4.1: September 18, 2002 Version 0.4.2: September 18, 2002 Version 0.4.3: November 28, 2004 Version 0.4.4: November 8, 2006 ) \ Copyright (C) 2002, 2004-2006 David N. Williams ( This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or at your option any later version. This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. In addition, please see the file POLITENESS included with this distribution. This Forth code is written for pfe, with the dstrings loadable module at version 0.7.2 or later. It can be used to generate an HTML file named `index.html` that displays a directory listing for our web archive emulation of FTP directories. For an overview of the scheme, see http://www-personal.umich.edu/~williams/archive/production.html. To run the main program after loading this file, enter: MKINDEXFILE ) \ *** NOTATION ( A "_" prefix means "emit to the output stream". "s" or "something.s" in stack comments stands for a Forth string [addr len]. ) \ *** PFE SCOPE decimal loadm dstrings 20000 4 make-$space dstrings ! synonym +" cat" synonym +` cat` synonym $+ cat synonym s+ s-cat synonym sdup 2dup synonym sdrop 2drop \ *** USER-CONFIG ( In HEADER+, the path follows TITLE-PREFIX$: ) $" DNW's Archive: " $constant title-prefix$ \ *** GENERAL USE create temp-buffer 256 allot : >temp-s ( s -- s' ) ( Copy the Forth string s as a measured string to TEMP-BUFFER and leave the Forth string representation of the copy. There is no check for sufficient room, and the input string is assumed not to overlap with the buffer. This word is pfe-dependent, because it uses the fact that HERE in pfe is equivalent to DP @. ) dp @ >r temp-buffer dp ! ( s) sm, ( s') r> dp ! ; : bl+ ( -- ) s" " s+ ; : \n+ ( -- ) \n$ $+ ; \ Unix line ends! : num>s ( n -- n.s ) ( Convert the number according to the current BASE to a Forth string in transient memory. ) <# dup >r abs s>d #s r> sign #> ; : num>$ ( n -- $: n$ ) ( Copy the number as a string into string space. ) num>s >$s-copy ; 0 [IF] : num+ ( n -- ) ( Concatenate the number as a string into string space. ) num>s s+ ; [THEN] : num0r+ ( +n r -- ) ( Concatenate the last r digits of the nonnegative number +n as a string into string space. If the number has fewer than r digits, fill with leading zeroes to make r digits. ) swap num>s \ assume no "-" rot over - ( r-#digits) dup 0> IF \ need leading "0"'s ( r-#digits) 0 DO $" 0" cat LOOP ELSE \ simply truncate negate ( #digits-r) /string THEN s+ ; : num0r>$ ( +n r -- $: num0r$ ) ( Copy the string conversion of the nonnegative number according to the spec for NUM0R+ into string space. Assume there is no current concatenation. ) num0r+ ENDCAT ; s" -Jan-Feb-Mar-Apr-May-Jun-Jul-Aug-Sep-Oct-Nov-Dec-" sm, 2constant -mons- : -mon- ( month -- month.s ) ( Leave the month string corresponding to month = 1,2,... ) 1- 4 * -mons- drop + 5 ; : date&time+ ( -- ) ( Concatenate the current date and time with "0"-filled fields as in "04-Jul-2002 09:02:06". This implementation uses $ARGS{ so it caches and recats any existing concatenation. ) ENDCAT ($: contin) time&date ( sec min hr day mo yr) ( yr) num>$ ( mo) -mon- >$s-copy ( day) 2 num0r>$ ( hr) num>$ ( min) 2 num0r>$ ( sec) 2 num0r>$ $ARGS{ contin yr mo day hr min sec } contin day mo yr +" " hr +" :" min +" :" sec ; \ *** OUTPUT AND INPUT \ GLOBALS 0 value outfile \ set by OPEN-OUTFILE and ?OPEN-`index.html` 0 value dirlevel \ set by PATH>DIRLEVEL and ACCEPT-PATH : open-outfile ( name.s -- ) ( Open the output file named by the input string in the current directory, and store the fid in OUTFILE. Abort if the file can't be opened. ) ( name.s) r/w create-file ( fid ior) ABORT" ***Can't open output file." ( fid) to outfile ; : ?open-`index.html` ( -- ) cr ." Is it okay to create a new file named `index.html` in the" cr ." current directory? ([n]/y) " 0 pad ! pad 1 accept 1 <> pad c@ toupper [char] Y <> or ABORT" ***`index.html` file creation aborted." cr ." Okay, I'm creating a new `index.html`." s" index.html" open-outfile ; : close-`index.html` ( -- ) outfile close-file ABORT" ***Error closing `index.html`." cr ." File `index.html` written to current directory. " ; : _s ( s -- ) ( Write the Forth string body to the output file. ) dup IF outfile write-file ABORT" ***Output file write error." ELSE sdrop THEN ; : _$ ($: $ -- ) ( Write the measured string body to the output file. ) $s> _s ; : _CAT$ ( -- ) ( Terminate and emit the current concatenation. Any compile-time or run-time string argument frame is unaffected. ) ENDCAT _$ ; : legal-path? ( path.s -- flag ) ( A legal path has the form `//.../`, with nonempty names ``. This word leaves false if path.s is empty or begins or ends with `/`, else it leaves true. It does *not* otherwise check for nonempty names. ) ( len) dup 0= IF sdrop false EXIT THEN over + 1- ( first.addr last.addr) c@ [char] / = swap c@ [char] / = or 0= ; : path>dirlevel ( path.s -- ) ( Set DIRLEVEL to the level of the last entry in the path, assumed to be legal. ) 0 >r \ level count ( path.s) BEGIN ( rest.s) s" /" search WHILE r> 1+ >r 1 /string REPEAT ( rest.s) sdrop r> ( count) 1+ to dirlevel ; : accept-path ($: -- path ) ( ACCEPT the path, in the form specified for PATH>DIRLEVEL, and set DIRLEVEL. Note the warning in LEGAL-PATH? ) BEGIN cr ." Enter the path of the directory with `/` between names," cr ." starting with the first directory under `archive` and" cr ." ending with the directory name." BEGIN cr ." Path? " pad 64 accept ( #accepted) ?dup UNTIL pad swap ( path.s) sdup legal-path? 0= WHILE sdrop cr ." Illegal path, try again." REPEAT ( path.s) sdup path>dirlevel ( path.s) >temp-s >$s ; : header+ ($: dirpath -- ) $ARGS{ dirpath } +` ` title-prefix$ $+ dirpath +` ` \n+ +` ` \n+ \n+ +` ` \n+ \n+ +` ` \n+ +` ` \n+ \n+ +`

Archive: ` dirpath +`

` \n+ \n+ +`

` \n+ +` Up to parent directory` \n+ +`

` \n+ \n+ +` ` \n+ +` ` \n+ +` ` \n+ +` ` ; : end-items+ ( -- ) \n+ +`
` \n+ \n+ ; : top-prefix+ ( -- ) dirlevel 0 ?DO +` ../` LOOP ; : toplink+ ( -- ) dirlevel IF +`

` \n+ +` Up to top of archive` \n+ +`

` \n+ \n+ THEN ; : accept-char>upper ( -- #accepted ) 0 pad c! pad 1 accept ( #accepted) pad c@ toupper pad c! ; : pad-is-Y|N? ( -- flag ) pad c@ [char] Y = pad c@ [char] N = or ; : ?license+ ( -- ) dirlevel 0= IF EXIT THEN BEGIN cr ." Do you want to mention the license? (y|n) " accept-char>upper ( #accepted) 0= pad-is-Y|N? 0= or WHILE cr ." Improper entry, try again." REPEAT pad c@ [char] N = IF EXIT THEN +`

` \n+ +` Files in this directory under the GNU` \n+ +` LGPL` \n+ +` typically have a` \n+ +` POLITENESS` \n+ +` request.` \n+ +`

` \n+ \n+ ; : trailer+ ( -- ) +` ` \n+ ; : pad-is-D|F|T|W|E? ( -- flag ) pad c@ >r r@ [char] D = r@ [char] F = or r@ [char] T = or r@ [char] W = or r> [char] E = or ; : accept-item-type ( -- 0|D|F|T|W ) BEGIN cr ." Enter one-letter directory item type, or `e` to end items." cr ." d|f|t|w|e? " accept-char>upper ( #accepted) 0= pad-is-D|F|T|W|E? 0= or WHILE cr ." Improper entry, try again." REPEAT pad c@ dup [char] E = IF drop 0 THEN ; : accept-item-name ( -- true|false ) ($: -- name$| ) cr ." Enter directory item name, or empty name to end items." cr ." Name? " pad 80 accept ( flag) dup IF pad over >temp-s >$s THEN ; : D-item+ ($: name -- ) ( Cat SHTML for a directory item. The #flastmod and #fsize SSI's are omitted. ) $ARGS{ name } \n+ \n+ +` ` \n+ +` ` name +` /` \n+ +` ` \n+ +` ` \n+ +` ` \n+ +` ` ; : F-item+ ($: name -- ) ( Cat SHTML for a normal file item. Nothing appended to name. ) $ARGS{ name } \n+ \n+ +` ` \n+ +` ` name +` ` \n+ +` ` \n+ +` ` \n+ +` ` \n+ +` ` ; : T-item+ ($: name -- ) ( Cat SHTML for a text file item that needs and extra `.txt` extension for proper display. Append `.txt` to the name where needed for html access, but do not append it to the displayed name. ) $ARGS{ name } \n+ \n+ +` ` \n+ +` ` name +` ` \n+ +` ` \n+ +` ` \n+ +` ` \n+ +` ` ; : W-item+ ($: name -- ) ( Cat SHTML for a wrapped text file item. The name has `.html` appended where needed for html access, or but is not appended to the displayed name. ) $ARGS{ name } \n+ \n+ +` ` \n+ +` ` name +` ` \n+ +` ` \n+ +` ` \n+ +` ` \n+ +` ` ; : accept-item+ ( -- flag ) ( ACCEPT the directory item type and name and cat the appropriate item. The flag is true if an item was accepted and cat'd, and false if the user entered a signal to terminate the item list. ) accept-item-type ( char) dup IF accept-item-name IF ($: name) ( char) CASE [char] D OF D-item+ ENDOF [char] F of F-item+ ENDOF [char] T OF T-item+ ENDOF [char] W OF W-item+ ENDOF ENDCASE true ELSE false THEN THEN ; \ *** MAIN PROGRAM : mkindexfile ( -- ) ?open-`index.html` accept-path ($: path) header+ BEGIN accept-item+ 0= UNTIL end-items+ toplink+ ?license+ trailer+ _CAT$ close-`index.html` ;