mailagent 1:3.1-81-4 / usr / bin / edusers

#!/usr/bin/perl
	eval 'exec perl -S $0 ${1+"$@"}'
		if $running_under_some_shell;

# $Id: edusers.SH 47 2008-06-26 19:18:00Z rmanfredi $
#
#  Copyright (c) 1990-2006, 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: edusers.SH,v $
# Revision 3.0.1.3  1995/08/07  16:06:24  ram
# patch37: added support for locking on filesystems with short filenames
#
# Revision 3.0.1.2  1995/03/21  12:50:11  ram
# patch35: added pl/cdir.pl to the list of appended files
#
# Revision 3.0.1.1  1994/09/22  13:39:28  ram
# patch12: created
#

$mversion = '3.1';
$patchlevel = '0';
$revision = '81';
$defeditor = '/usr/ae';
$phostname = '';
$long_filenames = 'define' eq 'define';

$userlist = "users";
$prog_name = $0;				# Who I am
$prog_name =~ s|^.*/(.*)|$1|;	# Keep only base name
$lockext = $long_filenames ? '.lock' : '!';	# Extension used by lock routines
*add_log = *stderr_log;			# Ensure logs will go to stderr also

$EDITOR = $ENV{'EDITOR'} || $ENV{'VISUAL'} || $defeditor;

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

$system = shift;		# Which system do we want
$version = shift;		# Which version it is

# If no system is specified, try locating a '.package', then source it
# to get information...
if ($system eq '') {
	die "$prog_name: you must specify a system name\n" unless &read_package;
	$system = $pkg'package;
	$version = $pkg'baserev;
}

# A single '-' or a missing version means "highest available" version.
$version = $Version{$system} if $version eq '-' || $version eq '';

# Full name of system for H table access
$pname = $system . "|" . $version;

die "$prog_name: no program called $system\n" unless $System{$system};
die "$prog_name: no package $system version $version\n"
	unless $Program{$pname};

# Go to the system directory.
chdir "$Location{$pname}" ||
	die "$prog_name: cannot go to $Location{$pname}\n";

-f $userlist || die "$prog_name: no $userlist file yet for $system $version.\n";

# Lock users file. That file should only be edited with the edusers script.
die "$prog_name: cannot lock $userlist.\n" if 0 != &acs_rqst($userlist);

system "$EDITOR $userlist";
warn "$prog_name: WARNING: edition failed...\n" if $?;
&free_file($userlist);

exit $?;

# 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");
}

# 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);

	return unless length $file;

	local ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
		localtime(time);
	$date = sprintf("%.2d/%.2d/%.2d %.2d:%.2d:%.2d",
		$year % 100,++$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
		$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//gm;		# Remove added ~ substitutions
		$eval =~ s/^\$//gm;						# Remove leading '$'
		$eval =~ s/ = "(.*)";/: $1/gm;			# 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 -i' 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 = 'gzip' unless defined $comptag;
	$locksafe = 'OFF' unless defined $locksafe;
	$execsafe = 'OFF' unless defined $execsafe;

	# 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;

	# Backward compatibility -- RAM, 17/03/2001
	$domain = $main::hiddennet || $main::mydomain unless defined $domain;
	$hidenet = $main::hiddennet eq '' ? 'OFF' : 'ON' unless defined $hidenet;

	$umask = oct($umask) if $umask =~ /^0/;	 # Translate umask into decimal
	$domain =~ s/^\.*//;					 # Strip leading '.'

	# 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;

# 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;
}

