#!/usr/bin/perl
	eval "exec perl -S $0 $*"
		if $running_under_some_shell;

# $Id: maillist.SH,v 3.0.1.5 1995/08/07 16:12:48 ram Exp $
#
#  Copyright (c) 1990-1993, Raphael Manfredi
#  
#  You may redistribute only under the terms of the Artistic License,
#  as specified in the README file that comes with the distribution.
#  You may reuse parts of this distribution only within the terms of
#  that same Artistic License; a copy of which may be found at the root
#  of the source tree for mailagent 3.0.
#
# $Log: maillist.SH,v $
# Revision 3.0.1.5  1995/08/07  16:12:48  ram
# patch37: forgot to define phostname, needed for NFS-secure locks
#
# Revision 3.0.1.4  1995/03/21  12:55:09  ram
# patch35: added pl/cdir.pl to the list of appended files
#
# Revision 3.0.1.3  1995/02/16  14:27:01  ram
# patch32: forgot to include pl/hostname.pl for NFS-secure locks
#
# Revision 3.0.1.2  1994/10/10  10:22:54  ram
# patch19: added various escapes in strings for perl5 support
#
# Revision 3.0.1.1  1994/10/04  17:36:37  ram
# patch17: extended logging to get better error/failure tracking
#
# Revision 3.0  1993/11/29  13:48:24  ram
# Baseline for mailagent 3.0 netwide release.
#

$mversion = '3.0';
$patchlevel = '44';
$phostname = 'hostname';

$prog_name = $0;				# Who I am
$prog_name =~ s|^.*/(.*)|$1|;	# Keep only base name

&read_config;		# First, read configuration file (in ~/.mailagent)

# take job number and command from environment
# (passed by mailagent)
$jobnum = $ENV{'jobnum'};
$fullcmd = $ENV{'fullcmd'};

$dest=shift;							# Who should the list to be sent to
$dest = $ENV{'path'} if $dest eq '';	# If dest was ommitted

# A single '-' as first argument stands for return path
$dest = $ENV{'path'} if $dest eq '-';

&read_dist;			# Read distributions and descriptions

open(INFO, "$cf'proglist") ||
	&fatal("cannot open description file");
@sysinfo = <INFO>;
close INFO;

&read_plsave;		# Read patchlevel description file
		
$tmp_mail = "$cf'tmpdir/xml$$";

open(XHEAD, ">$tmp_mail") || &fatal("cannot create $tmp_mail");
print XHEAD
"To: $dest
Subject: List of available distributions
X-Mailer: mailagent [version $mversion PL$patchlevel]

Here are the different packages available. If you want the whole
distribution, send me the following:

	\@SH maildist $dest system version

If you want patches, use:

	\@SH mailpatch $dest system version LIST

where LIST is a list of patches number, separated by spaces, commas,
and/or hyphens. Saying 23- means everything from 23 to the end.

Detailed instructions can be obtained by:

	\@SH mailhelp $dest


";

