`. 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` ;