| Current Path : /compat/linux/proc/self/root/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 |
| Current File : //compat/linux/proc/self/root/usr/local/majordomo/resend.20210401.orig |
#!/usr/bin/perl
# $Modified: Fri Jan 7 16:32:17 2000 by cwilson $
# Copyright 1992, D. Brent Chapman. All Rights Reserved. For use by
# permission only.
#
# $Source: /sources/cvsrepos/majordomo/resend,v $
# $Revision: 1.90 $
# $Date: 2000/01/07 15:32:39 $
# $Author: cwilson $
# $State: Exp $
#
# $Locker: $
#
# Okay, resend accepts many command line arguments, as revealed by the
# Getopts call:
# &Getopts("Aa:df:h:I:l:M:p:Rr:s") || die("resend: Getopts() failed: $!");
# Most of these are defined via the list config file, so in general,
# it's a really bad idea to hardcode them in the alias definition.
# In a future version of majordomo, these will likely all be removed.
#
# Here's a description of them, just to be documentive. Note that the
# only REQUIRED option is -l. Even that will probably go away in the future.
#
# -l <list-name> REQUIRED: specify list name
# -h <host-name> specify host name
# -f <from-addr> specify "sender" (default <list-name>-request)
# -M <max-msg-length> specify max message length to forward
# -p <precedence> add "Precedence: <precedence>" header
# -r <reply-to> add "Reply-To: <reply-to>" header
# -I <file-list> Bounce messages from users not listed in file
# in colon-separated <file-list>
# -a <passwd> approval password
# -A moderate list (require "Approved:" for posting)
# -R delete "Received:" lines
# -s enable "administrivia" checks
# -d debug; say it, but don't do it
# -C alternate config file
#
#$DEBUG = 1;
#// ----------
#use ADN::MIME;
use Jcode;
#// ----------
# set our path explicitly
# PATH it is set in the wrapper, so there is no need to set it here.
#$ENV{'PATH'} = "/bin:/usr/bin:/usr/ucb";
# Before doing anything else tell the world I am resend
# The mj_ prefix is reserved for tools that are part of majordomo proper.
# (not that anything uses this variable.)
$main'program_name = 'mj_resend'; #';
# If the first argument is "@filename", read the real arguments
# from "filename", and shove them onto the ARGV for later processing
# by &Getopts()
#
if ($ARGV[0] =~ /^\@/) {
$fn = shift(@ARGV);
$fn =~ s/^@//;
open(AV, "< $fn" ) || die("open(AV, \"< $fn\"): $!\nStopped");
undef($/); # set input field separator
$av = <AV>; # read whole file into string
close(AV);
@av = split(/\s+/, $av);
unshift(@ARGV, @av);
$/ = "\n";
}
# Parse arguments here. We do this first so that we can conditionally
# evaluate code in majordomo.cf based on $opt_l (or any other command line
# argument). Here I've assumed that perl was installed correctly and
# getopts.pl was place where it's supposed to be. This changes previous
# behavior which allowed getopts.pl to be in the same place as
# majordomo.cf.
require "getopts.pl";
#// &Getopts("C:c:Aa:df:h:I:l:M:p:Rr:s") || die("resend: Getopts() failed: $!");
&Getopts("C:c:Aa:df:h:I:l:M:m:p:Rr:s") || die("resend: Getopts() failed: $!");
if (!defined($opt_l)) {
die("resend: must specify '-l list'");
}
# Read and execute the .cf file
$cf = $opt_C || $opt_c || $ENV{"MAJORDOMO_CF"} || "/etc/majordomo.cf";
# Despite not having a place to send the remains of the body,
# it would be nice to send a message to root or postmaster, at least...
#
if (not sysopen CONFIG,$cf,O_RDONLY)
{
die sprintf qq|Unable to sysopen config file "$cf"%s.\n|,$! ? ": $!" : '';
}
elsif ((stat CONFIG)[4] != $>)
{
die qq|Config file "$cf" not owned by effective UID.\n|;
}
elsif (eval(join '', <CONFIG>), $@)
{
die qq|Unable to eval "$cf": $@.\n|;
}
else
{
close CONFIG;
}
chdir($homedir) || die("Can't chdir(\"$homedir\"): $!");
unshift(@INC, $homedir);
require "ctime.pl"; # For logging purposes
require "majordomo.pl";
require "majordomo_version.pl";
require "config_parse.pl";
# pickup hostname from majordomo.cf unless defined on the command line
$opt_h = $opt_h || $whereami;
# smash case for the list name
#$opt_l =~ tr/A-Z/a-z/;
# We must set up the mailers and logging as soon possible so that we can
# send and log complaints and aborts somewhere. Unfortunately we need to
# parse the config file to get some of the variables. So we fake it here,
# and set them properly later.
# XXX It is possible that owner-$opt_l won't be the right address, but we
# have little choice. Sending the bounces to $whoami_owner is an option,
# but might not clearly indicate the list name.
$sendmail_command = $sendmail_command || "/usr/sbin/sendmail";
$bounce_mailer = $bounce_mailer || "$sendmail_command -f\$sender -t";
&set_mail_from("owner-$opt_l");
&set_mail_sender("owner-$opt_l");
&set_mailer($bounce_mailer);
&set_abort_addr("owner-$opt_l");
&set_log($log, $opt_h, "resend", $opt_l);
if (!defined ($TMPDIR)) {
&bitch("\$TMPDIR wasn't defined in $cf. Using /usr/tmp instead.\n".
"Please define in $cf.\n");
$TMPDIR = '/usr/tmp';
}
# if we're running from a tty, just spit to stderr, else
# open up a temp file for the debug output.
#
if (!-t STDERR) {
close STDERR;
open (STDERR, ">>$TMPDIR/resend.debug");
}
# XXX some standard way of setting defaults needs to be done..
#
$MAX_HEADER_LINE_LENGTH = $MAX_HEADER_LINE_LENGTH || 128;
$MAX_TOTAL_HEADER_LENGTH = $MAX_TOTAL_HEADER_LENGTH || 1024;
print STDERR "$0 [$$]: starting.\n" if $DEBUG;
if (!@ARGV) {
die("resend: must specify outgoing list as last arg(s)");
# this doesn't have to be this way. It could slurp it
# from the alias it was invoked as...?
}
# A classic case of feeping creaturism. While there are possibly good reasons
# why all these things can be classified on the command line, there's
# *NO* good reason why everything is "opt_X". YATTF.
#
$opt_r = "$opt_r\@$opt_h" if (defined($opt_r));
&get_config($listdir, $opt_l);
$opt_A = &cf_ck_bool($opt_l,"moderate") if &cf_ck_bool($opt_l,"moderate");
$opt_h = $config_opts{$opt_l,"resend_host"}
if($config_opts{$opt_l,"resend_host"} ne '');
$opt_a = $config_opts{$opt_l,"approve_passwd"}
if ($config_opts{$opt_l,"approve_passwd"} ne '');
$opt_M = $config_opts{$opt_l,"maxlength"}
if ($config_opts{$opt_l,"maxlength"} ne '');
$opt_f = $config_opts{$opt_l,"sender"}
if ($config_opts{$opt_l,"sender"} ne '');
$opt_p = $config_opts{$opt_l,"precedence"}
if ($config_opts{$opt_l,"precedence"} ne '');
$opt_r = $config_opts{$opt_l,"reply_to"}
if ($config_opts{$opt_l,"reply_to"} ne '');
$opt_I = $config_opts{$opt_l,"restrict_post"}
if ($config_opts{$opt_l,"restrict_post"} ne '');
$opt_R = &cf_ck_bool($opt_l,"purge_received")
if &cf_ck_bool($opt_l,"purge_received");
$opt_s = &cf_ck_bool($opt_l,"administrivia")
if &cf_ck_bool($opt_l,"administrivia");
$opt_d = &cf_ck_bool($opt_l,"debug")
if &cf_ck_bool($opt_l,"debug");
#// ----------
if ($MAX_TOTAL_BODY_LENGTH && $MAX_TOTAL_BODY_LENGTH > 0) {
$opt_M = $MAX_TOTAL_BODY_LENGTH;
}
#// ----------
# Construct the envelope sender for outbound messages
if (defined($opt_f)) {
$sender = $opt_f;
} else {
#// $sender = "$opt_l-request";
$sender = "owner-$opt_m\@$opt_h";
}
#// ----------
$seqfile = "$listdir/$opt_l.seq";
if (!-r $seqfile) { # if there is no sequence file, make one
open(SEQ, ">$seqfile") || die("sequencer: open of $seqfile failed: $!");
print SEQ "1\n";
close SEQ;
}
#// ----------
&main'lopen(SEQ, "<", "$seqfile") || die("sequencer: locked open of $seqfile failed: $!");
chop($seqnum = <SEQ>);
# If the sender doesn't contain an `@', tack on one, followed by the
# hostname
if ($sender !~ /\@/) {
$sender .= "\@$opt_h";
}
# We can now properly define some of the mailer properties.
&set_mail_from($sender);
&set_mail_sender($sender);
&set_abort_addr($sender);
&set_log($log, $opt_h, "resend", $opt_l);
if (defined($opt_A) && ! defined($opt_a)) {
die("resend: must also specify '-a passwd' if using '-A' flag");
}
#
# These are headers to skip
#
$skip_headers = '/^from /i' .
'|| /^x-confirm-reading-to:/i' . # pegasus mail (windoze)
'|| /^disposition-notification-to:/i' . # eudora
'|| /^x-ack:/i' .
'|| /^sender:/i' .
'|| /^return-receipt-to:/i' .
'|| /^errors-to:/i' .
'|| /^flags:/i' .
'|| /^resent-/i' .
'|| /^priority/i' .
'|| /^x-pmrqc:/i' .
'|| /^return-path:/i' .
'|| /^encoding:/i' # could munge the length of the message
;
#
# Define the eval's used to catch "taboo" headers, message contents,
# and administrative headers. The taboo headers can be global
# or per list. The administrative headers are global.
#
# The eval is a construct like so:
# foo: { /^subject:\s*subscribe/ && ( $taboo = '/^subject:\s*subscribe/', last foo); }
# so that the eval returns the regexp that matched.
#
print STDERR "$0: defining evals to catch the bad stuff.\n" if $DEBUG;
if ($config_opts{$opt_l, 'taboo_headers'} ne '') {
@taboo_headers = split(/\001/,$config_opts{$opt_l, 'taboo_headers'});
if ($#taboo_headers >= $[) {
$is_taboo_header = "foo: {\n";
foreach $t (@taboo_headers) {
($ts = $t) =~ s/(['\\])/\\$1/g;
$is_taboo_header .= "$t && (\$taboo = '$ts', last foo);\n";
}
$is_taboo_header .= "\$taboo = \"\";\n}; \$taboo;\n";
}
}
if ($config_opts{$opt_l, 'taboo_body'} ne '') {
@taboo_body = split(/\001/,$config_opts{$opt_l, 'taboo_body'});
if ($#taboo_body >= $[) {
$is_taboo_body = "foo: {\n";
foreach $t (@taboo_body) {
($ts = $t) =~ s/(['\\])/\\$1/g;
$is_taboo_body .= "$t && (\$taboo = '$ts', last foo);\n";
}
$is_taboo_body .= "\$taboo = \"\";\n}; \$taboo;\n";
}
}
if (defined($global_taboo_headers)) {
@global_taboo_headers = split(/\n/,$global_taboo_headers);
if ($#global_taboo_headers >= $[) {
$is_global_taboo_header = "foo: {\n";
foreach $t (@global_taboo_headers) {
($ts = $t) =~ s/(['\\])/\\$1/g;
$is_global_taboo_header .= "$t && (\$taboo = '$ts', last foo);\n";
}
$is_global_taboo_header .= "\$taboo = \"\";\n}; \$taboo;\n";
}
}
if (defined($global_taboo_body)) {
@global_taboo_body = split(/\n/,$global_taboo_body);
if ($#global_taboo_body >= $[) {
$is_global_taboo_body = "foo: {\n";
foreach $t (@global_taboo_body) {
($ts = $t) =~ s/(['\\])/\\$1/g;
$is_global_taboo_body .= "$t && (\$taboo = '$ts', last foo);\n";
}
$is_global_taboo_body .= "\$taboo = \"\";\n}; \$taboo;\n";
}
}
#"; dammit.
# admin subject checks. Since $admin_headers is defined in $cf
# (majordomo.cf), an upgrade may not have $admin_headers.
# Bitch about it if so.
#
if (!defined($admin_headers)) {
&bitch("resend: \$admin_headers not defined in $cf !!\n" .
"Majordomo will only catch \"subscribe\" and \"unsubscribe\" in\n" .
"the subject field...\n");
@admin_headers = ('/^subject:\s*subscribe\b/i' ,
'/^subject:\s*unsubscribe\b/i');
} else {
@admin_headers = split(/\n/, $admin_headers);
}
$is_admin_header = "foo: {\n";
foreach $t (@admin_headers) {
$is_admin_header .= "$t && (\$taboo = '$t', last foo);\n";
}
$is_admin_header .= "\$taboo = \"\";\n}; \$taboo;\n";
# Body Check!
# Common things that people send to the wrong address.
# These are caught in the first 10 lines of the message body
# if 'administravia' is turned on and the message isn't marked approved.
#
# The code that catches this should transparently redirect
# majordomo commands to majordomo. That would give the additional
# advantage of not having to add to this silly construct for
# each new majordomo command.
#
# $admin_body should be defined in the $cf file, but an upgrade
# may miss this fact. Bitch about it, and use a minimal list if so.
#
if (!defined($admin_body)) {
&bitch("resend: \$admin_body not defined in $cf !!\n" .
"Majordomo will only catch \"subscribe\" and \"unsubscribe\" in\n" .
"the body.\nLook at $homedir/sample.cf for a good definition.");
@admin_body = ('/^subject:\s*subscribe\b/i' ,
'/^subject:\s*unsubscribe\b/i');
} else {
@admin_body = split(/\n/, $admin_body);
}
$is_admin_body = "foo: {\n";
foreach $t (@admin_body) {
$is_admin_body .= "$t && (\$taboo = '$t', last foo);\n";
}
$is_admin_body .= "\$taboo = \"\";\n}; \$taboo;\n";
print STDERR "$0: caching the message.\n" if $DEBUG;
#
# cache the message, so the parent sendmail process can exit.
#
&open_temp(OUT, "$TMPDIR/resend.$$.out") ||
&abort("resend: Can't open $TMPDIR/resend.$$.out: $!");
&open_temp(IN, "$TMPDIR/resend.$$.in") ||
&abort("resend: Can't open $TMPDIR/resend.$$.in: $!");
$subj_num = 0;
$subj_last = 0;
while (<STDIN>) {
#// ----------
if (/^subject:/i) {
$subj_num += 1; $subj_last = 1;
} else {
$subj_last = 0;
}
if ($subj_num == 1 && $subj_last == 1) {
my $n = ($_ =~ /iso-2022-jp/) ? 1 : 0;
#$_ = ADN::MIME::HeaderDecode($_, 'euc');
#$_ = ADN::MIME::HeaderEncode($_);
my $j = Jcode->new($_)->mime_decode;
$_ = $j->mime_encode;
if ($n == 1) { $_ =~ s/ISO-2022-JP/iso-2022-jp/g; }
# s/R[eE]\:.*[\(\[].*\d+[\)\]]/Re\:/g;
# s/R[eE]\:\s+R[eE]\:/Re\:/g;
# s/R[eE]\: *[\(\[]$opt_l[\: ]*\d+[\)\]]/Re\:/gi;
# s/R[eE]\:([ \(\[]+)([^=]+)[\)\]] /Re\: /;
s/R[eE]\:([ \(\[]+)([^ :=]+)[ :]\d+[\)\]]/Re\:/;
s/R[eE]\: *R[eE]\:/Re\:/g;
}
#// ----------
print IN $_;
}
close(IN);
open(IN, "$TMPDIR/resend.$$.in") ||
die("resend: Can't open $TMPDIR/resend.$$.tmp: $!");
#
# Message parsing starts here
#
print STDERR "$0: parsing header.\n" if $DEBUG;
# parse the header for bad lines, etc. We'll bounce in a moment.
#
$result = &parse_header;
# The first line of the body could hold an approved line. Let's check.
#
$_ = <IN>;
if (/^approved:\s*(.*)/i # aha!
&& defined($opt_a)) {
# OK, is it a valid "Approved:" line?
$approved = &chop_nl($1);
if ($approved ne $opt_a
&& !(&main'valid_passwd($listdir, $opt_l, $approved))) { #Augh!')){
$result .= " Invalid 'Approved:' header";
undef $approved;
}
# The Approved: line is valid
# Look at the next line:
$_ = <IN>;
if (/\S/) {
# We have something other than a blank line. We _assume_ it's
# header. Consequences: if it's not a header, things get screwed
# badly. If we reverse the logic and look instead for something
# header-like, we permit the possibility of the moderator leaving
# out the blank line, which is not a good idea because they might
# get used to it, which will bite them when they approve a message
# starting something that looks like a header.
# XXX Options: complain if we find no blank line and no header-like
# stuff.
close OUT; # Nuke the output so far.
unlink "$TMPDIR/resend.$$.out"; # XXX These filenames should be in
# variables.
# Open a new temp file.
&open_temp(OUT, "$TMPDIR/resend.$$.out") ||
&abort("resend: Can't open $TMPDIR/resend.$$.out: $!");
# We'll be nice and skip a From_ mailbox separator, which just
# might have been quoted by some intervening mail munger.
if (!/^>?From /) {
# Rewind back over the header line we just pulled
seek(IN, - length($_), 1);
}
# Parse the following as a completely new message.
$result .= &parse_header; # The return value won't matter; we're
# approved.
}
# else the line was blank; we let it be eaten and continue
} else {
# No approved line, dniwer
seek(IN, - length($_), 1);
}
print STDERR "$0: checking for valid sender.\n" if $DEBUG;
# Check for a valid sender, if the list has restrict_post set
# and the message isn't approved.
#
# aauuuugggh! 'moderator' != 'restrict_post' !! They should be the
# same!!
#
$result .= &check_sender if (defined($opt_I) && ! defined($approved));
# If approval is required, and we haven't got it, boing it goes..
#
$result = "Approval required: $result" if
(defined($opt_A) && ! defined($approved));
print STDERR "$0: sender check: '$result'\n" if $DEBUG;
# Print the RFC822 separator
print OUT "\n";
# Print out any message_fronters
#
if ($config_opts{$opt_l,"message_fronter"} ne '') {
local($fronter) = &config'substitute_values (
$config_opts{$opt_l,"message_fronter"}, $opt_l);#';
$fronter =~ s/\001|$/\n/g;
print OUT $fronter;
}
# We are guaranteed to be just after a blank line now. Slurp the body
$result .= &parse_body;
# Yes Tigger, *now* you can bounce. We've checked for
# any Approved headers & lines, taboo_headers, and taboo_bodies
&bounce($result) if ($result =~ /\S/ && !defined($approved));
# Print out any message_footers
#
print STDERR "$0: adding any footers.\n" if $DEBUG;
if ($config_opts{$opt_l,"message_footer"} ne '') {
local($footer) =
&config'substitute_values(
$config_opts{$opt_l,"message_footer"}, $opt_l); #'
$footer =~ s/\001|$/\n/g;
print OUT $footer;
}
# Finished munging the message and decided it's valid, now send it out.
#
close OUT;
# The following eval expands embedded variables like $sender
$sendmail_cmd = eval qq/"$mailer"/;
$sendmail_cmd .= " " . join(" ", @ARGV);
# check for the dreaded -t option to sendmail, which will cause
# mail to loop 26 times...
#
if ($sendmail_cmd =~ /sendmail/ && $sendmail_cmd =~ /\s-t/) {
$sendmail_cmd =~ s/-t//;
&bitch("resend: \$sendmail_cmd (aka \$mailer in majordomo.cf\n" .
"had a -t option. This will cause mail to loop 26 times.\n" .
"Since this probably isn't what you want to have happen,\n".
"resend has not passed that option to sendmail.\n");
}
print STDERR "$0: \$sendmail_cmd is $sendmail_cmd\n" if $DEBUG;
# To debug or not debug, that is the question.
#
if (defined($opt_d)) {
$| = 1;
$, = ' ';
print STDERR "Command: $sendmail_cmd\n";
open (IN, "$TMPDIR/resend.$$.out");
while (<IN>) {
print STDERR $_;
}
unlink(&fileglob("$TMPDIR", "^resend\.$$\."));
exit(0);
}
# open the mailer
#
local(*MAILOUT, *MAILIN);
if (defined($isParent = open(MAILOUT, "|-"))) {
&do_exec_sendmail(split(' ', $sendmail_cmd))
unless $isParent; # only if we're in the child
} else {
&abort("Failed to fork prior to mailer exec");
}
# open our tmp file
#
open(MAILIN, "$TMPDIR/resend.$$.out");
# spit it out!
#
while (<MAILIN>) {
print MAILOUT $_;
}
# cleanup
#
close(MAILIN);
unlink(&fileglob("$TMPDIR", "^resend\.$$\.")) || &abort("Error unlinking temp files: $!");
close(MAILOUT) || do {
$? >>= 8;
&abort("Mailer $sendmail_cmd exited unexpectedly with error $?")
unless ($sendmail_cmd =~ /sendmail/ && $? == $EX_NOUSER);
};
#// ----------
$seqnum++;
&main'lreopen(SEQ, ">", "$seqfile");
print SEQ $seqnum, "\n";
&main'lclose(SEQ);
#// ----------
# Seeya.
#
exit(0);
######################################################################
#
# Subroutines.
#
######################################################################
# check for a valid sender for moderated lists.
#
sub check_sender {
# Uh, who?
return " This may be hard to believe, but there was no \"From:\" field" .
"in this message I just received. I'm not gonna send it out, " .
"but you can... " if ! defined($from);
local($file) = 0;
# !@$#% cryptic variables. opt_I is restrict_post, which is a colon
# or whitespace seperated list of files that can contain valid
# senders.
# [[[ Scary, I just realized that !@$#% is almost valid perl... ]]]
local(@files) = split (/[:\s]+/, $opt_I);
foreach $file (@files) {
# Return a null message if the sender (from the From: or
# Reply-To: headers) is found
#
return "" if &is_list_member($from, $listdir, $opt_l, $file) ||
(defined $reply_to &&
$reply_to ne $from &&
&is_list_member($reply_to, $listdir, $opt_l, $file));
}
# We only get here if nothing matches.
#
" Non-member submission from [$from] ";
}
#
# parse_header.
# Slurp in the header, checking for bad things. Returns a non-zero length string if
# a taboo or administrative header is found.
#
# [[[ Why couldn't one simply slurp the header in, assign it to an
# assoc. array, and print out everything but the bad stuff? ]]]
#
sub parse_header {
local($gonna_bounce);
local($kept_last) = 0; # our return flag/string.
print STDERR "$0: parse_header: enter.\n" if $DEBUG;
print STDERR "$0: parse_header: taboo_headers = $is_taboo_header\n" if $DEBUG;
print STDERR "$0: parse_header: global_taboo_headers = $is_global_taboo_header\n" if $DEBUG;
print STDERR "$0: parse_header: admin_headers = $is_admin_header\n" if $DEBUG;
$subj_num = 0;
while (<IN>) {
print STDERR "$0: parse_header: [$.: $_]" if $DEBUG;
last if /^$/; # stop when we hit the end. RFC822.
next unless /\S/; # skip leading blank lines; usually only
# there if this is a restart after an
# in-body "Approved:" line
print STDERR "$0: parse_header: [$.] taboo_header check\n"
if $DEBUG;
# check for taboo_headers or approved header
#
if ($#taboo_headers >= $[ && !$approved &&
eval $is_taboo_header) {
$gonna_bounce .= "taboo header: $taboo ";
print STDERR "$0: parse_header: [$.: boing: $gonna_bounce\n" if $DEBUG;
}
if ($DEBUG && $@) {
# Something went boink in eval, say something useful.
print STDERR "$0: parse_header: taboo_header error $@\n";
}
if ($#global_taboo_headers >= $[ && !$approved &&
eval $is_global_taboo_header) {
$gonna_bounce .= "global taboo header: $taboo ";
print STDERR "$0: parse_header: [$.: boing: $gonna_bounce\n" if $DEBUG;
}
if ($DEBUG && $@) {
# Something went boink in eval, say something useful.
print STDERR "$0: parse_header: global_taboo_header error $@\n";
}
# check for administative headers:
# Usually subscribe, unsubscribe, etc, in Subject field
#
print STDERR "$0: parse_header: [$.] administrative_header check\n"
if $DEBUG;
if ($#admin_headers >= $[ && !$approved && defined($opt_s) &&
eval $is_admin_header) {
$gonna_bounce .= "admin request: $taboo ";
print STDERR "$0: parse_header: [$.: boing: $gonna_bounce\n" if $DEBUG;
}
print STDERR "$0: parse_header: Approved check\n" if $DEBUG;
# Check for Approved line
#
# Oddly enough, we may already be approved when we get here. In
# that case, we should nuke any extra Approved: headers we see.
# Why? Well, consider this: you change the password, but send an
# approved message out before the config change takes effect. So
# it bounces back to you with the Approved: line in it. This line
# is now valid. You approve the bounce using the cut-and-paste
# method, putting another Approved: line in front of the headers of
# the raw bounced message and send it off. There are now two
# Approved: headers. If we don't remove the Approved: header from
# the headers of the message you pasted, we've revealed your list
# password.
if (/^approved:\s*(.*)/i && defined($opt_a)) {
if (!$approved) {
print STDERR "$0: parse_header: found an approved header\n" if $DEBUG;
$approved = &chop_nl($1);
if ($approved ne $opt_a # check the p/w given against approve_passwd
&& !(&main'valid_passwd($listdir, $opt_l, $approved))) { # and also against admin_passwd ')
if (defined($opt_A)) { # bounce only if list is moderated
$gonna_bounce .= "Invalid 'Approved:' header ";
print STDERR "$0: parse_header: [$.: boing: $gonna_bounce\n" if $DEBUG;
}
undef $approved;
} else {
# reset the bounce counter, so that we return cleanly.
# this allows a message with a taboo_header or admin_header
# but with a valid Approved line to be posted.
$gonna_bounce = '';
next; # gotta remove that approved line, dontcha know
}
}
else {
# We have already been approved, so skip this header
next;
}
}
print STDERR "$0: parse_header: skipping headers\n" if $DEBUG;
# skip all these headers
if (eval $skip_headers) {
$kept_last = 0;
print STDERR "$0: skipped\n" if $DEBUG;
next;
}
# skip these special headers
if ((/^precedence:/i && defined($opt_p)) # skip only if "-p" set
|| (/^received:/i && defined($opt_R)) # skip only if "-R" set
|| (/^reply-to:/i && defined($opt_r)) # skip only if "-r" set
|| (/^\s/ && ! $kept_last)) # skip if skipped last
{
$kept_last = 0;
print STDERR "$0: skipped\n" if $DEBUG;
next;
}
# reset $kept_last in case next line is continuation
# this should go someplace now... but where?
print STDERR "$0: kept\n" if $DEBUG;
$kept_last = 1;
# prepend subject prefix
#
#// if ((/^subject:\s*/i)
if (/^subject:\s*/i) { $subj_num = 1; }
if ((/^subject:\s*/i)
&& ($config_opts{$opt_l,"subject_prefix"} ne '')) {
print STDERR "$0: parse_header: adding subject prefix\n" if $DEBUG;
local($foo) = &config'substitute_values($config_opts{$opt_l,"subject_prefix"}, $opt_l);#';
#// ----------
$foo =~ s/\$SEQNUM/$seqnum/;
#// ----------
local($foo_pat) = $foo;
$foo_pat =~ s/(\W)/\\$1/g;
s/^subject:[^\S\n]*/Subject: $foo /i if !/$foo_pat/;
}
# snag reply-to field
#
$reply_to = $1 if /^reply-to:\s*(.+)/i;
# snag from line
#
if (/^from:\s*(.+)/i) {
$from = $1;
$from_last = 1; # the from line can span lines
}
elsif ( defined($from_last) ) {
if ( /^\s+(.+)/ ) {
$from .= " $1";
} else {
undef($from_last);
}
}
# Virtual Majordomo Hack
# s/^to:(.*)\b$opt_l\b(.*)$/To:$1 $opt_l\@$whereami $2/i ;
&check_hdr_line($_); # check for length & balance on from, cc, and to fields.
print OUT $_;
}
#// ----------
if ($subj_num == 0) {
my $subj = 'Subject: ';
if ($config_opts{$opt_l,"subject_prefix"} ne '') {
$subj .= &config'substitute_values($config_opts{$opt_l,"subject_prefix"}, $opt_l);#';
$subj =~ s/\$SEQNUM/$seqnum/;
}
print OUT "$subj \n";
}
#// ----------
# finished with the header.
# Now, we aren't going to bounce yet, even if it looks bad,
# because we allow an Approved line as the _first_ line in the *body*.
#
# return $gonna_bounce if length($gonna_bounce);
print STDERR "$0: parse_header: adding header fields\n"
if $DEBUG;
# add new header fields
print OUT "Sender: $sender\n";
if (defined($opt_p)) {
print OUT "Precedence: $opt_p\n";
}
if (defined($opt_r)) {
print OUT "Reply-To: ", &config'substitute_values($opt_r), "\n"; #';
}
if ($config_opts{$opt_l,"sequence_prefix"} ne '') {
print OUT "X-Sequence: " . &config'substitute_values($config_opts{$opt_l,"sequence_prefix"}, $opt_l) . " $seqnum\n";
}
# print out per-list additonal headers
if ($config_opts{$opt_l,"message_headers"} ne '') {
local($headers) = &config'substitute_values (
$config_opts{$opt_l,"message_headers"}, $opt_l);#';
$headers =~ s/\001|$/\n/g;
print OUT $headers;
}
print STDERR "$0: parse_header: returning with '$gonna_bounce'\n" if $DEBUG;
" $gonna_bounce ";
}
# Meander through the message body, checking for
# administravia, taboo stuff, and excessive length.
#
sub parse_body {
local($body_line_count, $body_len) = 0;
local($gonna_bounce);
print STDERR "$0: parse_body: enter\n" if $DEBUG;
while (<IN>) {
$body_line_count++;
$body_len += length($_);
# check for administravia in the first 10 lines of the body
# if so told and not approved.
if ($body_line_count < 10
&& defined($opt_s)
&& !defined($approved)
&& eval $is_admin_body) {
$gonna_bounce .=
" admin request of type $taboo at line $body_line_count ";
next;
}
# if not approved, check for taboo body stuff
# and message length
#
if (!defined($approved)) {
if ($#taboo_body >= $[
&& eval $is_taboo_body) {
$gonna_bounce .=
" taboo body match \"$taboo\" at line $body_line_count ";
next;
}
if ($#global_taboo_body >= $[
&& eval $is_global_taboo_body) {
$gonna_bounce .=
" global taboo body match \"$taboo\" " .
"at line $body_line_count ";
next;
}
# make sure it doesn't make the message too long
if (defined($opt_M)
&& $body_len > $opt_M
&& !$already_bitched_about_length) {
$already_bitched_about_length++;
print STDERR "$0: parse_body: message too long\n" if $DEBUG;
$gonna_bounce .= " message too long (>$opt_M chars) ";
next;
}
}
print OUT $_;
}
print STDERR "$0: parse_body: exiting with '$gonna_bounce'\n"
if $DEBUG;
" $gonna_bounce ";
}
sub check_balance {
print STDERR "$0: check_balance: enter: $_\n" if $DEBUG;
# set a temporary variable
local($t) = shift;
# Remove quoted material
# ( looks like lisp, don't it? )
1 while $t =~ s/(^|([^\\\"]|\\.)+)\"([^\\\"\n]|\\.)*\"?/$1/g; #"
# strip out all nested parentheses
1 while $t =~ s/\([^\(\)]*\)//g;
# strip out all nested angle brackets
1 while $t =~ s/\<[^\<\>]*\>//g;
# if any parentheses or angle brackets remain, were imbalanced
if ($t =~ /[\(\)\<\>]/ && ! defined($approved)) {
&bounce("imbalanced parentheses or angle brackets");
return(undef);
}
return(1);
}
sub check_hdr_line {
local($_) = shift;
print STDERR "$0: check_hdr_line: enter: $_\n" if $DEBUG;
if (!/^\s/) { # is this a continuation line?
# Not a continuation line.
# If $balanced_fld is defined, it means the last field was one
# that needed to have balanced "()" and "<>" (i.e., "To:", "From:",
# and "Cc:", so check it. We do it here in case the last field was
# multi-line.
if (defined($balanced_fld)) {
&check_balance($balanced_fld);
}
# we undefine $balanced_fld and reset $field_len; these may be set below
undef($balanced_fld);
$field_len = 0;
}
# is this a field that must be checked for balanced "()" and "<>"?
if (defined($balanced_fld) || /^from:/i || /^cc:/i || /^to:/i) {
# yes it is, but we can't check it yet because there might be
# continuation lines. Buffer it to be checked at the beginning
# of the next non-continuation line.
# is this line too long?
if ((length($_) > $MAX_HEADER_LINE_LENGTH) && ! defined($approved)) {
&bounce("header line too long (>$MAX_HEADER_LINE_LENGTH)");
return(undef);
}
# is this field too long?
if ((($field_len += length($_)) > $MAX_TOTAL_HEADER_LENGTH) && ! defined($approved)) {
&bounce("header field too long (>$MAX_TOTAL_HEADER_LENGTH)");
return(undef);
}
$balanced_fld .= $_;
chop($balanced_fld);
}
# if we get here, everything was OK.
return(1);
}
sub bounce {
local(*BOUNCE);
local($reason) = shift;
local($_);
print STDERR "$0: bounce enter\n" if $DEBUG;
my $maddr0 = "$opt_m\@$opt_h";
my $maddr1 = "$opt_m-approval\@$opt_h";
&send_bounce(BOUNCE,
(($config_opts{$opt_l, 'moderator'} ne "") ?
#$config_opts{$opt_l, 'moderator'} : "$opt_l-approval\@$opt_h"),
#"BOUNCE $opt_l\@$opt_h: $reason");
$config_opts{$opt_l, 'moderator'} : $maddr1),
"BOUNCE $maddr0: $reason");
seek(IN, 0, 0);
while (<IN>) {
print BOUNCE $_;
}
close(BOUNCE);
unlink(&fileglob("$TMPDIR", "^resend\.$$\."));
print STDERR "$0: bounce exiting\n" if $DEBUG;
exit(0);
}
sub send_bounce {
local(*MAIL) = shift;
local($to) = shift;
local($subject) = shift;
local($isParent);
local($mailcmd);
if (defined $bounce_mailer) {
# The eval expands embedded variables like $sender
$mailcmd = eval qq/"$bounce_mailer"/;
}
else {
# Painful, but we have to provide some kind of backwards
# compatibility and this is what 1.93 used
$mailcmd = "/usr/sbin/sendmail -f$sender -t";
}
# clean up the addresses, for use on the sendmail command line
local(@to) = &ParseAddrs($to);
$to = join(", ", @to);
# open the process
if (defined($opt_d)) {
# debugging, so just say it, don't do it
open(MAIL, ">-");
print MAIL ">>> $mailcmd\n";
} else {
if (defined($isParent = open(MAIL, "|-"))) {
&do_exec_sendmail(split(' ', $mailcmd))
unless $isParent;
} else {
&abort("Failed to fork prior to mailer exec");
}
}
# generate the header
print MAIL <<"EOM";
To: $to
From: $sender
Subject: $subject
EOM
return;
}