foreach $pname (keys %Program) {
	($system, $version) = $pname =~ /^(\w+)\|([\w\.]+)*$/;
	$version = '---' if $version eq '0';
	$location = $Location{$pname};
	&add_log("dealing with $system $version") if $loglvl > 19;

	# Look for highest patchlevel (even if not maintained)
	$tmp = "";			# Temporary directory created

	if ($Archived{$pname}) {
		unless ($PSystem{$pname}) {
			# Archive not already listed in 'plsave'. Create a new
			# entry with a modification time of zero.
			$PSystem{$pname} = 1;
			$Patch_level{$pname} = -1;	# Not a valid patch level
			$Mtime{$pname} = 0;			# Force unpacking of archive
		}

		# We need to unarchive the directory only if archive
		# modification time is newer than the one in patchlist
		local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime, $mtime,
			$ctime,$blksize,$blocks) = stat(&expand($location));

		if ($mtime != $Mtime{$pname}) {	 # Archive was updated
			$Mtime{$pname} = $mtime;	 # Update mod time in 'plsave'
			# Create a temporary directory
			$tmp = "$cf'tmpdir/dml$$";
			mkdir($tmp, 0700) ||
				&fatal("cannot create $tmp");
			# Need to unarchive the distribution
			$location = &unpack($location, $tmp, $Compressed{$pname});
			$Patch_level{$pname} = -1;	# Force updating
		} else {
			&add_log("no changes in $system $version archive")
				if $loglvl > 15;
		}

	} else {
		# System is not archived
		$Patch_level{$pname} = -1;		# Force computation
	}

	if ($Patch_level{$pname} == -1) {
		# We still don't know wether there is a patchlevel or not...
		# Go to system directory, and look there.
		if (!chdir("$location")) {
			&add_log("ERROR cannot go to $location") if $loglvl;
			next;
		}
		if ($Patch_only{$pname}) {		# Only patches available
			if ($version eq '') {
				&add_log("ERROR old system $system has no version number")
					if $loglvl;
				next;
			}
			if (!chdir("bugs-$version")) {
				&add_log("ERROR no bugs-$version dir for $system")
					if $loglvl;
				next;
			}
			local($maxnum);
			# There is no patchlevel to look at -- compute by hand.
			for ($maxnum = 1; ; $maxnum++) {
				last unless -f "patch$maxnum" || -f "patch$maxnum.Z";
			}
			$maxnum--;		# We've gone too far
			$Patch_level{$pname} = $maxnum;
		} elsif (! -f 'patchlevel.h') {
			&add_log("no patchlevel.h for $system $version") if $loglvl > 17;
		} elsif (!open(PATCHLEVEL, "patchlevel.h")) {
			&add_log("cannot open patchlevel.h for $system $version")
				if $loglvl > 5;
		} else {
			while (<PATCHLEVEL>) {
				if (/.*PATCHLEVEL[ \t]*(\w+)/) {	# May have letters
					$Patch_level{$pname} = $1;
					last;
				}
			}
			close PATCHLEVEL;
			if ($Patch_level{$pname} == -1) {
				&add_log("malformed patchlevel.h for $system $version")
					if $loglvl > 5;
			}
		}
	}

	if ($Patch_level{$pname} >= 0) {
		&add_log("patchlevel is #$Patch_level{$pname} for $system $version")
			if $loglvl > 18;
	} else {
		$Patch_level{$pname} = -2;		# Signals: no patchlevel
		&add_log("no patchlevel for $system $version") if $loglvl > 18;
	}
	
	&clean_dir;			 # Remove tmp directory, if necessary

	# Now look for a description of the package...
	$describe = "";
	$found = 0;
	foreach (@sysinfo) {
		next if /^\s*#/;	# Skip comments
		next if /^\s*$/;	# Skip blank lines
		next if /^\*\s+$system/ && ($found = 1);
		last if $found && /^---|^\*/;		# Reached end of description
		$describe .= "X" . $_ if $found;
	}
	$* = 1;
	$describe =~ s/^X/\t/g;		# Indent description
	$* = 0;

	print XHEAD "System: $system";
	print XHEAD " version $version" if $version !~ /---/;
	print XHEAD "\nStatus: ";
	print XHEAD $Maintained{$pname} ? "maintained" : "not maintained";
	print XHEAD " (patches only)" if $Patch_only{$pname};
	print XHEAD " (official patches available)" if $Patches{$pname};
	print XHEAD "\n";
	if ($Maintained{$pname}) {
		if ($Patch_level{$pname} > 0) {
			print XHEAD "Highest patch: #$Patch_level{$pname}\n";
		} else {
			print XHEAD "No patches yet\n";
		}
	} else {
		print XHEAD "Patch level: #$Patch_level{$pname}\n"
			if $Patch_level{$pname} > 0;
	}
	print XHEAD "\n";
	print XHEAD "$describe\n" if $describe ne '';
	print XHEAD "\n";
}
print XHEAD "-- $prog_name speaking for $cf'user\n";
close XHEAD;

open(XHEAD, "$tmp_mail") || &fatal("cannot open mail file");
open(MAILER, "|$cf'sendmail $cf'mailopt $dest") || &nofork;
while (<XHEAD>) {
	print MAILER;
}
close MAILER;
if ($?) {
	&add_log("ERROR couldn't send list to $dest") if $loglvl > 0;
} else {
	&add_log("SENT list to $dest") if $loglvl > 2;
}
close XHEAD;

&write_plsave;			# Write new patchlist file
&clean_tmp;				# Remove temporary dirs/files
exit 0;					# All OK

sub clean_dir {
	chdir $cf'home;		# Leave [to be removed directory] first
	if ($tmp ne '') {
		system '/bin/rm', '-rf', $tmp if -d "$tmp";
		&add_log("directory $tmp removed") if $loglvl > 19;
		$tmp = "";
	}
}

sub clean_tmp {
	&clean_dir;
	unlink "$tmp_mail" if -f "$tmp_mail";
}

# Report error while forking a sendmail process
sub nofork {
	&add_log("SYSERR fork: $!") if $loglvl;
	&add_log("ERROR cannot launch $cf'sendmail") if $loglvl;
}

# In case of fatal error, the program does not simply die
# but also records the failure in the log.
sub fatal {
	local($reason) = @_;			# Why did we get here ?
	&add_log("FAILED ($reason)") if $loglvl > 0;
	die "$prog_name: $reason\n";
}

# Emergency signal was caught
sub emergency {
	local($sig) = @_;			# First argument is signal name
	&fatal("trapped SIG$sig");
}

