config root man

Current Path : /compat/linux/proc/68247/cwd/usr/local/majordomo/

FreeBSD hs32.drive.ne.jp 9.1-RELEASE FreeBSD 9.1-RELEASE #1: Wed Jan 14 12:18:08 JST 2015 root@hs32.drive.ne.jp:/sys/amd64/compile/hs32 amd64
Upload File :
Current File : //compat/linux/proc/68247/cwd/usr/local/majordomo/majordomo.pl

# General subroutines for Majordomo

# $Source: /sources/cvsrepos/majordomo/majordomo.pl,v $
# $Revision: 1.58 $
# $Date: 2000/01/07 12:32:04 $
# $Author: cwilson $
# $State: Exp $
# 
# $Header: /sources/cvsrepos/majordomo/majordomo.pl,v 1.58 2000/01/07 12:32:04 cwilson Exp $
# 

# The exit codes for abort.  Look in /usr/include/sysexits.h.
#
$EX_DATAERR = 65;
$EX_TEMPFAIL = 75;
$EX_NOUSER = 67;

package Majordomo;

$DEBUG = $main'DEBUG;

#  Mail header hacking routines for Majordomo
#
#  Derived from:
#  Routines to parse out an RFC 822 mailheader
#     E. H. Spafford,  last mod: 11/91
#  
#  ParseMailHeader breaks out the header into an % array
#    indexed by a lower-cased keyword, e.g.
#       &ParseMailHeader(STDIN, *Array);
#	use $Array{'subject'}
#
#    Note that some duplicate lines (like "Received:") will get joined
#     into a single entry in %Array; use @Array if you want them separate
#    $Array will contain the unprocessed header, with embedded
#     newlines
#    @Array will contain the header, one line per entry
#
#  RetMailAddr tries to pull out the "preferred" return address
#    based on the presence or absence of various return-reply fields


#  Call as &ParseMailHeader(FileHandle, *array)

sub main'ParseMailHeader  ## Public
{
    local($save1, $save2) = ($*, $/);
    local($FH, *array) =  @_;
    local ($keyw, $val);

    %array = ();

    # force unqualified filehandles into callers' package
    local($package) = caller;
    $FH =~ s/^[^':]+$/$package'$&/;

    ($*, $/) = (1, '');
    $array = $_ = <$FH>;
    s/\n\s+/ /g;
       
    @array = split('\n');
    foreach $_ (@array)
    {
	($keyw, $val) = m/^([^:]+):\s*(.*\S)\s*$/g;
	$keyw =~ y/A-Z/a-z/;
	if (defined($array{$keyw})) {
	    $array{$keyw} .= ", $val";
	} else {
	    $array{$keyw} = $val;
	}
    }
    ($*, $/) = ($save1, $save2); 
}


#  Call as $addr = &RetMailAddr(*array)
#    This assumes that the header is in RFC 822 format
# We used to strip the raw address from the header here, but the address is
# stripped again before it gets to the mailer and we may want to use the
# whole thing when we do a subscription.
sub main'RetMailAddr  ## Public
{
    local(*array) = @_;

    local($ReplyTo) = defined($array{'reply-to'}) ?
		$array{'reply-to'} : $array{'from'};

    $ReplyTo = $array{'apparently-from'} unless $ReplyTo;

    $ReplyTo;
}

# @addrs = &ParseAddrs($addr_list)
sub main'ParseAddrs {
    local($_) = shift;
    1 while s/\([^\(\)]*\)//g; 		# strip comments
    1 while s/"[^"]*"\s//g;		# strip comments"
    split(/,/);				# split into parts
    foreach (@_) {
	1 while s/.*<(.*)>.*/$1/;
	s/^\s+//;
	s/\s+$//;
    }

    @_;
}

