mmuegel

早期freebsd实现

;#    mqueue.pl - functions to work with the sendmail queue
;#
;# DESCRIPTION
;#    Both Get_Queue_IDs and Parse_Control_File are available to get 
;#    information about the sendmail queue. The cqueue program is a good
;#    example of how these functions work.
;#
;# AUTHOR
;#    Michael S. Muegel ([e-mail])  
;#
;# RCS INFORMATION
;#    mmuegel
;#    /usr/local/ustart/src/mail-tools/dist/foo/libs/mqueue.pl,v
;#    1.1 of 1993/07/28 08:07:19
X
package mqueue;
X
;###############################################################################
;# Get_Queue_IDs
;#
;# Will figure out the queue IDs in $Queue that have both control and data
;# files. They are returned in @Valid_IDs. Those IDs that have a
;# control file and no data file are saved to the array globbed by 
;# *Missing_Control_IDs. Likewise, those IDs that have a data file and no 
;# control file are saved to the array globbed by *Missing_Data_IDs.
;#
;# If $Skip_Locked is true they a message that has a lock file is skipped
;# and will not show up in any of the arrays.
;#
;# If everything went AOK then $Status is 1; otherwise, $Status is 0 and
;# $Msg tells what went wrong.
;#
;# Globals:
;#    None
;#
;# Arguments:
;#    $Queue, $Skip_Locked, *Missing_Control_IDs, *Missing_Data_IDs
;#
;# Returns:
;#    $Status, $Msg, @Valid_IDs
;###############################################################################
sub main'Get_Queue_IDs
{
X   local ($Queue, $Skip_Locked, *Missing_Control_IDs, 
X          *Missing_Data_IDs) = @_;
X   local (*QUEUE, @Files, %Lock_IDs, %Data_IDs, %Control_IDs, $_);
X
X   # Make sure that the * argument @arrays ar empty
X   @Missing_Control_IDs = @Missing_Data_IDs = ();
X
X   # Save each data, lock, and queue file in @Files
X   opendir (QUEUE, $Queue) || return (0, "error getting directory listing of $Queue");
X   @Files = grep (/^(df|lf|qf)/, readdir (QUEUE));
X   closedir (QUEUE);
X   
X   # Create indexed list of data and control files. IF $Skip_Locked is true
X   # then skip either if there is a lock file present.
X   if ($Skip_Locked)
X   {
X      grep ((s/^lf//) && ($Lock_IDs {$_} = 1), @Files);
X      grep ((s/^df//) && (! $Lock_IDs {$_}) && ($Data_IDs {$_} = 1), @Files);
X      grep ((s/^qf//) && (! $Lock_IDs {$_}) && ($Control_IDs {$_} = 1), @Files);
X   }
X   else
X   {
X      grep ((s/^df//) && ($Data_IDs {$_} = 1), @Files);
X      grep ((s/^qf//) && ($Control_IDs {$_} = 1), @Files);
X   };
X   
X   # Find missing control and data files and remove them from the lists of each
X   @Missing_Control_IDs = sort (grep ((! $Control_IDs {$_}) && (delete $Data_IDs {$_}), keys (%Data_IDs)));
X   @Missing_Data_IDs = sort (grep ((! $Data_IDs {$_} && (delete $Control_IDs {$_})), keys (%Control_IDs)));
X   
X   
X   # Return the IDs in an appartently random order
X   return (1, "", keys (%Control_IDs));
};
X
X
;###############################################################################
;# Parse_Control_File
;#
;# Will pase a sendmail queue control file for useful information. See the
;# Sendmail Installtion and Operation Guide (SMM:07) for a complete
;# explanation of each field.
;#
;# The following globbed variables are set (or cleared) by this function:
;#
;#    $Sender           The sender's address. 
;#
;#    @Recipients       One or more addresses for the recipient of the mail.
;#
;#    @Errors_To        One or more addresses for addresses to which mail
;#                      delivery errors should be sent.
;#
;#    $Creation_Time    The job creation time in time(3) format. That is,
;#                      seconds since 00:00:00 GMT 1/1/70.
;#
;#    $Priority         An integer representing the current message priority.
;#                      This is used to order the queue. Higher numbers mean 
;#                      lower priorities.
;#
;#    $Status_Message   The status of the mail message. It can contain any
;#                      text.
;#
;#    @Headers          Message headers unparsed but in their original order.
;#                      Headers that span multiple lines are not mucked with,
;#                      embedded \ns will be evident.
;#
;# In all e-mail addresses bounding <> pairs are stripped.
;#
;# If everything went AOK then $Status is 1. If the message with queue ID
;# $Queue_ID just does not exist anymore -1 is returned. This is very
;# possible and should be allowed for. Otherwise, $Status is 0 and $Msg 
;# tells what went wrong.
;#
;# Globals:
;#    None
;#
;# Arguments:
;#    $Queue, $Queue_ID, *Sender, *Recipients, *Errors_To, *Creation_Time, 
;#    *Priority, *Status_Message, *Headers
;#
;# Returns:
;#    $Status, $Msg
;###############################################################################
sub main'Parse_Control_File
{
X   local ($Queue, $Queue_ID, *Sender, *Recipients, *Errors_To, *Creation_Time,
X          *Priority, *Status_Message, *Headers) = @_;
X   local (*Control, $_, $Not_Empty);
X
X   # Required variables and the associated control. If empty at the end of
X   # parsing we return a bad status.
X   @REQUIRED_INFO = ('$Creation_Time', 'T', '$Sender', 'S', '@Recipients', 'R',
X		     '$Priority', 'P');
X
X   # Open up the control file for read
X   $Control = "$Queue/qf$Queue_ID";
X   if (! open (Control)) 
X   {
X      return (-1) if ((-x $Queue) && (! -f "$Queue/qf$Queue_ID") &&
X       (! -f "$Queue/df$Queue_ID"));
X      return (0, "error opening $Control for read: $!");
X   };
X
X   # Reset the globbed variables just in case
X   $Sender = $Creation_Time = $Priority = $Status_Message = "";
X   @Recipients = @Errors_To = @Headers = ();
X
X   # Look for a few things in the control file
X   READ: while (<Control>)
X   {
X      $Not_Empty = 1;
X      chop;
X
X      PARSE:
X      {
X         if (/^T(\d+)$/)
X         {
X            $Creation_Time = $1;
X         }
X         elsif (/^S(<)?([^>]+)/)
X         {
X            $Sender = $2;
X         }
X         elsif (/^R(<)?([^>]+)/)
X         {
X            push (@Recipients, $2);
X         }
X         elsif (/^E(<)?([^>]+)/)
X         {
X            push (@Errors_To, $2);
X         }
X         elsif (/^M(.*)/)
X         {
X            $Status_Message = $1;
X         }
X         elsif (/^P(\d+)$/)
X         {
X            $Priority = $1;
X         }
X         elsif (/^H(.*)/)
X         {
X            $Header = $1;
X            while (<Control>)
X            {
X               chop;
X               last if (/^[A-Z]/);
X               $Header .= "\n$_";
X            };
X            push (@Headers, $Header);
X	    redo PARSE if ($_);
X	    last if (eof);
X         };
X      };
X   };
X
X   # If the file was empty scream bloody murder
X   return (0, "empty control file") if (! $Not_Empty);
X
X   # Yell if we could not find a required field
X   while (($Var, $Control) = splice (@REQUIRED_INFO, 0, 2))
X   {
X      eval "return (0, 'required control field $Control not found')
X	       if (! $Var)";
X      return (0, "error checking \$Var: $@") if ($@);
X   };
X
X   # Everything went AOK
X   return (1);
};
X
1;
SHAR_EOF
chmod 0444 libs/mqueue.pl ||
echo 'restore of libs/mqueue.pl failed'
Wc_c="`wc -c < 'libs/mqueue.pl'`"
test 6908 -eq "$Wc_c" ||
	echo 'libs/mqueue.pl: original size 6908, current size' "$Wc_c"
fi
# ============= libs/newgetopts.pl ==============
if test -f 'libs/newgetopts.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping libs/newgetopts.pl (File already exists)'
else
echo 'x - extracting libs/newgetopts.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'libs/newgetopts.pl' &&
;# NAME
;#    newgetopts.pl - a better newgetopt (which is a better getopts which is
;#                    a better getopt ;-)
;#
;# AUTHOR
;#    Mike Muegel ([e-mail])
;#
;# mmuegel
;# /usr/local/ustart/src/mail-tools/dist/foo/libs/newgetopts.pl,v 1.1 1993/07/28 08:07:19 mmuegel Exp
X
;###############################################################################
;# New_Getopts
;#
;# Does not care about order of switches, options, and arguments like 
;# getopts.pl. Thus all non-switches/options will be kept in ARGV even if they
;# are not at the end. If $Pass_Invalid is set all unkown options will be
;# passed back to the caller by keeping them in @ARGV. This is useful when
;# parsing a command line for your script while ignoring options that you
;# may pass to another script. If this is set New_Getopts tries to maintain 
;# the switch clustering on the unkown switches.
;#
;# Accepts the special argument -usage to print the Usage string. Also accepts 
;# the special option -version which prints the contents of the string 
;# $VERSION. $VERSION may or may not have an embeded \n in it. If -usage 
;# or -version are specified a status of -1 is returned. Note that the usage
;# option is only accepted if the usage string is not null.
;# 
;# $Switches is just like the formal arguemnt of getopts.pl. $Usage is a usage
;# string with or without a trailing \n. *Switch_To_Order is an optional
;# pointer to the name of an associative array which will contain a mapping of
;# switch names to the order in which (if at all) the argument was entered.
;#
;# For example, if @ARGV contains -v, -x, test:
;#
;#    $Switch_To_Order {"v"} = 1;
;#    $Switch_To_Order {"x"} = 2;
;#
;# Note that in the case of multiple occurances of an option $Switch_To_Order
;# will store each occurance of the argument via a string that emulates
;# an array. This is done by using join ($;, ...). You can retrieve the
;# array by using split (/$;/, ...).
;#
;# *Split_ARGV is an optional pointer to an array which will conatin the
;# original switches along with their values. For the example used above 
;# Split_ARGV would contain:
;#
;#   @Split_ARGV = ("v", "", "x", "test");
;#
;# Another exciting ;-) feature that newgetopts has. Along with creating the 
;# normal $opt_ scalars for the last value of an argument the list @opt_ is 
;# created. It is an array which contains all the values of arguments to the 
;# basename of the variable. They are stored in the order which they occured 
;# on the command line starting with $[. Note that blank arguments are stored 
;# as "". Along with providing support for multiple options on the command 
;# line this also provides a method of counting the number of times an option 
;# was specified via $#opt_.
;#
;# Automatically resets all $opt_, @opt_, %Switch_To_Order, and @Split_ARGV
;# variables so that New_Getopts may be called more than once from within
;# the same program. Thus, if $opt_v is set upon entry to New_Getopts and 
;# -v is not in @ARGV $opt_v will not be set upon exit.
;#
;# Arguments:
;#    $Switches, $Usage, $Pass_Invalid, *Switch_To_Order, *Split_ARGV
;#
;# Returns:
;#    -1, 0, or 1 depending on status (printed Usage/Version, OK, not OK)
;###############################################################################
sub New_Getopts 
{
X    local($taint_argumentative, $Usage, $Pass_Invalid, *Switch_To_Order,
X          *Split_ARGV) = @_;
X    local(@args,$_,$first,$rest,$errs, @leftovers, @current_leftovers,
X          %Switch_Found);
X    local($[, $*, $Script_Name, $argumentative);
X
X    # Untaint the argument cluster so that we can use this with taintperl
X    $taint_argumentative =~ /^(.*)$/;
X    $argumentative = $1;
X
X    # Clear anything that might still be set from a previous New_Getopts
X    # call.
X    @Split_ARGV = ();
X
X    # Get the basename of the calling script
X    ($Script_Name = $0) =~ s/.*\///;
X    
X    # Make Usage have a trailing \n
X    $Usage .= "\n" if ($Usage !~ /\n$/);
X
X    @args = split( / */, $argumentative );
X
X    # Clear anything that might still be set from a previous New_Getopts call.
X    foreach $first (@args)
X    {
X       next if ($first eq ":");
X       delete $Switch_Found {$first};
X       delete $Switch_To_Order {$first};
X       eval "undef \@opt_$first; undef \$opt_$first;";
X    };
X
X    while (@ARGV)
X    {
X        # Let usage through
X        if (($ARGV[0] eq "-usage") && ($Usage ne "\n"))
X        {
X           print $Usage;
X           exit (-1);
X        }
X
X        elsif ($ARGV[0] eq "-version")
X        {
X           if ($VERSION)
X           {
X              print $VERSION;
X              print "\n" if ($VERSION !~ /\n$/);
X           }
X           else
X           {
X              warn "${Script_Name}: no version information available, sorry\n";
X           }
X           exit (-1);
X        }
X
X        elsif (($_ = $ARGV[0]) =~ /^-(.)(.*)/)
X        {
X           ($first,$rest) = ($1,$2);
X           $pos = index($argumentative,$first);
X
X           $Switch_To_Order {$first} = join ($;, split (/$;/, $Switch_To_Order {$first}), ++$Order);
X
X           if($pos >= $[) 
X           {
X               if($args[$pos+1] eq ':') 
X               {
X                   shift(@ARGV);
X                   if($rest eq '') 
X                   {
X                       $rest = shift(@ARGV);
X                   }
X
X                   eval "\$opt_$first = \$rest;";
X                   eval "push (\@opt_$first, \$rest);";
X                   push (@Split_ARGV, $first, $rest);
X               }
X               else 
X               {
X                   eval "\$opt_$first = 1";
X                   eval "push (\@opt_$first, '');";
X                   push (@Split_ARGV, $first, "");
X
X                   if($rest eq '') 
X                   {
X                       shift(@ARGV);
X                   }
X                   else 
X                   {
X                       $ARGV[0] = "-$rest";
X                   }
X               }
X           }
X
X           else 
X           {
X               # Save any other switches if $Pass_Valid
X               if ($Pass_Invalid)