# Asks for the exclusive access of a file. The config variable 'nfslock'
# determines whether the locking scheme has to be NFS-secure or not.
# The given parameter (let's say F) is the absolute path of the file we want
# to access. The routine checks for the presence of F.lock. If it exists, it
# sleeps 2 seconds and tries again. After 10 trys, it reports failure by
# returning -1. Otherwise, file F.lock is created and the pid of the current
# process is written. It is checked afterwards.
sub acs_rqst {
	local($file, $format) = @_;		# file to be locked, lock format
	local($max) = $cf'lockmax;		# max number of attempts
	local($delay) = $cf'lockdelay;	# seconds to wait between attempts
	local($mask);		# to save old umask
	local($stamp);		# string written in lock file
	&checklock($file, $format);		# avoid long-lasting locks
	if ($cf'nfslock =~ /on/i) {			# NFS-secure lock wanted
		$stamp = "$$" . &hostname;		# use PID and hostname
	} else {
		$stamp = "$$";					# use PID only (may spare a fork)
	}
	local($lockfile) = $file . $lockext;
	$lockfile = &lock'file($file, $format) if defined $format;
	while ($max) {
		$max--;
		if (-f $lockfile) {
			sleep($delay);				# busy: wait
			next;
		}
		# Attempt to create lock
		$mask = umask(0333);			# no write permission
		if (open(FILE, ">$lockfile")) {
			print FILE "$stamp\n";		# write locking stamp
			close FILE;
			umask($mask);				# restore old umask
			# Check lock
			open(FILE, $lockfile);
			chop($_ = <FILE>);			# read contents
			close FILE;
			last if $_ eq $stamp;		# lock is ok
		} else {
			umask($mask);				# restore old umask
			sleep($delay);				# busy: wait
		}
	}
	if ($max) {
		$result = 0;	# ok
	} else {
		$result = -1;	# could not lock
	}
	$result;			# return status
}

package lock;

# Return the name of the lockfile, given the file name to lock and the custom
# string provided by the user. The following macros are substituted:
#	%D: the file dir name
#   %f: the file name (full path)
#   %F: the file base name (last path component)
#   %p: the process's pid
#   %%: a plain % character
sub file {
	local($file, $_) = @_;
	s/%%/\01/g;				# Protect double percent signs
	s/%/\02/g;				# Protect against substitutions adding their own %
	s/\02f/$file/g;			# %f is the full path name
	s/\02D/&dir($file)/ge;	# %D is the dir name
	s/\02F/&base($file)/ge;	# %F is the base name
	s/\02p/$$/g;			# %p is the process's pid
	s/\02/%/g;				# All other % kept as-is
	s/\01/%/g;				# Restore escaped % signs
	$_;
}

# Return file basename (last path component)
sub base {
	local($file) = @_;
	local($base) = $file =~ m|^.*/(.*)|;
	$base;
}

# Return dirname
sub dir {
	local($file) = @_;
	local($dir) = $file =~ m|^(.*)/.*|;
	$dir;
}

package main;

# Remove the lock on a file. Returns 0 if ok, -1 otherwise
# Locking format is optional but when given must match the one used by
# the &acs_rqst() locking routine.
sub free_file {
	local($file, $format) = @_;		# locked file, locking format
	local($stamp);					# string written in lock file

	if ($cf'nfslock =~ /on/i) {			# NFS-secure lock wanted
		$stamp = "$$" . &hostname;		# use PID and hostname
	} else {
		$stamp = "$$";					# use PID only (may spare a fork)
	}

	local($lockfile) = $file . $lockext;
	$lockfile = &lock'file($file, $format) if defined $format;

	if ( -f $lockfile) {
		# if lock exists, check for pid
		open(FILE, $lockfile);
		chop($_ = <FILE>);
		close FILE;
		if ($_ eq $stamp) {
			# pid (plus hostname eventually) is correct
			$result = 0;
			unlink $lockfile;
		} else {
			# pid is not correct (we did not get that lock)
			$result = -1;
		}
	} else {
		# no lock file
		$result = 0;
	}
	$result;	# return status
}

# Add an entry to logfile
# There is no need to lock logfile as print is sandwiched betweeen
# an open and a close (kernel will flush at the end of the file).
sub add_log {
	# Indirection needed, so that we may remap add_log on stderr_log via a
	# type glob assignment.
	&usrlog'write_log($cf'logfile, $_[0], undef);
}

# When mailagent is used interactively, log messages are also printed on
# the standard error.
# NB: this function is not called directly, but via a type glob *add_log.
sub stderr_log {
	print STDERR "$prog_name: $_[0]\n";
	&usrlog'write_log($cf'logfile, $_[0], undef);
}

