#!/usr/bin/perl
#
# keeper -- archive keeper's assistant
#
# By Eric S. Raymond <esr@thyrsus.com> 1 Mar 1996
#
# Requires Perl 5 -- uses references
#
# $Id: keeper,v 1.15 1997/03/26 14:23:07 esr Exp $
#
### Configuration section ##################################################

$ftphome      = "/public/ftp";		# Use `echo -n ~ftp'
$ftptop       = "/pub/Linux";
$shared       = "/export/sunsite/users/esr/keeper";
$incoming     = "Incoming";
$sendmail     = "/usr/lib/sendmail -oem -t";
$century      = "19";
$timezone     = "EST";
$archfilemode = 0664;	# rw-rw-r--
$archdirmode  = 0775;	# rwxrwxr-x
$recent       = 720;	# Files more recent than this are flagged.

# Expiration time for stale exclusion locks, in seconds.
# For multiuser operation to work, this must be longer than
# the index rebuild time.  When I wrote this, Sunsite's 2-gig
# archive indexed in about 20 seconds under typical load. 
$lock_expire      = 120;

# Expiration file for the file and directory indexes.  We need this so
# files brought in from $incoming will be sure to get reflected in the
# indexes, because we don't rebuild on every dispatch (that would be
# way too slow!)
$file_expire       = (3 * 360);

# These lists depend on your archive's conventions for meta-information 
@ignore       = ("^README\$", "^!INDEX");	  # ignore these patterns
@inspecial    = ("HOW.TO.SUBMIT","LSM-TEMPLATE", "NAMES"); # ignore in $incoming only

# This list specifies directories that will *not* be checked for matches
@kill_list = ();

# Specify list of mirror config files.  Directories in these will be added
# to the kill list at startup time. 
@mirror_list = ("/export/sunsite/users/ewt/mirror/mirror.linux");

# Identification stuff for automatically generated mail
$archive      = "sunsite";
$fqdn         = "sunsite.unc.edu";
$signature    = "$ENV{'LOGNAME'} ($archive co-maintainer)";

#############################################################################

$version      = substr('$Revision: 1.15 $', 11, -2);

$top          =  $ftphome . $ftptop;

# Put the logs in the top-level archive directory.  We presume the top-level
# index page will hacve an entry to browse them.
$newlist      = "$top/NEW";
$newhtml      = "$top/NEW.html";

# Shared-database stuff, must be shared by all keeper copies per site
$findfile     = "$shared/files";
$finddir      = "$shared/directories";
$watchfile    = "$shared/watchlist";

# Note: don't make 'html' a file pattern!  This causes grief on the archive's
# top-level page, where some htmls are excplicitly indexed.
@docsuffixes = ( 'iafa', 'lsm', 'readme', 'asc', 'note', 'info',
		'announce', 'changelog', 'blurb', 'announcement',
		'license', 'sig', 'txt');
@docprefixes = ( 'readme', '!index', 'lost\+found' );
@months
  = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');

use File::Find;
use Getopt::Std;

# Globals:
#
# @filelist	list of all non-!INDEX files in the archive directories
# @dirlist	list of all archive directories (with descriptions) 
# @src		source filegroup for move/replace operations
# @dst		source filegroup for move/replace operations
# $cwd  	current working directory beneath top
# $inset	current contents of incoming directory
# $next 	index of first unprocessed file in $inset
#
# Also uses cache files under $shared/keeper
#

$|=1;

$LOGNAME=$ENV{'LOGNAME'};
$EDITOR=$ENV{'EDITOR'};
$LOGNAME=$ENV{'LOGNAME'};

$HOMELINK=$ENV{'HOMELINK'};
if ($HOMELINK) {
    $homelink = $HOMELINK;
} else {
    $homelink = "mailto:$LOGNAME\@$fqdn";
}

$HOMEADDR=$ENV{'HOMEADDR'};
if ($HOMEADDR) {
    $homeaddr = $HOMEADDR;
} else {
    $homeaddr  = "$LOGNAME\@$fqdn";
}

$PAGER=$ENV{'PAGER'};
if ($PAGER) {
    $pager = $PAGER;
} else {
    $pager = "more";
}

# Read any mirror configuration files, add local directories to kill list
foreach $f (@mirror_list) {
    my($local, @localdirs);
    if (open(MIRROR, "$f")) {
	while (<MIRROR>) {
	    $skip = 0 if /package=/;
	    $skip = 1 if /skip=/;
	    next unless /local_dir=/ && !$skip;
	    $local = $_;
	    $local =~ s/.*local_dir=$ftptop\///;
	    chop $local;
	    push(@mirror_dirs, $local);
	}
	close(MIRROR);
    }
}

getopts('r:s:c');
if ($opt_r)
{
    undef $opt_r if $opt_r eq '/';
    $opt_r = "/$opt_r" if $opt_r;
    chdir "$top$opt_r";
    &finddepth(\&preen, "$top$opt_r");
} elsif ($opt_s) {
    print "Stem of '$opt_s' is ", &stem($opt_s), "\n";
} elsif ($opt_c) {
    undef $opt_r if $opt_r eq '/';
    $opt_r = "/$opt_r" if $opt_r;
    chdir "$top$opt_r";

#   local($totalcount, $free);
    &finddepth(\&policy_check, "$top$opt_r");
    printf(STDERR "$free of $totalcount free; %02d%% (%d nonstandard)\n",
	   $free*100/$totalcount, $totalcount - $free); 
} else {
    &interactive;
}

exit;	# Everything past here is subroutines

# PREEN MODE ----------------------------------------------------------------

sub preen
# Rebuild all existing index files, depth-first.
{
    my($preflen) = length($top) + 1;
    my($dir) = "$File::Find::dir/$_";

    # must be a directory, and *not* a symlink
    return unless (-d $dir && !-l $dir);

    # We can go through mirror points: this means we'll rebuild index
    # files that were created locally on previous runs.  Don't mess
    # with index files that aren't writeable.
    return if (!-f "$dir/!INDEX" || !-w "$dir/!INDEX");

    &repairindex(substr("$dir",  $preflen));

    return 0;
}

# COPY CHECK MODE -----------------------------------------------------------

sub policy_check
# Check for potential problems with distribution policy 
{
    my($preflen) = length($top) + 1;
    my($file) = "$File::Find::dir/$_";

    return if $file =~ /Incoming/;

    # must be a directory, and *not* a symlink
    return unless (-f $file && !-l $file && $file =~ /\.lsm$/);

    $totalcount++;
    $free += check_policy($file);

    return 0;
}

# INTERACTIVE MODE -----------------------------------------------------------

sub set_dir
# Interpret user's directory specification
{
    my($try) = @_;
    my($newdir, @hits);
    my($popup);

    # handle Unixy special cases
    return "/" if $try eq "/";
    return $cwd if $try eq '.';
    return &dirname($cwd) if ($try eq '..');
    while (substr($try, 0, 1) eq '.') {
	if (substr($try, 0, 3) eq '../') {
	    $try = &dirname($cwd);
	    $try = substr($try, 3);
	} elsif (substr($try, 0, 3) eq './') {
	    last;
	}
    }

    # try relative paths first, if user allows them
    if (substr($try, 0, 1) ne '/') {
	@hits = grep(/^$cwd\/$try\t/, @dirlist); 
    } else {
	$try = substr($try, 1);
    }

    # otherwise try absolute paths
    if (!@hits) {
	@hits = (@hits, grep(/^$try\t/, @dirlist));
    }

    if (@hits == 0) {
	print "No directories match $try.\n";
	return undef;
    } elsif (@hits == 1) {
	($newdir) = split(' ', $hits[0]);
	print $hits[0], "\n";
	return $newdir;
    } else {
	print("Ambiguous specification:\n");
	&bar;
	print join("\n", @hits), "\n";
	&bar;
	return undef;
    }
}

