Source Code 1994 March/Source_Code_CD-ROM_Walnut_Creek_March_1994.iso/compsrcs/misc/volume41/mailagnt/part10

Text File | 1993-12-02 | 55.1 KB | 1,663 lines

Newsgroups: comp.sources.misc
From: Raphael Manfredi <[e-mail]>
Subject: v41i010:  mailagent - Flexible mail filtering and processing package, v3.0, Part10/26
Message-ID: <[e-mail]>
X-Md4-Signature: 6438a2029ff359b8d7c5c5f2bc5f554f
Sender: [e-mail] (Kent Landfield)
Organization: Advanced Computer Research Institute, Lyon, France.
Date: Thu, 2 Dec 1993 13:38:56 GMT
Approved: [e-mail]

Submitted-by: Raphael Manfredi <[e-mail]>
Posting-number: Volume 41, Issue 10
Archive-name: mailagent/part10
Environment: UNIX, Perl
Supersedes: mailagent: Volume 33, Issue 93-109

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then feed it
# into a shell via "sh file" or similar.  To overwrite existing files,
# type "sh file -c".
# The tool that generated this appeared in the comp.sources.unix newsgroup;
# send mail to [e-mail] if you want that tool.
# Contents:  agent/magent.SH agent/pl/dbr.pl bin/perload
#   misc/unkit/kitok.msg
# Wrapped by ram@soft208 on Mon Nov 29 16:49:56 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
echo If this archive is complete, you will see the following message:
echo '          "shar: End of archive 10 (of 26)."'
if test -f 'agent/magent.SH' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'agent/magent.SH'\"
else
  echo shar: Extracting \"'agent/magent.SH'\" \(19725 characters\)
  sed "s/^X//" >'agent/magent.SH' <<'END_OF_FILE'