# 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.
# Note the extra parameter $exec which is set by exec_secure() only.
sub file_secure {
	local($file, $type, $exec) = @_;
	return 1 unless -e $file;	# Missing file considered secure

	# If we're trying to execute a symbolic link, try to resolve it recursively
	# Otherwise, symlinks are not considered secure by file_secure().
	if (-l $file) {				# File is a symbolic link
		if ($exec) {
			local($target);
			$target = &symfile_secure($file, $type);
			return 0 unless defined $target;
			&add_log("NOTICE running $type $file actually runs $target")
				if $loglvl > 6;
			$file = $target;
		} else {
			&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 ($exec || -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 $file is world writable!") if $loglvl > 5;
		return 0;		# Unsecure file
	}

	# If file is excutable and seg[ug]id, make sure it's not publicly writable.
	# If writable at all, only the owner should have the rights. That's for
	# systems which do no reset the set[ug]id bit on write to the file.
	if (-x _) {
		if (($st_mode & $S_ISUID) && ($st_mode & ($S_IWGRP|$S_IWOTH))) {
			&add_log("WARNING setuid $type file $file is writable!")
				if $loglvl > 5;
			return 0;
		}
		if (($st_mode & $S_ISGID) && ($st_mode & ($S_IWGRP|$S_IWOTH))) {
			&add_log("WARNING setgid $type file $file is writable!")
				if $loglvl > 5;
			return 0;
		}
	}

	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) && $cf'groupsafe !~ /^off/i) {
		&add_log("WARNING $type file $file is group writable!") if $loglvl > 5;
		return 0;		# Unsecure file
	}
	local($dir);		# directory where file is located
	$dir = '.' unless ($dir) = ($file =~ m|(.*)/.*|);
	unless ($exec || -O $dir) {
		&add_log("WARNING you do not own directory of $type file $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
}

# Is a symbolic link to a file secure?
# Returns the final target if all links up to that file are secure, undef
# if one of the links is not secure enough.
sub symfile_secure {
	local($file, $type) = @_;
	local($target) = &symfile_check($file, 0);
	if (defined $target) {
		&add_log("symbolic file $file for $type file is secure")
			if $loglvl > 11;
	} else {
		&add_log("WARNING symbolic file $file for $type file is unsecure")
			if $loglvl > 5;
	}
	return $target;
}

# 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
	$MAX_LINKS = 100 unless defined $MAX_LINKS;	# May have been overridden
	if ($level++ > $MAX_LINKS) {
		&add_log("ERROR more than $MAX_LINKS levels of symlinks to reach $dir")
			if $loglvl;
		return 0
	}
	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
}

# Same as symdir_check, but target is a file!
sub symfile_check {
	local($file, $level) = @_;	# File, indirection level
	return undef if $level++ > $MAX_LINKS;
	local($nfile) = readlink($file);
	unless (defined $nfile) {
		&add_log("SYSERR readlink: $!") if $loglvl;
		return undef;
	}
	local($dir) = $file;			# Where symlink was held
	$dir =~ s|(.*)/.*|$1|;			# Suppress link component (tail)
	$file = &cdir($nfile, $dir);	# Follow symlink to get its path
	local($still_link) = -l $file;
	unless (-f $file || $still_link) {
		&add_log("ERROR $file does not exist") if !-e _ && $loglvl;
		&add_log("ERROR $file is not a plain file") if -e _ && $loglvl;
		return undef;				# Reached something that is not a plain file
	}
	# Check parent directory
	($dir = $file) =~ s|(.*)/.*|$1|;
	local($ST_MODE) = 2 + $[;		# Field st_mode from inode structure
	$st_mode = (stat($dir))[$ST_MODE];
	return undef unless &check_st_mode($dir, 1);
	return $file unless $still_link;		# Ok, link is secure
	return &symfile_check($file, $level);	# Still a symbolic link
}

# 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 $dir of $type file is world writable!")
			if $loglvl > 5;
		return 0;		# Unsecure directory
	}
	return 1 unless $both;
	if (($st_mode & $S_IWGRP) && $cf'groupsafe !~ /^off/i) {
		&add_log("WARNING directory $dir of $type file is group writable!")
			if $loglvl > 5;
		return 0;		# Unsecure directory
	}
	1;
}

# Make sure the file we are about to execute is secure. If it is a script
# with the '#!' kernel hook, also check the interpreter! Returns true if the
# file can be executed "safely".
sub exec_secure {
	local($file) = @_;	# File to be executed

	unless (-x $file) {
		&add_log("ERROR lacking execute rights on $file") if $loglvl > 1;
		return 0;
	}

	return 1 if $cf'execskip =~ /^on/i;	# Assume safe to be exec'ed

	local($cf'secure) = $cf'execsafe;	# Use exec settings for file_secure()

	unless (&file_secure($file, 'program', 1)) {
		&add_log("ERROR cannot execute unsecure $file") if $loglvl > 1;
		return 0;
	}

	&add_log("can allow exec() of $file") if $loglvl > 17;

	return 1 unless -T $file;	# Safe as far as we can tell, unless script...

	local($head);				# Heading line
	local($interpretor);		# Interpretor running the script
	local($perl) = '';			# Empiric support for perl scripts
	local(*SCRIPT);

	unless (open(SCRIPT, $file)) {
		&add_log("SYSERR open: $!") if $loglvl > 1;
		&add_log("ERROR cannot check script $file") if $loglvl > 1;
		return 0;
	}

	$head = <SCRIPT>;

	# Allow empiric support for common perl scripts
	# This is not bullet-proof, but should guard against common errors.

	if ($head =~ /\bperl\b/) {
		$perl = <SCRIPT>;
		if ($perl =~ /\beval\b.*\bexec\s+(\S+)/) {
			$perl = $1;
		} else {
			$perl = '';			# False alarm, can't check further
		}
	}

	close SCRIPT;

	($interpretor) = $head =~ /^#!\s*(\S+)/;
	$interpretor = '/bin/sh' unless $interpretor;
	unless (-x $interpretor) {
		&add_log("ERROR lacking execute rights on $interpretor") if $loglvl > 1;
		return 0;
	}

	unless (&file_secure($interpretor, 'interpretor', 1)) {
		&add_log("ERROR cannot run unsecure interpretor $interpretor")
			if $loglvl > 1;
		&add_log("ERROR cannot allow execution of script $file") if $loglvl > 1;
		return 0;
	}

	&add_log("can allow $interpretor to run $file") if $loglvl > 17;

	return 1 unless $perl;		# Okay, can run the script

	$perl = &locate_program($perl) unless $perl =~ m|/|;
	unless (-x $perl) {
		&add_log("ERROR lacking execute rights on $perl") if $loglvl > 1;
		return 0;
	}

	unless (&file_secure($perl, 'perl', 1)) {
		&add_log("ERROR cannot run unsecure perl $perl")
			if $loglvl > 1;
		&add_log("ERROR cannot allow execution of perl script $file")
			if $loglvl > 1;
		return 0;
	}

	&add_log("can allow $perl to run $file") if $loglvl > 17;

	return 1;					# Okay, perl can run it
}

# 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;
}

