#!/usr/bin/perl

#
# Allow faculty to create/delete e-mail lists using Mailman (www.list.org)
#

$| = 1;

use strict;

use CGI;
use CGI::Carp qw(fatalsToBrowser);
use English;
use File::MkTemp;
use IO::Dir;
use Fcntl ':flock';

my $www = new CGI;

# Definitions
my $MAILMAN_UID = 103;			  # must use numeric id!
my $MAILMAN_GID = 102;			  # must use numeric id!
my $MAILMAN_USER = 'mailman';		  # username for mailman user
my $SYSTEM_USER_CUTOFF=500;		  # sanity checks for a UID
my $SYSTEM_USER_CUTOFF_HIGH=1999;	  # sanity checks for a UID
   # URL to this script					  
my $URL = "https://otc.isu.edu/cgi-bin-ssl/classmail/classmail";
my $MAILMAN_PATH = "/var/spool/mailman";  # path to mailman
   # Python path setup for mailman
my $PYTHON_PATH = "$MAILMAN_PATH/Mailman:$MAILMAN_PATH/scripts";
my $MIN_LIST_NAME_LENGTH = 4;	          # minimum length for list
my $MAX_LIST_NAME_LENGTH = 20;	          # maximum length for list
my $GOOD_LIST_CHARS = "a-z0-9\\-";	  # pattern for a valid list name characters
my $GOOD_PASS_CHARS = $GOOD_LIST_CHARS;	  # pattern for a valid password
my $MIN_PASSWORD_LENGTH = 5;		  # minimum length for password
my $MAX_PASSWORD_LENGTH = 8;		  # maximum length for password
my $TEMP_DIR = "/tmp";			  # temporary files go here
my $TRAILING_EMAIL = "\@otc.isu.edu";	  # trailing email for list maintainers
my $SENDMAIL_ALIASES = "/etc/aliases";	  # system-wide alias file
my $SENDMAIL_ALIAS_COMMAND = "/usr/bin/newaliases"; # system 'newaliases' command
my $MAILMAN_URL = "https://otc.isu.edu/mailman"; # URL to mailman system
my $GET_OWNER = "/usr/local/www/cgi-bin-ssl/classmail/get_owner.py";

# Environment
$ENV{'PATH'} = "/bin:/usr/bin";		  # explicit path

# Slow down any guesses..
#sleep (3);

# Untaint remote user
my $user = $ENV{'REMOTE_USER'};
$user =~ /^([A-Za-z0-9]+)$/;
$user = $1;

# Get and verify CGI Data
my %config;
die "Unable to continue :$config{'error'}\n"
   unless (get_configuration($user, \%config));
if (($config{'pwent'}->[2] < $SYSTEM_USER_CUTOFF) ||
    ($config{'pwent'}->[2] > $SYSTEM_USER_CUTOFF_HIGH))
{
   die "Only real users allowed to use classmail."
}

print $www->header;
print $www->start_html(-title => "OTC Class E-Mail Lists",
		       -author => 'Craig Kelley',
 		       -base => 'true',
	 	       -target => undef,
		       -meta => undef,
		       -style => undef,
		       -BGCOLOR => 'white'
		      );

#
# you know the drill; here is the main switch for the 
# differing schizophrenic personalities of this program
#

if ($www->param('AddList')) {
   
   html_create_new_list();

}
elsif ($www->param('VerifyList')) {

   print "<h3>Step Two:  Verify and Configure List</h3>\n";

   print $www->start_form(-method => 'post',
			  -action => $URL);   

   my @current_lists = get_lists();
   my $name = $www->param('ListName');
   my $password = $www->param('NewPassword');

   if (verify_list_name($name, $password, \@current_lists)) {
      
      # keep state
      print $www->hidden(-name  => 'ListName',
			 -value => $name
			);
      print $www->hidden(-name  => 'NewPassword',
			 -value => $password
			);

      html_verify_list($www, \@current_lists);
      print $www->submit(-name  => 'AddListVerified',
			 -value => 'Create List Now'
			);
   }
   print $www->end_form();
}