Xcase $CONFIG in
X'')
X    if test -f config.sh; then TOP=.;
X    elif test -f ../config.sh; then TOP=..;
X    elif test -f ../../config.sh; then TOP=../..;
X    elif test -f ../../../config.sh; then TOP=../../..;
X    elif test -f ../../../../config.sh; then TOP=../../../..;
X    else
X        echo "Can't find config.sh."; exit 1
X    fi
X    . $TOP/config.sh
X    ;;
Xesac
Xcase "$0" in
X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
Xesac
Xecho "Extracting agent/magent (with variable substitutions)"
X$spitshell >magent <<!GROK!THIS!
X$startperl
X    eval 'exec perl -S \$0 "\$@"'
X        if \$running_under_some_shell;
X
X# You'll need to set up a .forward file that feeds your mail to this script,
X# via the filter. Mine looks like this:
X#   "|exec /users/ram/mail/filter >>/users/ram/.bak 2>&1"
X
X# $Id: magent.SH,v 3.0 1993/11/29 13:48:22 ram Exp ram $
X#
X#  Copyright (c) 1990-1993, Raphael Manfredi
X#
X#  You may redistribute only under the terms of the Artistic License,
X#  as specified in the README file that comes with the distribution.
X#  You may reuse parts of this distribution only within the terms of
X#  that same Artistic License; a copy of which may be found at the root
X#  of the source tree for mailagent 3.0.
X#
X# $Log: magent.SH,v $
X# Revision 3.0  1993/11/29  13:48:22  ram
X# Baseline for mailagent 3.0 netwide release.
X#
X
X# Perload ON
X
X#
X# The following were determined by Configure...
X#
X
X# Command used to compute hostname
X\$phostname = '$phostname';
X
X# Our domain name
X\$mydomain = '$mydomain';
X
X# Hidden network (advertised host)
X\$hiddennet = '$hiddennet';
X
X# Directory where mail is spooled
X\$maildir = '$maildir';
X
X# File in which mail is stored
X\$mailfile = '$mailfile';
X
X# Current version number and patchlevel
X\$mversion = '$VERSION';
X\$patchlevel = '$PATCHLEVEL';
X
X# Want to lock mailboxes with flock ?
X\$lock_by_flock = '$lock_by_flock';
X
X# Only use flock() and no .lock file
X\$flock_only = '$flock_only';
X
X# Our organization name
X\$orgname = '$orgname';
X
X# Private mailagent library
X\$privlib = '$privlib';
X
X# News posting program
X\$inews = '$inews';
X
X# Mail sending program
X\$mailer = '$mailer';
X
X#
X# End of configuration section.
X#
X!GROK!THIS!
X
X$spitshell >>magent <<'!NO!SUBS!'
X
X$prog_name = $0;                # Who I am
X$prog_name =~ s|^.*/(.*)|$1|;    # Keep only base name
X$has_option = 0;                # True if invoked with options
X$nolock = 0;                    # Do we need to get a lock file?
X$config_file = '~/.mailagent';    # Default configuration file
X$log_level = -1;                # Changed by -L option
X
X# Calling the mailagent as 'mailqueue' lists the queue
Xif ($prog_name eq 'mailqueue') {
X    unshift(@ARGV, '-l');
X}
X
X# Parse options
Xwhile ($ARGV[0] =~ /^-/) {
X    $_ = shift;
X    last if /--/;
X    if ($_ eq '-c') {        # Specify alternate configuration file
X        ++$nolock;            # Immediate processing wanted
X        $config_file = shift;
X    }
X    elsif ($_ eq '-d') {    # Dump rules
X        ++$has_option;        # Incompatible with other special options
X        ++$dump_rule;
X    }
X    elsif ($_ eq '-e') {    # Rule supplied on command line
X        local($*) = 1;
X        $_ = shift;
X        s/\n/ /g;
X        push(@Linerules, $_);
X        ++$edited_rules;    # Signals rules came from command line
X        ++$nolock;            # Immediate processing wanted
X    }
X    elsif ($_ eq '-f') {    # Take messages from UNIX mailbox
X        ++$nolock;            # Immediate processing wanted
X        ++$mbox_mail;
X        $mbox_file = shift;    # -f followed by file name
X    }
X    elsif ($_ eq '-h') {    # Usage help
X        &usage;
X    }
X    elsif ($_ eq '-i') {    # Interactive mode: log messages also on stderr
X        *add_log = *stderr_log;
X    }
X    elsif ($_ eq '-l') {    # List queue
X        ++$has_option;        # Incompatible with other special options
X        ++$list_queue;
X        ++$norule;            # No need to compile rules
X    }
X    elsif ($_ eq '-o') {    # Overwrite configuration variable
X        ++$nolock;            # Immediate processing wanted
X        $over_config .= "\n" . shift;
X    }
X    elsif ($_ eq '-q') {    # Process the queue
X        ++$has_option;        # Incompatible with other special options
X        ++$run_queue;
X    }
X    elsif ($_ eq '-r') {    # Specify alternate rule file
X        ++$nolock;            # Immediate processing wanted
X        $rule_file = shift;
X    }
X    elsif (/^-s(\S*)/) {    # Print statistics
X        ++$has_option;        # Incompatible with other special options
X        ++$stats;
X        ++$norule;            # No need to compile rules
X        $stats_opt = $1;
X    }
X    elsif ($_ eq '-t') {    # Track rule matches on stdout
X        ++$track_all;
X    }
X    elsif ($_ eq '-L') {    # Specify new logging level
X        $log_level = int(shift);
X    }
X    elsif ($_ eq '-V') {    # Version number
X        print STDERR "$prog_name $mversion PL$patchlevel\n";
X        exit 0;
X    }
X    elsif ($_ eq '-TEST') {    # Mailagent run via TEST (undocumented feature)
X        ++$test_mode;
X    }
X    else {
X        print STDERR "$prog_name: unknown option: $_\n";
X        &usage;
X    }
X}
X
X++$nolock if $has_option;        # No need to take a lock with special options
X
X# Only one option at a time (among those options which change our goal)
Xif ($has_option > 1) {
X    print STDERR "$prog_name: at most one special option may be specified.\n";
X    exit 1;
X}
X
X$file_name = shift;                # File name to be processed (null if stdin)
X$ENV{'IFS'}='' if $ENV{'IFS'};    # Shell separation field
X&get_configuration;                # Get a suitable configuration package (cf)
Xselect(STDOUT);                    # Because the -t option writes on STDOUT,
X$| = 1;                            # make sure it is flushed before we fork()
X$agent_wait = "agent.wait";        # Waiting file for out-of-the-queue mails
X$privlib = "$cf'home/../.." if $test_mode;    # Tests ran from test/out
X
X$orgname = &tilda_expand($orgname);        # Perform run-time ~name substitution
X
Xif ($orgname =~ m|^/|) {        # Name of organization kept in file
X    unless (open(ORG, $orgname)) {
X        &add_log("ERROR cannot read $orgname: $!") if $loglvl;
X    } else {
X        chop($orgname = <ORG>);
X        close ORG;
X    }
X}
X
X$ENV{'HOME'} = $cf'home;
X$ENV{'USER'} = $cf'user;
X$ENV{'NAME'} = $cf'name;
X$baselock = "$cf'spool/perl";    # This file does not exist
X$lockext = ".lock";                # Extension used by lock routines
X$lockfile = $baselock . $lockext;
X
Xumask(077);                        # Files we create are private ones
X$jobnum = &jobnum;                # Compute a job number
X
X# Allow only ONE mailagent at a time (resource consumming)
X&checklock($baselock);            # Make sure old locks do not remain
Xunless (-f $lockfile) {
X    # Try to get the lock file (acting as a token). We do not need locking if
X    # we have been invoked with an option and that option is not -q.
X    if ($nolock && !$run_queue) {
X        &add_log("no need to get a lock") if $loglvl > 19;
X    } elsif (0 == &acs_rqst($baselock)) {
X        &add_log("got the right to process mail") if $loglvl > 19;
X        ++$locked;
X    } else {
X        &add_log("denied right to process mail") if $loglvl > 19;
X    }
X}
X
Xif (!$locked && !$nolock) {
X    # Another mailagent is running somewhere
X    &queue_mail($file_name);
X    exit 0;
X}
X
X# Initialize mail filtering and compile filter rule if necessary
X&init_all;
X&compile_rules unless $norule;
X
X# If rules are to be dumped, this is the only action
Xif ($dump_rule) {
X    &dump_rules(*print_rule_number, *void_func);
X    unlink $lockfile if $locked;
X    exit 0;
X}
X
X# Likewise, statistics dumping is the only option
Xif ($stats) {
X    &report_stats($stats_opt);
X    unlink $lockfile if $locked;
X    exit 0;
X}
X
X# Listing the queue is also the only performed action
Xif ($list_queue) {
X    &list_queue;
X    unlink $lockfile if $locked;
X    exit 0;
X}
X
X# Taking messages from mailbox file
Xif ($mbox_mail) {
X    ++$run_queue if 0 == &mbox_mail($mbox_file);
X    unless ($run_queue) {
X        unlink $lockfile if $locked;
X        exit 1;        # -f failed
X    }
X    &add_log("processing queued mails") if $loglvl > 15;
X}
X
X# Suppress statistics when mailagent invoked manually (i.e. not in test mode)
X&no_stats if $nolock && !$test_mode;
X
X&read_stats;                    # Load statistics into memory for fast update
X&newcmd'load if $cf'newcmd;        # Load user-defined command definitions
X
Xif (!$run_queue) {                # Do not enter here if -q
X    if (0 != &analyze_mail($file_name)) {    # Analyze the mail
X        &add_log("ERROR while processing main message--queing it")
X            if ($loglvl > 0);
X        &queue_mail($file_name);
X        unlink $lockfile;
X        exit 0;                    # Do not continue
X    } else {
X        $file = $file_name;        # Never corrupt $file_name
X        $file =~ s|.*/(.*)|$1|;    # Keep only basename
X        $file = "<stdin>" if $file eq '';
X        &add_log("FILTERED [$file] $Header{'Length'} bytes") if $loglvl > 4;
X    }
X}
X
Xunless ($test_mode) {
X    # Fork a child: we have to take care of the filter script which is waiting
X    # for us to finish processing of the delivered mail.
X    &fork_child() unless $run_queue;
X
X    # From now on, we are in the child process... Don't sleep at all if logging
X    # level is greater that 11 or if $run_queue is true. Logging level of 12
X    # and higher are for debugging and should not be used on a permanent basis
X    # anyway.
X
X    $sleep = 1;                    # Give others a chance to queue their mail
X    $sleep = 0 if $loglvl > 11 || $run_queue;
X
X    while (&pqueue) {            # Eventually process the queue
X        sleep 30 if $sleep;        # Wait in case new mail arrives
X    }
X} else {
X    &pqueue;                    # Process the queue once in test mode
X}
X
X# End of mailagent processing
X&write_stats;                    # Resynchronizes the statistics file
X&compress'recompress;            # Compress some of the folders we delivered to
X&contextual_operations;            # Perform all the contextual operations
X&add_log("mailagent exits") if $loglvl > 17;
Xunlink $lockfile if $locked;
Xexit 0;
X
X# Print usage and exit
Xsub usage {
X    print STDERR <<EOF;
XUsage: $prog_name [-dhilqtV] [-s{umary}] [-f file] [-e rules] [-c config]
X       [-L level] [-r file] [-o def] [mailfile]
X  -c : specify alternate configuration file.
X  -d : dump filter rules (special).
X  -e : enter rules to be applied.
X  -f : get messages from UNIX-style mailbox file.
X  -h : print this help message and exits.
X  -i : interactive usage -- print log messages on stderr.
X  -l : list message queue (special).
X  -L : force logging level.
X  -o : overwrite config file with supplied definition.
X  -q : process the queue (special).
X  -r : sepcify alternate rule file.
X  -s : report gathered statistics (special).
X  -t : track rules on stdout.
X  -V : print version number and exits.
XEOF
X    exit 1;
X}
X
X# Read configuration file and alter it with the values specified via -o.
X# Then apply -r and -t by modifying suitable configuration parameters.
Xsub get_configuration {
X    &read_config($config_file);        # Read configuration file and set vars
X    &cf'parse($over_config);        # Overwrite with command line options
X    $cf'rules = $rule_file if $rule_file;        # -r overwrites rule file
X    $loglvl = $log_level if $log_level >= 0;    # -L overwrites logging level
X}
X
X#
X# The filtering routines
X#
X
X# Start-up initializations
Xsub init_all {
X    &init_signals;        # Trap common signals
X    &init_constants;    # Constants definitions
X    &init_interpreter;    # Initialize tables %Priority, %Function, ...
X    &init_env;            # Initialize the %XENV array
X    &init_matcher;        # Initialize special matching functions
X    &init_pseudokey;    # Initialize the pseudo header keys for H table
X    &init_builtins;        # Initialize built-in commands like @RR
X    &init_filter;        # Initialize filter commands
X    &init_special;        # Initialize special user table %Special
X}
X
X# Protect ourselves (trap common signals)
Xsub init_signals {
X    $SIG{'HUP'} = 'emergency';
X    $SIG{'INT'} = 'emergency';
X    $SIG{'QUIT'} = 'emergency';
X    $SIG{'PIPE'} = 'emergency';
X    $SIG{'IO'} = 'emergency';
X    $SIG{'BUS'} = 'emergency';
X    $SIG{'ILL'} = 'emergency';
X    $SIG{'SEGV'} = 'emergency';
X    $SIG{'ALRM'} = 'emergency';
X    $SIG{'TERM'} = 'emergency';
X}
X
X# Constants definitions
Xsub init_constants {
X    require 'ctime.pl';
X    # Values for flock(), usually in <sys/file.h>
X    $LOCK_SH = 1;                # Request a shared lock on file
X    $LOCK_EX = 2;                # Request an exclusive lock
X    $LOCK_NB = 4;                # Make a non-blocking lock request
X    $LOCK_UN = 8;                # Unlock the file
X
X    # Status used by filter
X    $FT_RESTART = 0;            # Abort current action, restart from scratch
X    $FT_CONT = 1;                # Continue execution
X    $FT_REJECT = 2;                # Abort current action, continue filtering
X    $FT_ABORT = 3;                # Abort filtering process
X
X    # Shall we append or remove folder?
X    $FOLDER_APPEND = 0;            # Append in folder
X    $FOLDER_REMOVE = 1;            # Remove folder
X
X    # Used by shell_command and children
X    $NO_INPUT = 0;                # No input (stdin is closed)
X    $BODY_INPUT = 1;            # Give body of mail as stdin
X    $MAIL_INPUT = 2;            # Pipe the whole mail
X    $HEADER_INPUT = 3;            # Pipe the header only
X    $NO_FEEDBACK = 0;            # No feedback wanted
X    $FEEDBACK = 1;                # Feed result of command back into %Header
X
X    # The filter message
X    local($address) = &email_addr;
X    $FILTER =
X        "X-Filter: mailagent [version $mversion PL$patchlevel] for $address";
X    $MAILER =
X        "X-Mailer: mailagent [version $mversion PL$patchlevel]";
X
X    # For header fields alteration
X    $HD_STRIP = 0;                # Strip header fields
X    $HD_KEEP = 1;                # Keep header fields
X
X    # Faked leading From line (used for digest items, by SPLIT)
X    local($now) = &ctime(time);
X    chop($now);
X    $FAKE_FROM = "From mailagent " . $now;
X}
X
X# Initializes environment. All the variables are initialized in XENV array
X# The sole purpose of XENV is to be able to know what changes wrt the invoking
X# environment when dumping the rules. It also avoid modifying the environment
X# for our children.
Xsub init_env {
X    foreach (keys(%ENV)) {
X        $XENV{$_} = $ENV{$_};
X    }
X}
X
X# List of special header keys which do not represent a true header field.
Xsub init_pseudokey {
X    %Pseudokey = (
X        'Body', 1,
X        'Head', 1,
X        'All', 1
X    );
X}
X
X#
X# Miscellaneous utilities
X#
X
X# Attempts a mailbox locking. The argument is the name of the file, the file
X# descriptor is the global MBOX, opened for appending.
Xsub mbox_lock {
X    local($file) = @_;                # File name
X    unless ($flock_only) {            # Lock with .lock
X        if (0 != &acs_rqst($file)) {
X            &add_log("WARNING could not lock $file") if $loglvl > 5;
X        }
X    }
X    # Make sure the file is still there and as not been removed while we were
X    # waiting for the lock (in which case our MBOX file descriptor would be
X    # useless: we would write in a ghost file!). This could happen when 'elm'
X    # (or other mail user agent) resynchronizes the mailbox.
X    close MBOX;
X    if (open(MBOX, ">>$file")) {
X        if ($lock_by_flock) {
X            unless (eval 'flock(MBOX, $LOCK_EX)') {    # Ask for exclusive lock
X                &add_log("WARNING could not flock $file: $!") if $loglvl > 5;
X            }
X        }
X    } else {
X        &fatal("could not reopen $file");
X    }
X    seek(MBOX, 0, 2);                # Someone may have appended something
X}
X
X# Remove lock on mailbox and return a failure status if closing failed
Xsub mbox_unlock {
X    local($file) = @_;                # File name
X    local($status);                    # Error status from close
X    $status = close(MBOX);            # Closing will remove flock lock
X    &free_file($file) unless $flock_only;        # Remove the .lock
X    $status ? 0 : 1;                # Return 0 for ok, 1 if close failed
X}
X
X# Computes the e-mail address of the user
Xsub email_addr {
X    $cf'user . '@' . &domain_addr;        # E-mail address in internet format
X}
X
X# Domain name address for current host
Xsub domain_addr {
X    local($_);                            # Our host name
X    $_ = $hiddennet if $hiddennet ne '';
X    if ($_ eq '') {
X        $_ = &hostname;                    # Must fork to get hostname, grr...
X        $_ .= $mydomain unless /\./;    # We want something fully qualified
X    }
X    $_;
X}
X
X# Strip out leading path to home directory and replace it by a ~
Xsub tilda {
X    local($path) = @_;                    # Path we wish to shorten
X    local($home) = $cf'home;
X    $home =~ s/(\W)/\\$1/g;                # Escape possible meta-characters
X    $path =~ s/^$home/~/;                # Replace the home directory by ~
X    $path;                                # Return possibly stripped path
X}
X
X# Compute the system mailbox file name
Xsub mailbox_name {
X    # If ~/.mailagent provides us with a mail directory, use it and possibly
X    # override value computed by Configure.
X    $maildir = $cf'maildrop if $cf'maildrop ne '';
X    # If Configure gave a valid 'maildir', use it. Otherwise compute one now.
X    unless ($maildir ne '' && -d "$maildir") {
X        $maildir = "/usr/spool/mail";        # Default spooling area
X        -d "/usr/mail" && ($maildir = "/usr/mail");
X        -d "$maildir" || ($maildir = "$cf'home");
X    }
X    local($mbox) = $cf'user;                    # Default mailbox file name
X    $mbox = $cf'mailbox if $cf'mailbox ne '';    # Priority to config variable
X    $mailbox = "$maildir/$mbox";                # Full mailbox path
X    if (! -f "$mailbox" && ! -w "$maildir") {
X        # No mailbox already exists and we can't write in the spool directory.
X        # Use mailfile then, and if we can't write in the directory and the
X        # mail file does not exist either, use ~/mbox.$cf'user as mailbox.
X        $mailbox = $mailfile;        # Determined by configure (%~ and %L form)
X        $mailbox =~ s/%~/$cf'home/go;    # %~ stands for the user directory
X        $mailbox =~ s/%L/$cf'user/go;    # %L stands for the user login name
X        $mailbox =~ m|(.*)/.*|;            # Extract dirname
X        $mailbox = "$cf'home/mbox.$cf'user" unless (-f "mailbox" || -w "$1");
X        &add_log("WARNING using $mailbox for mailbox") if $loglvl > 5;
X    }
X    $mailbox;
X}
X
X# Fork a new mailagent and update the pid in the perl.lock file. The parent
X# then exits and the child continues. This enables the filter which invoked
X# us to finally exit.
Xsub fork_child {
X    local($pid) = fork;
X    if ($pid == -1) {                # We cannot fork, exit.
X        &add_log("ERROR couldn't fork to process the queue") if $loglvl > 5;
X        unlink $lockfile if $locked;
X        exit 0;
X    } elsif ($pid == 0) {            # The child process
X        # Update the pid in the perl.lock file, so that any process which will
X        # use the kill(pid, 0) feature to check whether we are alive or not will
X        # get a meaningful status.
X        if ($locked) {
X            chmod 0644, $lockfile;
X            open(LOCK, ">$lockfile");    # Ignore errors
X            chmod 0444, $lockfile;        # Now it's open, so we may restore mode
X            print LOCK "$$\n";            # Write child's PID
X            close LOCK;
X        }
X        sleep(2);                    # Give filter time to clean up
X    } else {                        # Parent process
X        exit 0;                        # Exit without removing lock, of course
X    }
X    # Only the child comes here and returns
X    &add_log("mailagent continues") if $loglvl > 17;
X}
X
X# Report any eval error and returns 1 if error detected.
Xsub eval_error {
X    if ($@ ne '') {
X        $@ =~ s/ in file \(eval\) at line \d+//;
X        chop($@);
X        &add_log("ERROR $@") if $loglvl > 1;
X    }
X    $@ eq '' ? 0 : 1;
X}
X
X!NO!SUBS!
X$grep -v '^;#' pl/jobnum.pl >>magent
X$grep -v '^;#' pl/read_conf.pl >>magent
X$grep -v '^;#' pl/acs_rqst.pl >>magent
X$grep -v '^;#' pl/free_file.pl >>magent
X$grep -v '^;#' pl/add_log.pl >>magent
X$grep -v '^;#' pl/checklock.pl >>magent
X$grep -v '^;#' pl/lexical.pl >>magent
X$grep -v '^;#' pl/parse.pl >>magent
X$grep -v '^;#' pl/analyze.pl >>magent
X$grep -v '^;#' pl/runcmd.pl >>magent
X$grep -v '^;#' pl/filter.pl >>magent
X$grep -v '^;#' pl/matching.pl >>magent
X$grep -v '^;#' pl/locate.pl >>magent
X$grep -v '^;#' pl/rfc822.pl >>magent
X$grep -v '^;#' pl/macros.pl >>magent
X$grep -v '^;#' pl/header.pl >>magent
X$grep -v '^;#' pl/actions.pl >>magent
X$grep -v '^;#' pl/stats.pl >>magent
X$grep -v '^;#' pl/queue_mail.pl >>magent
X$grep -v '^;#' pl/pqueue.pl >>magent
X$grep -v '^;#' pl/builtins.pl >>magent
X$grep -v '^;#' pl/rules.pl >>magent
X$grep -v '^;#' pl/period.pl >>magent
X$grep -v '^;#' pl/eval.pl >>magent
X$grep -v '^;#' pl/dbr.pl >>magent
X$grep -v '^;#' pl/history.pl >>magent
X$grep -v '^;#' pl/once.pl >>magent
X$grep -v '^;#' pl/makedir.pl >>magent
X$grep -v '^;#' pl/emergency.pl >>magent
X$grep -v '^;#' pl/listqueue.pl >>magent
X$grep -v '^;#' pl/mbox.pl >>magent
X$grep -v '^;#' pl/context.pl >>magent
X$grep -v '^;#' pl/extern.pl >>magent
X$grep -v '^;#' pl/mailhook.pl >>magent
X$grep -v '^;#' pl/interface.pl >>magent
X$grep -v '^;#' pl/getdate.pl >>magent
X$grep -v '^;#' pl/include.pl >>magent
X$grep -v '^;#' pl/plural.pl >>magent
X$grep -v '^;#' pl/hostname.pl >>magent
X$grep -v '^;#' pl/mmdf.pl >>magent
X$grep -v '^;#' pl/compress.pl >>magent
X$grep -v '^;#' pl/newcmd.pl >>magent
X$grep -v '^;#' pl/q.pl >>magent
X$grep -v '^;#' pl/hook.pl >>magent
X$grep -v '^;#' pl/secure.pl >>magent
X$grep -v '^;#' pl/cmdserv.pl >>magent
X$grep -v '^;#' pl/power.pl >>magent
X$grep -v '^;#' pl/file_edit.pl >>magent
X$grep -v '^;#' pl/dynload.pl >>magent
X$grep -v '^;#' pl/gensym.pl >>magent
X$grep -v '^;#' pl/usrmac.pl >>magent
X$grep -v '^;#' pl/tilde.pl >>magent
X$grep -v '^;#' pl/mh.pl >>magent
Xchmod 755 magent
X$eunicefix magent
END_OF_FILE
  if test 19725 -ne `wc -c <'agent/magent.SH'`; then
    echo shar: \"'agent/magent.SH'\" unpacked with wrong size!
  fi
  chmod +x 'agent/magent.SH'
  # end of 'agent/magent.SH'