#
# acs_rqst
#
# Attempt to lock $file, using $format as locking format (used to derive the
# name of the lock file from the filename).
#
# Returns 0 if locked, -1 otherwise.
#
sub acs_rqst {
	local($file, $format) = @_;		# file to be locked, lock format
	return &acs_lock($file, $format, 0);
}

#
# acs_locktry
#
# Same as acs_rqst, but if the file is already locked by some other party, we
# do not wish to wait for the lock.
#
# Returns 1 if locked by someone else, 0 if locked by us, -1 otherwise.
sub acs_locktry {
	local($file, $format) = @_;		# file to be locked, lock format
	return &acs_lock($file, $format, 1);
}

#
# acs_lock
#
# 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.
#
# When $try is true, we return 1 if the file is already locked. This is used
# to attempt locking only when the file is not otherwise locked.
#
sub acs_lock {
	local($file, $format, $try) = @_;	# file to be locked, format, try only?
	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 $format ne '';
	local($waited) = 0;					# amount of time spent sleeping
	local($lastwarn) = 0;				# last time we warned them...
	local($wmin, $wafter);				# busy lock warn limits

	if ($cf'lockwarn =~ /(\d+),\s*(\d+)/)	{ ($wmin, $wafter) = ($1, $2) }
	elsif ($cf'lockwarn =~ /(\d+)/)			{ ($wmin, $wafter) = ($1, $1) }
	else									{ ($wmin, $wafter) = (20, 300) }

	while ($max > 0) {
		$max--;
		if (-f $lockfile) {
			return 1 if $try;			# already locked
			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
			return 1 if $try;			# already locked
			next;
		}
	} continue {
		sleep($delay);				# busy: wait
		$waited += $delay;
		# Warn them once after $wmin seconds and then every $wafter seconds
		if (
			(!$lastwarn && $waited > $wmin) ||
			($waited - $lastwarn) > $wafter
		) {
			local($waiting) = $lastwarn ? 'still waiting' : 'waiting';
			local($after) = $lastwarn ? 'after' : 'since';
			&add_log("WARNING $waiting for $file lock $after $waited seconds")
				if $loglvl > 3;
			$lastwarn = $waited;
		}
	}
	if ($max) {
		&add_log("NOTICE got $file lock after $waited seconds")
			if $lastwarn && $loglvl > 6;
		$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
}

# 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;
		}
	}
}

# Catch all common signals
sub catch_signals {
	unless (defined &emergency) {
		&add_log("WARNING no emergency routine to trap signals") if $loglvl > 4;
		return;
	}
	$SIG{'HUP'} = "emergency";
	$SIG{'INT'} = "emergency";
	$SIG{'QUIT'} = "emergency";
	$SIG{'PIPE'} = "emergency";
	$SIG{'IO'} = "emergency";
	$SIG{'BUS'} = "emergency";
	$SIG{'ILL'} = "emergency";
	$SIG{'SEGV'} = "emergency";
	$SIG{'ALRM'} = "emergency";
	$SIG{'TERM'} = "emergency";
}

# Get at the .package file, created by the dist program packinit.
# Returns true if package file was read and sourced correctly within
# the pkg package, false otherwise (in which case we are likely not to
# be within a package source tree).
sub read_package {
	local($pack) = '.package';
	unless (-f $pack) {
		local(@path) = ( '..', '../..', '../../..', '../../../..');
		foreach $dir (@path) {
			if (-f "$dir/$pack") {
				$pack = "$dir/$pack";
				last;
			}
		}
	}
	return 0 unless -f $pack;
	open(PACKAGE, $pack) || return 0;
	while (<PACKAGE>) {
		next if /^:/;
		next if /^#/;
		if (($var,$val) = /^\s*(\w+)=(.*)/) {
			$val = "\"$val\"" unless $val =~ /^['"]/;
			eval "\$pkg'$var = $val;";
		}
	}
	close PACKAGE;
	return 1;
}

# 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;
}