# Routine used to emit logs when no logging has been configured yet.
# As soon as a valid configuration has been loaded, logs will also be
# duplicated into the logfile. Used solely by &cf'setup.
# NB: this function is not called directly, but via a type glob *add_log.
sub stdout_log {
	print STDOUT "$prog_name: $_[0]\n";
	&usrlog'write_log($cf'logfile, $_[0], undef) if defined $cf'logfile;
}

#
# User-defined log files
#

package usrlog;

# Record a new logfile by storing its pathname in the %Logpath hash table
# indexed by names and the carbon-copy flag in the %Cc table.
sub new {
	local($name, $path, $cc) = @_;
	return if defined $Logpath{$name};	# Logfile already recorded
	return if $name eq 'default';		# Cannot redefined defaul log
	$path = "$cf'logdir/$path" unless $path =~ m|^/|;
	$Logpath{$name} = $path;			# Where logfile should be stored
	$Cc{$name} = $cc ? 1 : 0;			# Should we cc the default logfile?
	$Map{$path} = $name;				# Two-way hash table
}

# Delete user-defined logfile.
sub delete {
	local($name) = @_;
	return unless defined $Logpath{$name};
	local($path) = $Logpath{$name};
	delete $Logpath{$name};
	delete $Cc{$name};
	delete $Map{$path};
}

# User-level logging main entry point
sub main'usr_log {
	local($name, $message) = @_;	# Logfile name and message to be logged
	local($file);
	$file = ($name eq 'default' || !defined $Logpath{$name}) ?
		$cf'logfile : $Logpath{$name};
	&write_log($file, $message, $Cc{$name});
}

# Log message into logfile, using jobnum to identify process.
sub write_log {
	local($file, $msg, $cc) = @_;	# Logfile, message to be logged, cc flag
	local($date);
	local($log);

	local ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
		localtime(time);
	$date = sprintf("%.2d/%.2d/%.2d %.2d:%.2d:%.2d",
		$year,++$mon,$mday,$hour,$min,$sec);
	$log = $date . " $'prog_name\[$'jobnum\]: $msg\n";

	# If we cannot append to the logfile, first check whether it is the default
	# logfile or not. If it is not, then add a log entry to state the error in
	# the default log and then delete that user logname entry, assuming the
	# fault we get is of a permanent nature and not an NFS failure for instance.

	unless (open(LOGFILE, ">>$file")) {
		if ($file ne $cf'logfile) {
			local($name) = $Map{$file};	# Name under which it was registered
			&'add_log("ERROR cannot append to $name logfile $file: $!")
				if $'loglvl > 1;
			&'add_log("NOTICE removing logging to $file") if $'loglvl > 6;
			&delete($Map{$file});
			$cc = 1;				# Force logging to default file
		} else {					# We were already writing to default log
			return;					# Cannot log message at all
		}
	}

	print LOGFILE $log;
	close LOGFILE;

	# If $cc is set, a copy of the same log message (same time stamp guaranteed)
	# is made to the default logfile. If called with $file set to that default
	# logfile, $cc will be undef by construction.

	if ($cc) {
		open(LOGFILE, ">>$cf'logfile");
		print LOGFILE $log;
		close LOGFILE;
	}
}

package main;

package cf;

# This package is responsible for keeping track of the configuration variables.

# Read configuration file (usually in ~/.mailagent)
sub main'read_config {
	local($file) = @_;				# where config file is located
	local($_);
	$file = '~/.mailagent' unless $file;
	local($myhome) = $ENV{'HOME'};	# must be correctly set by filter
	$file =~ s/~/$myhome/;			# ~ substitution
	local($main'config) = $file;	# Save it: could be modified by config
	open(CONFIG, "$file") ||
		&'fatal("can't open config file $file");
	local($config) = ' ' x 2000;	# pre-extend to avoid realloc()
	$config = '';
	while (<CONFIG>) {
		next if /^[ \t]*#/;			# skip comments
		next if /^[ \t]*\n/;		# skip empy lines
		s/([^\\](\\\\)*)@/$1\\@/g;	# escape all un-escaped @ in string
		$config .= $_;
	}
	&parse($config) || &'fatal('bad configuration');
	close CONFIG;

	# Security checks, pending of those performed by the C filter. They are
	# somewhat necessary, even though the mailagent does not run setuid
	# (because anybody may activate the mailagent for any user by sending him
	# a mail, and world writable configuration files makes the task too easy
	# for a potential hacker). The tests are performed once the configuration
	# file has been parsed, so logging of fatal errors may occur.

	local($unsecure) = 0;

	$unsecure++ unless &'file_secure($'config, 'config');
	$unsecure++ unless &'file_secure($rules, 'rule');
	&'fatal("unsecure configuration!") if $unsecure;

	return unless -f "$rules";		# No rule file
}