sub interactive
# normal interactive mode
{
    my($current);

    print "This is keeper $version, the archivist's assistant.  Type ? for help\n";

    # Make sure the lock directory is accessible.
    if (-e "$shared") {
	die("$shared is not a directory!\n") if (!-d "$shared");
	die("$shared is not writable!\n") if (!-w "$shared");
    } else {
	die("couldn't create $shared directory!\n")
	    unless mkdir("$shared", 0770);
    }

    # Now read the watch list
    if (!open(WATCHLIST, $watchfile)) {
	print "Could not open watch list file!\n";
    } else {
	local($person, $directories);
	while (<WATCHLIST>) {
	    $_ =~ s/\s*#.*//;
	    next if $_ =~ /^\s*$/;
	    ($person, @directories) = split;
	    $watchlist{$person} = join('|', @directories);
	}
	close(WATCHLIST);
    }

    $cwd = $incoming;
    $current = "src";

    while (1) {
	&do_cacheindex;

	undef @src if (@src <= 1); 
	print "Source: ", &show(@src), "\n" if ($src[0]);
	undef @dst if (@dst <= 1); 
	print "Target: ", &show(@dst), "\n" if ($dst[0]);
	print "keeper[$waiting]/$cwd";
	if ($current eq "src") {
	    print "> ";
	} elsif ($current eq "dst") {
	    print ">> ";
	} else {
	    print "? ";		# Should never happen!
	}

        last unless $_ = <STDIN>;

	chdir("$top/$cwd");
	($cmd, @args) = split(' ');
	$arg1 = $args[0];
	$arg2 = $args[1];

	&do_cacheindex;

	if ($cmd eq '?' || $cmd eq 'help') { 
	    do_help($arg1);
	}
	elsif ($cmd eq 'next' || $cmd eq 'n') {
	    $current = 'src';
	    undef @dst;
	    &do_next($arg1);
	}
	elsif ($cmd eq 'source' || $cmd eq 's') {
	    &do_pick($arg1, 'src') if @args;
	    $current = 'src';
	}
	elsif ($cmd eq 'target' || $cmd eq 't') {
	    &do_pick($arg1, 'dst') if @args;
	    $current = 'dst';
	}
	elsif ($cmd eq 'add' || $cmd eq 'a') {
	    if ($arg1) {
		push(@$current, @args);
	    } elsif (@$current[0] eq $incoming) {
		push(@$current, $inset[$next++]);
	    } else {
		print "Sorry, I don\'t know what to add here.\n";
	    }
	}
	elsif ($cmd eq 'drop' || $cmd eq 'd') {
	    if ($arg1) {
		my(%diff);
		grep($diff{$_}++, @args);
		@$current = grep(!$diff{$_}, @$current);
	    } else {
		pop(@$current);
		if ($$current[0] eq $incoming) {
		    $next-- if ($next > 0);
		    @src = @$current; 
		}
	    }
	}
	elsif ($cmd eq 'browse' || $cmd eq 'b') {
	    &do_browse(@$current);
	}
	elsif ($cmd eq 'yell' || $cmd eq 'y') {
	    &do_yell(@$current);
	}
	elsif ($cmd eq 'guess' || $cmd eq 'g') {
	    if (!&do_check(@src)) {
		undef @src;
	    } else {
		$current = 'dst' if &do_dispatch(@src);
	    }
	}
	elsif ($cmd eq 'put' || $cmd eq 'p') {
	    if ($arg1) {
		my($realdir) = set_dir($arg1);

		if ($realdir) {
		    @dst = ($realdir);
		} else {
		    print "No archive directory matching $arg1\n";
		    goto skipout;
		}
	    }
	    if (&do_put) {
		$waiting -= $#src if ($src[0] eq $incoming);
		undef @src; undef @dst;
	    }
	  skipout:;
	}
	elsif ($cmd eq 'link' || $cmd eq 'l') {
	    if (@args == 1)
	    {
		if (!@$current) {
		    print "Can't link an empty filegroup to anywhere.\n";
		} elsif ($arg1 = &set_dir($arg1)) {
		    do_file_link($arg1, @src);
		}
	    } elsif (($arg1 = &set_dir($arg1)) && ($arg2 = &set_dir($arg2))) {
		do_directory_link($arg1, $arg2);
	    }
	}
	elsif ($cmd eq 'zap' || $cmd eq 'z') {
	    	&do_zap($current);
	}
	elsif ($cmd eq 'find' || $cmd eq 'f') {
	    my(@candidates) = grep(/${arg1}/, @dirlist);
	    print join("\n", @candidates) . "\n";
	}
	elsif ($cmd eq 'query' || $cmd eq 'q') {
	    my(@candidates) = grep(/${arg1}/, @filelist);
	    print join("\n", @candidates) . "\n";		
	}
	elsif ($cmd eq 'cd' || $cmd eq 'c')
	{
	    $cwd = set_dir($arg1);
	    $cwd = $incoming if !$arg1 || $arg eq '.';
	    $cwd = "" if $cwd eq '/';
	}
	elsif ($cmd eq 'mkdir' || $cmd eq 'm') {
	    &do_mkdir($arg1);
	}
	elsif ($cmd eq 'kill' || $cmd eq 'k') {
	    &do_kill($arg1);
	}
	elsif ($cmd eq 'rename' || $cmd eq 'r') {
	    &do_rename($arg1, $arg2);
	}
	elsif ($cmd eq 'edit' || $cmd eq 'e') {
	    do_edit($arg1);
	}
	elsif ($cmd eq 'x') {
	    if (substr($arg1, 0, 1) eq 'm') {
		print "Mirrors:\n", join("\n", @mirror_dirs), "\n";
	    } elsif (substr($arg1, 0, 1) eq 'l') {
		print "File links:\n";
		foreach $f (sort keys %filelinks) {
		    print $f, " -> ", $filelinks{$f}, "\n";
		}
	    } elsif (substr($arg1, 0, 1) eq 'd') {
		print "Directory links:\n";
		foreach $f (sort keys %dirlinks) {
		    print $f, " -> ", $dirlinks{$f}, "\n";
		}
	    } elsif (substr($arg1, 0, 1) eq 'w') {
		print "Watch list:\n";
		foreach $f (sort keys %watchlist) {
		    print $f, " -> ", $watchlist{$f}, "\n";
		}
	    } else {
		print "Undefined examine command\n";
	    }
	}
	elsif (substr($cmd, 0, 1) eq '!') {
	    system(substr($_, 1));
	}
	elsif ($cmd =~ /^\s*$/o) {
	    # do nothing 
	}
	else {
	    print "Unknown command\n";
	}
    }
    print "\n";
}

# Interactive help