fi
if test -f 'agent/pl/dbr.pl' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'agent/pl/dbr.pl'\"
else
  echo shar: Extracting \"'agent/pl/dbr.pl'\" \(10634 characters\)
  sed "s/^X//" >'agent/pl/dbr.pl' <<'END_OF_FILE'
X;# $Id: dbr.pl,v 3.0 1993/11/29 13:48:39 ram Exp ram $
X;#
X;#  Copyright (c) 1990-1993, Raphael Manfredi
X;#
X;#  You may redistribute only under the terms of the Artistic License,
X;#  as specified in the README file that comes with the distribution.
X;#  You may reuse parts of this distribution only within the terms of
X;#  that same Artistic License; a copy of which may be found at the root
X;#  of the source tree for mailagent 3.0.
X;#
X;# $Log: dbr.pl,v $
X;# Revision 3.0  1993/11/29  13:48:39  ram
X;# Baseline for mailagent 3.0 netwide release.
X;#
X;#
X;# This is a simple database. Items are sorted by key, and have a tag
X;# associated with it. Both are necessary to access the database. Every record
X;# also carries a time stamp and associated values.
X;#
X;# The hashing is done like that: If the key is shorter than two characters,
X;# an X is appended. Then, let 'a' and 'b' be the first and second character of
X;# the name. Then the file 'b' is stored under directory 'a', and in 'b' there
X;# are entries with the following format (separtion is the TAB character).
X;#
X;#     key tag timestamp <values>
X;#
Xpackage dbr;
X
X# Compute the relative path under the once directory for a given name
Xsub hash_path {
X    local($hname) = @_;
X    # Ensure at least 2 characters. Fill in missing chars with 'X'.
X    $hname .= "X" if (length($hname) < 2);
X    $hname .= "X" if (length($hname) < 2);
X    $hname =~ s/[^A-Za-z0-9_]/X/g;    # Don't want funny chars in path name
X    # Get only the 2 first characters
X    local(@chars) = split(//, substr($hname, 0, 2));
X    '/' . join('/', @chars);
X}
X
X# Fetch the entry in a dbr file and return the value of the timestamp and
X# the line number in the file. Return (0,0) if no previous record was found
X# for the name/tag association. An error is signaled by (-1,0). A line number
X# different from 0, as in (0, 10), indicates that an entry was found but the
X# selection did not succeed. Note that the timestamp returned is > 0 iff the
X# entry was found and the selection was done completely.
X# All the attached values are returned at the end of the list. It is possible
X# to filter among those values by specifying a list of regular expressions, at
X# the end of the argument list. An empty regular expression means the item is
X# not to be filtered on (equivalent of '/.*/'). Expressions provided are
X# taken as exact values to be matched against unless they start with '/' or '&'.
X# A '/' denotes a regular expression to be applied, whilst '&' denotes function
X# to be called with the actual value argument: function should return zero
X# for rejection or any other value for selection.
Xsub info {
X    local($hname, $tag, @what) = @_;
X    local($file);                        # DBR file associated with '$hname'
X    local(@values);                        # Attached values to the item
X    local($_);
X    ($hname, $tag) = &default($hname, $tag);
X    $file = $cf'hashdir . &hash_path($hname);
X    return (0,0) unless -f "$file";
X    unless (open(DBR, $file)) {
X        &'add_log("ERROR could not open dbr file $file: $!") if $'loglvl;
X        return (-1, 0);
X    }
X    local($linenum) = 0;                # Value of line if found
X    local($timestamp) = 0;                # Associated time stamp
X    &'acs_rqst($file);                    # Lock file (avoid concurrent updating)
X    while (<DBR>) {
X        if (s/^(\S+)\s([\w-]+)\s(\d+)\t*//) {
X            next unless $1 eq $hname;
X            next unless $2 eq $tag;
X            $linenum = $.;                # Record line number
X            $timestamp = int($3);        # And timestamp
X            last if &match;                # Found it if matches @what filter
X            $timestamp = 0;                # Not found yet
X        } else {                        # Invalid entry
X            &'add_log("ERROR $file corrupted, line $.") if $'loglvl;
X            $timestamp = -1;            # Signals error
X            last;                        # Abort processing
X        }
X    }
X    &'free_file($file);                    # Remove lock on file
X    close DBR;                            # Close file
X    ($timestamp, $linenum, @values);    # Return item information
X}
X
X# Apply match from @what, and fill in @values as a side effect if matched.
Xsub match {
X    local(@target) = split(/\t|\n/);    # Get values from line
X    local($idx) = -1;                    # Index within @target
X    local($matched) = 1;                # Assume selection will match
X    local($res);                        # Eval result
X    local($@);                            # Eval error report string
X    foreach $what (@what) {
X        $idx++;                            # Advance in @target
X        next if $what eq '';            # Skip empty selection
X        if ($what =~ m|^/|) {            # Regular expression
X            $res = eval '$target[$idx] =~ ' . $what;
X            &'add_log("WARNING dbr error: $@") if $@ && $'loglvl > 5;
X            next if $@;
X            $matched = $res;
X        } elsif ($what =~ m|^&|) {        # Function to apply
X            $res = eval "$what('" . $target[$idx] . "')";
X            &'add_log("WARNING dbr error: $@") if chop($@) && $'loglvl > 5;
X            next if $@;
X            $matched = $res;
X        } else {                        # Regular string comparaison
X            $matched = $target[$idx] eq $what;
X        }
X        last unless $matched;
X    }
X    @values = @target if $matched;        # Fill in values if selection ok
X    $matched;                            # Return matching status
X}
X
X# Update the entry ($hname, $tag) in file to hold the current timestamp. If the
X# $linenum parameter is non-null, we know we may copy the old file until that
X# line (excluded), then replace the current line with the new timestamp.
X# If $linenum is null, then we may safely append the entry in the file. If
X# the $linenum parameter is 'undef', then the user does not have it precomputed
X# or wishes to have the line number re-computed.
X# The new values held in @values replace the old ones for the entry. If 'undef'
X# is given instead, then the corresponding entry is deleted from the database.
Xsub update {
X    local($hname, $tag, $linenum, @values) = @_;
X    local($now) = time;                    # Current time
X    local($file);                        # DBR file associated with '$hname'
X    local($_);
X    ($hname, $tag) = &default($hname, $tag);
X    $file = $cf'hashdir . &hash_path($hname);
X    unless (-f "$file") {
X        local($dirname) = $file =~ m|^(.*)/.*|;
X        &'makedir($dirname);
X    }
X    $linenum = (&info($hname, $tag))[1] unless defined($linenum);
X    if ($linenum == 0) {                # No entry previously recorded
X        return unless defined(@values);    # Nothing to delete
X        unless(open(DBR, ">>$file")) {
X            &'add_log("ERROR cannot append in $file: $!") if $'loglvl;
X            return;
X        }
X        &'acs_rqst($file);                # Lock file (avoid concurrent updating)
X        print DBR "$hname $tag $now\t";    # The name, command tag and timestamp
X        print DBR join("\t", @values);    # Associated values
X        print DBR "\n";
X        close DBR;
X        &'free_file($file);                # Remove lock on file
X    } else {                            # An entry existed already
X        unless (open(DBR, ">$file.x")) {
X            &'add_log("ERROR cannot create $file.x: $!") if $'loglvl;
X            return;
X        }
X        unless (open(OLD, "$file")) {
X            &'add_log("ERROR couldn't reopen $file: $!") if $'loglvl;
X            close DBR;
X            return;
X        }
X        &'acs_rqst($file);                # Lock file (avoid concurrent updating)
X        while (<OLD>) {
X            if ($. < $linenum) {        # Before line to update
X                print DBR;                # Print line verbatim
X            } elsif ($. == $linenum) {    # We reached line to be updated
X                next unless defined(@values);
X                print DBR "$hname $tag $now\t";
X                print DBR join("\t", @values);
X                print DBR "\n";
X            } else {                    # Past updating point
X                print DBR;                # Print line verbatim
X            }
X        }
X        close OLD;
X        close DBR;
X        unless (rename("$file.x", "$file")) {
X            &'add_log("ERROR cannot rename $file.x to $file: $!") if $'loglvl;
X        }
X        &'free_file($file);                # Remove lock on file
X    }
X}
X
X# Delete entry. This is really a wrapper to the more general update routine
X# and is provided as a convenience only.
Xsub delete {
X    local($hname, $tag, $linenum) = @_;
X    &update($hname, $tag, defined($linenum) ? $linenum : undef, undef);
X}
X
X# Make sure the hashing name and the tag are correct, or use default values.
Xsub default {
X    local($hname, $tag) = @_;
X    $hname =~ s/^\s+//;                    # Leading blanks would perturb dbr
X    $hname =~ s/\s/_/g;                    # All other spaces replaced by _
X    $hname = 'X' unless $hname;            # Hashing name cannot be empty
X    $tag =~ s/\s/_/g;                    # Tag has to be a single word
X    $tag = 'UNKNOWN' unless $tag;        # Tag cannot be empty
X    ($hname, $tag);
X}
X
X# Cleaning operation. Remove all the entries in the file whose timestamp is
X# older than the supplied date limit.
Xsub clean {
X    local($agemax) = @_;
X    local($limit) = time - $agemax;        # Everything newer is kept
X    &recursive_clean($cf'hashdir);        # Recursively scan directory
X}
X
X# Recursively scan the direcroy and deal with each file
Xsub recursive_clean {
X    local($dir) = @_;                    # Directory to scan
X    local(@contents);                    # Contents of the directory
X    unless (opendir(DIR, $dir)) {
X        &'add_log("WARNING cannot open directory $dir: $!") if $'loglvl > 5;
X        return;
X    }
X    @contents = readdir(DIR);            # Slurp the whole thing
X    closedir DIR;                        # And close dir, ready for recursion
X    local($_);
X    foreach (@contents) {
X        next if $_ eq '.' || $_ eq '..';
X        if (-d "$dir/$_") {
X            &recursive_clean("$dir/$_");
X            next;
X        }
X        &clean_file("$dir/$_");
X    }
X    unless (opendir(DIR, $dir)) {
X        &'add_log("WARNING cannot re-open directory $dir: $!") if $'loglvl > 5;
X        return;
X    }
X    @contents = readdir(DIR);            # Slurp the whole thing
X    closedir DIR;
X    unless (@contents > 2) {            # Has at least . and ..
X        unless (rmdir($dir)) {            # Don't leave empty directories
X            &'add_log("SYSERR rmdir: $!") if $'loglvl;
X            &'add_log("ERROR could not remove directory $dir") if $'loglvl;
X        }
X    }
X}
X
X# Clean single dbr file, using $limit as the oldest allowed time stamp
Xsub clean_file {
X    local($file) = @_;            # File to be cleaned
X    &'add_log("processing $file") if $'loglvl > 18;
X    unless (open(FILE, $file)) {
X        &'add_log("WARNING cannot open file $file: $!") if $'loglvl > 5;
X        return;
X    }
X    unless (open(NEW, ">$file.x")) {
X        &'add_log("ERROR cannot create $file.x: $!") if $'loglvl > 1;
X        close FILE;
X        return;
X    }
X    &'acs_rqst($file);            # Lock file to prevent concurrent mods
X    local($warns) = 0;            # Avoid cascade warnings
X    local($_, $.);
X    while (<FILE>) {
X        if (/^(\S+)\s([\w-]+)\s(\d+)\t*/) {
X            # Variable $limit was set in 'clean'
X            if ($3 > $limit) {            # File new enough
X                next if (print NEW);    # Copy line verbatim
X                &'add_log("SYSERR write: $!") if $'loglvl;
X                &'add_log("WARNING truncated $file at line $.") if $'loglvl > 5;
X                last;
X            }
X        } else {
X            # Skip bad lines, up to a maximum of 10
X            if (++$warns > 10) {
X                &'add_log("WARNING $file truncated at line $.") if $'loglvl > 5;
X                last;
X            } else {
X                &'add_log("NOTICE $file corrupted, line $.") if $'loglvl > 6;
X                next;
X            }
X        }
X    }
X    close FILE;
X    close NEW;
X    unless (rename("$file.x", $file)) {
X        &'add_log("ERROR cannot rename $file.x to $file: $!") if $'loglvl;
X    }
X    unless (-s "$file") {
X        unless (unlink($file)) {    # Don't leave empty files behind
X            &'add_log("SYSERR unlink: $!") if $'loglvl;
X            &'add_log("ERROR could not remove $file") if $'loglvl;
X        }
X    }
X    &'free_file($file);                # Remove lock on file
X}
X
Xpackage main;
X
END_OF_FILE
  if test 10634 -ne `wc -c <'agent/pl/dbr.pl'`; then
    echo shar: \"'agent/pl/dbr.pl'\" unpacked with wrong size!
  fi
  # end of 'agent/pl/dbr.pl'
fi
if test -f 'bin/perload' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'bin/perload'\"
else
  echo shar: Extracting \"'bin/perload'\" \(20834 characters\)
  sed "s/^X//" >'bin/perload' <<'END_OF_FILE'
X: # feed this into perl
X'/bin/true' && eval 'exec perl -S $0 "$@"'
X    if $running_under_some_shell;
X'di';
X'ig00';
X
X#
X# This perl script is its own manual page [generated by wrapman]
X#
X
X# $Id: perload,v 3.0 1993/11/29 13:50:28 ram Exp ram $
X#
X#  Copyright (c) 1990-1993, Raphael Manfredi
X#
X#  You may redistribute only under the terms of the Artistic License,
X#  as specified in the README file that comes with the distribution.
X#  You may reuse parts of this distribution only within the terms of
X#  that same Artistic License; a copy of which may be found at the root
X#  of the source tree for mailagent 3.0.
X#
X# $Log: perload,v $
X# Revision 3.0  1993/11/29  13:50:28  ram
X# Baseline for mailagent 3.0 netwide release.
X#
X
X# Replace each function definition in a loading section by two stubs and
X# reject the definition into the DATA part of the script if in a dataload
X# section or into a FILE if in an autoload section.
X
X$in_load = 0;                    # In a loading section
X$autoload = '';                    # Name of autoloaded file
X$has_invocation_stub = 0;        # True if we detect a #! stub
X$current_package = 'main';        # Current package
X$init_emitted = 0;                # True when dataloading stamp was emitted
X$in_function = 0;
X
Xrequire 'getopt.pl';
X&Getopt;
X
Xwhile (<>) {
X    if ($. == 1 && /^(:|#).*perl/) {    # Invocation stub
X        $has_invocation_stub = 1;
X        print;
X        next;
X    }
X    if ($. <= 3 && $has_invocation_stub) {
X        print;
X        next;
X    }
X    if (/^\s*$/) {
X        &flush_comment;
X        print unless $in_function;
X        print if $in_function && !$in_load;
X        if ($in_function && $in_load) {
X            push(@Data, "\n") unless $autoload;
X            $Auto{$autoload} .= "\n" if $autoload;
X        }
X        next;
X    }
X    if (/^\s*;?#/) {
X        if (/#\s*perload on/i) {        # Enter a loading section
X            print unless /:$/;
X            $in_load = 1;
X            next;
X        }
X        if (/#\s*perload off/i) {        # End a loading section
X            print unless /:$/;
X            $in_load = 0;
X            next;
X        }
X        if (/#\s*autoload (\S+)/i) {    # Enter autoloading section
X            print unless /:$/;
X            push(@autoload, $autoload);    # Directives may be nested
X            $autoload = $1;
X            $in_load += 2;
X            next;
X        }
X        if (/#\s*offload/i) {            # End autoloading section
X            print unless /:$/;
X            $autoload = pop(@autoload);    # Revert to previously active file
X            $in_load -= 2;
X            next;
X        }
X        &emit_init unless $init_emitted;
X        push(@Comment, $_) unless $in_function;
X        print if $in_function && !$in_load;
X        next unless $in_function;
X        push(@Data, $_) unless $autoload;
X        $Auto{$autoload} .= $_ if $autoload;
X        next;
X    }
X    &emit_init unless $init_emitted;
X    /^package (\S+)\s*;/ && ($current_package = $1);
X    unless ($in_load) {
X        &flush_comment;
X        print;
X        next;
X    }
X    # We are in a loading section
X    if (/^sub\s+([\w']+)\s*\{(.*)/) {
X        die "line $.: function $1 defined within another function.\n"
X            if $in_function;
X        # Silently ignore one-line functions
X        if (/\}/) {
X            &flush_comment;
X            print;
X            next;
X        }
X        $comment = $2;
X        $in_function = 1;
X        $function = $1;
X        ($fn_package, $fn_basename) = $function =~ /^(\w+)'(\w+)/;
X        unless ($fn_package) {
X            $fn_package = $current_package;
X            $fn_basename = $function;
X        }
X        # Keep leading function comment
X        foreach (@Comment) {
X            push(@Data, $_) unless $autoload;
X            $Auto{$autoload} .= $_ if $autoload;
X        }
X        @Comment = ();
X        # Change package context for correct compilation: the name is visible
X        # within the original function package while the body of the function
X        # is compiled within the current package.
X        $declaration = "sub $fn_package" . "'load_$fn_basename {$comment\n";
X        $package_context = "\tpackage $current_package;\n";
X        if ($autoload) {
X            $Auto{$autoload} .= $declaration . $package_context;
X        } else {
X            push(@Data, $declaration, $package_context);
X        }
X        # Emit stubs
X        print "sub $fn_package", "'$fn_basename";
X        print " { &auto_$fn_package", "'$fn_basename; }\n";
X        print "sub auto_$fn_package", "'$fn_basename { ";
X        print '&main\'dataload' unless $autoload;
X        print '&main\'autoload(' . "'$autoload'" . ', @_)' if $autoload;
X        print "; }\n";
X        next;
X    }
X    unless ($in_function) {
X        &flush_comment;
X        print;
X        next;
X    }
X    # We are in a loading section and inside a function body
X    push(@Data, $_) unless $autoload;
X    $Auto{$autoload} .= $_ if $autoload;
X    $in_function = 0 if /^\}/;
X    if (/^\}/) {
X        push(@Data, "\n") unless $autoload;
X        $Auto{$autoload} .= "\n" if $autoload;
X    }
X}
X
X@auto = keys %Auto;
Xif (@auto > 0) {
X    print &q(<<'EOC');
X:# Load the calling function from file and call it. This function is called
X:# only once per file to be loaded.
X:sub main'autoload {
X:    local($__file__) = shift(@_);
X:    local($__packname__) = (caller(1))[3];
X:    local($__rpackname__) = $__packname__;
X:    local($__saved__) = $@;
X:    $__rpackname__ =~ s/^auto_//;
X:    &perload'load_from_file($__file__);
X:    $__rpackname__ =~ s/'/'load_/;
X:    $@ = $__saved__;        # Restore value $@ had on entrance
X:    &$__rpackname__(@_);    # Call newly loaded function
X:}
X:
X:# Load file and compile it, substituing the second stub function with the
X:# loaded ones. Location of the file uses the @AUTO array.
X:sub perload'load_from_file {
X:    package perload;
X:    local($file) = @_;                # File to be loaded
X:    local($body) = ' ' x 1024;        # Pre-extent
X:    local($load) = ' ' x 256;        # Loading operations
X:    # Avoid side effects by protecting special variables which will be
X:    # changed by the autoloading operation.
X:    local($., $_, $@);
X:    $body = '';
X:    $load = '';
X:    &init_auto unless defined(@'AUTO);    # Make sure we have a suitable @AUTO
X:    &locate_file unless -f "$file";        # Locate file if relative path
X:    open(FILE, $file) ||
X:        die "Can't load $'__rpackname__ from $file: $!\n";
X:    while (<FILE>) {
X:        $load .= '*auto_' . $1 . '\'' . $2 . '= *' . $1 . '\'' . "load_$2;\n"
X:            if (/^sub\s+(\w+)'load_(\w+)\s*\{/);
X:        $body .= $_;
X:    }
X:    close FILE;
XEOC
X    if ($opt_t) {
X        print &q(<<'EOC');
X:    # Untaint body when running setuid
X:    $body =~ /^([^\0]*)/;
X:    # No need to untaint $load, as it was built using trusted variables
X:    eval $1 . $load;
XEOC
X    } else {
X        print &q(<<'EOC');
X:    eval $body . $load;
XEOC
X    }
X    print &q(<<'EOC');
X:    chop($@) && die "$@, while parsing code of $file.\n";
X:}
X:
X:# Initialize the @AUTO array. Attempt defining it by using the AUTOLIB
X:# environment variable if set, otherwise look in auto/ first, then in the
X:# current directory.
X:sub perload'init_auto {
X:    if (defined $ENV{'AUTOLIB'} && $ENV{'AUTOLIB'}) {
X:        @AUTO = split(':', $ENV{'AUTOLIB'});
X:    } else {
X:        @AUTO = ('auto', '.');
X:    }
X:}
X:
X:# Locate to-be-loaded file held in $file by looking through the @AUTO array.
X:# This variable, defined in 'load_from_file', is modified as a side effect.
X:sub perload'locate_file {
X:    package perload;
X:    local($fullpath);
X:    foreach $dir (@'AUTO) {
X:        $fullpath = $dir . '/' . $file;
X:        last if -f "$fullpath";
X:        $fullpath = '';
X:    }
X:    $file = $fullpath if $fullpath;        # Update var from 'load_from_file'
X:}
X:
XEOC
X}
X
Xif (@Data > 0) {
X    print &q(<<'EOC');
X:# Load the calling function from DATA segment and call it. This function is
X:# called only once per routine to be loaded.
X:sub main'dataload {
X:    local($__packname__) = (caller(1))[3];
X:    local($__rpackname__) = $__packname__;
X:    local($__at__) = $@;
X:    $__rpackname__ =~ s/^auto_//;
X:    &perload'load_from_data($__rpackname__);
X:    local($__fun__) = "$__rpackname__";
X:    $__fun__ =~ s/'/'load_/;
X:    eval "*$__packname__ = *$__fun__;";    # Change symbol table entry
X:    die $@ if $@;        # Should not happen
X:    $@ = $__at__;        # Restore value $@ had on entrance
X:    &$__fun__;            # Call newly loaded function
X:}
X:
X:# Load function name given as argument, fatal error if not existent
X:sub perload'load_from_data {
X:    package perload;
X:    local($pos) = $Datapos{$_[0]};            # Offset within DATA
X:    # Avoid side effects by protecting special variables which will be changed
X:    # by the dataloading operation.
X:    local($., $_, $@);
X:    $pos = &fetch_function_code unless $pos;
X:    die "Function $_[0] not found in data section.\n" unless $pos;
X:    die "Cannot seek to $pos into data section.\n"
X:        unless seek(main'DATA, $pos, 0);
X:    local($/) = "\n}";
X:    local($body) = scalar(<main'DATA>);
X:    local($*) = 1;
X:    die "End of file found while loading $_[0].\n" unless $body =~ /^\}$/;
XEOC
X    if ($opt_t) {
X        print &q(<<'EOC');
X:    # Untaint body when running setuid
X:    $body =~ /^([^\0]*)/;
X:    # Now we may safely eval it without getting an insecure dependency
X:    eval $1;        # Load function into perl space
XEOC
X    } else {
X        print &q(<<'EOC');
X:    eval $body;        # Load function into perl space
XEOC
X    }
X    print &q(<<'EOC');
X:    chop($@) && die "$@, while parsing code of $_[0].\n";
X:}
X:
XEOC
X    print &q(<<'EOC') unless $opt_o;
X:# Parse text after the END token and record defined loadable functions (i.e.
X:# those whose name starts with load_) into the %Datapos array. Such function
X:# definitions must be left adjusted. Stop as soon as the function we want
X:# has been found.
X:sub perload'fetch_function_code {
X:    package perload;
X:    local($pos) = tell main'DATA;
X:    local($in_function) = 0;
X:    local($func_name);
X:    local($., $_);
X:    while (<main'DATA>) {
X:        if (/^sub\s+(\w+)'load_(\w+)\s*\{/) {
X:            die "DATA line $.: function $1'$2 defined within $func_name.\n"
X:                if $in_function;
X:            $func_name = $1 . '\'' . $2;
X:            $Datapos{$func_name} = $pos;
X:            $in_function = 1;
X:            next;
X:        }
X:        $in_function = 0 if /^\}/;
X:        next if $in_function;
X:        return $pos if $func_name eq $_[0];
X:        $pos = tell main'DATA;
X:    }
X:    0;        # Function not found
X:}
X:
XEOC
X    print &q(<<'EOC') if $opt_o;
X:# This function is called only once, and fills in the %Datapos array with
X:# the offset of each of the dataloaded routines held in the data section.
X:sub perload'fetch_function_code {
X:    package perload;
X:    local($start) = 0;
X:    local($., $_);
X:    while (<main'DATA>) {            # First move to start of offset table
X:        next if /^#/;
X:        last if /^$/ && ++$start > 2;    # Skip two blank line after end token
X:    }
X:    $start = tell(main'DATA);        # Offsets in table are relative to here
X:    local($key, $value);
X:    while (<main'DATA>) {            # Load the offset table
X:        last if /^$/;                # Ends with a single blank line
X:        ($key, $value) = split(' ');
X:        $Datapos{$key} = $value + $start;
X:    }
X:    $Datapos{$_[0]};        # All that pain to get this offset...
X:}
X:
XEOC
X    print &q(<<'EOC');
X:#
X:# The perl compiler stops here.
X:#
X:
X:__END__
X:
X:#
X:# Beyond this point lie functions we may never compile.
X:#
X:
XEOC
X    # Option -o directs us to optimize the function location by emitting an
X    # offset table, which lists all the position within DATA for each possible
X    # dataloaded routine.
X    if ($opt_o) {
X        print &q(<<'EOC');
X:#
X:# DO NOT CHANGE A IOTA BEYOND THIS COMMENT!
X:# The following table lists offsets of functions within the data section.
X:# Should modifications be needed, change original code and rerun perload
X:# with the -o option to regenerate a proper offset table.
X:#
X:
XEOC
X        $trailing_message = &q(<<'EOC');
X:
X:#
X:# End of offset table and beginning of dataloading section.
X:#
X:
XEOC
X        $pos = 0;            # Offset relative to this point (start of table)
X        foreach (@Data) {
X            $Datapos{"$1\'$2"} = $pos - $now
X                if /^sub\s+(\w+)'load_(\w+)\s*\{/;    # } for vi
X            $pos += length;
X        }
X        @poskeys = keys %Datapos;    # Array of routine names (fully qualified)
X
X        # Write out a formatted table, each entry stored on $entry bytes and
X        # formatted with the $format string.
X        ($entry, $format) = &get_format(*poskeys);
X
X        # The total size occupied by the table is the size of one item times
X        # the number of items plus the final trailing message at the end of
X        # the table.
X        $table_size = $entry * @poskeys + length($trailing_message);
X
X        # Output formatted table
X        foreach (sort @poskeys) {
X            printf($format, $_, $table_size + $Datapos{$_});
X        }
X        print $trailing_message;
X    }
X
X    # Output code for each dataloaded function
X    foreach (@Data) {
X        print;
X    }
X    print &q(<<'EOC');
X:#
X:# End of dataloading section.
X:#
X:
XEOC
X}
X
Xif (@auto > 0) {
X    mkdir('auto',0755) unless -d 'auto';
X    foreach $file (@auto) {
X        unless (open(AUTO, ">auto/$file")) {
X            warn "Can't create auto/$file: $!\n";
X            next;
X        }
X        print AUTO &q(<<'EOC');
X:# This file was generated by perload
X:
XEOC
X        print AUTO $Auto{$file};
X        close AUTO;
X    }
X}
X
X# Compute optimum format for routine offset table, returning both the size of
X# each entry and the formating string for printf.
Xsub get_format {
X    local(*names) = @_;
X    local($name_len) = 0;
X    local($max_len) = 0;
X    foreach (@names) {
X        $name_len = length;
X        $max_len = $name_len if $name_len > $max_len;
X    }
X    # The size of each entry (preceded by one tab, followed by 12 chars)
X    $name_len = $max_len + 1 + 12;
X    ($name_len, "\t%${max_len}s %10d\n");
X}
X
Xsub emit_init {
X    print &q(<<'EOC');
X:#
X:# This perl program uses dynamic loading [generated by perload]
X:#
X:
XEOC
X    $init_emitted = 1;
X}
X
Xsub flush_comment {
X    print @Comment if @Comment > 0;
X    @Comment = ();
X}
X
Xsub q {
X    local($_) = @_;
X    local($*) = 1;
X    s/^://g;
X    $_;
X}
X
X#
X# These next few lines are legal in both perl and nroff.
X#
X
X.00;        # finish .ig
X
X'di            \" finish diversion--previous line must be blank
X.nr nl 0-1    \" fake up transition to first page again
X.nr % 0        \" start at page 1
X'; __END__    \" the perl compiler stops here
X
X'''
X''' From here on it's a standard manual page.
X'''
X
X.TH PERLOAD 1 "June 20, 1992"
X.AT 3
X.SH NAME
Xperload \- builds up autoloaded and dataloaded perl scripts
X.SH SYNOPSIS
X.B perload
X[ \fB\-ot\fR ]
X[ \fIfile\fR ]
X.SH DESCRIPTION
X.I Perload
Xtakes a perl script as argument (or from stdin if no argument is supplied)
Xand prints out on stdout an equivalent script set-up to perform autoloading
Xor dataloading. The translation is directed by special comments within the
Xoriginal script. Using dynamic loading can drastically improve start-up
Xperformances, both in time and in memory, as perl does not need to compile
Xthe whole script nor store its whole compiled form in memory.
X.PP
X.I Autoloading
Xdelays compilation of some functions until they are needed. The code for these
Xfunctions is loaded dynamically at run-time. The atomicity of loading is a
Xfile, which means that putting more than one function into a file will cause
Xall these functions to be loaded and compiled as soon as one among them is
Xneeded.
X.PP
X.I Dataloading
Xis a form of autoloading where no extra file are needed. The script carries
Xall the functions whose compilation is to be delayed in its data segment
X(in the \fIperl\fR sense, i.e. they are accessible via the DATA filehandle).
XThe scripts parses the data segment and extracts only the code for the needed
Xsubroutine, which means granularity is better than with autloading.
X.PP
XIt is possible for a single script to use both autoloading and dataloading at
Xthe same time. However, it should be noted that a script using only dataloading
Xis self contained and can be moved or shared accross different platforms without
Xfear. On the contrary, a script using only autoloading relies on some externally
Xprovided files. Sharing this script among different platforms requires sharing
Xof these external files. The script itself cannot be redistributed without
Xalso giving the extra files holding the autoloaded functions.
X.PP
XThe major drawback with dataloading is that the DATA filehandle cannot be used
Xfor anything else and may result in code duplication when two scripts could
Xshare the same pieces of code. Autoloading appears as the perfect solution in
Xthis case since two scripts may freely share the same functions without
Xactually duplicating them on the disk (hence saving some precious disk blocks
X:-).
X.SH CRITERIA
XFunctions to be dataloaded or autoloaded must meet the following layout
Xcriteria:
X.TP 5
X\-
XThey must not be one-line functions like \fIsub sorter { $a <=> $b }\fR.
XThose functions are simply output verbatim, as they are already so
Xsmall that it would not be worth to dynamically load them,
X.TP
X\-
XThe first line must be of the form \fIsub routine_name {\fR, with an optional
Xcomment allowed after the '{'.
X.TP
X\-
XThe function definition must end with a single '}' character left aligned.
X.TP
X\-
XPackage directives outside any function must be left aligned.
X.PP
XAll the above restrictions should not be source of a problem if "standard"
Xwriting style is used. There are also some name restrictions: the package
Xname \fIperload\fR is reserved, as is the \fI@AUTO\fR array when autoloading
Xis used. Packages must not start with \fIauto_\fR, as this is prepended to
Xuser's package names when building the stubs. Furthermore, the subroutines
Xnames \fImain'autoload\fR and
X\fImain'dataload\fR must not be used by the original script. Again, these
Xshould not cause any grief.
X.SH DIRECTIVES
XThe translation performed by
X.I Perload
Xis driven by some special comment directives placed directly within the code.
XEnding those directives with a ':' character will actually prevent them from
Xbeing output into the produced script. Case is irrelevant for all the directives
Xand the comment need not be left-aligned, although it must be the first
Xnon-space item on the line.
X.PP
XThe following directives are available:
X.TP 10
X# Perload ON
XTurns on the \fIperload\fR processing. Any function definition which meets
Xthe criteria listed in the previous section will be replaced by two stubs and
Xits actual definition will be rejected into the data segment (default) or a
Xfile when inside an autoloading section.
X.TP
X# Perload OFF
XTurns off any processing. The script is written as-is on the standard output.
X.TP
X# Autoload \fIpath\fR
XRequests autoloading from file \fIpath\fR, which may be an absolute path or
Xa relative path. The file will be located at run-time using the @AUTO array
Xif a non-absolute path is supplied or if the file does not exist as listed.
XAutoloading directives may be nested.
X.TP
X# Offload \fIpath\fR
XThe argument is not required. The directive ends the previous autoloading
Xdirective (the inmost one). This does not turn off the \fIperload\fR processing
Xthough. The \fIpath\fR name is optional here (in fact, it has only a comment
Xvalue).
X.SH OPTIONS
XPerload accepts only two options. Using \fB\-o\fR is meaningful only when
Xdataloading is used. It outputs an offset table which lists the relative
Xoffset of the dataloaded functions within the data section. This will spare
Xperl the run-time parsing needed to locate the function, and results in an good
Xspeed gain. However, it has one major drawback: it prevents people from
Xactually modifying the source beyond the start of the table. But anything
Xbefore can be freely edited, which is particulary useful when tailoring the
Xscript.
X.PP
XThis option should not be used when editing of functions within the data
Xsection is necessary for whatever reason. When \fB\-o\fR is used, any
Xchange in the dataloaded function must be committed by re-running perload
Xon the original script.
X.PP
XThe other option \fB\-t\fR is to be used when producing a script which is
Xgoing to run setuid. The body of the loaded function is untainted before being
Xfed to eval, which slightly slows down loading (the first time the function is
Xcalled), but avoids either an insecure dependency report or weird warnings from
Xtaintperl stating something is wrong (which is the behaviour with 4.0 PL35).
X.SH FILES
X.TP 10
Xauto
Xthe subdirectory where all produced autoloaded files are written.
X.SH ENVIRONMENT
XNo environment variables are used by \fIperload\fR. However, the autoloaded
Xversion of the script pays attention to the \fIAUTOLIB\fR variable as a colon
Xseparated set of directories where the to-be-loaded files are to be found
Xwhen a non-absolute path was specified. If the \fIAUTOLIB\fR variable is not
Xset, the default value 'auto:.' is used (i.e. look first in the auto/
Xsubdirectory, then in the current directory.
X.SH CAVEAT
XSpecial care is required when using an autoloading script, especially when
Xexecuted by the super-user: it would be very easy for someone to leave a
Xspecial version of a routine to be loaded, in the hope the super-user (or
Xanother suitable target) executes the autoloaded version of the script with
Xsome \fIad hoc\fR changes...
X.PP
XThe directory holding the to-be-loaded files should therefore be protected
Xagainst unauthorized access, and no file should have write permission on them.
XThe directory itself should not be world-writable either, or someone might
Xsubstitute his own version.
XIt should also be considered wise to manually set the @AUTO variable to a
Xsuitable value within the script itself.
X.PP
XThe \fB\-o\fR option uses \fIperl\fR's special variable \fI$/\fR with a
Xmulti-character value. I suspect this did not work with versions of \fIperl\fR
Xprior to 4.0, so any script using this optimized form of dataloading will not
Xbe 100% backward compatible.
X.SH AUTHOR
XRaphael Manfredi <[e-mail]>
X.SH CREDITS
XValuable input came from Wayne H. Scott <[e-mail]>. He is
Xmerely the author of the optimizing offset table (\fB\-o\fR option).
X.PP
X.I Perload
Xis based on an article from Tom Christiansen <[e-mail]>,
X.I Autoloading in Perl,
Xexplaining the concept of dataloading and giving a basic implementation.
X.SH "SEE ALSO"
Xperl(1).
END_OF_FILE
  if test 20834 -ne `wc -c <'bin/perload'`; then
    echo shar: \"'bin/perload'\" unpacked with wrong size!
  fi
  chmod +x 'bin/perload'
  # end of 'bin/perload'
fi
if test -f 'misc/unkit/kitok.msg' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'misc/unkit/kitok.msg'\"
else
  echo shar: Extracting \"'misc/unkit/kitok.msg'\" \(161 characters\)
  sed "s/^X//" >'misc/unkit/kitok.msg' <<'END_OF_FILE'
XSubject: Kit %-(name) is available
X
XThe %-(parts) parts of the %-(name) kit package
Xhave been successfully unpacked in %-(kitdir).
X
X-- mailagent speaking for %u
END_OF_FILE
  if test 161 -ne `wc -c <'misc/unkit/kitok.msg'`; then
    echo shar: \"'misc/unkit/kitok.msg'\" unpacked with wrong size!
  fi
  # end of 'misc/unkit/kitok.msg'
fi
echo shar: End of archive 10 \(of 26\).
cp /dev/null ark10isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 26 archives.
    echo "Now run 'sh PACKNOTES', then read README and type Configure.'"
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still must unpack the following archives:
    echo "        " ${MISSING}
fi
exit 0

exit 0 # Just in case...