# Parse config file held in variable and return 1 if ok, 0 for errors
sub parse {
	local($config) = @_;
	return 1 unless defined $config;
	local($eval) = ' ' x 1000;		# Pre-extend
	local($myhome) = $ENV{'HOME'};	# must be correctly set by filter
	local($var, $value);
	local($_);
	$eval = '';
	foreach (split(/\n/, $config)) {
		if (/^[ \t]*([^ \t\n:\/]*)[ \t]*:[ \t]*([^#\n]*)/) {
			$var = $1;
			$value = $2;
			$value =~ s/\s*$//;						# remove trailing spaces
			$eval .= "\$$var = \"$value\";\n";
			$eval .= "\$$var =~ s|~|$myhome|g;\n";	# ~ substitution
		}
	}
	eval $eval;			# evaluate configuration parameters within package

	if ($@ ne '') {				# Parsing error detected
		local($error) = $@;		# Logged error
		local($*) = 1;
		$error = (split(/\n/, $error))[0];		# Keep only first line
		# Dump error message on stderr, as well as faulty configuration file.
		# The original is restored out of the perl form to avoid surprise.
		$eval =~ s/^\$.* =~ s\|~\|.*\n//g;		# Remove added ~ substitutions
		$eval =~ s/^\$//g;						# Remove leading '$'
		$eval =~ s/ = "(.*)";/: $1/g;			# Keep only variable value
		chop($eval);
		print STDERR <<EOM;
**** Syntax error in configuration:
$error

---- Begin of Faulty Configuration
$eval
---- End of Faulty Configuration

EOM
		&'add_log("syntax error in configuration: $error") if $'loglvl > 1;
		return 0;
	}

	# Define the mailagent parameters from those in config file
	$logfile = $logdir . "/$log";
	$seqfile = $spool . "/$seq";
	$hashdir = $spool . "/$hash";
	$main'loglvl = int($level);		# This one is visible in the main package
	$main'track_all = 1 if $track =~ /on/i;		# Option -t set by config
	$sendmail = $'mailer if $sendmail eq '';	# No sendmail program specified
	$sendnews = $'inews if $sendnews eq '';		# No news posting program
	$mailopt = '-odq' if $mailopt eq '' && $sendmail =~ /sendmail/;

	# Backward compatibility -- RAM, 25/04/94
	$fromesc = 'ON' unless defined $fromesc;	# If absent from ~/.mailagent
	$lockmax = 20 unless defined $lockmax;
	$lockdelay = 2 unless defined $lockdelay;
	$lockhold = 3600 unless defined $lockhold;
	$queuewait = 60 unless defined $queuewait;
	$queuehold = 1800 unless defined $queuehold;
	$queuelost = 86400 unless defined $queuelost;
	$runmax = 3600 unless defined $runmax;
	$umask = 077 unless defined $umask;
	$email = $user unless defined $email;
	$compspec = "$spool/compressors" unless defined $compspec;
	$comptag = 'compress' unless defined $comptag;
	$locksafe = 'ON' unless defined $locksafe;

	# For backward compatibility, we force a .lock locking on mailboxes.
	# For system ones (name = login), there's no problem because the lock
	# file is still under the 14 characters limit. If mail is saved in folders
	# whose name is longer, there might be problems though. There's little we
	# can do about it here, lest they choose an alternate locking name.
	# Note that mailagent's $lockext global variable setting depends on the
	# fact that the target system supports flexible filenames or not, so only
	# mailbox locking is a problem -- RAM, 18/07/95

	$mboxlock = '%f.lock' unless defined $mboxlock;

	$umask = oct($umask) if $umask =~ /^0/;	 # Translate umask into decimal

	# Update @INC perlib search path with the perlib variable. Paths not
	# starting by a '/' are supposed to be under the mailagent private lib
	# directory.

	local(%seen);		# Avoid dups in @INC (might be called more than once)

	foreach (@INC) { $seen{$_}++; }

	if (defined $perlib) {
		foreach (split(':', $perlib)) {
			s/^~/$home/;
			$_ = $'privlib . '/' . $_ unless m|^/|;
			push(@INC, $_) unless $seen{$_}++;
		}
	}

	1;		# Ok
}

package main;

# Expands an archive's name
sub expand {
	local($path) = shift;		# The archive
	# Look for extension of base path (eg: .cpio.Z)
	local(@fullpath) = <${path}.*>;
	if (-1 == $#fullpath) {
		&clean_tmp;
		&fatal("no archive file");
	}
	$path = $fullpath[0];		# Name with archive extension
}

# Unpack(path,dir,flag) restores archive `path' into `dir'
# and returns the location of the main directory.
sub unpack {
	local($path) = shift;		# The archive
	local($dir) = shift;		# Storage place
	local($compflag) = shift;	# Flag for compression (useful for short names)
	local($unpack) = "";		# Will hold the restore command
	$path = &expand($path);		# Name with archive extension
	&add_log("archive is $path") if $loglvl > 19;
	# First determine wether it is compressed
	if ($compflag) {
		$unpack = "zcat | ";
	}
	# Cpio or tar ?
	if ($path =~ /\.tar/) {
		$unpack .= "tar xof -";
	} else {
		$unpack .= "cpio -icmd";
	}
	system "< $path (cd $dir; $unpack)";
	$path =~ s|.*/(\w+)|$1|;	# Keep only basename
	local ($stat) = $?;			# Return status
	if ($stat) {
		&clean_tmp;
		&fatal("unable to unpack $path");
	}
	&add_log("unpacked $path with \"$unpack\"") if $loglvl > 12;

	# The top level directory is the only file in $dir
	local(@top) = <${dir}/*>;
	if ($#top < 0) {
		&clean_tmp;
		&fatal("$prog_name: no top-level dir for $path");
	}
	if ($#top > 0) {
		&add_log("WARNING more than one file in $dir") if $loglvl > 4;
	}
	&add_log("top-level dir for $path is $top[0]") if $loglvl > 19;
	$top[0];		# Top-level directory
}

# Read a distribution file and fill in data structures for
# the query functions. All the data are stored in associative
# arrays, indexed by the system's name and version number.
# Associative arrays are:
#
# name          indexed by       information
#
# %Program      name + version   have we seen that line ?
# %System       name             is name a valid system ?
# %Version      name             latest version for system
# %Location		name + version   location of the distribution
# %Archived     name + version   is distribution archived ?
# %Compressed   name + version   is archive compressed ?
# %Patch_only   name + version   true if only patches delivered
# %Maintained   name + version   true if distribution is maintained
# %Patches      name + version   true if official patches available
#
# For systems with a version of '---' in the file, the version
# for accessing the data has to be a "0" string.
#
# Expected format for the distribution file:
#     system version location archive compress patches
#
# The `archive', `compress' and `patches' fields can take one
# of the following states: "yes" and "no". An additional state
# for `patches' is "old", which means that only patches are
# available for the version, and not the distribution. Another is
# "patch" which means that official patches are available.
# All these states can be abbreviated with the first letter.
#
sub read_dist {
	local($fullname);
	open(DIST, "$cf'distlist") ||
		&fatal("cannot open distribution file");
	while (<DIST>) {
		next if /^\s*#/;	# skip comments
		next if /^\s*$/;	# skip empty lines
		next unless s/^\s*(\w+)\s+([.\-0-9]+)//;
		$fullname = $1 . "|" . ($2 eq '---'? "0" : $2);
		if (defined $Program{$fullname}) {
			&add_log("WARNING duplicate distlist entry $1 $2 ignored")
				if $loglvl > 5;
			next;
		}
		$Program{$fullname}++;
		$Version{$1} = ($2 eq '---' ? "0" : $2) unless
			defined($System{$1}) && $Version{$1} > ($2 eq '---' ? "0":$2);
		$System{$1}++;
		unless (/^\s*(\S+)\s+(\w+)\s+(\w+)\s+(\w+)/) {
			&add_log("WARNING bad system description line $.")
				if $loglvl > 5;
			next;	# Ignore, but it may corrupt further processing
		}
		local($location) = $1;
		local($archive) = $2;
		local($compress) = $3;
		local($patch) = $4;
		$location =~ s/~\//$cf'home\//;		# ~ expansion
		$Location{$fullname} = $location;
		$Archived{$fullname}++ if $archive =~ /^y/;
		$Compressed{$fullname}++ if $compress =~ /^y/;
		$Patch_only{$fullname}++ if $patch =~ /^o/;
		$Maintained{$fullname}++ if $patch =~ /^y|o/;
		$Patches{$fullname}++ if $patch =~ /^p/;
	}
	close DIST;
}

# Make sure lock lasts for a reasonable time
sub checklock {
	local($file, $format) = @_;				# Full path name, locking format
	local($lockfile) = $file . $lockext;	# Add lock extension
	$lockfile = &lock'file($file, $format) if defined $format;
	if (-f $lockfile) {
		# There is a lock file -- look for how long it's been there
		local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
			$atime,$mtime,$ctime,$blksize,$blocks) = stat($lockfile);
		if ((time - $mtime) > $cf'lockhold) {
			# More than outdating time!! Something must have gone wrong
			unlink $lockfile;
			$file =~ s|.*/(.*)|$1|;	# Keep only basename
			&add_log("UNLOCKED $file (lock older than $cf'lockhold seconds)")
				if $loglvl > 5;
		}
	}
}