# Check to see if a list is valid.  If it is, return the validated list
# name; if it's not, return ""
sub main'valid_list {
    local($listdir) = shift;
    # start with a space-separated list of the rest of the arguments
    local($taint_list) = join(" ", @_);
    # strip harmless matched leading and trailing angle brackets off the list
    1 while $taint_list =~ s/^<(.*)>$/$1/;
    # strip harmless trailing "@.*" off the list
    $taint_list =~ s/\@.*$//;
    # anything else funny with $taint_list probably isn't harmless; let's check
    # start with $clean_list the same as $taint_list
    local($clean_list) = $taint_list;
    # clean up $clean_list
    $clean_list =~ s/[^-_0-9a-zA-Z]*//g;
    # if $clean_list no longer equals $taint_list, something's wrong
    if ($clean_list ne $taint_list) {
	return ""; 
    } 
    # convert to all-lower-case
    $clean_list =~ tr/A-Z/a-z/;
    # check to see that $listdir/$clean_list exists
    if (! -e "$listdir/$clean_list") {
	return "";
    }
    return $clean_list;
}

# compare two email address to see if they "match" by converting  to all
# lower case, then stripping off comments and comparing what's left.  If
# a optional third argument is specified and it's not undefined, then
# partial matches (where the second argument is a substring of the first
# argument) should return true as well as exact matches.
#
# if optional third argument is 2, then compare the two addresses looking
# to see if the addresses are of the form user@dom.ain.com and user@ain.com
# if that is the format of the two addresses, then return true.
sub main'addr_match {
    local($a1) = &main'chop_nl(shift);
    local($a2) = &main'chop_nl(shift);
    local($partial) = shift;	# may be "undef"

    print STDERR "addr_match: enter\n" if $DEBUG;
    print STDERR "addr_match: comparing $a1 against $a2\n" if $DEBUG;

    if ($partial == 1) {
	$a1 =~ tr/A-Z/a-z/;
	$a2 =~ tr/A-Z/a-z/;
	if (index($a1, $a2) >= $[) {
	    return(1);
	} else {
	    return(undef);
	}
    }
	
    local(@a1, @a2);

    $a1 =~ tr/A-Z/a-z/;
    $a2 =~ tr/A-Z/a-z/;

    @a1 = &main'ParseAddrs($a1);
    @a2 = &main'ParseAddrs($a2);
    if (($#a1 != 0) || ($#a2 != 0)) {
	# Can't match, because at least one of them has either zero or
	# multiple addresses
	return(undef);
    }

    if ($partial == 2 && ($a1[0] ne $a2[0])) { # see if addresses are
                                               # foo@baz.bax.edu, foo@bax.edu
       local(@addr1,@addr2);
	  @addr1 = split(/\@/, $a1[0]);
	  @addr2 = split(/\@/, $a2[0]);
	  if ( $#addr1 == $#addr2 && $#addr1 == 1 && 
               $addr1[0] eq $addr2[0] && (index($addr1[1], $addr2[1]) >= $[))
	  {
	    return(1);
	  }
       }

    return($a1[0] eq $a2[0]);
}

# These are package globals referenced by &setabortaddr and &abort

$abort_addr = "owner-majordomo";

sub main'set_abort_addr {
    $abort_addr = shift unless ($#_ < $[);
}

# Abort the process, for the reason stated as the argument

local($log_disabled);
local($logging_abort, $mailing_abort);

sub main'abort { #'
    # first, tell the requestor that something bad happened.
    # XXX is this really meaningful for, say, resend?
    if (-e main'REPLY) {
	print main'REPLY <<END_MSG;
>>> Sorry, an error has occurred while processing your request
>>> The caretaker of Majordomo ( $abort_addr ) has been notified
>>> of the problem.
END_MSG
	close (main'REPLY);
    }

    # print the reason for the abort to stderr; maybe someone will see it
    print STDERR "$main'program_name: ABORT\n", join(" ",  @_), "\n";

    # log the reason for the abort, if possible.  We don't log if the
    # log is inaccessible, or if we're aborting trying to log that we're
    # aborting.
    unless ($log_disabled || $logging_abort) {
	$logging_abort = join(" ", @_);
	&main'log("ABORT", $logging_abort);
	$logging_abort = "";
    }
    else {
	# Use previous message if we recursed
	@_ = ($logging_abort) if $logging_abort;
    }

    # send a message to the Majordomo owner, if possible. We don't mail
    # if we're aborting trying to mail that we're aborting.
    if (! $mailing_abort &&
	defined($abort_addr) && defined($main'bounce_mailer)) {

	$mailing_abort = 1; # Break recursion loops

	# We must set the mailer correctly here just in case it was
	# originally set to the normal mailer; that probably won't get us
	# anywhere
	&main'set_mailer($main'bounce_mailer);
	&main'sendmail(ABORT, $abort_addr, "MAJORDOMO ABORT ($main'program_name)");#'
	print ABORT <<"EOM";

MAJORDOMO ABORT ($main'program_name)!!

@_

EOM
	close(ABORT);
    }

    exit $EX_DATAERR;
}

# bitch about a serious problem, but not fatal.

local($logging_warning, $mailing_warning);

sub main'bitch {
    # print the warning to stderr in case all else fails
    # maybe someone will see it
    print STDERR "$main'program_name: WARNING\n", join(" ", @_), "\n";

    # log the warning, if possible
    unless ($log_disabled || $logging_warning) {
	$logging_warning = 1;
	&main'log("WARNING ", join(" ", @_), "\n"); #';
	$logging_warning = 0;
    }

    # send a message to the Majordomo owner, if possible
    if (! $mailing_warning &&
	defined($abort_addr) && defined($main'bounce_mailer)) {

	$mailing_warning = 1; # Break recursion loops

	# We must set the mailer correctly here just in case it was
	# originally set to the normal mailer; that probably won't get us
	# anywhere
	&main'set_mailer($main'bounce_mailer);
	&main'sendmail(WARN, $abort_addr, "MAJORDOMO WARNING ($main'program_name)");#';
	print WARN <<"EOM";

MAJORDOMO WARNING ($main'program_name)!!

@_

EOM
	close(WARN);
	$mailing_warning = 0;
    }
}



# do a quick check of permissions.
#
sub main'check_permissions {
    local($err);
    if ( ! -w $log_file ) {
	if ( ! -e $log_file ) {			# log file may not exist, check dir perms.
	    local($dir);
	    ($dir) = $log_file =~ m@^(/\S+)/@;
	    if ( ! -w $dir ) {
		$err .= "Unable to create log file in $dir, check permissions.\n"; # 
	    }
	} else {
	    $err .= "Unable to write to log file, check permissions on $log_file\n";
	}
    }

    if ( ! -w $main'listdir ) {
	$err .= "Unable to write to list directory \$listdir, check permissions on $main'listdir\n";
    }

    if (length $err) {
	$err = "While running with an effective uid of $> and an effective gid of $), Majordomo\nran into the following problems:\n" .
	    $err;
	$log_disabled = 1;
	&main'abort($err);#';
    }
}