elsif ($www->param('AddListVerified')) {

   print "<h3>Step Three:  Adding List and Notifying Maintainer</h3>\n";

   print $www->start_form(-method => 'post',
			  -action => $URL);   

   my @current_lists = get_lists();
   my $name = $www->param('ListName');
   my $password = $www->param('NewPassword');

   if (verify_list_name($name, $password, \@current_lists)) {

      # keep state
      print $www->hidden(-name  => 'ListName',
			 -value => $name
			);
      print $www->hidden(-name  => 'NewPassword',
			 -value => $password
			);
      # More work to do?

      if ($www->param('VerifyList')) {

	 html_verify_list($www, \@current_lists);

      }
      else {

	 # keep state
	 print $www->hidden(-name  => 'CreationMethod',
			    -value => $www->param('CreationMethod')
			   );
	 print $www->hidden(-name  => 'sourceList',
			    -value => $www->param('sourceList')
			   )
	    if (defined $www->param('sourceList'));
		
	 # make sure a valid list is selected, if we're using one
	 if (($www->param('CreationMethod') eq 'fromList') &&
	     (!defined $www->param('AddListNowVerified')))
	 {
	    
	    print $www->hidden(-name  => 'AddListVerified',
			       -value => '1'
			      );
	    html_verify_list_again($www);
	    
	 }
	 else {

	    # looks good, create the list now

	    create_mailman_list($www, $name, $password, \%config);
	 }
      }
   }
   print $www->end_form;
}
elsif ($www->param('DeleteList') && (!defined $www->param('MainMenu'))) {

   print $www->start_form(-method => 'post',
			  -action => $URL);   

   my $list_name = $www->param('DeleteList');
   unless ($list_name =~ /^([$GOOD_LIST_CHARS]+)$/) {
      die "Illegal list name given ($list_name)\n";
   }
   $list_name = $1;
   my %all_lists;
   get_owners(\%all_lists, get_lists());

   my $email = "$user$TRAILING_EMAIL";
   
   unless (grep /^$list_name$/, @{$all_lists{$email}}) {
      die "You either do not own the list named '$list_name' or it does not exist.\n";
   }
   if ($www->param('DeleteListVerify')) {
      
      if (erase_list($list_name)) {
	 $UID = $EUID;
	 $GID = $EGID;
	 my $newalias = `$SENDMAIL_ALIAS_COMMAND`;
	 die "$SENDMAIL_ALIAS_COMMAND appears to have failed : $newalias\n"
	    unless ($newalias =~ /bytes\s+total/);
	 print "<h2>$list_name has been erased.</h2><p>\n";
	 print $www->submit(-name  => 'MainMenu',
			    -value => 'Okay');
      }

   }
   else {
      print $www->hidden(-name  => 'DeleteList',
			 -value => $list_name);
      print "<h2>Are you certain you want to erase the list named '$list_name'?</h2><p>\n";
      print "Once this action is taken, all the e-mail addresses in this list will be\n";
      print "gone.  You may wish to 'clone' this list into a new list before erasing\n";
      print "it (if you plan on using this group of addresses in the future, eg. if\n";
      print "theraputics-1 is moving on to theraputics-2, it's best to create the\n";
      print "theraputics-2 list <em>first</em> and then erase the theraputics-1 list)<p>\n";
      print $www->submit(-name  => 'DeleteListVerify',
			 -value => 'Yes');
      print $www->submit(-name  => 'MainMenu',
			 -value => 'No');
   }
      
   print $www->end_form;
}