# Read stored informations for archived systems. The format of
# the file is the following:
#	system version patchlevel mtime
# where:
#	- system is the name of the system
#	- version is the version number or --- if none
#	- patchlevel is the current patchlevel, or -2 if no PL
#	- mtime is the modification time of the archive
#
# The function builds the following associative array, indexed
# by the system's name and version number (which has to be a null
# string for systems with no version number, marked '---'):
#
# name          indexed by       information
#
# %PSystem      name + version   true if line seen
# %Patch_level  name + version   current patch level
# %Mtime        name + version   last modification time
#
# If the 'plsave' file is not found, a new empty one is created
#
sub read_plsave {
	local($fullname);
	if (!open(PATLIST, "$cf'plsave")) {
		&add_log("creating new patlist file") if $loglvl > 8;
		system 'cp', '/dev/null', $cf'plsave;
		open(PATLIST, "$cf'plsave") ||
			&fatal("cannot open patlist file");
	}
	while (<PATLIST>) {
		next if /^\s*#/;	# skip comments
		next if /^\s*$/;	# skip empty lines
		next unless s/^\s*(\w+)\s+([\w\.]+)//;
		$fullname = $1 . "|" . ($2 eq '---'? "0" : $2);
		if (defined($PSystem{$fullname})) {
			&add_log("WARNING duplicate patlist entry $1 $2 ignored")
				if $loglvl > 5;
			next;
		}
		$PSystem{$fullname}++;
		unless (/^\s*([\-\d]+)\s+(\d+)/) {
			&add_log("WARNING bad patlist description line $.")
				if $loglvl > 5;
			next;	# Ignore, but it may corrupt further processing
		}
		$Patch_level{$fullname} = $1;
		$Mtime{$fullname} = $2;
	}
	close PATLIST;
}