# These are package globals referenced by &setlogfile and &log
$log_file = "/tmp/log.$$";
$log_host = "UNKNOWN";
$log_program = "UNKNOWN";
$log_session = "UNKNOWN";

# set the log file
sub main'set_log {
    $log_file = shift unless ($#_ < $[);
    $log_host = shift unless ($#_ < $[);
    $log_program = shift unless ($#_ < $[);
    $log_session = shift unless ($#_ < $[);

}

# Log a message to the log
sub main'log {

    print STDERR "$0:  main'log()\n" if $DEBUG;

    local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime;
    local(*MAILMSG);

    print STDERR "$0:  main'log(): opening logfile $log_file\n" if $DEBUG;

    if (&main'lopen(LOG, ">>", $log_file)) { #';
	# if the log is open, write to the log
	printf LOG "%s %02d %02d:%02d:%02d %s %s[%d] {%s} ",
	    $ctime'MoY[$mon], $mday, $hour, $min, $sec,
	    $log_host, $log_program, $$, $log_session;
	print LOG join(" ", @_), "\n";
	&main'lclose(LOG);
    } else {
	
	print STDERR "$0:  main'log(): log not open, writing to STDERR and attempting to mail.\n" if $DEBUG;

	# otherwise, write to stderr
	printf STDERR "%s[%d] {%s} ", $log_program, $$, $log_session;
	print STDERR join(" ", @_), "\n";

        # send a message to the Majordomo owner, if possible
        if (defined($abort_addr)) {
	    &main'sendmail(MAILMSG, $abort_addr, # '(
						     "MAJORDOMO NOTICE: Can't open log");
	    printf MAILMSG "%s[%d] {%s} ", $log_program, $$, $log_session;
   	    print MAILMSG join(" ", @_), "\n";
	}
    }
    print STDERR "$0:  main'log(): done\n" if $DEBUG;

}

# Globals referenced by &set_mail* and &sendmail
$mail_prog = "$sendmail_command -f\$sender -t";
$mail_from = $whoami;
$mail_sender = $whoami_owner;

# set the mailer
sub main'set_mailer {
     $mail_prog = shift;
}

# set the default from address
sub main'set_mail_from {
    $mail_from = shift;
}