else {
   # Default Page
   print "<H2>" . $config{'pwent'}->[6] . "'s Class E-Mail Lists</H2><p>\n";
   print $www->start_form(-method => 'post',
			  -action => $URL);

   # Get e-mail lists owned by this person
   my %all_lists;
   get_owners(\%all_lists, get_lists());

   my $email = "$user$TRAILING_EMAIL";
   if ($all_lists{$email}) {
      print "Current E-Mail Lists: <p>\n";
      print "<UL>\n";
      my $list;
      foreach $list (@{$all_lists{$email}}) {
	 print "<LI><a href=\"$URL?DeleteList=$list\">[Delete]</a>$list\n";
      }
      print "</UL><p>\n";
   }
   else {
      print "<i>You have no class E-Mail lists setup right now</i><p>\n";
   }
   print $www->submit(-name => 'AddList',
		      -value => 'Add A New E-Mail List');
   print $www->submit(-name => 'ListLists',
		      -value => 'Show My E-Mail Lists');
   print "<p>\n";
   print "Please either click on a list to delete if (if you have any), or click\n";
   print "on the 'Add A New E-Mail List' button to create a new one.\n";
   print $www->end_form;
}

print $www->end_html();
exit (0);

# end of program here

#
# subroutines follow
#

#
# get_configuration: lookup user, verify rights, etc.
#

sub get_configuration {

   my ($user, $rhash) = @_;

   @{$rhash->{'pwent'}} = getpwnam($user);

   # Verify User

   unless (ref $rhash->{'pwent'} eq "ARRAY") {
      $rhash->{'error'} = "getpwnam() failed for $user";
      return undef;
   }

   # Verify Group

   if ($rhash->{'pwent'}->[3] == 111) {
      $rhash->{'error'} = "student users not allowed";
      return undef;
   }

   return 1;
}

#
# Get a list of all current mailing lists..  dunno if there are security
# problems with this (there probably are, but I'll wait until someone
# complains before trying to "fix" it).
#

sub get_lists {

   my $dir = new IO::Dir "$MAILMAN_PATH/lists";
   my (@results, $dirent);

   if (defined $dir) {
      while (defined($dirent = $dir->read)) {
	 next if ($dirent =~ /^\./);
	 if ($dirent =~ /^([$GOOD_LIST_CHARS]+)$/) {
	    $dirent = $1;
	    push (@results, $dirent);

	 }
      }
   }
   else {
      die "Unable to read lists: $MAILMAN_PATH/lists : $!";
   }

   return sort(@results);

}

#
# Return an array of all members within a mailing list
#

sub get_members {

   my $source_list = shift;

   # untaint source list
   $source_list =~ /([$GOOD_LIST_CHARS]+)/;
   $source_list = $1;

   # construct call to python mailman program 
   my $command = "$MAILMAN_PATH/bin/list_members $source_list";
   my @email_addresses = `$command`;

   return @email_addresses;

}

#
# html for choosing the type of list 
#

sub html_verify_list {

   my $www = shift;
   my $rcurrent_lists = shift;

   print "How would you like this list to be created?<p>\n";
   print "<TABLE border=0><TR><TD>\n";
   print $www->radio_group(-name      => 'CreationMethod',
			   -values    => ['blank', 'fromList'],
			   -default   => 'blank',
			   -linebreak => 'true',
			   -labels    => { 
					  'blank'    => 'Blank, without any addresses',
					  'fromList' => 'Use addresses from selected list:'
					 }
			  ); 
   print "</TD><TD>\n";
   print $www->scrolling_list(-name     => 'sourceList',
			      -values   => $rcurrent_lists,
			      -size     => 5,
			      -multiple => undef
			     );
   print "</TD></TR></TABLE>\n";
   
}

#
# html for verifying a list that is selected
#

sub html_verify_list_again {

   my $www = shift;

   my $source_list = $www->param('sourceList');
   my $members = scalar(get_members($source_list));

   if ($members > 1) {
      print "You are about to create a new mailing list based on this list:<p>\n";
      print "<H3>$source_list</H3><p>\n";
      print "This list currently has<p>\n";
      print "<H3>$members members,</H3><p>\n";
      print "all of whom will recieve a welcome message to <em>your</em> new\n";
      print "new list.  Are you certain that you want to do this?<p>\n";
      print $www->submit(-name  => 'AddListNowVerified',
			 -value => 'Yes'
			);
      print $www->submit(-name  => 'DefaultPage',
			 -value => 'No'
			);
   }
   else {
      print "Sorry, but the list named <em>$source_list</em>\n";
      print "does not have any members.<p>\n";
      print $www->submit(-name  => 'DefaultPage',
			 -value => 'Start Over'
			);
   }
}