# Write the new 'plsave', but only if the distributions are found
# in the %Program array (I assume read_dist() has been called).
# The 'plsave' file is locked during the updating process, so that
# no conflicting access occurs. There is a small chance that the
# file we write is not correct, in case the distribution file changed
# while we were processing a mail. However, it isn't a big problem.
sub write_plsave {
	local($lockext) = ".lock";		# Needed by checklock (via acs_rqst)
	local($system);
	local($version);
	if (0 != &acs_rqst($cf'plsave)) {
		&add_log("WARNING updating unlocked patlist file") if $loglvl > 5;
	}
	if (!open(PATLIST, ">$cf'plsave")) {
		&add_log("ERROR unable to update $cf'plsave") if $loglvl;
		return;
	}
	print PATLIST
"# This file was automatically generated by $prog_name.
# It records the archived distributions, their patch level if any, and
# the modification time of the archive, so that these informations can
# be updated when necessary. Do not edit this file.

";
	foreach $pname (keys %PSystem) {
		if ($Archived{$pname}) {
			($system, $version) = $pname =~ /^(\w+)\|([\w\.]+)*$/;
			$version = '---' if $version eq '0';
			print PATLIST "$system $version ";
			print PATLIST "$Patch_level{$pname} $Mtime{$pname}\n";
			&add_log("updated patlist for $system $version") if $loglvl > 18;
		} else {
			&add_log("$system $version removed from patlist") if $loglvl > 18;
		}
	}
	close PATLIST;
	&free_file($cf'plsave);
}

# A file "secure" if it is owned by the user and not world writable. Some key
# file within the mailagent have to be kept secure or they might compromise the
# security of the user account. Additionally, for 'root' users or if the
# 'secure' parameter in the config file is set to ON, checks are made for
# group writable files and suspicious directory as well.
# Return true if the file is secure or missing, false otherwise.
sub file_secure {
	local($file, $type) = @_;	# File to be checked
	return 1 unless -e $file;	# Missing file considered secure
	if (-l $file) {				# File is a symbolic link
		&add_log("WARNING sensitive $type file $file is a symbolic link")
			if $loglvl > 5;
		return 0;		# Unsecure file
	}
	local($ST_MODE) = 2 + $[;	# Field st_mode from inode structure
	unless (-O _) {				# Reuse stat info from -e
		&add_log("WARNING you do not own $type file $file") if $loglvl > 5;
		return 0;		# Unsecure file
	}
	local($st_mode) = (stat(_))[$ST_MODE];
	if ($st_mode & $S_IWOTH) {
		&add_log("WARNING $type file is world writable!") if $loglvl > 5;
		return 0;		# Unsecure file
	}

	return 1 unless $cf'secure =~ /on/i || $< == 0;

	# Extra checks for secure mode (or if root user). We make sure the
	# file is not writable by group and then we conduct the same secure tests
	# on the directory itself
	if ($st_mode & $S_IWGRP) {
		&add_log("WARNING $type file is group writable!") if $loglvl > 5;
		return 0;		# Unsecure file
	}
	local($dir);		# directory where file is located
	$dir = '.' unless ($dir) = ($file =~ m|(.*)/.*|);
	unless (-O $dir) {
		&add_log("WARNING you do not own directory of $type file")
			if $loglvl > 5;
		return 0;		# Unsecure directory, therefore unsecure file
	}
	$st_mode = (stat(_))[$ST_MODE];
	return 0 unless &check_st_mode($dir, 1);

	# If linkdirs is OFF, we do not check further when faced with a symbolic
	# link to a directory.
	if (-l $dir && $cf'linkdirs !~ /^off/i && !&symdir_secure($dir, $type)) {
		&add_log("WARNING directory of $type file $file is an unsecure symlink")
			if $loglvl > 5;
		return 0;		# Unsecure directory
	}

	1;		# At last! File is secure...
}

# Is a symbolic link to a directory secure?
sub symdir_secure {
	local($dir, $type) = @_;
	if (&symdir_check($dir, 0)) {
		&add_log("symbolic directory $dir for $type file is secure")
			if $loglvl > 11;
		return 1;
	}
	0;	# Not secure
}

# A symbolic directory (that is a symlink pointing to a directory) is secure
# if and only if:
#   - its target is a symlink that recursively proves to be secure.
#   - the target lies in a non world-writable directory
#   - the final directory at the end of the symlink chain is not world-writable
#   - less than $MAX_LINKS levels of indirection are needed to reach a real dir
# Unfortunately, we cannot check for group writability here for the parent
# target directory since the target might lie in a system directory which may
# have a legitimate need to be read/write for root and wheel, for instance.
# The routine returns 1 if the file is secure, 0 otherwise.
sub symdir_check {
	local($dir, $level) = @_;	# Directory, indirection level
	return 0 if $level++ > $MAX_LINKS;
	local($ndir) = readlink($dir);
	unless (defined $ndir) {
		&add_log("SYSERR readlink: $!") if $loglvl;
		return 0;
	}
	$dir =~ s|(.*)/.*|$1|;		# Suppress link component (tail)
	$dir = &cdir($ndir, $dir);	# Follow symlink to get its final path target
	local($still_link) = -l $dir;
	unless (-d $dir || $still_link) {
		&add_log("ERROR inconsistency: $dir is a plain file?") if $loglvl;
		return 0;		# Reached a plain file while following links to a dir!
	}
	unless (-d "$dir/..") {
		&add_log("ERROR inconsistency: $dir/.. is not a directory?") if $loglvl;
		return 0;		# Reached a file hooked nowhere in the file system!
	}
	# Check parent directory
	local($ST_MODE) = 2 + $[;	# Field st_mode from inode structure
	$st_mode = (stat(_))[$ST_MODE];
	return 0 unless &check_st_mode("$dir/..", 0);
	# Recurse if still a symbolic link
	if ($still_link) {
		return 0 unless &symdir_check($dir, $level);
	} else {
		$st_mode = (stat($dir))[$ST_MODE];
		return 0 unless &check_st_mode($dir, 1);
	}
	1;	# Ok, link is secure
}

# Returns true if mode in $st_mode does not include world or group writable
# bits, false otherwise. This helps factorizing code used in both &file_secure
# and &symdir_check. Set $both to true if both world/group checks are desirable,
# false to get only world checks.
sub check_st_mode {
	local($dir, $both) = @_;
	if ($st_mode & $S_IWOTH) {
		&add_log("WARNING directory of $type file $dir is world writable!")
			if $loglvl > 5;
		return 0;		# Unsecure directory
	}
	return 1 unless $both;
	if ($st_mode & $S_IWGRP) {
		&add_log("WARNING directory of $type file $dir is group writable!")
			if $loglvl > 5;
		return 0;		# Unsecure directory
	}
	1;
}

# Apply directory changes into current path and return new directory
sub cdir {
	local($dir, $cur) = @_;			# New relative path, current directory
	return $dir if $dir =~ m|^/|;	# Already an absolute path
	chop($cur = `pwd`) unless defined $cur;
	local(@cur) = split(/\//, $cur);
	local(@dir) = split(/\//, $dir);
	local($path);
	foreach $item (@dir) {
		next if $item eq '.';	# Stay in same dir
		if ($item eq '..') {	# Move up
			pop(@cur);
		} else {
			push(@cur, $item);	# Move down
		}
	}
	local($path) = '/' . join('/', @cur);
	$path =~ tr|/||s;			# Successive '/' are useless
	$path;
}

# Return only the hostname portion of the host name (no domain name)
sub myhostname {
	local($_) = &hostname;
	s/^([^.]*)\..*/$1/;			# Trim down domain name
	$_;
}

# Compute hostname once and for all and cache its value (since we have to fork
# to get it).
sub hostname {
	unless ($cache'hostname) {
		chop($cache'hostname = `$phostname`);
		$cache'hostname =~ tr/A-Z/a-z/;			# Cannonicalize to lower case
	}
	$cache'hostname;
}