# set the default sender address
sub main'set_mail_sender {
    $mail_sender = shift;
}

# Exec a mailer process
sub main'do_exec_sendmail {
    &main'abort("do_exec_sendmail, number of args <= 1 unsafe to exec")
      if scalar(@_) <= 1;
    # It makes sense to check to see that the mailer is valid here, but the
    # abort routine must make certain that recursion doesn't develop,
    # because abort calls this routine.
    &main'abort("$main'program_name: do_exec_sendmail, mailer $_[0] not executable")
      unless (-x $_[0]);
    exec(@_);
    die("Failed to exec mailer \"@_\": $!");
}

# Open a mailer on the far end of a filehandle
sub main'sendmail { #''
    local($MAIL) = shift;
    local($to) = shift;
    local($subject) = shift;
    local($from) = $mail_from;
    local($sender) = $mail_sender;
    # The following eval expands embedded variables like $sender
    local($mail_cmd) = eval qq/"$mail_prog"/;
    local($isParent);
    if ($#_ >= $[) { $from = shift; }
    if ($#_ >= $[) { $sender = shift; }

    # force unqualified filehandles into caller's package
    local($package) = caller;
    $MAIL =~ s/^[^':]+$/$package'$&/;

    # clean up the addresses, for use on the mailer command line
    local(@to) = &main'ParseAddrs($to);
    for (@to) {
	$_ = join(", ", &main'ParseAddrs($_));
    }
    $to = join(", ", @to);  #';

print STDERR "$0: main'sendmail:  To $to, Subject $subject, From $from\n" 
    if $DEBUG;
print STDERR "$0: main'sendmail:  Sender $sender, mail_cmd = $mail_cmd\n"
    if $DEBUG;

    # open the process
    if (defined($isParent = open($MAIL, "|-"))) {
 	&main'do_exec_sendmail(split(' ', $mail_cmd))
 	    unless ($isParent);
     } else {
 	&main'abort("Failed to fork prior to mailer exec");
     }

    # Generate the header.  Note the line beginning with "-"; this keeps
    # this message from being reprocessed by Majordomo if some misbegotten
    # mailer out there bounces it back.
    print $MAIL 
"To: $to
From: $from
Subject: $subject
Reply-To: $from

--

";
    
    return;
}

# check the password for a list
sub main'valid_passwd {
    local($listdir, $list, $passwd) = @_;

    # is it a valid list?
    local($clean_list) = &main'valid_list($listdir, $list);
    if ($clean_list ne "") {
	# it's a valid list check config passwd first 
        if (defined($main'config_opts{$clean_list,"admin_passwd"}) &&
            $passwd eq $main'config_opts{$clean_list,"admin_passwd"} ) 
	      {	return 1; }

	# read the password from the file in any case
	if (&main'lopen(PASSWD, "", "$listdir/$clean_list.passwd")) {
	    local($file_passwd) = <PASSWD>;
	    &main'lclose(PASSWD);
	    $file_passwd = &main'chop_nl($file_passwd);
	    # got the password; now compare it to what the user sent
	    if ($passwd eq $file_passwd) {
		return 1;
	    } else {
		return 0;
	    }
	} else {
	    return 0;
	}
    } else {
	return 0;
    }
}

# Check to see that this is a valid address. 
# A valid address is a single address with 
# no "|" in the address part. It may not start with a - either.
# If it has a / in it, we use some heuristics to find out if the address
# may be a file. Some other heuristics attempt to look for a valid X.400
# address. This is not infalible.
sub main'valid_addr {
    local($addr, $list) = @_;
    local(@addrs, $temp);

    # Parse the address out into parts
    @addrs = &main'ParseAddrs($addr);

    # if there's not exactly 1 part, it's no good
    # XXX Should inform the poor user of this fact.
    if ($#addrs != 0) {
	return undef;
    }

    local($_) = $addrs[0];

    # Deal with unbalanced brackets or parenthesis in an address.
    $temp = $_;

    # Nuke anything within quotes.
    1 while $temp =~ s/(^|([^\\\"]|\\.)+)\"(([^\\\"]|\\.)*|$)\"?/$1/g;

    # Remove nested parentheses " <- placate emacs' highlighting
    1 while $temp =~ s/\([^\(\)]*\)//g;

    # Remove nested angle brackets
    1 while $temp =~ s/\<[^\<\>]*\>//g;

    # remove nested square brackets
    1 while $temp =~ s/\[[^\[\]]*\]//g;

    # If any parentheses of brackets remain, they are unbalanced and the
    # address is illegal.
    if ($temp =~ /[\(\)\<\>\[\]]/) {
	if (-e main'REPLY) {
	    print main'REPLY <<"EOM"
**** The address you supplied, $_
**** Does not seem to be a legal Internet address.  It seems to have an
**** uneven number of parentheses or brackets.
	
EOM

	}
	&main'log("WARNING", "Unbalanced address: $_");
	return undef;
    }

    if ($temp =~ /[,;:]/) {
        if (-e main'REPLY) {
            print main'REPLY <<"EOM"
**** The address you supplied, $_
**** Does not seem to be a legal Internet address.  It seems to have
**** unquoted colons, commas, or semicolons.

EOM

        }
        &main'log("WARNING", "Illegal chars in address: $_");
        return undef;
    }


    # Deal with legal spaces in a stripped address, then check and reject
    # any remaining space.  Note that as I write this, the comment stripper
    # ParseAddrs does not handle things like a quoted local part but I've
    # included the correct routines just in case it ever does.
    $temp = $_;

    # We assume that the comment stripper will have eaten leading and
    # trailing space.

    # This mess turns "jason ti bb i tt s"@hpc.uh.edu into
    # "jasontibbitts"@hpc.uh.edu
    1 while $temp =~ s/\"(.*)\s(.*)\"/\"$1$2\"/g;

    # This compresses space before dots or `@'s. " <- placate emacs' highlighting
    1 while $temp =~ s/\s(\.|@)/$1/g;

    # This compresses space after dots or `@'s.
    1 while $temp =~ s/(\.|@)\s/$1/g;

    # We've taken out all legitimate space from the address (yes, RFC822
    # permits that kind of bogosity), so if the address has spaces, we have
    # a problem.
    if ($temp =~ /\s/) {
	if (-e main'REPLY) {
	    print main'REPLY <<"EOM";
**** The address you supplied, $_
**** does not seem to be a legal Internet address.  You may have supplied
**** your full name instead of your address, or you may have included your
**** name along with your address in a manner that does not comply with
**** Internet standards for addresses.
**** It is also possible that you are using a mailer that wraps long lines
**** and the end of your request ended up on the following line.  If the
**** latter is true, try using backslashes to split long lines.  (Split the
**** line between words, then put a backslash at the end of all but the
**** last line.)

EOM
	}
	&main'log("WARNING", "Illegal space in address: $_");
	return undef;
    }

    # Addresses must have both an @ and a .
    if (!(/\@/ && /\./)) {
	if (-e main'REPLY) {
	    print main'REPLY <<"EOM";
**** The address you supplied, $_
**** is not a complete address.  When providing an address, you must give
**** the full name of the machine including the domain part (like
**** host.corp.com), not just your user name or your name and the short
**** name of the machine (just user or user\@host is not legal).

EOM
	}
	&main'log("WARNING", "Non-domained address: $_");
	return undef;
    }

    
    # o  if there's a "|" in it, it's hostile
    # o  if there is a - sign at the front of the address, it may be an attempt
    #    to pass a flag to the MTA
    # o  bail if they're attempting to subscribe the list to itself
    # 

    print STDERR "$0: valid_addr: comparing '$addr' to '$list'\n" if $DEBUG;

    # XXX Should at least tell the user that there was a problem.
    if ( /\|/ || /^-/ ) {
	&main'abort("HOSTILE ADDRESS (invalid first char or |) $addr"); #'
	return undef;
    }

    # Some sendmails are dumb enough to do bad things with this
    if (/\:include\:/) {
        &main'abort("HOSTILE ADDRESS (tried to use :include: syntax) $addr"); #'
        return undef;
    }

    if ( $addr eq $list ) {
	&main'abort("HOSTILE ADDRESS (tried to subscribe list) $addr"); # '
	return undef;
    }

    # if the is a / in it, it may be an attempt to write to a file.
    # or it may be an X.400, HP Openmail or some other dain bramaged
    # address 8-(. We check this by breaking the address on '/'s
    # and checking to see if the first component of the address
    # exists. If it does we bounce it as a hostile address.

    # XXX Again, we shouldn't be aborting without telling the user
    if ( m#/# ) {
	local(@components) = ($_ =~ /([\/\@]?[^\/\@]+)/g);

	&main'abort("HOSTILE ADDRESS (path exists to /file) $addr")
                if (-e "/$components[0]"); #'
	&main'abort("HOSTILE ADDRESS (path exists to file) $addr")
                if (-e "$components[0]"); #'

       # then as an extra check that can be turned off in the majordomo.cf
       # file we make sure that the last component of the address has an
       # @ sign on it for an X.400->smtp gateway translation.

        if (!$main'no_x400at) {
	    &main'abort("HOSTILE ADDRESS (no x400 \@) $addr") if (
                    "$components[$#components]" !~ /\@/);  #'
	}

        # check to see that the c= and a[dm]= parts exist
	if (!$main'no_true_x400) {
            &main'abort("HOSTILE ADDRESS (no x400 c=) $addr")
                    if ($_ !~ m#/c=#); #'
            &main'abort("HOSTILE ADDRESS (no x400 a[dm]=) $addr")
                    if ($_ !~ m#/a[dm]=#); #'
       }
   }

print STDERR "$0: valid_addr: exit\n" if $DEBUG;

   return $_;
}

# is this a valid filename?
sub main'valid_filename {
    local($directory) = shift;
    local($list) = shift;
    local($suffix) = shift;
    local($taint_filename) = shift;
    local($clean_filename);

    # Safety check the filename.
    if ($taint_filename =~ /^[\/.]|\.\.|[^-_0-9a-zA-Z.\/] /) {
	return undef;
    } else {
	$clean_filename = $taint_filename;
    }
    if (! -f "$directory/$list$suffix/$clean_filename") {
	return undef;
    }
    return "$directory/$list$suffix/$clean_filename";
}

# Chop any trailing newlines off of a string, and return the string
sub main'chop_nl {
    if ($#_ >= $[) {
	local($x) = shift;
	$x =~ s/\n+$//;
	return($x);
    } else {
	return(undef);
    }
}

# Perform simple filename globbing, so we don't have to use the <...> glib
# syntax which has caused problems.
sub main'fileglob {
    local($dir) = shift;
    local($pat) = shift;
    local(@files) = ();

    opendir(DIR, $dir) || return undef;
    @files = grep(/$pat/, readdir(DIR));
    grep($_ = "$dir/$_", @files);  # perl4 doesn't have map!

    closedir(DIR);

    return @files;
}

sub main'is_list_member {
    local($subscriber, $listdir, $clean_list, $file) = @_;
    local($matches) = 0;
    local(*LIST);
    local($_);

    print STDERR "is_list_member: enter\n" if $DEBUG;

    $file = "$listdir/$file" if defined $file && $file !~ m|^/|;
    $file = "$listdir/$clean_list" unless defined $file;
    print STDERR "is_list_member: checking $file for $subscriber\n"
	if $DEBUG; 
    if (open(LIST, $file)) {
	while (<LIST>) {
	    if (&main'addr_match($subscriber, $_, 
	       (&main'cf_ck_bool($clean_list,"mungedomain") ? 2 : undef))) {
		$matches++;
		last;
	    }
	}
	close(LIST);
    }
    else {
	&main'bitch("Can't read $file: $!"); #'"";
    }

    print STDERR "is_list_member: exit $matches\n" if $DEBUG;

    return($matches);
}

# From: pdc@lunch.engr.sgi.com (Paul Close)
# > Shouldn't list and list-digest  be equivalent for things like
# > retrieval of files? As it stands now, if I subscribe to
# > foo-list-digest and I want to retrieve a file for foo-list or list the
# > members of foo-list, and foo-list is a private list for these
# > purposes, then I'm out of luck.
# 
# I agree.  The approach I took for solving this was to add a function called
# private_okay() to use instead of list_member() in cases where you wanted to
# restrict function to members of the list or list-digest.
# 
# If restrict_post is defined, private_okay searches those lists, otherwise
# it searches list and list-digest.  Anywhere majordomo consults a private_*
# variable, I use private_okay instead of list_member.  Works quite nicely.
#
# Added in access checking mechanisms as well to replace
# private_XYZ with some flexability.  This will be exanded to be
# more flexible than the current [open|list|closed] capability.
#  --Chan 96/04/23
#
sub main'access_check {
    local($cmd, $subscriber,$listdir,$clean_list) = @_;
    local(@lists,$list,$altlist,$total);

    print STDERR "access_check: enter\n" if $DEBUG;

    # bail right away if the command is disabled.
    # 
    if ($main'config_opts{$clean_list, "${cmd}_access"} =~ /closed/) {#'
	print STDERR "access_check: ${cmd}_access is closed.\n" if $DEBUG;
	return 0 ;
    }

    # bail right away if the command is wide open
    #
    if ($main'config_opts{$clean_list, "${cmd}_access"} =~ /open/) {#'
	print STDERR "access_check: ${cmd}_access is open.\n" if $DEBUG;
	return 1;
    }
    
    # now check a little deeper.
    #
    if ( length($main'config_opts{$clean_list,'restrict_post'} )) {
        @lists = split(/[:\s]+/,
                     $main'config_opts{$clean_list,'restrict_post'});
    } else {
        if ($clean_list =~ /(.*)-digest/) {
            $altlist = $1;
        } else {
            $altlist = "$clean_list-digest";
        }
        @lists = ($clean_list);
	push(@lists, $altlist) if -e "$listdir/$altlist";
    }

    print STDERR "access_check: checking lists " , join(', ', @lists), "\n" 
	if $DEBUG;

    $total = 0;
    foreach $list (@lists) {
	$total += &main'is_list_member($subscriber, $listdir, $clean_list, $list);
    }
    print STDERR "access_check: exit\n" if $DEBUG;
    return $total;
}

1;

Man Man