#
# html for the first step in creating a new list
#

sub html_create_new_list {

   print "<h3>Step One:  Name Your List</h3>\n";
   print $www->start_form(-method => 'post',
			  -action => $URL);
   
   print <<EOP;
      In order to create a new list, all I need to know is the name of the
      class that you prefer.  Some examples are 'ppra299', 'psci-401', and
      'pharmacology2'.  The email list cannot have any character other
      than the <i>lowercase</i> letters (a-z), numbers (0-9) and/or a dash (-).  Plus, 
      it cannot conflict with already existing email list names, but don't worry
      about that because I'll double-check for you.<p>
      What E-Mail list would you like to create?<p>
EOP
   print $www->textfield(-name => 'ListName',
			 -default => undef,
			 -size => $MAX_LIST_NAME_LENGTH,
			 -maxlength => $MAX_LIST_NAME_LENGTH) . "<P>\n";
   print "Enter a password you would like to use to maintain your list:<BR>\n";
   print "<em>(Five characters minimum)</em><BR>\n";
   print $www->textfield(-name => 'NewPassword',
			 -default => undef,
			 -size => $MAX_PASSWORD_LENGTH,
			 -maxlength => $MAX_PASSWORD_LENGTH) . "<p>\n";
   print $www->submit(-name => 'VerifyList',
		      -value => 'Add This List');
   print $www->end_form;
   print $www->end_html;
}

#
# Verify list name (You are not for to trusting HTTP input!)
#

sub verify_list_name {

   my ($name, $password, $rcurrent_lists) = @_;
   my $checks_out = 1;

   # list name verification
   if ($name =~ /([^$GOOD_LIST_CHARS])/) {
      print "<b>Problem</b>: I found an illegal character '$1' in the list name.<BR>\n";
      undef $checks_out;
   }
   if (length($name) < $MIN_LIST_NAME_LENGTH) {
      print "<b>Problem</b>: A list name must be at least $MIN_LIST_NAME_LENGTH characters long.<BR>\n";
      undef $checks_out;
   }
   if (length($name) > $MAX_LIST_NAME_LENGTH) {
      print "<b>Problem</b>: A list name must be less than $MAX_LIST_NAME_LENGTH characters long.<BR>\n";
      undef $checks_out;
   }
   if (grep /^$name$/, @$rcurrent_lists) {
      print "<b>Problem</b>: The list named '$name' already exists.<BR>\n";
      undef $checks_out;
   }
   
   # password verification
   if ($password =~ /([^$GOOD_PASS_CHARS])/) {
      print "<b>Problem</b>: I found illegal character '$1' in your password<BR>\n";
      undef $checks_out;
   }
   if (length($password) < $MIN_PASSWORD_LENGTH) {
      print "<b>Problem</b>: A password must be at least $MIN_PASSWORD_LENGTH characters long.<BR>\n";
      undef $checks_out;
   }
   if (length($password) > $MAX_PASSWORD_LENGTH) {
      print "<b>Problem</b>: A password must be no more than $MAX_PASSWORD_LENGTH characters long.<BR>\n";
      undef $checks_out;
   }
   
   unless (defined $checks_out) {
      print "<p>I'm sorry, but you'll need to fix the above problem(s) before continuing.<p>\n";
      print $www->submit(-name => 'AddList',
			 -value => 'Try Again');
   }

   # verification done

   return $checks_out;

}

#
# create mailman list -- do the real work here
#