sub do_help
{
    my($topic) = @_;

    if (!$topic || $topic eq '?' || $topic eq 'help') {
	print <<EOF;
Keeper, or "Archive Keeper's Assistant", is a program that semi-automates
the maintainance of large FTP & HTML source archives.  

Help is available on the following topics:

theory              keeper's theory of operation
groups              the concept of a file group
commands            summary of commands
normal              normal operation of keeper
environment         environment variables that affect keeper
tips                tips for using keeper effectively

Help is also available for each of the individual commands.

EOF
    } elsif ($topic eq 'theory') {
	print <<EOF;
Keeper is designed for use by software archive sites that use the LSM 
convention and support both FTP and WWW access.  It assumes that the root
of your archive tree is visible to both access tools, and that both FTP
and HTML indices need to be generated and kept up to date.

Keeper further assumes that you have a directory called $incoming which
is a drop area for archive submissions.  The main task it supports is
dispatching groups of submitted files to appropriate places in the
archhive directory.  It also supports moving files and subdirectories
around within the archive.

To this end, the basic entity in Keeper's view of the world is the filegroup.
It helps you pick filegroups up and move them around.   (See \`help filegroup'
for details).  It also supports replacing a filegroup with another filegroup.
After each such operation, the relevant archive index files are automatically
rebuilt to describe the new state of things.

Keeper is quite deliberately not designed with an all-singing, all-dancing
browser interface (it doesn't even have directory-listing commands).  Instead,
it assumes that you will be running it in one window of an X desktop with
a Web browser pointed at the archive in the other.

EOF
    } elsif ($topic eq 'groups') {
	print <<EOF;
Keeper's commands operate on file groups.  Each file group is presumed to
consist of archive files (typically gzipped tars or RPMSs) and document files
including an LSM.  Keeper operations act on  source and target filegroups;
you can set these with the \`next', \`source', or `target' commands.

The \`next' command always operates on the $incoming directory; it tries
to make the source group the next logical filegroup (for details on its
methods do \`help next'). It also tells subsequent \`add' and \`drop'
operations to operate on the source group.  It undefines the target group.

The \`source' command selects files from the current directory for the
source group by prefix regexp (if given).  It also tells subsequent
\`add' and \`drop' operations to operate on the source group.

The \`target' command selects files from the current directory for the
source group by prefix regexp.  It also tells subsequent \`add' and
\`drop' operations to operate on the target group.

Because the prefix match used by these commands is far from perfect,
you can also \`add' and \`drop' files from the current filegroup individually. 
If the current group is in $incoming, \`add' with no arguments grabs the
next file in ASCIIbetical order and adds it to the group.  The command
\`drop' with no arguments drops the last file.

EOF
    } elsif ($topic eq 'commands') {
	print <<EOF;
(Every command can be abbreviated to its first letter.)

next   [file]      set source filegroup to the next out of $incoming
source [regexp]    select source files with given prefix in current directory
target [regexp]    select target files with given prefix in current directory
add    [files...]  add to the currently selected filegroup
drop   [files...]  drop from the currently selected filegroup
browse             browse document files in the currently selected filegroup
yell               yell at author about package naming
guess              try to deduce a target filegroup corresponding to source
put    [dir]       move source filegroup to target filegroup or directory
link   [src] dst   symbolic-link source to destination
zap    [files...]  delete (zap) files in the current filegroup
find   regexp...   list all archive directories matching regexp
query  regexp      list all archive files matching regexp 
cd     [regexp]    change to archive directory matching regexp
mkdir  dir         make a new archive directory with index entry
kill   dir         remove an empty archive directory
rename old new     move an archive directory to another location in the tree
edit   [dir]       edit index file for current directory (or dir if given)
x      l|d|m|w     examine 
!                  pass command to shell
^D                 exit keeper

EOF
    } elsif ($topic eq 'normal') {
	print <<EOF;
To clean out $incoming most efficiently, use the following algorithm:

1. Do \`n' to grab the next source filegroup from $incoming.  If there's 
   none, you're done.

2. Inspect the source filegroup names, possibly eyeball a browser pointed at
   $incoming, and do any adds and drops needed to make the filegroup complete.

3. Do `g' to try to compute a match.  At this point keeper will detect if the
   submission is bad or missing an LSM file.  If it's good, go to step 5.

4. If the submission is bad, you'll be shown any document files keeper can
   find and then prompted for the author's name.  If you can't determine it,
   just press enter at the name prompt to abort sending the letter and
   deleting the files (you can \`zap' them later if you want).  Go to step 1

5. If the match looks OK, type \`p' with no argument and fill in any
   description needed.  Note that if the target filegroup includes unrelated
   files you can use `drop' to unexpose them.  Go to step 1.

6. If no match, use \`b' to try to deduce a target directory from the LSM.
   Either use `p' with a directory argument to move the filegroup, or punt.
   Go to step 1. 

EOF

    } elsif ($topic eq 'environment') {
	print <<EOF;
The following environment variables affect keeper's operation:

EDITOR sets the editor used by the \`e' command to edit index files.

PAGER sets the page used by the \`browse' command. 

HOMELINK sets your the contents of the hotlink in the "Updated by"
line at the bottom of each page you prepare.  If HOMELINK is  not set,
keeper will assume you have a home page on the archive site.

HOMEADDR sets the label text in the "Updated by" line at the bottom of
each page you prepare.  If HOMELINK is  not set, keeper will make an
email address from your login name and the site hostname.

EOF

    } elsif ($topic eq 'tips') {
	print <<EOF;
In the keeper prompt, the number in square brackets is a count of files
waiting in $incoming.  That's the current working directory relative
to the archive top, after the colon.  The > at the end is single when
the current filegroup (for purposes of \`browse'/\`add'/\`drop'/\`zap') 
is the source group; double (>>) when it's the target group.

The most common mistake (which the author sometimes makes himself)
is to forget that when \`guess' finds a match, the *target* filegroup
becomes the current one.  Usually you'll trip over this when \`browse'
inexplicably fails to work.

In commands that take paths, (\`put', \`cd', \`mkdir', \`kill', \`rename',
and \`edit') keeper first tries for a unique relative-path match in
the directory list, then for a unique absolute one (actually, relative
to the archive top).  You can force an absolute path by prepending `/'
to the path.

When you can't figure where to put a new package, the `l' and `q' commands
are your friends.  Often they can help you find a related one.  You can also
explore the archive hierarchy with the browser in the other window.

To move files, use \`cd' followed by \`s' followed by \`p'.  (This is
the most important use for `source').

EOF
    } elsif ($topic eq 'next' || $topic eq 'n') {
	print <<EOF;
An archive maintainer's most common task is riffling through the $incoming
directory dispatching files to an archive.  You can view this directory as
a sequence of project filegroups.  Because project filegroups conventionally
have a common name prefix, each filegroup usually shows as a collection
of adjacent files in the $incoming directory listing.

The \`next' command looks at the $incoming files in ASCIIbetical order
and tries to step to the next project filegroup, making it the source
filegroup.  Keeper maintains an internal pointer; each time \`next'
is called, it tries to collect names with a common prefix starting at
the pointer.  The pointer is then bumped past the collected group.

The optional argument allows you to set the next pointer.  It is, in
effect, set to just before the first file that matches the argument
prefix, then a normal \`next' is performed.

Next makes the target filegroup undefined.

EOF
    } elsif ($topic eq 'source' || $topic eq 's') {
	print <<EOF;
The `source' command sets the source group to all files from the current
directory that match a given regexp.  This regexp need not be a prefix.

If the current directory is $incoming, this command has a side effect:
the next pointer (see \`help next') is set to point to just after the last
file in the new source group.

After a \`source' command, subsequent \`add' and \`drop' commands operate
on the source filegroup. 

The \`source' command can be useful when the common-prefix test used by
\`next' fails.

EOF
    } elsif ($topic eq 'target' || $topic eq 't') {
	print <<EOF;
The `target' command sets the target group to all files from the current
directory that match a given regexp.  This regexp need not be a prefix.

If the current directory is $incoming, this command has a side effect:
the next pointer (see \`help next') is set to point to just after the last
file in the new target group.

After a \`target' command, subsequent \`add' and \`drop' commands operate
on the target filegroup. 

The \`target' command can be useful when the common-prefix test used by
\`next' fails.

EOF
    } elsif ($topic eq 'add' || $topic eq 'a') {
	print <<EOF;
The \`add' command allows you to add files to the current filegroup.  

If you give it arguments, those files are added.  If you don't, and
the current filegroup is in $incoming, the next file in $incoming after
the last in the filegroup is added.  In other directories, the command
interpreter cannot compute a default and will complain.

EOF
    } elsif ($topic eq 'drop' || $topic eq 'd') {
	print <<EOF;
The \`drop' command allows you to drop files from the current filegroup.

If you give it arguments, those files are added.  If you don't, the last
file in the group is dropped.  If the current filegroup is in $incoming,
the next pointer is also decremented, so the dropped file will be picked
up by a subsequent \`next'.
EOF
    } elsif ($topic eq 'browse' || $topic eq 'b') {
	print <<EOF;
The \`browse' command attempts to pick out documentation files from the
current filegroup and display them.  

EOF
    } elsif ($topic eq 'yell' || $topic eq 'y') {
	print <<EOF;
The \`yell' command generates a form letter to a package author about his
package's name.  You'll be prompted for the author's name, the present
package name, and the suggested new one.  You'll see the note, and it will
be sent only if you confirm.

EOF
    } elsif ($topic eq 'guess' || $topic eq 'g') {
	print <<EOF;
The \`guess' command tries to deduce an archive target filegroup corresponding
to the current source group.

It first performs integrity checks on the gzipped files in the current
filegroup, and checks for the presence of an LSM file.  If any test is
failed, the command code attempts to send a form letter to the
distribution maintainers.

Keeper tries to deduce maintainer names itself from the LSM file.  If
it can't, you have to supply the author's name.  To assist you in
determining it, \`guess' will do the equivalent of a \`browse'.

If matches in the archive directories are found, the current filegroup
(for purposes of \`add', \`drop', \`browse', and \`zap') becomes the
target filegroup.

You will be warned if the contact lists for the source and target lists
is not the same (this may indicate a name collision between two different
projects).  You will also see the package's Copying-Policy if it is not
GPL or BSD (this to help spot restricted packages that you may not want
to archive.)

To actually replace the target filegroup, use \`put'.

EOF
    } elsif ($topic eq 'put' || $topic eq 'p') {
	print <<EOF;
If source and target filegroups are defined, the \`put' command deletes
the files in the target filegroup and replaces them with the ones in
the source filegroup.

If there is no target filegroup, the optional argument may be used to 
specify an archive directory to move the contents of the source file 
group.

When moving files from $Incoming, this command also causes log entries
to be written to the files NEW and NEW.html in the archive top
directory.  In this case the command code also prompts for a
description of each non-document file to be put in the target
directory's !INDEX. (If you enter a bare newline after keeper has
listed candidate matches, it will copy the first candidate.) Derived
index files in the target directory are then remade.

Also, when moving files from $Incoming, keeper tries to deduce an
email contact list from a package's LSM file.  If it succeeds, notice
of installation is mailed to that list.

When moving files from a directory other than $incoming, \`put' moves any
description of those files from the source directory's !INDEX file to the
target directory's !INDEX.  Derived index files for both directories are
then remade.

EOF
    } elsif ($topic eq 'link' || $topic eq 'l') {
	print <<EOF;
The \`link' command creates a symlink between the source and target
directories, or links for a source filegroup in a target directory; it
can be used to allow a file or directory to live in multiple
categories in the topic tree.

If the command gets a single argument, it is required to be an
existing directory; the files in the current source group get symlinked
to that directory.  (THIS FORM OF THE COMMAND IS NOT YET IMPLEMENTED!) 

If the command gets two arguments, both must be existing directories.
The name of the last segment of the first directory argument is
symlinked into the second.

EOF
    } elsif ($topic eq 'zap' || $topic eq 'z') {
	print <<EOF;
Delete files in the current filegroup (and remove them from the group).
With no arguments, delete all files in the group.

If the group contains only one file, it is quietly deleted.  If the
group contains more than one file, you are prompted for confirmation
before each deletion.

If the current directory is not $incoming, its index files will be
rebuilt afterwards.

This command is mainly useful for zapping random bits of flotsam out of
$incoming.

If there is an LSM file in the group and maintainers can be extracted
from it, they will be sent a form letter informing them of the deletion
and requesting that any questions or comments come back to you.

EOF
    } elsif ($topic eq 'find' || $topic eq 'f') {
	print <<EOF;
Find all archive directories whose names match the given regexp.  

Because the directory listing includes index descriptions, this command can
be useful for placing new projects.

EOF
    } elsif ($topic eq 'query' || $topic eq 'q') {
	print <<EOF;
List all archive files whose names match the given regexp.  

This command may be useful if your filegroup is a fragment that really seems
to go with some existing project that doesn't quite match by prefix.

EOF
    } elsif ($topic eq 'cd' || $topic eq 'c') {
	print <<EOF;
Change working directory.  This command matches its regexp argument against 
the directory listing.  All alternatives are listed.  The directory change
is done only if there is exactly one alternative.

A cd command with no arguments takes you back to the $incoming directory.

The point of this command is to enable you to pick up filegroups in
directories other than the $incoming one, for use in move and delete
commands.

EOF
    } elsif ($topic eq 'mkdir' || $topic eq 'm') {
	print <<EOF;
Make a new archive directory. Only the last segment can be new.

You will be prompted for a description for the new directory.

EOF
    } elsif ($topic eq 'kill' || $topic eq 'k') {
	print <<EOF;
Remove an empty archive directory.  Keeper will not allow deletion of
an archive directory that still has non-!INDEX files in it.

EOF
    } elsif ($topic eq 'rename' || $topic eq 'r') {
	print <<EOF;
Rename an archive directory.  Give both paths relative to the archive top.
The last segment of the first one gets renamed into the last segment of the
second one.

Thus, to move "fromdir/foo" into "todir" with the same name, you need to do 
"rename fromdir/foo todir/foo".  To rename the directory so its new name is
"bar", do "rename fromdir/foo todir/bar"

The description for the new directory will be copied from the description
for the old one, and all relevant index files updated.

EOF
    } elsif ($topic eq 'edit' || $topic eq 'e') {
	print <<EOF;
Edit the master !INDEX file in the current directory, then remake derived
index files.  If you give an argument directory, the !INDEX in that directory
will be edited instead.

For this command to work, your shell environment must have the variable
EDITOR set to an editor that will accept the name of a file to edit as 
its single argument.  Either vi or emacs should do nicely.

EOF
    } elsif ($topic eq 'x') {
	print <<EOF;
This command (intended primarily for debugging) allows you to examine
keeper's internal tables.  It takes an argument telling it which table 
to dump.

m = dump current mirror-point list

l = dump list of file crosslinks

d = dump list of directory crosslinks

w = dump current watch list

EOF
    } elsif ($topic eq '!') {
	print <<EOF;
This command simply passes the entered command line to the shell.

EOF
    } else {
	print "No help is available on this topic.\n";
    }
}

# File utility code

sub dump_date
{
    local($date) = @_;

    my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($date);
    return "$months[$mon] $mday, $century$year $hour:$min:$sec $timezone";
}

sub short_date
{
    local($date) = @_;

    my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($date);
    return "$mday$months[$mon]$year";
}

sub basename
# return filename with the directory part stripped away
{
    my($file) = @_;
    $file =~ s:^.*/::;
    return($file);
}

sub dirname
# return filename with the basename part stripped away
{
    my($file) = @_;
    if ($file =~ /\//) {
	$file =~ s:/[^/]*$::;
    } else {
	$file = "";
    }
    return($file);
}

sub mtime
# get the last modification time of the given file
{
    my($file) = @_;
    my(@statinfo);

    (@statinfo = stat($file)) || die("failed to stat $file!\n");
    return($statinfo[9]);
}

# Filegroup utility code 

sub show
# Display a filegroup.  $1 is the filegroup's name, $2 the filegroup itself
{
    my(@ref) = @_;

    if (!@ref) {
	return "<empty>";
    } else {
	return shift(@ref) . "/{" . join(' ', @ref) . "}";
    }
}

sub file_delete 
# Non-interactively delete the contents of a filegroup
{
    my(@set) = @_;
    my($dir) = shift(@set);

    foreach $f (@set) {
	if (!unlink("$top/$dir/$f")) {
	    print "Deletion of $top/$dir/$f failed\n";
	} else {
	    # remove all links to the affected file
	    for $g (keys %filelinks) {
		if ($filelinks{$g} eq "$dir/$f")
		{
		    if (unlink($g)) {
			$dirlinks{$g} = undef;
			print "Deleting link $g.\n";
			&repairindex(&dirname($g));
		    } else {
			print "Removal of link $g failed\n";
		    }
		}
	    }
	}
    }
}

# LSM parsing

sub lsm_format_ok
# Check that LSMs are in a correct version 3 or later format
{
    my($lsm) = @_;

    open(LSM, $lsm);

    # Simple check; we'll make it better later
    do {$_ = <LSM>} while ($_ && !/^\S/);
    return 0 unless /^Begin3/;

    close(LSM);

    return 1;
}

sub closest_of_type
# return files most closely prefix-matching a given file in current directory
{
    my($dir, $match, $type) = @_;

    opendir(DIR,"$top/$dir");
    my(@files) = readdir(DIR);
    closedir(DIR);

    # First, look for a stem match.  Then, from within those,
    # choose files with longest possible prefix match.
    my (@matchdocs) = grep(/$type/ && &stem($_) eq &stem($match), @files);
    my (%matchlevel);

    grep($matchlevel{$_} = &stem_match($_, $match), @matchdocs);

    my ($max) = 0;
    for (keys %matchlevel) {
	if ($matchlevel{$_} > $max) {
	    $max = $matchlevel{$_};
	}
    }

    return (grep($matchlevel{$_} == $max, @matchdocs));
}

sub lsm_extract_maintainers
# Try to extract an author and maintainers list from the LSM file(s), if any
{
    local(@set) = @_;

    my($dir) = shift(@set);
    my(@maintainers);

    foreach $f (@set) {
	next unless $f =~ /\.lsm$/;
	open(LSM, "$top/$dir/$f");
	my($accept) = 0;
	while (<LSM>) {
	    if (/^Author/ || /^Maintaine/) {
		$accept = 1;
	    } elsif (/^[A-Z]/) {
		$accept = 0;
	    }
	    next unless $accept;
	    $_ =~ s/^[^@]*=//;		# Kluge to accept old LSM formats
	    next unless /\s(\S+@\S+)\s/;
	    push(@maintainers, $1) unless grep($1 eq $_, @maintainers);
	}
	close(LSM);
    }

    return(@maintainers);
}

# Functions for recognizing and displaying docfiles

sub docfilename
# Return 1 if a given filename is probably a documentation file, 0 otherwise
{
    my($n) = @_;
    my($generic, $ext);

    $generic = $n;
    $generic =~ tr/[A-Z]/[a-z]/;
    $ext = $generic;
    $ext =~ s/.*\.//;

    foreach $p (@docsuffixes) {
	if ($ext eq $p) { return 1; }
    }
    foreach $p (@docprefixes) {
	if ($generic =~ /^$p/) { return 1; }
    }

    return 0;
}

sub bar
{
    print '-' x 79, "\n";
}

sub do_browse
# Browse all doc files in the current filegroup
{
    my(@set) = @_;
    my(@docfiles);

    chdir($top . "/" . shift(@set));

    @docfiles = grep(&docfilename($_), @set);
    if (!@docfiles) {
	print "No documentation files in filegroup.\n";
	return 0;
    }

    &bar;
    system($pager . " " . join(' ', @docfiles));
    &bar;
    return 1;
}

# Sending notifications

sub mailout
# send mail to the supplied to list and to watchers
{
    my($to, $subject, $message, $notice, $dir) = @_;

    my(@watchers) = grep($dir =~ /$watchlist{$_}/, keys(%watchlist)); 

    return unless $watchers || $to;

    &disable_interrupts;
    if (!open(MAILER, "|$sendmail")) {
	print "Mailer $sendmail won't fly.\n";
	&reenable_interrupts;
	return;
    }

    # If the to list is empty, just send to watchers.
    # If the to list is non-empty, blind-copy to watchers.
    print MAILER "To: $to\n" if $to;
    print MAILER "To: ", join(' ', @watchers) ,"\n" if @watchers && !$to; 
    print MAILER "Bcc: ", join(' ', @watchers) ,"\n" if @watchers && $to; 

    print MAILER "Subject: $subject\n\n";
 
    print MAILER $message;

    print MAILER <<EOF if $to;

This message was a form letter generated by keeper $version, but replying to
it will reach the human who told keeper what to do.  You got this note
because you're listed as a maintainer or author of the kit in question.
If the kit was actually uploaded by someone else, and you know who that
person is, please try to get that person to list him or herself in the LSM.  
EOF

    print MAILER <<EOF;
--
			$signature
EOF
    close(MAILER);

    print $notice, ": ", $to, "\n";
    &reenable_interrupts;
}

# Check filegroup correctness

sub check_policy
# Reveal copying policy if not free
{
    my($f) = @_;
    my($restricted);

    open(LSM, $f);
    while (<LSM>) {
	next unless /^Copying/;
	next if /^Copying-policy:\s+L?GPL2?\s*$/oi;
	next if /^Copying-policy:\s+PD\s*$/oi;
	next if /^Copying-policy:\s+GNU\s*$/oi;
	next if /^Copying-policy:\s+GNU[ -]L?GPL\s*$/oi;
	next if /^Copying-policy:\s+GNU General Public License/oi;
	next if /^Copying-policy:\s+GNU Public License/oi;
	next if /^Copying-policy:\s+BSD\s*$/oi;
	next if /^Copying-policy:\s+BSD-like\s*$/oi;
	next if /^Copying-policy:\s+X\s+Consortium\s*$/oi;
	next if /^Copying-policy:\s+Artistic\s+License\s*$/oi;
	next if /^Copying-policy:\s+free(ware)?\.?\s*$/oi;
	next if /^Copying-policy:\s+shareware\.?\s*$/oi;
	next if /^Copying-policy:.*freely (re)?distributable\.?\s*$/oi;
	next if /^Copying-policy:.*FRS\.?\s*$/oi;
	next if /^Copying-policy:\s+public[\s-]+domain\s*/oi;
	$_ =~ s/^Copying-policy://;
	$f =~ s/$top\///;
	print "$f: $_";
	$restricted = 1;
    }
    close(LSM);

    return(!$restricted);
}

sub do_check
# Check the filegroup for correctness.  Return of 0 means it's OK to delete.
{
	my(@set) = @_;
	my($dir, @files, @zipped, @badfiles, $subject, $date, $filelist);
	my(@lsm);

	@files = @set;
	$dir = shift(@files);
	chdir("$top/$dir");

	# Check for bad uploads
	@zipped = grep(/\.t?gz$/o, @files);
	if (@zipped) {
		# Relies on gzip -t -v to return 1 if archive is bad
		@badfiles = grep(system("gzip -t $_"), @zipped);
	}

	# check for missing LSM
	@lsm = grep(/\.lsm$/i, @set);

	# Describe the problems, if any
	undef $problems;
	if (!@lsm) {
	    $problems .= "* Missing LSM file.\n";
	} else {
	    foreach $f (@lsm) {
		if (!&lsm_format_ok($f)) {
		    $problems .= "* LSM file $f is not in correct (version 3) format.\n";
		} else {
		    &check_policy($f);
		}
	    }
	    if (!&lsm_extract_maintainers(@set)) {
		$problems .= "* Can't get email contacts from LSM file.\n";
	    }
	}
	if (@badfiles) {
	    $problems .= "* One or more archive files don't uncompress properly:\n  " . join(' ', @badfiles)  . " \n";
	}

	# Warn about files with recent mod dates, they may still be growing
	foreach $f (@files) {
	    if (time - &mtime($f) < $recent) {
		print "Warning: file $f may be being modified!\n";
	    }
	}

	# integrity tests passed?  then we're done
	return 1 unless ($problems);

	$author = &get_author("Problems:\n$problems", @set);
	if ($author =~ /^[ \t]*$/) {
		print "Bad author name, I won't send mail or delete the files.\n";
		return 1;
	}

	# We have the author.  Mail a notification to him
	$subject = join(' ', @files);
	$date = &dump_date(time);
	my($note) = <<EOF;
I tried to process the file(s) in the subject line out of $archive's incoming
directory and into the archives sometime around $date, but
encountered the following problems:

$problems

Consequently, your file(s) 

$subject

have been removed from the $incoming directory.  Any good ones are gone
along with the bad; sorry about that, but it's our only way to avoid hassles
if the responsible person never gets back to us.

Would you re-upload your kit and check that each archive is valid and it
has a correct LSM file, please?   The \`keeper' tool we use to 
maintain $archive depends strongly on correct LSMs.
EOF
	&mailout($author, $subject, $note, "Rejection notice sent to", $incoming);

	file_delete(@set);

	print "Deleted: ", &show(@set), "\n";
	$waiting -= $#set;

	return 0;	
}

sub do_yell
# Complain about naming problems
{
    my(@set) = @_;
    my($dir, @files, $subject, $date, $oldname, $newname, $note);
    my($lsm);

    @files = @set;
    $dir = shift(@files);
    chdir("$top/$dir");

    $author = &get_author("Name of package is non-canonical\n", @set);
    if ($author =~ /^[ \t]*$/) {
	print "Bad author name, I won't send mail.\n";
	return;
    }

    print "Present name? "; $oldname = <STDIN>; chop $oldname;
    if ($oldname =~ /^[ \t]*$/) {
	print "Bad package name, I won't send mail.\n";
	return;
    }

    print "Better name? "; $newname = <STDIN>; chop $newname;
    if ($newname =~ /^[ \t]*$/) {
	print "Bad package name, I won't send mail.\n";
	return;
    }

    $note = <<EOF;
Your package is being processed from $archive's submissions queue into
the archive directories, and should appear there shortly.  This is
*not* a rejection notice.

However, we think the name of your package may make life more difficult for
the semi-automated archive tools we're developing.  We would appreciate it if 
you would rename your next release kit in a more GNU-like way, perhaps as
$newname.

It's helpful to everybody if your archive files all have GNU-like
names -- all-lower-case alphabetic stem prefix, followed by a dash,
followed by a version number and extension.  The stem prefix should
be common to all a project's files.  Please don't use underscores.

foobar-0.23.tar.gz, foobar.lsm, foobar.README
    This is a good set of names that helps our tools

tai-chi-0.1.tar.gz, tai-chi-0.1.lsm
    These are OK.

StUdlYCodE-8.1.tar.gz, blargh-lsm
    These are bad.  The first one will confuse people trying to type it.
    The second one will confuse our helper tools because they won't be
    able to tell that "lsm" is an extension.

Thanks for your cooperation.
EOF
    $date = &dump_date(time);
    &mailout($author, "$oldname ($date)", $note, "Yell note sent to", $incoming);

    return;	
}

# Index remaker and lock code

# Interrupt protection and multi-user exclusion

sub disable_interrupts
# Begin operation that must be atomic, but doesn't contend with other keepers
{
    $SIG{'INT'} = 'IGNORE';
    $SIG{'QUIT'} = 'IGNORE';
    $SIG{'HUP'} = 'IGNORE';
}

sub reenable_interrupts
# Atomic operation is finished
{
    $SIG{'INT'} = 'DEFAULT';
    $SIG{'QUIT'} = 'DEFAULT';
    $SIG{'HUP'} = 'DEFAULT';
}

sub begin_critical_region
# Begin critical region, don't proceed until we get exclusion or time out
{
    my($timeleft) = $lock_expire;

    # sigh...there's a window between the test and create here
    unless (-e "$shared/LOCK") {
	open(LOCK, ">$shared/LOCK") || die("Can't create lock file!\n");
	close(LOCK);
    }

    # the timeout allows us to ignore a stale lock after a while
    while (!link("$shared/LOCK", "$shared/LOCK.ASSERTED") && $timeleft-- > 0) {
	print "Waiting $timeleft seconds on the keeper exclusion lock...\n";
	sleep(1);
    }

    &disable_interrupts;
}

sub end_critical_region
# End critical region, releasing exclusion lock
{
    print "Uh oh! Exclusion lock is missing or can't be deleted!\n"
	if !unlink("$shared/LOCK.ASSERTED");

    &reenable_interrupts;
}

# Index remaker and lock code

sub seek_incoming
# seek the next pointer to the first file lexicographically >= the argument
{
    my($match) = @_;

    foreach $i (0..$#inset) {
	if ($inset[$next = $i] ge $match) {
	    return;
	}
    }
    $next = 0;		
}

sub do_rebuild
# Rebuild the file and directory indices
{
    print "Regenerating index files...";

    open(FINDFILE, ">$findfile");
    open(FINDDIR, ">$finddir");
    foreach $myd ($top) {
	(my($myddev,$mydino,$mydmode,$mydnlink) = stat($myd))
	    || (warn("Can't stat $myd: $!\n"), next);
	if (chdir($myd)) {
	    ($dir,$_) = ($myd,'.');
	    $myd =~ s,/$,, ;
	    &indexdir($myd, $mydnlink, "");
	} else {
	    warn "Can't cd to $myd: $!\n";
	}
    }
    close(FINDFILE);
    close(FINDDIR);
    print("done\n");
}

sub indexdir
# Helper function for do_rebuild
{
    my($dir,$nlink,$desc) = @_;
    my($dev,$ino,$mode,$subcount);
    my($name, $preflen);

    $preflen = length($top) + 1;

    $name = substr(${dir}, $preflen);
    return if grep($name =~ /^$_/, (@kill_list, @mirror_dirs));
    print FINDDIR $name . "\t" . $desc . "\n" if $name;

    # Get the list of files in the current directory.
    opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return);
    my(@filenames) = readdir(DIR);
    closedir(DIR);

    if ($nlink == 2) {        # This dir has no subdirectories.
	for (@filenames) {
	    next if $_ eq '.';
	    next if $_ eq '..';
	    $name = "$dir/$_";
	    $nlink = 0;

	    next if (/\/!INDEX/);	# Exclude index files
	    print FINDFILE substr(${name},$preflen) . "\n";
	}
    }
    else {                    # This dir has subdirectories.

	if (open(INDEX, "!INDEX")) {
		while (<INDEX>) {
			if (/^([^ ]*)\/ *(.*)/) {
				$index{$1} = $2;
			}
		}
		close(INDEX);
	}

	$subcount = $nlink - 2;
	for (@filenames) {
	    next if $_ eq '.';
	    next if $_ eq '..';
	    $nlink = 0;
	    $name = "$dir/$_";
	    $topic = substr(${name}, $preflen);
	    if ($subcount <= 0) {    # Seen all the subdirs?
		print FINDFILE $topic . "\n";
	    } else {
		# Get link count and check for directoriness.
		($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;

		if (-d _) {

		    # It really is a directory, so do it recursively.

		    if (chdir $_) {
			&indexdir($name,$nlink, $index{&basename($name)});
			chdir '..';
		    }
		    --$subcount;
		} else {
		    print FINDFILE $topic . "\n";
		}
	    }
	}
    }
}

sub do_cacheindex
# Set the globals @filelist, @dirlist, $inset, and $next
{
    # Make sure our cache of the incoming directory is up to date
    if (&mtime("$top/$incoming") > $last_incoming) {
	#
	# Set up the global $inset to contain a copy of the incoming
	# directory, sorted.  Also, change $next so it corresponds to
	# the same place in the incoming list, allowing for possible
	# additions or deletions since last reread.
	#
	my($oldnext);

	$last_incoming = time;
	$oldnext = $inset[$next];

	opendir(INCOMING, "$top/$incoming")
		|| die("can't open $top/$incoming!\n");
	@inset = readdir(INCOMING);
	close(INCOMING);
	@inset = sort grep(!/^\./ && !&ignore($incoming, $_), @inset);

	&seek_incoming($oldnext);
	$waiting = @inset;
    }

    # Rebuild index files if needed
    if (!-e $findfile || (time - &mtime($findfile)) > $file_expire) {
	&begin_critical_region;
	&do_rebuild;
	&end_critical_region;
    } 

    # If we haven't cached the index files since they were last regenerated,
    # reread them now.
    if (&mtime("$findfile") > $last_index) {
	$last_index = time;
	print "Rereading index files...";

	# rebuild the file list 
	undef @filelist;
	open(FINDFILE, $findfile) || die("failed to open $findfile\n");
	while (<FINDFILE>) {
	    next if (/^$incoming\//);	# don't index the incoming directory
	    chop;
	    push(@filelist, $_);
	}
	print "file index OK, ";
	close(FINDFILE);

	# rebuild the directory list
	undef @dirlist;
	open(FINDDIR, $finddir) || die("failed to open $finddir\n");
	while (<FINDDIR>) {
	    chop;
	    push(@dirlist, $_);
	}
	print "directory index OK\n";
	close(FINDDIR);

	# prepare the symlinks lists
	undef %filelinks;
	undef %dirlinks;
	foreach $f (@filelist) {
	    my($actual);
	    if (-l "$top/$f") {
		$actual = &dirname($f) . "/". readlink("$top/$f");
		while ($actual =~ m|\.\./|) {
		    $actual =~ s|[^/]+/../||;
		}
		if (-d "$top/$actual") {
		    $dirlinks{$f} = $actual;
		} else {
		    $filelinks{$f} = $actual;
		}
	    }
	}
    }
}

# Functions for recognizing file groups

sub stem
# extract the stem prefix of a project file
{
    my($file) = @_;

    # First check to see if we've got a GNUish name with version number
    # after a dash.  If so, allow numbers in the stem.
    return $1 if $file =~ /(^[a-zA-Z0-9_-]*[a-zA-Z0-9])-[0-9][0-9.]*/;

    # Otherwise stop the stem on the first digit, because we can't tell
    # whether it is part of a version number or not.
    # Don't allow the stem to end with - or . because filegroups often
    # contain pairs like "foo-2.3.tar.gz" and "foo.lsm".
    $file =~ /(^[a-zA-Z_-]*[a-zA-Z])/o;
    return($1);
}

sub stem_match
# how closely do two strings match?
{
    my($old, $new) = @_;

    foreach $i (0..length($old)) {
	return $i-1 if (substr($old, 0, $i) ne substr($new, 0, $i));
    }

    return length($old);
}

sub ignore
# Tell us which files to ignore completely
{
    local($dir, $file) = @_;

    return 1 if $file eq '.' || $file eq '..';

    foreach $f (@ignore) {
	return 1 if $file =~ /$f/i;
    }

    if ($dir eq $incoming) {
	foreach $f (@inspecial) {
	    return 1 if $file =~ /$f/i;
	}
    }

    return 0;
}

sub do_next
# Try to select the next filegroup to process.  Uses and modifies $inset, $next
# Sets @src
{
    my($base) = @_;
    my($n, $stem);

    &seek_incoming($arg1) if $arg1;

    if (!$inset[$next]) {
	print "No more filegroups, rewinding.\n";
	$next = 0;
	return if (!$waiting);
    }

    $stem = &stem($inset[$next]);
    @src = ($incoming);
    while (&stem($inset[$next]) eq $stem) {
	push(@src, $inset[$next++]);
    }
}

# How to pick filegroups by regexp

sub do_pick
# Pick files matching regexp in current directory
{
    my($regexp, $modify) = @_;
    my(@new);

    @new = grep(/${regexp}/ && !&ignore($cwd, $_), glob('*'));
    if (@new) {
	@$modify = @new;
	unshift(@$modify, $cwd);
	if (@$modify[0] eq $incoming) {
		&seek_incoming(@$modify[$#$modify]);
	}
    } else {
	print "No matches.\n";
	undef @$modify;
    }
}


sub do_kill
# remove a directory from the topic tree
{
    my($dir) = @_;
    my(@mpoint);

    if (!$dir) {
	print "Kill command requires an argument.\n";
    } elsif (!($dir = &set_dir($dir))) {
	print "No matching directory\n";
    } elsif ((@mpoint = grep($dir =~ /^$_/, @mirror_dirs))) {
	print "$arg is at or below the mirror point $mpoint[0]\n"; 
    } else {
	opendir(DIR,"$top/$dir");
	my(@filelist) = readdir(DIR);
	closedir(DIR);

	my(@nogood) = grep(!&ignore($dir, $_), @filelist);
	if (@nogood) {
	    print "Directory $dir is nonempty (", join(' ', @nogood), ").\n";
	} else {
	    &begin_critical_region;
	    foreach $f (@filelist) {
		next if $f eq '.';
		next if $f eq '..';
		unlink("$top/$dir/$f");
	    }
	    if (!rmdir("$top/$dir")) {
		print "Directory removal failed\n";
	    } else {
		&repairindex(&dirname($dir));

		# remove all links to the affected directory
		for $d (keys %dirlinks) {
		    if ($dirlinks{$d} eq $dir)
		    {
			if (unlink($d)) {
			    $dirlinks{$d} = undef;
			    &repairindex(&dirname($d));
			} else {
			    print "Removal of link $d failed\n";
			}
		    }
		}

		$date = &dump_date(time);

		# Action logging for internal consumption
		open(ACTLOG, ">>$shared/LOG");
		print ACTLOG "At $date, $LOGNAME:\n";
		print ACTLOG "* removed the directory $dir\n";
		close(ACTLOG);

		# Notify anybody with a watch on this directory

		&mailout(undef, 
			 "$archive action notice from the \`keeper' program", 
			 "At $date I removed directory $dir.\n",
			 "Watch-list notice sent to",
			 $dir);

		&do_rebuild;
	    }
	    &end_critical_region;
	}
    }
}

# How to move directories

sub rrhook
{
    if (-d "$top/$File::Find::dir/$_") {
	repairindex("$File::Find::dir/$_");
    }
}

sub do_rename
# Rename a directory; takes two paths as arguments.
{
    my($old, $new) = @_;
    my($newparent, @mpoint);

    if (!$old || !$new) {
	print "Command needs two arguments\n";
    } elsif (!($old = &set_dir($old))) {
	print "Bad first argument\n";
    } elsif (!($newparent = &set_dir(&dirname($new)))) {
	print "Bad second argument\n";
    } elsif (($new = "$newparent/". &basename($new)) && -d "$top/$new") {
	print "$new already exists\n";
    } elsif ((@mpoint = grep($_ =~ /^$old/, @mirror_dirs))) {
	print "$old is above mirror point(s) ", join(' ', @mpoint), "\n"; 
    } elsif ((@mpoint = grep($new =~ /^$_/, @mirror_dirs))) {
	print "$new is at or below the mirror point $mpoint[0]\n"; 
    } else {
	&begin_critical_region;
	chdir $top;
	if (rename($old, $new)) {
	    my(%descs) = &readindex(&dirname($old));

	    $olddesc = $descs{&basename($old)};
	    print "No description for ", &basename($old), "\n" unless $olddesc;

	    &writeindex(&dirname($new), &basename($new) . "/",  $olddesc);

	    # transplant all links to the affected directory
	    for $d (keys %dirlinks) {
		if ($dirlinks{$d} eq $old)
		{
		    my($levels) = scalar(split('/', $d)) - 1;
		    my($newloc) = "../" x $levels . $new;

		    if (unlink($d) && symlink($newloc, $d)) {
			$dirlinks{$d} = $undef;
			$dirlinks{$newloc} = $new;
		    } else {
			print "Relink of $d to $newloc failed\n";
		    }
		}
	    }

	    # Order is important here, lower directory indexes have to get
	    # remade before higher ones in order for the !INDEX pointers to
	    # come out right.  So rebuild everything under the new directory
	    # depth-first.  Then rebuild the old -- this sequence will work
	    # regardless of where $new is relative to $old, though it may
	    # duplicate some work.
	    &finddepth(\&rrhook, $new);
	    &repairindex(&dirname($old));
	    &repairindex(&dirname($new));

	    my($date) = &dump_date(time);

	    # Action logging for internal consumption
	    open(ACTLOG, ">>$shared/LOG");
	    print ACTLOG "At $date, $LOGNAME:\n";
	    print ACTLOG "* moved directory $old to $new\n";
	    close(ACTLOG);

	    # Notify anybody with a watch on this directory
	    &mailout(undef, 
		     "$archive action notice from the \`keeper' program", 
		     "At $date, I renamed directory $old to $new.\n",
		     "Watch-list notice sent to",
		     $old);

	    &do_rebuild;
	} else {
	    print "Directory move failed, error $!\n";
	}
	&end_critical_region;
    }
}

sub do_edit
# Edit descriptions file for given package
{
    my($dir) = @_;

    if ($dir eq $incoming) {
	print "The $incoming directory has no !INDEX\n";
	return;
    } elsif (!($dir = &set_dir($dir))) {
	return;
    }

    # read the existing descriptions for comparison
    my(%olddesc) = &readindex($dir);

    chdir("$top/$dir");
    if (!$EDITOR) {
	print "No editor defined.  See \`help editor'\n";
	return;
    } elsif ($dir eq '/') {
	system("$EDITOR $top/!INDEX");
    } else {
	system("$EDITOR $top/$dir/!INDEX");
    }

    # if user deleted necessary descriptions, get them back
    &repairindex($dir);

    # read new descriptions
    my(%newdesc) = &readindex($dir);

    my(%notify);
    foreach $k (keys %olddesc) {

	# ignore the header
	next if '!!header!!' eq $k;

	# we can ignore any deletions, since repairindex was called and 
	# all files and directories now present should have descriptions
	next unless $newdesc{$k};

	# ignore any descriptions that haven't changed
	next if $olddesc{$k} eq $newdesc{$k};

	# if it's a directory, rebuild in order to include the new description
	if (-d $k) {
	    &repairindex("$dir/$k");
	    next;
	}

	# it's a file, so fake up a filegroup from closest matching LSM files;
	# use this to compute the file maintainers
	my(@lsms) = &closest_of_type($dir, $k, '\.lsm$');
	unshift(@lsms, $dir);
	my(@maint) = &lsm_extract_maintainers(@lsms);
	unless (@maint) {
	    print "Can't find maintainers for $k\n";
	    next;
	}

	# OK, set up a notification pair
	$notify{$k} = join(' ', @maint);
    }

    # now we have a set of notification pairs; invert it
    my(%invert);
    foreach (keys %notify) {
	$invert{$notify{$_}} .= " $_";
    }

    # right, now we can generate the actual notifications
    foreach (keys %invert) {
	my($date) = &dump_date(time);
	my($note) = "At $date the following descriptions were changed.\n\nFrom:\n";
	my (@changed) = split(' ', $invert{$_});

	foreach $s (@changed) {
	    next unless $s;
	    $note .= sprintf("%-24s %s\n", $s, $olddesc{$s});
	}

	$note .= "\nTo:\n";

	foreach $s (@changed) {
	    next unless $s;
	    $note .= sprintf("%-24s %s\n", $s, $newdesc{$s});
	}

	&mailout($_,
	    "$archive action notice from the keeper program",
	    $note,
	    "Description change note for$invert{$_} mailed to",
	    $dir);
    }
}

# Here goes the actual dispatching logic

sub do_dispatch
# try to compute a target fileset corresponding to the source
{
    my(@files) = @_;

    my($dir) = shift(@files);
    my($stem, @candidates, $ok, $firstdir, @srcmaint, @dstmaint);

    if (!@files) {
	print "Filegroup is empty\n";
	return 0;
    }

    # Here's where we compute the candidate match set
    # Ignore symlinks, we always replace at the file's original location. 
    $stem = &stem($files[0]);
    @candidates = grep(&stem(&basename($_)) eq $stem, @filelist);
    foreach $f (1..$#files) {
	$stem = &stem($files[$f]);
	@candidates = grep((!-l "$top/$_") && &stem(&basename($_)) eq $stem, @candidates);
    } 

    if (@candidates == 0) {
	print "No matches.\n";
	return 0;
    } else {
	# We appear to have found matches

	# Check that all files in the match set are in the same directory
	$ok = 1;
	$firstdir = &dirname($candidates[0]);
	foreach $f (1..$#candidates) {
	    $ok = 0 if (&dirname($candidates[$f]) ne $firstdir);
	}
	if (!$ok) {
	    print "Matches are not all in the same directory:\n";
	    &bar;
            print join("\n", @candidates) . "\n";
	    &bar;
	    return 0;
	}

	# List looks valid.  Construct the fileset
	@dst = ($firstdir, grep($_ = &basename($_), @candidates));

	# Warn user if author lists don't match
	@srcmaint = &lsm_extract_maintainers(@src);
	@dstmaint = &lsm_extract_maintainers(@dst);
	if (!@srcmaint && !@dstmaint) {
	    print "Can't determine maintainers for either filegroup.\n";
	} else {
	    my(%srcdope);
	    grep($srcdope{$_}++, @srcmaint);
	    grep($dstdope{$_}++, @dstmaint);
	    if (grep($srcdope{$_} != $dstdope{$_}, (@srcdope, @dstdope))) {
		print "Source maintainers: ", join(' ', @srcmaint), "\n";
		print "Target maintainers: ", join(' ', @dstmaint), "\n";
	    } else {
		print "Source and target maintainer lists match OK.\n";
	    }
	    undef %srcdope; undef %dstdope;
	}

	return 1;
    }
}

sub do_put
# Replace target filegroup with source filegroup.
# If target filegroup contains no files this is just a move.
{
    my(%srcdesc, %dstdesc);

    if (!@src) {
	print "Source filegroup is empty!\n";
	return 1;
    } elsif (!@dst) {
	print "Target filegroup is empty!\n";
	return 1;
    }

    # This is where we make sure every non-document file in the 
    # source group has a description.  It's important to
    # do all the description input outside the critical region
    %srcdesc = &readindex($src[0]) unless ($src[0] eq $incoming);
    foreach $i (1..$#src) {
	my($base) = &basename($src[$i]);
	if (!&docfilename($src[$i]) && !$srcdesc{$base}) {
	    $srcdesc{$base} = &get_description($dst[0], $base);
	}
    }
    %dstdesc = &readindex($dst[0]);

    # Get description text associated with destination directory
    my(%pindex) = &readindex(&dirname($dst[0]));
    my($pdesc) = $pindex{&basename($dst[0])};

    &begin_critical_region;

    # Check that nobody has dispatched the filegroup since we computed a match
    foreach $i (1..$#src) {
	if (!-e "$top/$src[0]/$src[$i]") {
	    print "$src[0]/$src[$i] is missing!\n";
	    &end_critical_region;
	    return 1;
	}
    }

    my(@maintainers) = &lsm_extract_maintainers(@src);

    open(NEWFD, ">>$newlist") || die("failed to open $newlist");

    if ( -f $newhtml ) {
	open(NEWHTML, ">>$newhtml") || die "failed to open $newhtml";
    } else {
	open(NEWHTML, ">$newhtml") || die "failed to open $newhtml";

	my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime();
	$date = "$months[$mon] $mday, 19$year $hour:$min:$sec EST";

	print NEWHTML "<HTML>\n";
	print NEWHTML "<TITLE>New files on $archive as of $date</TITLE>\n";
	print NEWHTML "<H1>New files on $archive as of $date</H1>\n";
	print NEWHTML "<P><A HREF=\"welcome.html\">Welcome message</A>\n";
	print NEWHTML "<DL>\n";
    }

    # Deletion must go first in case we're replacing a file with no name change
    &file_delete(@dst);

    foreach $i (1..$#src) {
	my($filename) = "$src[0]/$src[$i]"; 
	my($dest) = $dst[0];
	my($base);

	if (system("mv $top/$filename $top/$dest")) {
	    printf "Error executing \"mv $top/$filename $top/$dest\"\n";
	    next;
	}

	# Also move all symlinks 
	foreach $f (keys %filelinks) {
	    if ($filelinks{$f} eq $filename) {
		if (unlink("$top/$f") && symlink("$top/$f", "$top/$dest/$filename")) {
		    print "Transplanting link from $f\n";
		    $filelinks{$f} = "$dest/$filename";
		} else {
		    print "Attempt to transplant link from $f failed.\n";
		}
	    }
	}

	$base = &basename($filename);
	chmod($archfilemode, "$top/$dest/$base");

	if (!&docfilename($filename)) {
	    &writeindex($dest, $base, $srcdesc{$base});

	    if (&dirname($filename) eq $incoming) {
		my(@statinfo);

		if (!(@statinfo = stat("$top/$dest/$base"))) {
		    print "Failed to stat source file $top/$dest/$base!\n";
		    next;
		}

		my($size) = $statinfo[7];
		my($date) = &dump_date($statinfo[9]);

		print NEWFD "$dest/$base ($size bytes)\n";
		print NEWFD "   $srcdesc{$base} ($date)\n";
		print NEWFD "\n";

		print NEWHTML "<DT><A HREF=\"$dest/$base\">$dest/$base</A> ($size bytes)</DT>\n";
		print NEWHTML "<DD>$srcdesc{$base} ($date)</DD>\n";

	    }
	} 
    }

    close NEWFD;
    close NEWHTML;

    # Action logging for internal consumption
    if ($src[0] ne $incoming) {
	open(ACTLOG, ">>$shared/LOG");
	print ACTLOG "At ", &dump_date(time), " ", $LOGNAME, ":\n";
	print ACTLOG "* deleted ", &show(@dst), "\n" if @dst > 1;
	print ACTLOG "* moved ", &show(@src), " to $dst[0]\n";
	close(ACTLOG)
	}

    # What we're trying to do here is avoid rebuilding the indexes
    # every time after the most common action (filing stuff out of
    # $Incoming).  We can afford to do it every time when moving stuff
    # between archive directories, because that's not a common operation.
    &do_rebuild if ($src[0] ne $incoming);

    if (@maintainers) {
	my($to) = join(' ', @maintainers);
	my($date) = &dump_date(time);
	$pdesc = " ($pdesc)" if pdesc;
	my($note) = <<EOF;
At about $date, \`keeper' moved the following files from
$src[0] to $dst[0]$pdesc:

EOF

	foreach $s (@src[1..$#src]) {
	     $note .= sprintf("%-24s %s\n", $s, $srcdesc{$s});
	}

	if ($#dst) {
	    $note .= "\nThese replaced the following files:\n\n";
	    foreach $s (@dst[1..$#dst]) {
		$note .= sprintf("%-24s %s\n", $s, $dstdesc{$s});
	    }
	}    

	$note .= <<EOF;

Thank you for your contribution of time, effort, and creativity.
EOF

	&mailout($to,
	    "$archive action notice from the \`keeper' program",
	    $note,
	    "Notification mailed to",
	    $dst[0]);
    }

    &end_critical_region;

    # Now the critical stuff is done; rebuild the HTML index files
    &repairindex("$dst[0]");
    &repairindex("$src[0]") if ($src[0] ne $incoming);

    return 1;
}

sub writeindex
# write an index entry, count on repairindex to re-sort them properly later
{
    my($dest, $base, $descrip) = @_;

    if (open(INDEX, ">>$top/$dest/!INDEX")) {
	printf INDEX ("%-24s %s\n", $base, $descrip);
	close(INDEX);
    }
}

sub do_file_link
{
    my($dir, @files) = @_;

    print "Filegroup-to-directory links are not yet implemented\n";
}

sub do_directory_link
# Create a symlink for the source directory in the target directory
{
    my($srcdir, $dstdir) = @_;

    my(%pindex) = &readindex(&dirname($srcdir));
    my($pdesc) = $pindex{&basename($srcdir)};
    unless ($pdesc) {
	print "Can't get a description for $srcdir!\n";
	return;
    }

    unless (chdir("$top/$dstdir")) {
	print "Can't get to destination directory!\n";
	return;
    }

    my($base) = &basename($srcdir);
    my($popup) = ("../" x (1+scalar(split('/', @dstdir))));

    if (!symlink("$popup$srcdir" , $base)) {
	print "Symlink of $popup$srcdir $base failed.\n";
    } else {
	&writeindex($dstdir, "$base/", $pdesc);
	$dirlinks{"$dstdir/$base", "$popup$srcdir"};
	&repairindex($dstdir);
    }
}

sub do_zap
# Interactively delete files in a file group, notifying the maintainers
{
    my($current) = @_;
    my(@maint) = &lsm_extract_maintainers(@$current);

    my(@deletia) = $$current[0];
    if (!@$current) {
	print "No current filegroup\n";
	return;
    } else {
	@args = @$current[1..$#$current] if (!@args);
	foreach $f (@args) {
	    if (@args != 1) {
		my($ans);
		print "Delete $$current[0]/$f? ";
		$ans = <STDIN>;
		chop($ans);
		next unless $ans =~ /^y/i;
	    }
	    unlink("$top/$$current[0]/$f"); 
	    @$current = grep($_ ne $f, @$current);
	    push(@deletia, $f);
	    $waiting-- if ($src[0] eq $incoming);

	    # remove all links to the affected files
	    for $f (keys %filelinks) {
		if ($filelinks{$f} eq "$$current[0]/$f")
		{
		    if (unlink($f)) {
			$dirlinks{$f} = undef;
			&repairindex(&dirname($f));
		    } else {
			print "Removal of link $f failed\n";
		    }
		}
	    }
	}
    }

    &repairindex($$current[0]) if ($$current[0] ne $incoming);

    my($date) = &dump_date(time);

    # Action logging for internal consumption
    if ($$current[0] ne $incoming) {
	&begin_critical_region;
	open(ACTLOG, ">>$shared/LOG");
	print ACTLOG "At $date, $LOGNAME:\n";
	print ACTLOG "* zapped ", &show(@deletia), "\n";
	close(ACTLOG);
	&end_critical_region;
    }

    # Send notification to watchers; also to maintainers if possible
    my($to) = join(' ', @maint);
    if (!$to) {
	print "No maintainers found, can't send them a deletion notice\n";
    }

    # Get description text associated with destination directory
    my(%pindex) = &readindex(&dirname($$current[0]));
    my($pdesc) = $pindex{&basename($$current[0])};

    print "Reason for deletion?\n";
    $reason = <STDIN>;
    chop $reason;

    my($deleted) = join(' ', @deletia);
    $pdesc = " ($pdesc)" if $pdesc;
    my($notification) = <<EOF;
At about $date, I made \`keeper' delete the following files
from $$current[0]$pdesc:

$deleted

$reason
EOF
     &mailout($to, 
		 "$archive action notice from the \`keeper' program",
		 $notification,
		 "Deletion notice sent to",
		 $$current[0]);
}

sub do_mkdir
# make a new topic directory
{
    my($dir) = @_;

    my(@mpoint);
    if (!$dir) {
	print "Mkdir command requires an argument.\n";
	return;
    }

    my($parent) = &dirname($dir);
    if ($parent ne "" && !($parent = &set_dir($parent))) {
	return;
    }

    if ((@mpoint = grep($dir =~ /^$_/, @mirror_dirs))) {
	print "$dir would be at or below the mirror point $mpoint[0]\n"; 
    }

    &begin_critical_region;
    if (mkdir("$top/$dir", $archdirmode)) {
	&repairindex($dir);
	&repairindex(&dirname($dir));
    } else {
	print "Directory creation failed\n";
    }

    my($date) = &dump_date(time);

    # Action logging for internal consumption
    open(ACTLOG, ">>$shared/LOG");
    print ACTLOG "At $date $LOGNAME:\n";
    print ACTLOG "* created a new directory $dir\n";
    close(ACTLOG);

    &do_rebuild;

    # Notify anybody with a watch on the parent directory
    &mailout(undef, 
	     "$archive action notice from the \`keeper' program", 
	     "At $date I renamed directory $old to $new.\n",
	     "Watch-list notice sent to",
	     $parent);

    &end_critical_region;
}

# Functions that might demand user input go here

sub get_description
# Deduce or collect a description for the given file
{
    my($dest, $base, $descrip) = @_;
    my(@matches);

    if (open(DESC, "<$top/$dest/!INDEX")) {
	my($stem) = &stem($base);
	@matches = grep(/^$stem/, <DESC>);
	close(DESC);
	if (@matches) {
	    &bar;
	    print @matches;
	    &bar;
	}
    }

    print "What is ", $base, "?\n";
    $descrip = <STDIN>;
    chop($descrip);

    if (($descrip =~ /^\s*$/) && @matches) {
	$descrip = $matches[0];
	chop $descrip;
	$descrip =~ s/^[^ ]+ +//;
	print "Copied over the first match.\n";
    } 

    return($descrip);
}

sub get_author
# Deduce or collect the name of the maintainers(s) for a package
{
    my($comment, @set) = @_;

    my(@maintainers) = &lsm_extract_maintainers(@set);
    my($author);

    if (@maintainers) {
	print "$comment";
	$author = join(' ', @maintainers);
	print "Contact list is: $author\n";
    } else {
	&do_browse(@set); 
	print "$comment";
	print "Contact? "; $author = <STDIN>; chop $author;
    }

    return($author);
}

# The rest is index-builder logic

sub readindex
# Read index from given directory and return it
{
    my($dir) = @_;
    my(%descs);

    $dir = "/$dir" if $dir;
    if (!open(INDEX, "<$top$dir/!INDEX")) {
	print "Warning: $dir has no !INDEX\n";
    } else {
	my($seendashes) = 0;
	my($first);
	$first = <INDEX>;
	return undef unless ($first =~ /generated by keeper/);
	while (<INDEX>) {
	    my($filename, $descrip);
	    $seendashes = 1 if (/^----/); 
	    $descs{'!!header!!'} .= $_ unless $seendashes;
	    chop;
	    if ($seendashes && /^([^ ]+) +(.*)$/) {
		$filename = $1;
		$descrip = $2;

		$filename =~ s|[@/]$||;
		$descrip =~ s/[ ]+$//;

		$descs{$filename} = "$descrip";
	    }
	}
	close(INDEX);
    }
    return(%descs);
}

sub writehtmlheader
{
    my($file, $directory) = @_;

    print $file "<!-- This file generated by keeper $version.  Do not edit by hand! -->\n";
    print $file "<HTML>\n";
    print $file "<TITLE>$directory</TITLE>\n";
    print $file "<H1>Index of $directory</H1>\n";
}

sub htmldir
{
    my($file, $type, $fdir, $dir, $desc) = @_;
    my($t, $m);

    if ( -l "$top/$fdir/$dir" ) {
	$t = '@';
    } elsif (grep($_ eq "$fdir/$dir", @mirror_dirs)) {
	$t = '/&';
    } else {
	$t = '/';
    }

    if ($type eq 'l') {
	if ( -f "$top/$fdir/$dir/!INDEX.html" ) {
	    print $file "<DT><A HREF=\"$dir/!INDEX.html\">"
		. "$dir$t</A>\n";
	} else {
	    print $file "<DT><A HREF=\"$dir\">$dir$t</A>\n";
	}

	if ($desc) {
	    print $file "<DD>$desc</DD>\n";
	}
    } else {
	if ( -f "$top/$fdir/$dir/!INDEX.short.html" ) {
	    printf($file "<A HREF=\"$dir/%!INDEX.short.html\">"
		   . "%-28s %s\n", "$dir$t</A>", "$desc");
	} else {
	    printf($file "<A HREF=\"$dir\">"
		   . "%-28s %s\n", "$dir$t</A>", "$desc");
	}
    }
}

sub hdrformat
# reformat an index header for use in long-format HTML
{
    my($hdr) = @_;

    $hdr =~ s/(\b[a-z]+:\/\/\S+[\w\/])([.\s])/<a href="\1">\1<\/a>\2/g;

    $hdr =~ s/\n/<br>\n/g;
    return $hdr . "<p>\n";
}

sub inlineable
{
    my($file) = @_;

    return ($file =~ /\.lsm$/) || ($file =~ /[.-]README$/);
}

sub repairindex
# rebuild the index files for a given directory 
{
    my($dir) = @_;
    my($indexname, @files, %descs, $updated);

    my(%pindex) = &readindex(&dirname($dir));
    my($pdesc) = $pindex{&basename($dir)};

    $indexname = "!INDEX";

    if ( ! -f "$top/$dir/$indexname") {
	print "$dir/!INDEX doesn't exist - creating\n";
    } else {
	print "Rebuilding $dir indexes...\n";
	%descs = &readindex("$dir");
	if (!keys(%descs)) {
	    print "$dir/!INDEX is not in keeper format\n";
	    return;
	}
    }

    opendir(DIR, "$top/$dir");
    @files = sort grep(!/^\./, readdir(DIR));
    closedir(DIR);

    # Pick up descriptions for any file we don't have
    foreach $n (@files) {
	if (!&docfilename($n) && !$descs{$n}) {
	    $descs{$n} = &get_description($dir, $n);
	}
    }

    &disable_interrupts;
    open(INDEXHTML,">$top/$dir/$indexname.html") || die("cannot create $top/$dir/$indexname.html");
    open(INDEXSHTML, ">$top/$dir/$indexname.short.html") || 
	die("cannot create $indexname.short.html");
    open(INDEX, ">$top/$dir/$indexname") || die("cannot create $top/$dir/$indexname");
    $SIG{INT} = 'IGNORE';

    print INDEX "$dir/!INDEX generated by keeper $version; do not edit by hand!\n";

    print INDEX $descs{'!!header!!'} if $descs{'!!header!!'};
    print INDEX "------------------------------------------------------------------------------\n";
    
    &writehtmlheader(INDEXHTML, "$top/$dir");
    &writehtmlheader(INDEXSHTML, "$top/$dir");

    # Long-format header
    print INDEXHTML "What you'll find here: <STRONG>$pdesc</STRONG><P>\n" if $pdesc; 
    print INDEXHTML &hdrformat($descs{'!!header!!'}) if $descs{'!!header!!'};
    print INDEXHTML "You can also view this index in <A HREF=!INDEX.short.html>terse format</A>, or return to the <A HREF=\"../!INDEX.html\">parent directory</A>.<P>";
    print INDEXHTML "<HR>\n";
    print INDEXHTML "<DL>\n";

    # Short-format header
    print INDEXSHTML "<PRE>\n";
    &htmldir(INDEXSHTML, "s", "..", $dir, "Parent directory");
    printf(INDEXSHTML "<A HREF=\"!INDEX.html\">%-28s Long index format\n",
	   "!INDEX.html</A>");

    # Are there any non-document files in the group
    my($do_inline) = scalar(grep(!&ignore($dir, $_) && !&inlineable($_), @files));

    foreach $n (@files) {
	unless (($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,
		 $ctime,$blksize,$blocks) = stat("$top/$dir/$n")) { 
	    print "Repairindex failed to stat $top/$dir/$n\n";
	    next;
	}

	next if ($n eq 'lost+found');
	if (!&docfilename($n)) {
	    if ( -l "$top/$dir/$n") {
		$indexname = "$n@";
	    } elsif ( -d "$top/$dir/$n") {
		$indexname = "$n/";
	    } else {
		$indexname = "$n";
	    }

	    printf(INDEX "%-24s %s\n", $indexname, $descs{$n});
	} else {
	    $indexname = "$n";
	}

	if ( -d "$top/$dir/$n" ) {
	    &htmldir(INDEXHTML, "l", $dir, $n, $descs{$n});
	    &htmldir(INDEXSHTML, "s", $dir, $n, $descs{$n});
	} elsif (($n =~ /^!INDEX/ ) || ($n =~ /^README$/)) {
	    next;
	} elsif ($do_inline && &inlineable($n)) {
	    next;
	} else {
	    # This code uses a tables hack to format the package name
	    # line.  This should degrade gracefully on browsers that
	    # don't grok tables -- all the fields will just collapse to the
	    # left and become whitespace-separated.  The percentages are
	    # figured to make everything fit even on a browser with an
	    # 80-char-wide text window (they depend on the date part being
	    # 8 characters or less long).
	    print INDEXHTML "<DT><TABLE WIDTH=\"100%\" CELLPADDING=0><TR><TD WIDTH=\"40%\"><A HREF=\"$n\">$indexname</A><TD WIDTH=\"30%\">";

	    if ($do_inline) {
		foreach $f (&closest_of_type($dir, $n, 'lsm$')) {
		    print INDEXHTML " (<A HREF=\"$f\">LSM entry</A>)";
		}

		foreach $f (&closest_of_type($dir, $n, 'README$')) {
		    print INDEXHTML " (<A HREF=\"$f\">README</A>)";
		}
	    }

	    print INDEXHTML '<TD WIDTH="10%" ALIGN=RIGHT> ', &short_date($mtime), "</TR></TABLE>\n";

	    if ($descs{$n}) {
		print INDEXHTML "<DD>$descs{$n} ($size bytes)\n";
	    }
	    printf(INDEXSHTML "<A HREF=\"$n\">%-28s %s\n",
		   "$indexname</A>", $descs{$n});
	}
    }

    $updated  = "<ADDRESS>Last updated by <A HREF=\"$homelink\">$homeaddr</A> using keeper $version on " . &dump_date(time) . "</ADDRESS>\n";

    print INDEXHTML "</DL>\n";
    print INDEXHTML "<HR>\n";
    print INDEXHTML $updated;
    print INDEXSHTML "</PRE>\n";
    print INDEXSHTML "<HR>\n";
    print INDEXSHTML $updated;
    close INDEXHTML;
    close INDEX;
    close INDEXSHTML;

    # Now the README file.  Allow this to fail if README is not writeable
    if (($pdesc||$descs{'!!header!!'}) && open(README, ">$top/$dir/README")) {
	print README "README for $dir\n\n"; 
	print README "What you'll find here: $pdesc\n\n" if $pdesc; 
	print README $descs{'!!header!!'} if $descs{'!!header!!'};
	close(README);
    } elsif (-w "$top/$dir/README") {
	unlink("$top/$dir/README");
    }

    &reenable_interrupts;
}

# keeper ends here