sub create_mailman_list {

   my ($www, $list_name, $password, $config) = @_;

   # untaint important variables
   my $prototype = $www->param('sourceList');
   if (length($prototype) > 1) {
      $prototype =~ /([$GOOD_LIST_CHARS]+)/;
      $prototype = $1 || undef;
   }
   $list_name =~ /([$GOOD_LIST_CHARS]+)/;
   $list_name = $1;
   $password =~  /([$GOOD_PASS_CHARS]+)/;
   $password = $1;

   # verify new list name isn't bad..
   return
      unless (defined verify_list_name($list_name, $password));
   
   # Take care of possible prototype list
   my $filename = undef;
   print "Creating new list <st>$list_name</st>.<br>\n";
   if (defined ($prototype) ) {
      print "Compiling a list of members already in <st>$prototype</st>.<BR>\n";
      my @members = get_members($prototype);
      if (scalar(@members) > 1) {
	 my $tempfh;
	 ($tempfh, $filename) = mkstempt('classmail.XXXXXX', $TEMP_DIR);
	 die "Unable to create temporary file $filename ($!)\n"
	    unless (defined $tempfh);
	 print $tempfh @members;
	 $tempfh->close;
      }
   }
   
   # Create the new mailing list inside mailman; don't need to 
   # worry about quoting stuff because legal characters are
   # already enforced.

   my @command;
   push @command, (
		   "$MAILMAN_PATH/bin/newlist",
		   $list_name,
		   $config->{'pwent'}->[0] . $TRAILING_EMAIL,
		   $password,
		   "1"		  # force non-interactive
		  );
   
   print "Sending command to Mailman.<br>\n";

   # save output from command to add to alias list
   my @result_set = do_command (@command);
   
   if (grep /FAILED/, @result_set) {
      print "<H2>Error:</H2> " . join ("", @result_set);
      return;
   }
   else {
      # Get rid of garbage from result set
      while ($result_set[0] =~ /^[^\#]/) {
	 shift @result_set;
      }
   }
   unless (@result_set > 4) {
      print "<H2>Error:</H2> result set not large enough.  Command somehow failed.";
      print "Result Set:<br><pre>" . join ("", @result_set) . "</pre>\n";
      return;
   }

   print "Adding system alias for new list.<br>\n";
   add_alias (@result_set[0 .. 6]);
   $UID = $EUID;
   $GID = $EGID;
   my $newalias = `$SENDMAIL_ALIAS_COMMAND`;
   die "$SENDMAIL_ALIAS_COMMAND appears to have failed : $newalias\n"
      unless ($newalias =~ /bytes\s+total/);

   print_new_list_instructions($list_name, $password);

   if (defined $filename) {
      print "Migrating users from prototype list.<BR>\n";
      @command = ("$MAILMAN_PATH/bin/add_members", 
		  "-n", "$TEMP_DIR/$filename",
		  "-w", "y",
		  $list_name
		 );
      print "<h2>" . join (" ", @command) . "</h2><p>\n";
      @result_set = do_command (@command);
   
      if (grep /FAILED/, @result_set) {
	 print "<H2>Error:</H2> " . join ("", @result_set);
	 return;
      }

      unlink "$TEMP_DIR/$filename";	  # get rid of temporary file
   }

   return;

}

#
# Fork, become mailman user, run command, return results from a pipe
#
# boring stuff, really...
#

sub do_command {

   my @command = @_;

   # fork worker

   my $pid;
   $pid = open(KID, "-|");
   die "Can't fork: $!" 
      unless defined $pid;
   my @output;
   if ($pid) {					  # parent
      while (<KID>) {
	 push (@output, $_);
      }
   }
   else {					  # kid
      my @temp = ($MAILMAN_UID, $MAILMAN_GID);
      $GID = $MAILMAN_GID;
      $EGID = $MAILMAN_GID;
      $UID = $MAILMAN_UID;
      $EUID = $MAILMAN_UID;
      # Make sure privs are really gone
      ($EUID, $EGID) = @temp;
      my @groups = split(/\s/, $EGID);
      die "Still have root privs ([$UID] [$EUID] [$GID] [$EGID])" 
	 if (
	     ($EUID == 0) ||
	     (grep (/^0$/, @groups)) ||
	     (grep (/root/, @groups))
	    );
      $ENV{PATH} = "/bin:/usr/bin:$MAILMAN_PATH/bin";
      my $rc = 0xffff & system @command;
      my $errstr;
      if ($rc != 0) {
	 if ($rc == 0xff00) {
	    print "<h2>COMMAND FAILED</h2> $!\n";
	    while ($errstr = <STDERR>) {
	       print $errstr;
	    }
	 }
	 elsif ( $rc > 0x80) {
	    $rc >>= 8;
	    print "<h2>COMMAND FAILED</h2> (returned non-zero exit status \"$rc\")\n";
	    while ($errstr = <STDERR>) {
	       print $errstr;
	    }
	 }
	 else {
	    print "<h2>COMMAND FAILED</h2> ran with ";
	    if ($rc & 0x80) {
	       $rc &= ~0x80;
	       print "coredump from ";
	    }
	    print "signal $rc\n";
	    while ($errstr = <STDERR>) {
	       print $errstr;
	    }
	 }	    
	 exit(1);
      }
      exit (0);
   }

   return @output;
}

#
# Add an alias to the sendmail alias file
#
# Note:  There must be a section in the file with this exact wording:
#
#      # BEGIN CLASSMAIL
#
#      # END CLASSMAIL
#
# (where the pound (#) is in the first column
#

sub add_alias {

   my @lines = @_;

   # Get the aliases file ready for manipulation
   open ALIASES, "+>>$SENDMAIL_ALIASES"
      or die "Unable to open append on $SENDMAIL_ALIASES: $!\n";
   flock ALIASES, LOCK_EX;			  # exlusive lock
   seek ALIASES, 0, 0;				  # rewind
   my @aliases = <ALIASES>;

   my $i;
   for ($i=0; $i<=$#aliases; $i++) {
      next unless ($aliases[$i] =~ /^\s*\#\s+BEGIN\s+CLASSMAIL.*/);
      last;
   }
   if ($i == $#aliases) {
      flock ALIASES, LOCK_UN;
      close ALIASES;
      die "Cannot find token #[\\t ]+BEGIN CLASSMAIL in sendmail alias file.\n";
   }
   splice (@aliases, $i+1, 0, @lines);
   seek ALIASES, 0, 0;
   truncate ALIASES, 0;
   print ALIASES join "", @aliases;
   flock ALIASES, LOCK_UN;
   close ALIASES;   

}

#
# Remove an alias to the sendmail alias file
#
# Note:  There must be a section in the file with this exact wording:
#
#      # BEGIN CLASSMAIL
#
#      # END CLASSMAIL
#
# (where the pound (#) is in the first column);
#
# Return Value:  undef = success otherwise an error message is returned
#

sub rm_alias {

   my $list_name = shift;

   # Get the aliases file ready for manipulation
   open ALIASES, "+>>$SENDMAIL_ALIASES"
      or return "Unable to open append on $SENDMAIL_ALIASES: $!\n";
   flock ALIASES, LOCK_EX;			  # exlusive lock
   seek ALIASES, 0, 0;				  # rewind
   my @aliases = <ALIASES>;

   my ($i, $j);
   # find Classmail's section of /etc/aliases
   for ($i=0; $i<=$#aliases; $i++) {
      next unless ($aliases[$i] =~ /^\s*\#\s+BEGIN\s+CLASSMAIL.*/);
      last;
   }
   # at end of file?
   if ($i == $#aliases) {
      flock ALIASES, LOCK_UN;
      close ALIASES;
      return "Cannot find token #[\\t ]+BEGIN CLASSMAIL in sendmail alias file.\n";
   }
   # look for end of Classmail's section or the list we're looking for
   for ($j=$i+1; $j<=$#aliases; $j++) {
      if ($aliases[$j] =~ /^\s*\#\s+END\s+CLASSMAIL.*/) {
	 return "Unable to find the list named '$list_name' in $SENDMAIL_ALIASES\n";
      }
      last
	 if ($aliases[$j] =~ /^\#\#\s$list_name.*/);
	 
   }
   # at end of file?
   if ($j == $#aliases) {
      flock ALIASES, LOCK_UN;
      close ALIASES;
      return "Cannot find token #[\\t ]+END CLASSMAIL in sendmail alias file.\n";
   }

   # now $j is the first line of our alias; remove all comments from here on until
   # we get to a non-commentted line; remove all lines until we get to another 
   # comment
   my $erased_lines = 0;
   for ($i=$j; $i<=$#aliases; $i++) {
      last unless ($aliases[$i] =~ /^\#\#.*/);
      $erased_lines++;
      print STDERR "RM - $aliases[$i]";
   }
   for ($i=($j + $erased_lines); $i<=$#aliases; $i++) {
      last if ($aliases[$i] =~ /^\#\#.*/);
      $erased_lines++;
      print STDERR "rm - $aliases[$i]";
   }

   # remove this alias
   splice (@aliases, $j, $erased_lines, ());

   # truncate and re-write the file
   seek ALIASES, 0, 0;
   truncate ALIASES, 0;
   print ALIASES join "", @aliases;
   flock ALIASES, LOCK_UN;
   close ALIASES;   

   return undef;
}

#
# get_owners : get the owner(s) of a mailing list
#
# get_owners(\%response, 'listname', 'listname', ...);
#
# %response will look like this:
#
#  ( 'email@address' => ['list1', 'list2'],
#    'foo@domain.com' => ['list3'],
#   etc..
#

sub get_owners {

   my $rhash = shift;
   my @list_names = @_;

   $ENV{'PYTHONPATH'} = $PYTHON_PATH;

   return unless (scalar @list_names);

   my $args = join (" ", @list_names);
   open FH, "$GET_OWNER $args |"
      or die "Unable to open pipe: $GET_OWNER $args | ($!)\n";
   my ($line, $list_name, $owners, @owners, $owner);
   while ($line = <FH>) {
      chop $line;
      if ($line =~ /^(\S+)\s+\[(.*)\]$/) {
	 $list_name = $1;
	 $owners = $2;
	 $owners =~ s/\'//g;
	 @owners = split (/,\s*/, $owners);
	 foreach $owner (@owners) {
	    push (@{$rhash->{$owner}}, $list_name);
	 }
      }
   }
   close FH;
}

#
# erase_list (list_name)
#
# nuke a mailing list
#

sub erase_list {

   my $list_name = shift;

   print "Erasing Mailman list.<BR>\n";
   my @command = ("$MAILMAN_PATH/bin/rmlist", "-a", $list_name);
   my @result_set = do_command (@command);
   
   if (grep /FAILED/, @result_set) {
      print "<H2>Error:</H2> " . join ("", @result_set);
      return;
   }

   print "Disassociating System Alias.<BR>\n";
   my $error = rm_alias($list_name);
   if ($error) {
      print "<H2>Error: $error</H2>\n";
      return;
   }

   return 1;

}

# simple procedure to print out instructions for the new list (*sniff*, it was just
# a wee HTML form not so long ago, and look at it now)

sub print_new_list_instructions {

   my ($listname, $password) = @_;

   print "<p><H3>Congratulations!  Your new list is ready.</H3><p>\n";
   print <<EOP

      You will want to note (or print) the following information:<p>
      <UL>
      <LI>Mailing list administration web page:<p>
          <a href="$MAILMAN_URL/admin/$listname">
           $MAILMAN_URL/admin/$listname
          </a><p>
      <LI>Your list password:<p>
          <st>$password</st><p>
      <LI>The web page that allows people to join the list:<p>
	  <a href="$MAILMAN_URL/listinfo/$listname">
           $MAILMAN_URL/listinfo/$listname
          </a><p>
      <LI>The web page that allows you to erase this list when it is no longer needed:<p>
          <a href="$URL">
           $URL
          </a>
      </UL><p>
      You should also recieve a confirmation via e-mail right away.

      </BODY></HTML>
EOP

}