Setting Reply-To: field for mail alias

[Suresh Kolichala]

We have a strange requirement of defining a mail alias combining two mailing
lists, such that any mail sent to this mail alias would reach to the members
of both the mailing lists. Now, we have a problem with "Reply-To:" field.

In the mails sent to the mail alias reaches both the list, but the Reply-To:
field in each of the mailing lists appear with the individual mailing list's
address, whereas, what we want it to be set to the mail alias address, so that
any one's response to this mail in any of the mailing lists, should appear
to both the mailing lists. Hope I have been clear.

Do you guys have any quick solutions ? One thing, I can think of, is to
create a user-account, instead of mail alias, and having a .forward file
to process the headers (basically adding Reply-To: field) and then sending
it to both the mailing lists. In this case, do I have to invoke the
sendmail for this mail to be sent without distrubing the headers ? We want
any post sent to this mail alias to appear with the From: field showing the
originator's e-mail address, but Reply-To: must be set to the alias that
combines both the mailing lists.

I appreciate *any* solutions. Thanks in advance !!

Suresh Kolichala.
***
Reality is an illusion caused by the lack of alcohol.

[Kari E. Hurtta]

sur...@austin.ibm.com (Suresh Kolichala) writes:
蓄e have a strange requirement of defining a mail alias combining two mailing
蜷ists, such that any mail sent to this mail alias would reach to the members
褂f both the mailing lists. Now, we have a problem with "Reply-To:" field.
< PROBLEM DELETED >

I think that my 'kehlist' can do that.


(I have posted that to alt.sources under Archive-name: kehlist0103/* )

#!/bin/sh
cat > kehlist.README <<'EOM'

Kehlist is simple(?) filter to implement mailing list.
You can implement mailing list by using sendmail's
aliases, but that way replies to mail, which comes
from list, goes to sender.

Kehlist adds or modifies Reply-To: header that way,
that replies to mail goes to list. Or alternatively kehlist
leaves Reply-To: header intact and adds or modifies
Wide-Reply-To: header so group replies to mail goes
to list (see: group reply mode).

Kehlist can decode base64 and quoted-printable
content-transfer-encodings to 8bit encoding.
Kehlist avoids decoding base64 content-transfer-encoding
if charset is something odd (for example UNICODE-1-1).
It also can code 8bit content-transfer-encoding to
quoted-printable encoding. Kehlist cancels decoding of
quoted-printable or base64 encoding if resulting part
will be binary content-tranfer-encoding (ie. when resultting
text have too long lines transformation is not done).
Kehlist also considers content of part to be binary
if it includes nul characters.

Kehlist also allow to split list so several sublists,
which acts together as one list.

Kehlist does NOT process automatically subscribe or
unsubscribe requests.

Usage: ./kehlist [-d] [-f0] [-g] [-r] [-p] [-b] [-e] [-M MAILER-DAEMON] [-f] [-U UUCP] [-D DNET] [-C] [-P List] bumerang address-list list-name [full-name]
./kehlist [-d] [-f0] -F config-file

Put the following aliases to sendmail aliases file:
my-list: "|/path/kehlist my-list-request /path/list_addresses my-list 'My funny list'"
my-list-request: myname

or

my-list: "|/path/kehlist -F /path/my-list.config"
my-list-request: myname

If you call kehlist from .forward -file, take care that that user
(which owns that .forward file) have merked as 'trusted' user in sednmail.cf.

And put to file my-list.config:
List-name: My funny list
List-address: my-list
Bumerang-address: my-list-request
Address-file: list_addresses
#Following are defaults:
Insert-Resent-headers: False
Drop-Resent-headers: False
Private-List: False
Allow-Bumerang: False
Insert-Errors-To: False
Mailer-Daemon: MAILER-DAEMON
Use-From: True
Accept-UUCP: False
UUCP-Domain: UUCP
Accept-DECNET: False
DECNET-Domain: DNET
Convert-Message: True
Precedence: List
Set-Precedence: False
Add-Host-Name: False
Group-Reply-Mode: False
Process-Return-Receipt-To: True
List-Receiver-Mode: NIL

list_addresses file can include, for example:

Kari....@Fmi.Fi = hur...@dionysos.fmi.fi
QP: some.user@somewhere
# This user can't decode quoted-printable yourself
8BIT: some.other.user@somewhere

It can also include
DEBUG: My.Name@somewhere
LIST: My funny list <list_addresses2> = my-list-request

(no - I _don't_ really like to be in every possible mailing list!!)

Syntax of address file is same as sendmail's :include: files except
that = indicates alias addresses of subscriber and before address
there can be 'mode:' where mode is one of NIL, 8BIT, QP.
Mode can be also be one of DEBUG and LIST. First address is
that to what addresses postings to list are sent. Addresses after =
are used to see, if address of envelope sender is in list.
Character # indicates that rest of line is comment. If want use characters
# and = in addresses, put address inside of < >.

Mode tells which transformations for MIME body-parts must do: NIL means
no transformations, 8BIT means transformation from quoted-printable
to 8bit (this is doen only for subtypes of 'text' -type, sometimes
kehlist may unintionally produce trabsformation quoted-printable
to binary - this isn't prevented as it should), QP means transformation
from 8bit (or binary) to quoted-printable. Krhlist don't handle
base64 encoding.

Receivers of mode DEBUG get one copy of all envelopes, which kehpager
sends.

Receivers of mode LIST have sublists (or parent lists). Format for that is:
LIST: List Name <list1@machine> = <list1-request@machine>
Actual mode of mode LIST can tell in config file with:
List-Receiver-Mode: NIL
or
List-Receiver-Mode: QP
or
List-Receiver-Mode: 8BIT

If listaname1 have receiver:
LIST: List Name <listname2@machine> = <listname2-request@machine>
Then listname2 must be receiver:
LIST: List Name <listname1@machine> = <listname1-request@machine>
Otherwise kehlist bounces mail with configuration error.

When mail comes from sublist, kehlist replaces address of sublist in
Reply-To: and Wide-Reply-To: headers with address of list.

Notice that pipes in aliases file are run under sendmail's default uid
(which is normally 1). (At least, when using sendmail 8.6.X)

Subcribers can be one per line or they can be seperated by comma (,).
If in address have = or : characters, but address inside to < > braces
(if that part of address isn't already quoted).

Kehlist send incoming mails to all subscribers EXCEPT to (envelope) sender. If
sender wanna copy of letter, he can add header
X-kehlist-copy: sender@address
to mail. In group reply mode kehlist scans To:, CC:, Resent-TO: and Resent-CC:
header for receivers and avoids sending mail to these receivers (this CAN'T
be overrided with X-kehlist-copy).

Kehlist modifies Reply-To: header following way:
1) Adds address of list to beginning of Reply-To line
2) Removes list members from Reply-To line
3) Adds address(es) from From line to Reply-To line, if
address wasn't member of list _and_ there wasn't Reply-to
line originally. If using of From -header is disabled
then kehlist uses envelope sender instead.
4) X-kehlist-copy addresses are also added to Reply-To line
(if they didn't member of list)

If envelope sender isn't member of list, kehlist adds X-kehlist-notice
header, which tell that fact, to mail. That is done, that it is easy
notice, if some envelope sender addresses is missing from list (envelope
sender is easy add as alias to subscribers list by using '=' -syntax).

Return-Receipt-To header generates delivery raport from kehlist if
in config file have NOT line:
Process-Return-Receipt-To: False
Return-Receipt-To headers are removed.

Kehlist removes any Errors-To:, Content-Lenght:, Return-Receipt-To:
and Return-Path: headers from mail.

Option -p or line
Private-List: True
in config file, causes that kehlist requires that enevelope sender
is member of list (bumerang anddress should be fully qualified in this
case, because it is mentioned in kehlist's error message. For example:
Bumerang-address: my-list...@my.domain
)

Option -r or line
Insert-Resent-headers: True
in config file, causes that kehlist adds Resent-* headers to mail
(list address should be fully qualified, bacuase domain of list address
is used in message-id (header Resent-Message-ID). For example:
List-address: my-...@my.domain)
Kehlist also adds Resent-* headers when there already was some Resent-*
header mail in mail, even when config file reads:
Insert-Resent-headers: False
To avoid completely creation of Resent-* headers, add to config file:
Drop-Resent-headers: False

Drop-Resent-headers: False
in config file, causes that all old Resent-* headers are dropped from mail.
This also drops old X-List-Processor: and X-kehlist-notice: headers from mail.

Option -b or line
Allow-Bumerang: True
in config file, causes that mail's with null envelope sender (or where
envelope-sender is MAILER-DAEMON) isn't rejected. Normally kehlist rejects
these mail to avoid mail loops (what can happend if list is misconfigured).

With option -M <mailer-daemon name> or line
Mailer-Daemon: <mailer-daemon name>
in config file, changes which address is treated as null sender.
This address should match to name in 'Dn' -line in (local) sendmail.cf.

Option -e or line
Insert-Errors-To: True
in config -file, causes that kehlist adds Errors-To -header line to mail.

Option -f or line
Use-From: False
in config -file, causes that kehlist uses envelope sender in
Reply-To or Wide-Reply-To -line (instead of addresses in From -line).

With option -U <UUCP-Domain> or lines
Accept-UUCP: True
UUCP-Domain: <UUCP-Domain>
in config -file, kehlist parses host!user form from "From " -line
(and in headers of mail). If in host haven't damain appended
(ie. no unquoted '.') then, kehlist appends <UUCP-Domain> to that
(with '.'). That address is domainized to RFC 822 form.
Kehlist don't handle UUCP bang-paths.

With option -D <DECNET-Domain> or lines
Accept-DECNET: True
DECNET-Domain: <DECNET-Domain>
in config -file, kehlist parses host::user form from "From " -line
and in headers of mail. If in host haven't damain appended
(ie. no unquoted '.') then, kehlist appends <DECNET-Domain> to that
(with '.'). That address is domainized to RFC 822 form.
If Accept-DECNET is false, kehlist confuses Decnet addresses with
RFC 822 group syntax (Group syntax uses one : -character after phrase).

Option -C or line
Convert-Message: False
in config -file, puts transparent mode. In that mode conversions for
MIME-messages isn't done. Also in transparent mode kehlist don't use
temporary files. Header
Content-Conversion: Prohibited
in message also puts kehlist to transparent mode.
Notice that this severely limits of functionality of kehpager (when
kehpager don't use temporary files, kehpager can't consume mail
several times).

With option -P <precedence-value> or lines
Precedence: <precedence-value>
Set-Precedence: True
in config file kehlist adds Precedence header to mail (if not exists).
Value 'List' is recommended. 'Precedence: List' is sendmail8-ism, check
implications of that from sendmail's documentation.

With line
Add-Host-Name: True
in config line, kehlist adds host part to addresses where it is missing.
Host name is taken from address of list or from bumerang address of list or
(as last resort) from output of 'hostname' command.

With line
Group-Reply-Mode: True
in config file, kehlist goes to group reply mode. In that mode kehlist
1) Inserts Wide-Reply-To: headers (instead of Reply-To: header) to mail
2) Scans To:, CC:, Resent-To: and Resent-CC: lines for receivers.
Kehlist don't send mail to these receivers (even though them are
members of list) in group reply mode.
Kehlist modifies Wide-Reply-To: line if it exists in mail even when kehlist
don't have group reply mode.

Option -f0 tells that mail don't have unix "From " mailbox separator in
beginning. In this case address of envelope sender is taken from Return-Path:
header.

Options -d, -dd and -ddd are for debugging. Sendmail isn't called
when that option -dd or -ddd is used.

Any address can be form: prase <real@address>. Kehlist handles all kind valid
RFC822 address syntax (if there is some error, complain to me
<Kari....@Fmi.FI>). If kehlist failed to parse something, which is valid
according of RFC822, it can be consider as bug.

For address comparision, domain part of address is turn to lowercase.
Kehlist also removes quotes from form "Firstname.Lastname"@domain when
quotes isn't required. Kehlist tries quite hard, that it newer generate
illegal address or Reply-To line.

Kehlist don't allow normally mailing from list to another list. Reasons:
1) Prevent mail looping, if someone puts
X-kehlist-copy: list@address
2) Thre isn't correct addresses for Reply-To or Wide-Reply-To
headers when mail comes from another list and these lists
are not configured to be sublists to another.
Kehlist allows mailing from list to another list when mail comes from
another sublist of that list. Kehlist also allows mailing from another
list when all of following are true
1) kehlist is in group reply mode
2) kehlist adds Resent-* headers to mail
3) there was old Resent-* headers in mail

Finally: Check exit codes used in perl -script - they can vary.
Also check invocation of sendmail (also options).

That's all, folk!

- Kari E. Hurtta <Kari....@Fmi.FI>
EOM
cat >kehlist.NOTE-1 <<'EOM'
[ Kehlist is filter to implement mailing list. ]

Notes to kehlist.README:

#1:
| Receivers of mode LIST have sublists (or parent lists). Format for that is:
| LIST: List Name <list1@machine> = <list1-request@machine>
| Actual mode of mode LIST can tell in config file with:
| List-Receiver-Mode: NIL
| or
| List-Receiver-Mode: QP
| or
| List-Receiver-Mode: 8BIT

| If listaname1 have receiver:
| LIST: List Name <listname2@machine> = <listname2-request@machine>
| Then listname2 must be receiver:
| LIST: List Name <listname1@machine> = <listname1-request@machine>
| Otherwise kehlist bounces mail with configuration error.

There is two topologies, which don't lead duplicates of mail:
1) All sublists are listed in address file of every sublist.
2) Sublist are formed as tree.
Most of other topologies causes that part of subscribers get same article
several times. In worst topology subscriber get mail n-2 times, where n is
number of sublists. I recommend to use topology 1). It produces minimal number
of extra Received: -headers.

#2:
| With line
| Add-Host-Name: True
| in config line, kehlist adds host part to addresses where it is missing.
| Host name is taken from address of list or from bumerang address of list or
| (as last resort) from output of 'hostname' command.

This should be true in group-reply-mode, because sendmail don't know about
Wide-Reply-To: -header and threfore can't qualify addresses in that line.

It should be true also when sublists is used (because sublists uses
X-kehlist-ring: -header to prevent looping).

When this is true address of list should be fully qualified in config-file
so kehlist get host name from here ('hostname' command usually gives hostname
without domain part).

- Kari E. Hurtta <Kari....@Fmi.FI>

EOM
cat >patch1.README <<'EOM'
General information:

Kehlist is simple(?) filter to implement mailing list.
You can implement mailing list by using sendmail's
aliases, but that way replies to mail, which comes
from list, goes to sender.

Kehlist adds or modifies Reply-To: header that way,
that replies to mail goes to list. Or alternatively kehlist
leaves Reply-To: header intact and adds or modifies
Wide-Reply-To: header so group replies to mail goes
to list (see: group reply mode).

This patch changes kehlist version from 1.3 to 1.3.1

Changes of kehlist in this patch:

Quoted-Printable encoding is now done better.

If in mail have 8bit data, but it dont have MIME-Version
-header, it is mimefied by adding:
MIME-Version: 1.0
Content-Type: text/plain; charset=UNKNOWN-8BIT
Content-Transfer-Encoding is put to 8bit (or binary), but
it can later to transfered to quoted-printable if requested.

Mail with STD 11 (RFC 1049) Content-Type: -header is converted to
MIME. [ STD 11 includes RFC 822 and RFC 1049 ]

Now kehlist adds MIME-Version: 1.0 header if it
add Content-Type or Content-Encoding: -header to embedded
mail (inside of type Message/RFC822). Previously
MIME-Version: -header was not added. Also handling of
Message/RFC822 is now generally better.

Some minor fixes.

Some debug lines added.

To applying this patch, use command: patch <patch1.diff

EOM
echo Patch 1 is already included!
cat >kehlist <<'EOM'
#!/bin/perl
# Author: Kari E. Hurtta <Kari....@Fmi.FI>
$version='v1.3.1';

require 'sysexits.ph';

# Exit codes (from sysexits.ph):
$e_usage = &EX_USAGE;
$e_config = &EX_CONFIG;
$e_data = &EX_DATAERR;
$e_syntax = &EX_DATAERR;
$e_perm = &EX_NOPERM;
$e_system = &EX_OSERR;
$e_tmpfail = &EX_TEMPFAIL;
$e_software = &EX_SOFTWARE;

# Charset's which is safe to do conversion quoted-printable -> 8bit or
# base64 -> 8bit
@charsets = ( 'US-ASCII', 'ISO-8859-1', 'ISO-8859-2', 'ISO-8859-3',
'ISO-8859-4', 'ISO-8859-5', 'ISO-8859-5', 'ISO-8859-6',
'ISO-8859-7', 'ISO-8859-8', 'ISO-8859-9','ISO-8859-10' );
for $i ( @charsets ) { $safe_charset{$i} = 1; }
#
sub get_dir {
local($prog) = @_;
if ($prog =~ m#^(.*/)[^/]*#) {
return $1;
}
return './';
}

sub add_path {
local ($file,$path) = @_;
$file = $path . $file if ( $file !~ m%^(\.\.|\.|)/% );
return $file;
}

if ($ARGV[0] =~ /^-(dd*)$/) {
$debug=length($1);
print "Debug value: $debug\n";
shift @ARGV;
}

$nofrom = 0;
if ($ARGV[0] eq '-f0') {
$nofrom = 1;
shift @ARGV;
}

$mailer_daemon = 'MAILER-DAEMON';
$list_mode = 'NIL';
$time=time;
$time_s=&timestring($time);
$use_from=1;
$group_reply_mode=0;
$accept_uucp=0;
$accept_decnet=0;
$decnet_domain = 'DNET';
$precedence='List';
$set_precedence = 0;
$tmpdir = '/usr/tmp';
$no_tmpfile = 0;
$fh = 'A000';
$drop_resent = 0;
$full='';
$domainize = 1;
$handle_RR = 1;
@b64_codes=('A'..'Z','a'..'z','0'..'9','+','/');
for ($i=0; $i < 64; $i++) { $b64_val{@b64_codes[$i]}=$i; }
$b64_val{'='} = 'EOF';

if ($ARGV[0] eq '-F') {
if ($#ARGV != 1) {
print STDERR "Usage: $0 [-d] [-f0] [-g] [-r] [-p] [-b] [-e] [-M MAILER-DAEMON] [-f] [-U UUCP] [-D DNET] [-C] [-P List] bumerang address-list list-name [full-name]\n";
print STDERR " $0 [-d] [-f0] -F config-file\n";
exit $e_usage;
}
$conf = &add_path($ARGV[1],&get_dir($0));
if (!open (CONF, "<$conf")) {
print STDERR "$0: Can't open $conf: $!\n";
exit $e_config;
}
while (<CONF>) {
chop;
s/^[ \t]+//;
s/[ \t]+$//;
next if (/^$/ || /^\#/);
if (/^List-name:[ \t]*(.*)$/) {
$full = $1;
} elsif (/^List-address:[ \t]*(.*)$/) {
$a = $1;
$b='';
$c='';
$dummy = '';
$list = &eat_addr(*a,'',*b,*c,*dummy);
$full = $c if ($full eq '');
} elsif (/^Bumerang-address:[ \t]*(.*)$/) {
$a = $1;
$b='';
$c='';
$dummy = '';
$bumerang = &eat_addr(*a,'',*b,*c,*dummy);
$bumerangfull = $c;
} elsif (/^Address-file:[ \t]*(.*)$/) {
$a = $1;
$file = &add_path($a,&get_dir($conf));
} elsif (/^Address-list:[ \t]*(.*)$/) {
$a = $1;
$file = &add_path($a,&get_dir($conf));
} elsif (/^Insert-Resent-headers:[ \t]*True$/) {
$resent=1;
} elsif (/^Insert-Resent-headers:[ \t]*False$/) {
$resent=0;
} elsif (/^Drop-Resent-headers:[ \t]*True$/) {
$drop_resent=1;
} elsif (/^Drop-Resent-headers:[ \t]*False$/) {
$drop_resent=0;
} elsif (/^Private-List:[ \t]*True$/) {
$private=1;
} elsif (/^Private-List:[ \t]*False$/) {
$private=0;
} elsif (/^Allow-Bumerang:[ \t]*True$/) {
$allow_bumerang=1;
} elsif (/^Allow-Bumerang:[ \t]*False$/) {
$allow_bumerang=0;
} elsif (/^Insert-Errors-To:[ \t]*True$/) {
$errors_to=1;
} elsif (/^Insert-Errors-To:[ \t]*False$/) {
$errors_to=0;
} elsif (/^List-Receiver-Mode:[ \t]*NIL$/) {
$list_mode = 'NIL';
} elsif (/^List-Receiver-Mode:[ \t]*8BIT$/) {
$list_mode = '8BIT';
} elsif (/^List-Receiver-Mode:[ \t]*QP$/) {
$list_mode = 'QP';
} elsif (/^Mailer-Daemon:[ \t]*(.+)$/) {
$mailer_daemon = $1;
} elsif (/^Use-From:[ \t]*True$/) {
$use_from = 1;
} elsif (/^Use-From:[ \t]*False$/) {
$use_from = 0;
} elsif (/^Accept-UUCP:[ \t]*True$/) {
$accept_uucp = 1;
} elsif (/^Accept-UUCP:[ \t]*False$/) {
$accept_uucp = 0;
} elsif (/^UUCP-Domain:[ \t]*(.+)$/) {
$uucp_domain = $1;
} elsif (/^Accept-DECNET:[ \t]*True$/) {
$accept_decnet = 1;
} elsif (/^Accept-DECNET:[ \t]*False$/) {
$accept_uucp = 0;
} elsif (/^DECNET-Domain:[ \t]*(.+)$/) {
$decnet_domain = $1;
} elsif (/^Convert-Message:[ \t]*True$/) {
$no_tmpfile = 0;
} elsif (/^Convert-Message:[ \t]*False$/) {
$no_tmpfile = 1;
} elsif (/^Add-Host-Name:[ \t]*True$/) {
$domainize = 1;
} elsif (/^Add-Host-Name:[ \t]*False$/) {
$domainize = 0;
} elsif (/^Process-Return-Receipt-To:[ \t]*True$/) {
$handle_RR = 1;
} elsif (/^Process-Return-Receipt-To:[ \t]*False$/) {
$handle_RR = 0;
} elsif (/^Precedence:[ \t]*(.+)$/) {
$precedence = $1;
} elsif (/^Set-Precedence:[ \t]*True$/) {
$set_precedence = 1;
} elsif (/^Set-Precedence:[ \t]*False$/) {
$set_precedence = 0;
} elsif (/^Group-Reply-Mode:[ \t]*True$/) {
$group_reply_mode = 1;
} elsif (/^Group-Reply-Mode:[ \t]*False$/) {
$group_reply_mode = 0;
} else {
print STDERR "$0: Bad config file line in $conf:\n$_\n";
exit $e_config;
}
}
close(CONF);
if (!defined $list) {
print STDERR "$0: Address-file missing from $conf\n";
exit $e_config;
}
if (!defined $file) {
print STDERR "$0: List-address missing from $conf\n";
exit $e_config;
}
if (!defined $bumerang) {
print STDERR "$0: Bumerang-address missing from $conf\n";
exit $e_config;
}
} else {

if ($ARGV[0] eq '-g') {
$group_reply_mode=1;
shift @ARGV;
}

if ($ARGV[0] eq '-r') {
$resent=1;
shift @ARGV;
}

if ($ARGV[0] eq '-p') {
$private=1;
shift @ARGV;
}

if ($ARGV[0] eq '-b') {
$allow_bumerang=1;
shift @ARGV;
}

if ($ARGV[0] eq '-e') {
$errors_to=1;
shift @ARGV;
}

if ($ARGV[0] eq '-M') {
if ($#ARGV < 1) {
print STDERR "$0: -M option requires argument.\n";
exit $e_usage;
}
$mailer_daemon = $ARGV[1];
shift @ARGV; shift @ARGV;
}

if ($ARGV[0] eq '-f') {
$use_from=0;
shift @ARGV;
}

if ($ARGV[0] eq '-U') {
if ($#ARGV < 1) {
print STDERR "$0: -U option requires argument.\n";
exit $e_usage;
}
$uucp_domain = $ARGV[1];
$accept_uucp = 1;
shift @ARGV; shift @ARGV;
}

if ($ARGV[0] eq '-D') {
if ($#ARGV < 1) {
print STDERR "$0: -D option requires argument.\n";
exit $e_usage;
}
$decnet_domain = $ARGV[1];
$accept_decnet = 1;
shift @ARGV; shift @ARGV;
}

if ($ARGV[0] eq '-C') {
$no_tmpfile = 1;
shift @ARGV;
}

if ($ARGV[0] eq '-P') {
if ($#ARGV < 1) {
print STDERR "$0: -P option requires argument.\n";
exit $e_usage;
}
$precedence = $ARGV[1];
$set_precedence = 1;
shift @ARGV; shift @ARGV;
}

if ($#ARGV<2 || $#ARGV >3) {
print STDERR "Usage: $0 [-d] [-f0] [-g] [-r] [-p] [-b] [-e] [-M MAILER-DAEMON] [-f] [-U UUCP] [-D DNET] [-C] [-P List] bumerang address-list list-name [full-name]\n";
print STDERR " $0 [-d] [-f0] -F config-file\n";
exit $e_usage;
}

$member=0;
$a = $ARGV[0];
$b='';
$c='';
$dummy = '';
$bumerang = &eat_addr(*a,'',*b,*c,*dummy);
$bumerangfull = $c;
$a = $ARGV[2];
$file = &add_path($ARGV[1],&get_dir($0));
$full = $ARGV[3];
$b='';
$c='';
$dummy = '';
$list = &eat_addr(*a,'',*b,*c,*dummy);
$full = $c if ($full eq '');

}

$full = &normalize_phrase($full);
# Only used when private list
$bumerangfull = &normalize_phrase($bumerangfull);
&normalize($list,*list,undef);
&normalize($bumerang,*bumerang,undef);

$domain=$list;
$a='';
$list_local=&eat_addr(*domain,'@',*a,undef,undef);
if ($domain eq '') {
$domain=$bumerang;
$a='';
&eat_addr(*domain,'@',*a,undef,undef);
}
chop($domain="@" . `hostname`) if ($domain eq '');

sub timestring {

local($time) = @_;
local($gsec,$gmin,$ghour,$gmday)=gmtime($time);
local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)=localtime($time);
local($Mon)=('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug',
'Sep','Oct','Nov','Dec')[$mon];
local($diff)=0;
local($mdiff)=$mday-$gmday;
local($sig)='+';
local($tzname)='';

# Use them
( $gsec,$sec,$mon,$year,$wday,$yday );

$mdiff = 1 if ($mdiff < -1);
$mdiff = -1 if ($mdiff > 1);

$diff = 24*60*$mdiff + 60*($hour-$ghour) + $min-$gmin;

if ($diff < 0) {
$sig='-';
$diff=-$diff;
}

if (defined $ENV{'TZ'} && $ENV{'TZ'} =~ /^(...)/) {
$tzname = $1;
}
if ($isdst) {
$tzname .= ' ' if $tzname ne '';
$tzname .= 'DST';
}
$tzname = " ($tzname)" if $tzname ne '';

sprintf ('%2d %s %04d %02d:%02d:%02d %s%02d%02d%s',
$mday,$Mon,1900 + $year,$hour,$min,$sec,
$sig,$diff/60,$diff%60,$tzname);
}

sub add_domain {
local($address,$domain) = @_;
local ($a) = '';
local ($b) = &eat_addr(*address,'@',*a,undef,undef);
$address = $domain if ($address eq '');
return $b . $address;
}

if ($domainize) {
$list = &add_domain($list,$domain);
$bumerang = &add_domain($bumerang,$domain);
}

if (!open (RECEIVERS,"<$file")) {
print STDERR "$0: Can't open $file: $!\n";
exit $e_config;
}

$kehlist_notice = '';
sub notice {
local($text) = @_;
$kehlist_notice .= "\n " if ($kehlist_notice ne '');
$text =~ s/\n+$//;
$text =~ s/\n[ \t]*/\n /g;
$kehlist_notice .= $text;
}

sub eat_com {
local (*text) = @_;
local ($result) = '';

if ($text =~ s/^(\(([^\(\)\\]|\\.)*)//) {
$result .= $1;
while ($text =~ /^\(/) {
$result .= &eat_com(*text);
if ($text =~ s/^(([^\(\)\\]|\\.)*)//) {
$result .= $1;
}
}
if ($text =~ s/^(\))//) {
$result .= $1;
}
}
return $result;
}

sub message_id {
local($line,$msg) = @_;
local($pras) = "";
local($mb) = "";
local ($comm) = "";
local($return) = &eat_addr(*line,'',*comm,*pras,*mb);

if ($mb ne '<') {
&notice("No Message-ID in header: $msg");
return undef;
}
if ($pras ne '') {
&notice("Extra prase in header: $msg");
}
return $return;
}

sub eat_addr {
local (*str,$trm,*comm,*pras,*mb) = @_;
local ($return,$filled);
local ($nobreak) = 0;

$return = '';
$filled = '';
$str =~ s/^[ \t]+// if 0 > index($trm,' ');
while ($str ne '' && (0 > index($trm,substr($str,0,1))
|| $nobreak)) {
if ($str =~ s/^(\"([^\"]|\\.)*\")//) {
$return .= $1;
$filled .= $1;
}
elsif ($str =~ s/^(\[([^\[]|\\.)*\])//) {
$return .= $1;
$filled .= $1;
}
elsif ($str =~ /^\(/) {
$comm .= ' ' if ($comm ne '');
$comm .= &eat_com(*str);
}
elsif ($str =~ s/^([^\.\[\]\"\,\(\) \t\:\;\<\>\@\!\=\/]+)//) {
$return .= $1;
$filled .= $1;
} elsif ($str =~ s/^(.)//) {
$it = $1;
$return .= $it;
$nobreak = 1 if $it eq '<' && defined $mb;
$nobreak = 0 if $it eq '>' && defined $mb;
if ($it eq '<' && defined $pras && defined $mb) {
$pras .= $filled;
$return = '<';
$filled = '';
}
$filled .= $it;
}
if (0 > index($trm,' ')) {
if ($str =~ s/^([ \t]+)//) {
$filled .= $1;
}
}
}
if ($str =~ /^:/ && defined $pras) {
$pras .= $filled;
$return = '';
$filled = '';
}
if (defined $mb) {
$mb = '';
$mb = '<' if ($return =~ s/^\<(.*)\>$/\1/);
}
return $return;
}

if (!$nofrom) {
$_ = <STDIN>;

if (!/^From /) {
print STDERR "$0: Mail don't start with unix-mail From_ line\n";
exit $e_data;
}

if (/^From (.*)$/) {
$text = $1;
&parse_envelope($text,$_,*from,*fromorig,' ');
}
}

sub parse_envelope {
local($text,$line,*from,*fromorig,$sep) = @_;

$comm = '';
$fromorig = '';
$dummy = '';
$from = &eat_addr(*text,$sep,*comm,undef,*dummy);
if ($from eq '') {
undef $from;
undef $fromorig;
} else {
if ($accept_decnet) {
local($user) = $from;
local($host) = &eat_addr(*user,':',*comm,undef,undef);
if ($user =~ s/^:://) {
local ($dd) = $host;
if ($host !~ /^\[.*\]$/) {
$host = &eat_addr(*dd,'.',*comm,undef,undef);
$dd = '.' . $decnet_domain if ($dd eq '');
$host .= $dd;
}
$from = $user . '@' . $host;
}
}
$from = &normalize($from,*fromorig,undef);
if ($comm ne '') {
print STDERR "$0: Comment in envelope address: $comm\n" .
"\tEnvelope: $line";
exit $e_syntax;
}
}
}

while(<RECEIVERS>) {
s/\n$//;
s/^[ \t]+//;
s/[ \t]+$//;
next if (/^$/ || /^\#/);
s/\t/ /g;

$line = $_;
$addr = '';
$raddr = '';
$raddrb = '';
$mode = 'NIL';
while ('' ne $line) {
$comm = '';
$prase = '';
$dummy = '';
$a = &eat_addr(*line,',=:#',*comm,*prase,*dummy);
if ($a ne '') {
$b = &normalize($a,*raddrb,undef);
$a = &normalize($a,*raddr,$domain);
if ($addr eq '') {
push (@rec,$a);
$addr = $a;
$mode{$addr} = $mode;
}
$alias{$a} = $addr;
$comm{$a} = $comm;
$prase{$a} = &normalize_phrase($prase);
$raddr{$a} = $raddr;
if ($debug > 2) {
print "$a: \t----------\n";
print "\tAlias:\t$addr\n";
print "\tComm:\t$comm\n";
print "\tPhrase:\t",$prase{$a},"\n";
print "\tRaddr:\t$raddr\n";
}
if ($a ne $b) {
$alias{$b} = $addr;
$comm{$b} = $comm;
$prase{$b} = $prase{$a};
$raddr{$b} = $raddrb;
if ($debug > 2) {
print "$b: \t$a\n";
print "\tAlias:\t$addr\n";
print "\tComm:\t$comm\n";
print "\tPhrase:\t",$prase{$b},"\n";
print "\tRaddr:\t$raddrb\n";
}
}
}
if ($line =~ s/^: *//) {
$mode = $prase;
if ($mode ne 'NIL' && $mode ne '8BIT' && $mode ne 'QP' &&
$mode ne 'DEBUG' && $mode ne 'LIST') {
print STDERR
"$0: $file: $.: Bad mode ($mode)\n\t$_\n";
exit $e_config;
}
} elsif ($line =~ s/^ *, *//) {
$addr = '';
$mode = 'NIL';
} elsif ($line =~ /^ *\#/) {
last;
} else {
$line =~ s/^ *=//;
$line =~ s/ +//;
}
}
}
if (defined $from) {
$rp="$fromorig";
} else {
undef $rp;
}

sub normalize { # Normalizes address for comparision
local($n,*full,$domain) = @_;
local($a,$b,$c,$l,$ud);
local($addr) = $n;
local($route) = '';
$b = '';
if ($n =~ /^@/) {
$route = &eat_addr(*n,':',*b,undef,undef);
if ($n =~ s/^://) {
$route .= ':';
}
if ($n eq '') {
print STDERR "$0: Bad address: $addr\n";
exit $e_syntax;
}
}
$a = &eat_addr(*n,'@',*b,undef,undef);
# Domainize UUCP address
if ($n eq '' && $accept_uucp) {
$n = &eat_addr(*a,'!',*b,undef,undef);
if ($a eq '') { # Not UUCP address
$a = $n;
$n = '';
} else {
$a =~ s/^\!//;
$ud = $n;
if ($n !~ /^\[.*\]$/) {
$n = &eat_addr(*ud,'.',*b,undef,undef);
$ud = '.' . $uucp_domain if ($ud eq '');
$n .= $ud;
}
$n = '@' . $n;
}
}
# Strip quotes from "FirstName.Surname"@domain without
# makeing illegal address
$l = '';
while ('' ne ($c = &eat_addr(*a,'.',*b,undef,undef))) {
if ($c =~ s/^\"(.*)\"$/\1/) {
$c = "\"$c\""
if ($c !~ /^[A-Za-z0-9]+(\.[A-Za-z0-9]+)*$/);
}
$l .= $c;
if ($a =~ s/^\.//) {
$l .= '.';
}
}
if ($a ne '') {
print STDERR "$0: Bad address: $addr\n";
exit $e_syntax;
}
$n = $domain if ($n eq '' && defined $domain && $domainize &&
$l !~ /^\\/ && $route eq '');
$full = $route . $l . $n if (defined $full);
$n =~ tr/A-Z/a-z/;
return $l . $n;
}

sub normalize_phrase { # Normalize phrase
local ($phrase) = @_;
local ($result) = '';
local ($a,$b);
$phrase =~ s/^ +//;
$phrase =~ s/ +$//;
while ('' ne ($a = &eat_addr(*phrase,' ',*b,undef,undef))) {
if ($a !~ /^\".*\"$/) {
if ($a =~ /[\"\.<>@\[\]():,;\\]/) {
$a =~ s/\\/\\\\/g;
$a =~ s/\"/\\\"/g;
$a = '"' . $a . '"';
}
} elsif ($a =~ /^\"(.+)\"$/) {
$b = $1;
if ($b =~ /^[A-Za-z0-9]+( [A-Za-z0-9]+)*$/) {
$a = $b;
}
}
$result .= $a;
if ($phrase =~ s/^ +//) {
$result .= ' ';
}
}
return $result;
}

sub split_line {
local($line,*arr) = @_;
local($comm,$addr,$pras,$raddr,$list);
local($saved_line) = $line;

$line =~ tr/\t\n/ /;
$line =~ s/^[\, ]+//;
$raddr = '';
$list = '';
while ('' ne $line) {
$dummy = '';
$comm = '';
$pras = '';
if ('' ne ($addr = &eat_addr(*line,',:;',*comm,*pras,*dummy))) {
$addr = &normalize($addr,*raddr,$domain);
push(@arr,$raddr . "\t" . &normalize_phrase($pras) .
"\t" . $comm . "\t" . $addr . "\t" . $list);
} else {
if ($accept_decnet && $pras !~ /[ \t\"\\]/ && $line =~ s/^:://) {
local ($user) = &eat_addr(*line,',;',*comm,undef,undef);
local ($dd) = $pras;
if ($pras !~ /^\[.*\]$/) {
$pras = &eat_addr(*dd,'.',*comm,undef,undef);
$dd = '.' . $decnet_domain if ($dd eq '');
$pras .= $dd;
}
$addr = $user . '@' . $pras;
$pras = '';
$addr = &normalize($addr,*raddr,undef);
push(@arr,$raddr . "\t\t" .
$comm . "\t" . $addr . "\t" . $list);
} elsif ($line =~ s/^://) {
$list = &normalize_phrase($pras);
} elsif ($line =~ s/^;//) {
$list = '';
} else {
print STDERR "$0: Bad header line: $saved_line\n";
exit $e_data;
}
}
$line =~ s/^[\, ]+//;
}
}

@copy = ();
@return_copy = ();

$line='';
$field='';
@reply_to = ();
@wide_reply_to = ();
$resent_seen = 0;
@r_reply_to = ();
@r_wide_reply_to = ();
@receivers = ();
$was_wide_reply_to = 0;
@from = ();
undef $message_id;
@headers_head = ();
@headers_tail = ();
@headers_dropped = ();
$have_mime = 0;
@top_mime_headers = ();
@x_kehlist_ring = ();
$flag_list = 0;
undef $sub_nomember;

sub eat_mime_headers { # From subtype
local($stream,*array) = @_;
local($line) = '';
local($field) = '';
local($a,$b);
local($ok) = 1;
undef @array;

print "eat_mime_headers: stream: $stream\n" if ($debug > 2);

while(<$stream>) {
chop;
last if (/^$/);
if (/^[ \t]/) {
$line .= "\n" . $_;
next;
}
elsif (/^([^ :]+):(.*)$/) {
$a=$1;
$b=$2;
push(@array,"$field:$line") if $field ne '';
$field = $a;
$line = $b;
} else {
&notice("Bad mime header:\n$_\n");
$ok = 0;
last;
}
}
push(@array,"$field:$line") if $field ne '';
return $ok;
}

while(<STDIN>) {
chop;
last if (/^$/);
if (/^[ \t]/) {
$line .= "\n" . $_;
next;
}
elsif (/^([^ :]+):(.*)$/) {
$a=$1;
$b=$2;
&flush_header;
$field = $a;
$line = $b;
} else {
print STDERR "$0: Bad header line: $_\n";
exit $e_data;
}
}
&flush_header;

sub flush_header {
if ($field eq '' && $line eq '') {
return;
}
if ($field eq '') {
print "$0: Bad header line: $line\n";
exit $e_data;
}

$c = $field;
$c =~ tr/A-Z/a-z/;
if ($c ne 'reply-to' &&
$c ne 'return-receipt-to' &&
$c ne 'content-length' &&
$c ne 'errors-to' &&
$c ne 'return-path' &&
$c ne 'wide-reply-to' &&
$c ne 'x-kehlist-ring' &&
$c ne 'x-kehlist-no-member') {
if ($c =~ /^content-/) {
push (@top_mime_headers,"$field:$line");
} elsif ($c =~ /^resent-/) {
$resent_seen = 1;
push (@headers_dropped,"$field:$line");
} elsif ($c =~ /^x-list-processor$/ ||
$c =~ /^x-kehlist-/ && $c ne 'x-kehlist-copy') {
push (@headers_dropped,"$field:$line");
} elsif ($c =~ /^x-/) {
push (@headers_tail,"$field:$line");
} else {
push (@headers_head,"$field:$line");
}
}

if ($c eq 'message-id') {
local($id) = &message_id($line,"$field: $line");
if (defined $id && defined $message_id &&
$id ne $message_id) {
&notice("Extra Message-ID: $line");
} elsif (defined $id) {
$message_id = $id;
}
}

if ($c eq 'return-path') {
$line =~ tr/\n\t/ /;
$line =~ s/^ *//;
if ($nofrom == 0) {
local($af,$bf);
&parse_envelope($line, "$field: $line",*af,*bf,'');
&notice("Extra Return-Path: $line")
if ($af ne $from || $bf ne $fromorig);

} else {
&parse_envelope($line, "$field: $line",*from,*fromorig,'');
$nofrom = 0;
}
}

if ($c eq 'x-kehlist-no-member') {
local($mb) = '';
local($comm,$pras);
local($str) = $line;
local($a) = &eat_addr(*str,'',*comm,*pras,*mb);
$sub_nomember = $a if ($mb eq '<');
}

&split_line($line,*x_kehlist_ring)
if ($c eq 'x-kehlist-ring');
&split_line($line,*reply_to)
if ($c eq 'reply-to');
&split_line($line,*r_reply_to)
if ($c eq 'resent-reply-to' && $#r_reply_to < 0);
if ($c eq 'wide-reply-to') {
&split_line($line,*wide_reply_to);
$was_wide_reply_to = 1;
}
if ($c eq 'resent-wide-reply-to' && $#r_wide_reply_to < 0) {
&split_line($line,*r_wide_reply_to);
$was_wide_reply_to = 1;
}

&split_line($line,*return_copy)
if ($c eq 'return-receipt-to' && $handle_RR);

&split_line($line,*copy)
if ($c eq 'x-kehlist-copy');
&split_line($line,*from)
if ($c eq 'from' && $use_from);
$flag_list = 1
if ($c eq 'x-list-processor');
&mime_version($line)
if ($c eq 'mime-version');
if ($c eq 'content-conversion') {
local($v) = $line;
local($comm) = '';
$v =~ tr/\t\n/ /;
local($value) = &eat_addr(*v,'',*comm,undef,undef);
$value =~ tr/A-Z/a-z/;
$no_tmpfile = 1 if ($value eq 'prohibited');
}
$set_precedence = 0 if ($c eq 'precedence');

&split_line($line,*receivers)
if ($group_reply_mode && ($c eq 'to' ||
$c eq 'cc' ||
$c eq 'resent-to' ||
$c eq 'resent-cc' ||
$c eq 'bcc' ||
$c eq 'resent-bcc'));

$field='';
$line='';
}

sub push_sel {
local(*a1,*a2) = @_;
local(%mark) = ();
local($i);

for $i (@a1) {
$mark{$i} = 1;
}

for $i (@a2) {
next if ($mark{$i});
push(@a1,$i);
$mark{$i} = 1;
}
}

@orig_reply_to = @reply_to;

if ($#r_reply_to >= 0) {
&push_sel(*reply_to,*r_reply_to);
} else {
@r_reply_to = @orig_reply_to;
}

if ($#r_wide_reply_to >= 0) {
&push_sel(*wide_reply_to,*r_wide_reply_to);
}
$resent = 1 if ($resent_seen && !$drop_resent);

if ($nofrom) {
print STDERR
"$0: Missing Return-Path: -header -- no envelope sender data.\n";
exit $e_syntax;
}

if ((!defined $from || $from eq $mailer_daemon) && !$allow_bumerang) {
if (!defined $from) {
print STDERR "$full <$list> - No envelope sender.\n";
} else {
if (defined $fromorig) {
print STDERR "$full <$list> - Envelope sender <$fromorig>\n";
} else {
print STDERR "$full <$list> - Envelope sender <$from>\n";
}
}
print STDERR "$full <$list> - Possible bumerang - rejected.\n";
print STDERR "$full <$list> - Possible misconfiguration of list.\n";
exit $e_perm;
}

sub mime_content {
local($line,*type,*subtype,*sub,*sep,*values,*comments) = @_;
local($field,$value,$com);

$com = '';

$type = &eat_addr(*line,'/',*com,undef,undef);
if ($type eq '' || ! ($line =~ s%^/%%)) {
&notice("Bad Content-Type header");
return 0;
}
$type =~ tr/A-Z/a-z/;
$subtype = &eat_addr(*line,';',*com,undef,undef);
if ($subtype eq '') {
&notice("SubType missing from Content-Type header");
return 0;
}
$comments { '*head*' } = $com;
$subtype =~ tr/A-Z/a-z/;
while ($line =~ s/^;//) {
$com = '';
$field = &eat_addr(*line,'=',*com,undef);
last if ($field eq '' || !($line =~ s/^=//));
$field =~ tr/A-Z/a-z/;
$value = &eat_addr(*line,';',*com,undef,undef);
if ($value =~ /^"(.*)"$/) {
$value = $1;
$value =~ s/\\(.)/\1/g;
}
$values{$field} = $value;
$comments{$field} = $com;
}
if ($line ne '') {
&notice("Failed to parse Content-Type header, bailing out: $line");
return 0;
}
$sub = 0;
if ($type eq 'multipart') {
$sub = 1;
if (defined $values{'boundary'}) {
$sep = $values{'boundary'};
} else {
&notice("Multpart type requires Boundary argument.");
return 0;
}
$sub = 5 if ($subtype eq 'digest');
} elsif ($type eq 'message') {
$sub = 6;
# Message/Partial is not supported
$sub = 3 if ($subtype eq 'partial');
$sub = 4 if ($subtype eq 'external');
# Process only message/rfc822
$sub = 2 if ($subtype eq 'rfc822');
}
return 1;
}

sub mime_encoding {
local($line,*enc) = @_;
local($com) = '';
$enc = &eat_addr(*line,'',*com,undef,undef);
if ($enc eq '') {
&notice("Bad Content-Transfer-Encoding header");
return 0;
}
$enc =~ tr/A-Z/a-z/;
if ($enc eq '7bit') {
return 1;
} elsif ($enc eq 'binary') {
return 1;
} elsif ($enc eq '8bit') {
return 1;
} elsif ($enc eq 'quoted-printable') {
return 1;
} elsif ($enc eq 'base64') {
return 1;
}
&notice("Unsupported encoding: $enc");
return 0;
}

sub check_body {
local($handle) = @_;
local($high) = 0;
local($long) = 0;
local($null) = 0;
local($a,$i);
while(<$handle>) {
$long = 1 if (length($_) > 950);
$high = 1 if (/[\200-\377]/);
$null = 1 if (/\0/);
}
return 'binary' if ($long || $null);
return '8bit' if ($high);
return '7bit';
}

sub parse_mime_headers {
local (*headers,*type,*subtype,*encoding,*sub,*sep,*values,*comments,
$isdigest) = @_;
local ($a,$h,$t,$c);
local($ok) = 1;
local(%count);

$type = 'text';
$subtype = 'plain';
if ($isdigest) {
$type = 'message';
$subtype = 'rfc822';
}
%values = ();
%comments = ();
$encoding = '7bit';
$sub = 0;
undef $sep;

for $a (@headers) {
if ($a =~ /^([^ :]+):(.*)$/) {
$h = $1;
$t = $2;
($c = $h) =~ tr/A-Z/a-z/;
$t =~ tr/\n\t/ /;
if ($c eq 'content-type' || $c eq 'content-transfer-encoding' ||
$c eq 'content-id') {
$count{$c}++;
if ($count{$c} > 1) {
&notice("Multiple $h headers !!\n");
$ok = 0;
}
}
$ok = $ok && &mime_content($t,*type,*subtype,
*sub,*sep,*values,*comments)
if ($c eq 'content-type');
$ok = $ok && &mime_encoding($t,*encoding)
if ($c eq 'content-transfer-encoding');
} else {
&notice ("Bad MIME header: $a");
$ok = 0;
}
}
&notice("This MIME part is skipped due the errors.") if (!$ok);
return $ok;
}

sub quote_value {
local($c) = @_;
if ($c =~ /[^-A-Za-z0-9+]/) {
$c =~ s/\\/\\\\/g;
$c =~ s/"/\\"/g;
$c = '"' . $c . '"';
}
return $c;
}

sub write_mime_headers {
local ($stream,*headers,*type,*subtype,*encoding,*sub,
*sep,*values,*comments) = @_;
local ($a,$b,$c,$len,$h,$t);
if (defined $sep) {
$values{'boundary'} = $sep;
}
for $a (@headers) {
if ($a =~ /^([^ :]+):(.*)$/) {
$h = $1;
$t = $2;
($c = $h) =~ tr/A-Z/a-z/;
print $stream $a,"\n"
if ($c ne 'content-type' &&
$c ne 'content-transfer-encoding' &&
$c ne 'content-length');
}
}

if (defined $encoding) {
print $stream "Content-Transfer-Encoding: $encoding\n";
}
if (defined $type && defined $subtype) {
$a = "$type/$subtype";
if ( $comments{'*head*'} ne '' ) {
$a .= ' ' . $comments{'*head*'};
}
$len = 15 + length($a);
for $b ( keys %values ) {
$c = &quote_value($values{$b});
if ($comments{$b} ne '' ) {
$c .= ' ' . $comments{$b};
}
$c = $b . '=' . $c;
if ($len + length($c) > 75) {
$a .= ";\n\t";
$len = 8;
} else {
$a .= "; ";
$len += 2;
}
$a .= $c;
$len += length($c);
}
print $stream "Content-Type: $a\n";
}
}

$tmpfile= $tmpdir . '/kehlist' . $$;

if (!$no_tmpfile) {
if(open(BODY,"+>$tmpfile")) {
unlink $tmpfile;
while (<STDIN>) {
if (!print BODY $_) {
print STDERR "$0: Failed to write tmpfile: $tmpfile: $! \n";
exit $e_tmpfail; # Try again later
# Disk full ?
}
}
if (!seek(BODY,0,0)) {
print STDERR "Seeking to beginning of tmpfile failed: $tmpfile: $!\n";
exit $e_system;
}
print "Stream BODY = $tmpfile\n" if ($debug > 3);
} else {
&notice("Can't open tmpfile: $tmpfile: $!");
&disable;
}
}
if ($no_tmpfile) {
open (BODY,"<-") || die "$0: dup failed: $!\n";
print "Stream BODY = STDIN\n" if ($debug > 3);
}

print "Stream BODY == " . tell(BODY) . "\n" if ($debug > 3);

%nosend = ();
if ($group_reply_mode) {
for $a ( @receivers ) {
@b = split("\t",$a);
if ($b[3] ne '') {
$c = $b[3];
if ($debug) { print "Nosend: $c\n"; }
$nosend{$c}=1;
if (defined $alias{$c} && $alias{$c} ne $c) {
if ($debug) { print "Nosend: ",$alias{$c},"\n"; }
$nosend{$alias{$c}}=1;
}
}
}
}

sub add_it {
local($target,$addr) = @_;
if ((defined $target) && ($target ne '')) {
$target .= "\t";
} else {
$target = '';
}
$target .= '<' . $addr . '>' ;
return $target;
}

$listcount = 0;
$target = '';
$sender_mode = 'NIL';

%normalized = ();

for $f ( @rec ) {
$n = &normalize($f,undef,undef);
$normalized{$f} = $n;
$mode = 'NIL';
$b = $f;
$a = $f;
$mode = $mode{$a} if defined $mode{$a};
$b = $raddr{$f} if defined $raddr{$f};
$mode = $mode{$b} if defined $mode{$b};

if ($debug) { print "Scan receiver: $f -- $n -- mode: $mode -- "; }
if ( defined $from && ($f eq $from ||
defined $alias{$from} && $alias{$from} eq $f)) {
$member++;
undef $rp;
if ($debug) { print "envelope sender <$fromorig>\n"; }
$sender_mode = $mode;
} else {
if ($debug) { print "\n"; }
}
}

if ($debug > 2) {
if (defined $sub_nomember) { print "Sub nomember: $sub_nomember\n"; }
else { print "Sub nomember NOT defined\n"; }
}

sub replace_list {
local(*addrs) = @_;
local($a,$b);
local(@new) = ();
local($raddr,$pras,$comm,$addr,$blist);

for $a ( @addrs ) {
@b = split("\t",$a);
$raddr = $b[0];
$pras = $b[1];
$comm = $b[2];
$addr = $b[3];
$blist = $b[4];

if ($addr eq $from
|| defined $alias{$addr} && $alias{$addr} eq $from
|| defined $alias{$from} && $addr eq $alias{$from}
|| defined $alias{$addr} && defined $alias{$from}
&& $alias{$addr} eq $alias{$from}
) {
$comm .= " (Was: $addr)" if ($addr !~ /[\(\)\\]/ &&
$comm !~ /\(Was: /);
$addr = &normalize($list,*raddr,undef);
$pras = $full;
}
push(@new,$raddr . "\t" . $pras .
"\t" . $comm . "\t" . $addr . "\t" . $blist);
}
@addrs = @new;
}

if ($sender_mode eq 'LIST') {
print "Sender <$from> -- <$fromorig> is companion list (sender mode: $sender_mode)\n"
if ($debug);
&replace_list(*reply_to);
&replace_list(*orig_reply_to);
&replace_list(*r_reply_to);
&replace_list(*wide_reply_to);
&replace_list(*r_wide_reply_to);

for $a ( @x_kehlist_ring ) {
@b = split("\t",$a);
if ($b[3] ne '') {
$c = $b[3];
if ($debug) { print "Nosend (RING): $c\n"; }
$nosend{$c}=1;
if (defined $alias{$c} && $alias{$c} ne $c) {
if ($debug) { print "Nosend (RING): ",$alias{$c},"\n"; }
$nosend{$alias{$c}}=1;
}
}
}
@copy = (); # No copy when privious list is already done copy
} else {
print "Sender <$from> -- <$fromorig> ISN'T companion list (sender mode: $sender_mode)\n"
if ($debug);
@x_kehlist_ring = ();
undef $sub_nomember;
}

if ($flag_list) {
if ($sender_mode ne 'LIST') {
if ($group_reply_mode && $resent && $resent_seen) {
# Now -- Mailing from list to another is allowed
} else {
if (defined $fromorig) {
print STDERR "$full <$list> - Sender <$fromorig> isn't my companion list.\n";
} else {
print STDERR "$full <$list> - Sender <$from> isn't my companion list.\n";
}
exit $e_perm;
}
} else {
if ($#x_kehlist_ring < 0) {
if (defined $fromorig) {
print STDERR "$full <$list> - Sender <$fromorig> haven't marked myself as his companion list.\n";
} else {
print STDERR "$full <$list> - Sender <$from> haven't marked myself as his companion list.\n";
}
exit $e_config;
}
}
}

if ($private && !$member) {
print STDERR "$full <$list> - This list is private.\n";
if (defined $fromorig) {
print STDERR "$full <$list> - Sender <$fromorig> isn't member of the list.\n";
} else {
print STDERR "$full <$list> - Sender <$from> isn't member of the list.\n";
}
print STDERR "$full <$list> - Subscribtions to: $bumerangfull <$bumerang>\n";
exit $e_perm;
}

if ($private && defined $sub_nomember) {
print STDERR "$full <$list> - This list is private.\n";
print STDERR "$full <$list> - Sender <$sub_nomember> isn't member of the companion list.\n";
print STDERR "$full <$list> - Subscribtions to: $bumerangfull <$bumerang>\n";
exit $e_perm;
}

for $f ( @rec ) {
$n = $normalized{$f};
$mode = 'NIL';
$b = $f;
$a = $f;
$mode = $mode{$a} if defined $mode{$a};
$b = $raddr{$f} if defined $raddr{$f};
$mode = $mode{$b} if defined $mode{$b};

if ($debug) { print "Receiver: $f -- $n -- mode: $mode -- "; }
if ( defined $from && ($f eq $from ||
defined $alias{$from} && $alias{$from} eq $f)) {
if ($debug) { print "envelope sender <$fromorig> -- no copy\n"; }

} elsif ($nosend{$n}) {
if ($debug) {
print "in receivers of mail (or in X-kehlist-ring) -- no copy\n";
}
} else {

$f = $raddr{$f} if defined $raddr{$f};
if ($debug) { print "copy: $f\n"; }

if ($mode ne 'DEBUG') {
$target = &add_it($target,$f);
push(@resent_to, $b . "\t" . $prase{$a} .
"\t\t" . $a . "\t" . $full);
}

$target_mode{$mode} = &add_it($target_mode{$mode},$f);
if ($mode eq 'LIST') {
$listcount++;
push(@x_kehlist_ring, $b . "\t" . $prase{$a} .
"\t\t" . $a . "\t");
}

}
}

for $a ( @copy ) {
@b = split("\t",$a);
$f = $b[0];
$mode = 'NIL';
$mode = $mode{$b[0]} if defined $mode{$b[0]};
$mode = 'NIL' if $mode eq 'DEBUG';

$n = $b[3];
if ($nosend{$n}) {
if ($debug) { print "Copy receiver: $f -- $n -- in receivers of mail -- ignored\n"; }
&notice("No extra copy to <$f>");
next;
}
if ($debug) { print "Copy receiver: $f -- $n -- mode: $mode\n"; }

$target = &add_it($target,$f);
$target_mode{$mode} = &add_it($target_mode{$mode},$f);
}

$return_target = '';
%return_target_mode = ();

for $a ( @return_copy ) {
@b = split("\t",$a);
$f = $b[0];
$mode = 'NIL';
$mode = $mode{$b[0]} if defined $mode{$b[0]};
$mode = 'NIL' if $mode eq 'DEBUG';

$n = $b[3];
if ($debug) { print "RR receiver: $f -- $n -- mode: $mode\n"; }

$return_target = &add_it($return_target,$f);
$return_target_mode{$mode} = &add_it($return_target_mode{$mode},$f);
}

@errors_to = ( $bumerang . "\t" . $bumerangfull );

sub disable {
&notice("Conversions disabled.") if (!$no_tmpfile);
$no_tmpfile = 1;
}

sub mime_version {
local($line) = @_;
local($comm,$vers);

$line =~ tr/\t\n/ /;
$line =~ s/^[\, ]+//;

$comm = '';
$vers = &eat_addr(*line,'',*comm,undef,undef);
if ($vers ne '1.0') {
&notice("Unsupported MIME version: $vers");
&disable;
}
$have_mime = 1;
}

if ($no_tmpfile) {
push(@headers_tail,@top_mime_headers);
@top_mime_headers = ();
}

push(@resent_from, $list . "\t" . $full . "\t");
&push_sel(*x_kehlist_ring,*resent_from);

if (defined $rp && $#reply_to < 0) {
if ($#from >= 0) {
push(@reply_to,@from);
} else {
push(@reply_to, $rp . "\t\t\t" . $from);
}
}
push (@wide_reply_to, @reply_to); # If Wide-Reply-To header is used

push (@reply_to,@copy); # For x-kehlist-copy stuff
push (@wide_reply_to,@copy); # - "" -
push (@resent_to,@copy); # - "" -

sub filter_addresses {
local (*addr) = @_;
local (@new) = ();
local (%was) = ();

push(@new, $list . "\t" . $full . "\t");
$was{$list}=1;

for $a ( @addr) {
@b = split("\t",$a);
next if (defined $alias{$b[3]});
next if (defined $was{$b[0]});

$was{$b[0]} = 1;
push(@new,$a);
}

return @new;
}

sub print_header {
local($mail,$name,*list) = @_;
local($a,$line,@b,$len,$entry,$list);

$line = '';
$len=length($name)+2;
$list = '';
for $a ( @list ) {
@b = split("\t",$a);
if ($b[4] ne $list && $list ne '') {
$line .= ";,\n\t"; $len = 0;
$list = '';
} elsif ($line ne '') {
$line .= ', ';
$len +=2;
}
if ($b[4] ne $list) {
$list = $b[4];
$entry = $list . ': ';
if ($len > 0) {
$line .= "\n\t";
$len = 0;
}
$line .= $entry;
$len += length($entry);
}

if ($b[1] ne '' || $b[0] =~ /^@/) {
$entry = "$b[1] <$b[0]>";
} else {
$entry = $b[0];
}
if ($b[2] ne '') {
$entry .= " $b[2]";
}
if ($len + length($entry) > 75) {
$line .= "\n\t";
$len = 0;
($line .= "\t", $len = 8) if ($list ne '');
}
$line .= $entry;
$len += length($entry);
}
if ($list ne '') {
$line .= ';'; $len += 1;
$list = '';
}
print $mail "${name}: $line\n";
}

if (defined $fromorig) {
&notice("Sender <$fromorig> isn't member of the list.")
if (!$member);
} else {
&notice("Sender <$from> isn't member of the list.") if (!$member);
}
&notice("Sender <$sub_nomember> isn't member of\nthe companion list.")
if ($drop_resent && defined $sub_nomember);
if (defined $fromorig) {
$sub_nomember = $fromorig if (!$member && !defined $sub_nomember);
} else {
$sub_nomember = $from if (!$member && !defined $sub_nomember);
}

$dbg='';
$dbg = $target_mode{'DEBUG'} if defined $target_mode{'DEBUG'};

if ($target ne '') {

print "Delivering normal mail: --------------------------------\n"
if ($debug);

if ($no_tmpfile) {
local($islist) = 0;
print "Delivery: no tmpfile: NIL\n" if ($debug > 2);
$islist = 1 if $listcount > 0; # Some list receivers
&mail_it($target,$dbg,'NIL',0,$islist );
} else {
local($islist,$trg);
for $mode ( keys %target_mode) {
print "Delivery: tmpfile: $mode\n" if ($debug > 2);
$islist = 0;
$trg = $target_mode{$mode};
if ($mode eq 'LIST') {
$islist = 2; # List only
$mode = $list_mode;
print "List receiver -- mode: $mode\n" if ($debug);
}
next if $mode eq 'DEBUG';
if (!seek(BODY,0,0)) {
print STDERR "Seeking to beginning of tmpfile failed: $tmpfile: $!\n";
exit $e_system;
}
&mail_it($trg,$dbg,$mode,0,$islist);
}
}
$eated = 0;
} else {

print "No receivers -- eating mail\n"
if ($debug);
while(<BODY>) { }
$eated = 1;
}

if ($return_target ne '') {
print "Delivering RR mail: --------------------------------\n"
if ($debug);
if ($no_tmpfile) {
print "RR Delivery: No tmpfile: NIL\n" if ($debug > 2);
&mail_it($return_target,$dbg,'NIL',1,0);
} else {
for $mode ( keys %return_target_mode) {
print "RR Delivery: tmpfile: $mode\n" if ($debug > 2);
next if $mode eq 'DEBUG';
next if $mode eq 'LIST';
if (!seek(BODY,0,0)) {
print STDERR
"Seeking to beginning of tmpfile failed: $tmpfile: $!\n";
exit $e_system;
}
&mail_it($return_target_mode{$mode},$dbg,$mode,1,0);
}
}
} else {
print "No RR receivers -- No RR delivering\n" if ($debug);
}

sub decode_quoted_printable {
local($input,$output) = @_;
local($line,$res,$val,$cont,$a);
local($eoln) = '';

while($line = <$input>) {
$res = '';
$cont = 0;
$eoln = '';
if ($line =~ s/(\n)$//) {
$eoln = $1;
}
while ($line ne '') {
if ($line =~ s/^([^=]+)//) {
$res .= $1;
} elsif ($line =~ s/^=([0-9A-Fa-f][0-9A-Fa-f])//) {
$val = hex($1);
$res .= pack('C',$val);
} elsif ($line =~ s/^=[ \t]*$//) {
$cont = 1;
} else {
$line =~ s/^(.)//;
$res .= $1
}
}
$res .= $eoln if (!$cont);
print $output $res;
}
}

sub b64_char {
local($c,*res,*bit,$output,$binary,*pend)=@_;

return 1 if !defined $b64_val{$c};
return 0 if $b64_val{$c} eq 'EOF';
local($val) = $b64_val{$c};
$res <<=6;
$res |= $val;
$bit += 6;
if ($bit >= 8) {
local($ch) = $res >> ($bit - 8);
$res -= $ch << ($bit - 8);
$bit -= 8;
local($a) = pack('C',$ch);
if ($a ne "\n" && $pend) {
print $output "\r";
}
$pend = 0;
if (!$binary && $a eq "\r") {
$pend = 1;
return 1;
}
print $output $a;
}
return 1;
}

sub decode_base64 {
local($input,$output,$binary) = @_;
local($line,$a);
local ($res) = 0;
local($bit) = 0;
local($pend) = 0;

while($line = <$input>) {
while ($line =~ s/^(.)//) {
$a = $1;
return if !&b64_char($a,*res,*bit,$output,
$binary,*pend);
}
}
print "\r" if ($pend);
}

sub code_quoted_printable {
local($input,$output) = @_;
local($line,$res,$val,$eoln,$a);

while ($line = <$input>) {
$res = '';
$eoln = '';
if ($line =~ s/(\n)$//) {
$eoln = $1;
}
while ($line =~ s/^(.)//) {
$a = $1;
$val = unpack('C',$a);
if ($a eq '=' || $val < 32
|| $a eq '.' && $res eq ''
|| $a eq 'F' && $res eq '' && $line =~ /^rom /
|| $val > 126 || $a eq ' ' && $line eq '') {
$a = '=' . sprintf ('%02X',$val);
}
# We need wrap line if _encoded_ line will become over
# 76 characters long !
if (length($res . $a) > ( $line eq '' ? 76 : 75)) {
print $output $res . "=\n";
$res = '';
# We need check conditions where $res eq '' again !!
if ($a eq '.' || $a eq 'F' && $line =~ /^rom /) {
$a = '=' . sprintf ('%02X',$val);
}
}

$res .= $a;
}
print $output $res . $eoln;
}
}

sub write_part {
local($input,$output,$encoding,$type,$subtype,$sep,
*headers,*values,*comments) = @_;

print "write_part: input: $input output: $output\n"
if ($debug > 2);
print "write_part: input: $input == " . tell($input) . "\n"
if ($debug > 3);

if (!seek($input,0,0)) {
print STDERR "Seeking to beginning of tmpfile failed: $!\n";
exit $e_system;
}
print "write_part! input: $input == " . tell($input) . "\n"
if ($debug > 3);

if (!defined $encoding) {
$encoding = &check_body($input);
if (!seek($input,0,0)) {
print STDERR "Seeking to beginning of tmpfile failed: $!\n";
exit $e_system;
}
}
&write_mime_headers($output,*headers,*type,*subtype,
*encoding,undef,*sep,*values,*comments);

print $output "X-kehlist-notice: $kehlist_notice\n"
if $kehlist_notice ne '';
$kehlist_notice = '';
print $output "\n";

while (<$input>) {
if (!print $output $_) {
print STDERR "Failed to write tmpfile: $!\n";
exit $e_tmpfail; # Try again later
# Disk full ?
}
}
}

sub convert_to_mime {
local($input,$output,*headers,$mode) = @_;
local($kehlist_notice) = '';
local($transparent) = 0;
local(@copy) = ();

local($type_1049) = '';
local($version_1049) = '';
local($resource_1049) = '';
local($comment_1049) = '';

print "convert_to_mime: input: $input output: $output mode: $mode\n"
if ($debug > 2);
print "convert_to_mime: input: $input == " . tell($input) . "\n"
if ($debug > 3);

if (!$transparent) {
local($a,$h,$t,$c);

for $a (@headers) {
if ($a =~ /^([^ :]+):(.*)$/) {
$h = $1;
$t = $2;
($c = $h) =~ tr/A-Z/a-z/;
$t =~ tr/\n\t/ /;

if ($c eq 'content-type') {
if ($type_1049 ne '') {
&notice("Multiple $h headers !!\n" .
"No conversion to MIME.");
$transparent = 1;
} else {
local($line) = $t;
$type_1049 = &eat_addr(*line,';',*comment_1049,
undef,undef);
$type_1049 =~ tr/A-Z/a-z/;
if ($type_1049 !~ /^[a-z]+$/) {
&notice("Bad (RFC 1049) Content-Type: $t\n" .
"Error in type field. " .
"No conversion to MIME.");
$transparent = 1;
}
if (!$transparent && $line =~ s/^;//) {
$version_1049 = &eat_addr(*line,';',*comment_1049,
undef,undef);
if ($version_1049 eq '') {
&notice("Bad (RFC 1049) Content-Type: $t\n" .
"Error in version field. " .
"No conversion to MIME.");
$transparent = 1;
}
$version_1049 = '' if ($version_1049 eq 'null');
}
if (!$transparent && $line =~ s/^;//) {
$resource_1049 = &eat_addr(*line,'',*comment_1049,
undef,undef);
if ($resource_1049 eq '') {
&notice("Bad (RFC 1049) Content-Type: $t\n" .
"Error in resource field. " .
"No conversion to MIME.");
$transparent = 1;
}
}
}
}
if ($c ne 'content-type' && $c ne 'content-transfer-encoding') {
push(@copy,$a);
}
} else {
&notice("Bad header: $a\n" .
"No conversion to MIME.");
$transparent = 1;
}
}
}

local($encoding) = '7bit';

if (!$transparent) {
$encoding = &check_body($input);
if (!seek($input,0,0)) {
print STDERR
"Seeking to beginning of body (offset $pos) failed: $!\n";
exit $e_system;
}
}

local($mime_type) = 'Text/Plain';
if (!$transparent) {
if ($type_1049 ne '') {
if ($type_1049 eq 'text') {
# Type Text don't exist in RFC 1049
$mime_type = 'Text/Plain';
&notice("WARNING: Not a RFC 1049 Content-Type: Text\n");
} elsif ($type_1049 eq 'postscript') {
$mime_type = 'Application/PostScript';
} elsif ($type_1049 eq 'sgml') {
$mime_type = 'Application/SGML';
if ($version_1049 ne '') {
if ($version_1049 =~ /^IS\.([0-9]+)\.([0-9]+)$/) {
$mime_type .= "; SGML-Version=\"ISO $1-$2\"";
} else {
&notice("WARNING: Odd RFC 1049 Postscript version " .
" number: $version_1049");
}
}
} else {
$mime_type = "Application/X-RFC1049-$type_1049";
}
&notice("Converting RFC 1049 type $type_1049 \n" .
"to MIME type $mime_type");
$mime_type .= "; RFC1049-type=$type_1049";
$mime_type .= '; RFC1049-version=' . &quote_value($version_1049)
if ($version_1049) ne '';
$mime_type .= '; RFC1049-resource=' . &quote_value($resource_1049)
if ($resource_1049) ne '';
$mime_type .= " $comment_1049"
if ($comment_1049 ne '');
}
if ($encoding ne '7bit') {
push(@copy,"Content-Transfer-Encoding: $encoding");
$mime_type .= '; charset = UNKNOWN-8BIT';
&notice("Body have 8-bit characters (or too long lines).\n" .
"Marking charset to be UNKNOWN-8BIT");
}

if ($encoding ne '7bit' || $type_1049 ne '') {
push(@copy,"MIME-Version: 1.0");
push(@copy,"Content-Type: $mime_type");
&notice("Converting mail to MIME format.");
} else {
print "No conversion to MIME needed.\n" if ($debug);
$transparent = 1;
}
}

print $output "X-kehlist-notice: $kehlist_notice\n"
if $kehlist_notice ne '';

if ($transparent) {
for $a (@headers) {
print $output $a,"\n";
}
print $output "\n";

while(<$input>) {
if (!print $output $_) {
print STDERR "$0: Failed to write tmpfile: $!\n";
exit $e_tmpfail; # Try again later
# Disk full ?
}
}
} else {
&handle_body_part($input,$output,*copy,$mode,0);
}
}

sub handle_body_part {
local($input,$output,*headers,$mode,$isdigest) = @_;
local($transparent) = 0;
++$fh;
local($handle) = 'FILE' . $fh;
local($name) = $tmpdir . '/kehlist' . $$ . $fh;
++$fh;
local($handle2) = 'FILE' . $fh;
local($name2) = $tmpdir . '/kehlist' . $$ . $fh;
local($kehlist_notice) = '';
local($handle_o) = 0;
local($handle2_o) = 0;
local($a);
local($type,$subtype,$encoding,$sub,$sep,%values,%comments);
local($charset);

print "handle_body_part: input: $input output: $output mode: $mode\n"
if ($debug > 2);
print "handle_body_part: input: $input == " . tell($input) . "\n"
if ($debug > 3);

undef $charset;

if (!open ($handle,"+>$name")) {
&notice("Can't open $name: $!\n" .
"Going to transparent mode for that bodypart.");
$transparent = 1;
} else {
unlink $name;
$handle_o = 1;
}

if (!open ($handle2,"+>$name2")) {
&notice("Can't open $name2: $!\n" .
"Going to transparent mode for that bodypart.");
$transparent = 1;
} else {
unlink $name2;
$handle2_o = 1;
}

if (!$transparent) {
if (!&parse_mime_headers(*headers,*type,*subtype,*encoding,
*sub,*sep,*values,*comments,$isdigest)) {
$transparent = 1;
} else {
# Message/Partial isn't supported
$transparent = 1 if ($sub == 3);
# Message/External don't need processing
$transparent = 1 if ($sub == 4);
if ($sub == 6) {
&notice('Unknown subtypes of message are not processed');
$transparent = 1;
}
}
}

if ($transparent) {
print $output "X-kehlist-notice: $kehlist_notice\n"
if $kehlist_notice ne '';
for $a (@headers) {
print $output $a,"\n";
}
print $output "\n";

while(<$input>) {
if (!print $output $_) {
print STDERR "$0: Failed to write tmpfile: $!\n";
exit $e_tmpfail; # Try again later
# Disk full ?
}
}
} else {
if (defined $values{'charset'}) {
$charset = $values{'charset'};
$charset =~ tr/a-z/A-Z/;
}
if ($sub == 1 || $sub == 5) { # Take multipart
local($line,$ok);
local($mysep) = '=_KEHList#'. $$ . '%' . time .
'#' . $fh . '_=';
local ($end) = 0;
local($isdigest) = $sub == 5;
local($eoln,$eoln2);
local (@headers2);
# preable
$eoln = '';
while(<$input>) {
$eoln2 = '';
if (s/(\n)$//) { $eoln2 = $1; }
$line = $_;
$line =~ s/[ \t]+$//;
if ($line eq '--' . $sep ) {
last; # First part
}
if ($line eq '--' . $sep . '--' ) {
$end = 1;
last;
}
print $handle2 $eoln . $_;
$eoln = $eoln2;
}
$end = 1 if eof ($input);
while (!$end) {
undef @headers2;
print $handle2 "\n--" . $mysep . "\n";
$ok = &eat_mime_headers($input,*headers2);
if (!seek($handle,0,0)) {
print STDERR "Seeking to beginning of tmpfile failed: $name: $!\n";
exit $e_system;
}
open(FOO,"+>&${handle}");
if (!truncate(FOO,0)) {
print STDERR "Can't truncate workfile: $name: $!\n";
exit $e_system;
}
close(FOO);
$eoln = '';
while(<$input>) {
$line = $_;
$line =~ s/[ \t]+$//;
$line =~ s/\n//;
if ($line eq '--' . $sep ) {
last; # Next part
}
if ($line eq '--' . $sep . '--' ) {
$end = 1;
last; # Was last part
}
# Take care that \n before part
# separator is part of part separator!
$eoln2 = '';
if (s/(\n)$//) {
$eoln2 = $1;
}
if (!print $handle $eoln . $_) {
print STDERR "$0: Failed to write tmpfile: $name: $!\n";
exit $e_tmpfail; # Try again later
# Disk full ?
}
$eoln = $eoln2;
}
$end = 1 if eof ($input);
if (!seek($handle,0,0)) {
print STDERR "$0: Failed to seek beginning of tmpfile: $name: $!\n";
exit $e_system;
}
if ($ok) {
&handle_body_part($handle,$handle2,
*headers2,$mode,$isdigest);
} else {
local($a);
&notice("Can't handle this body part.");
print $handle2 "X-kehlist-notice: $kehlist_notice\n" if ($kehlist_notice ne '');
$kehlist_notice = '';
for $a (@headers2) {
print $handle2 "$a\n";
}
print $handle2 "\n";
while (<$handle>) {
print $handle2 $_;
}
}
}
# And write tail
print $handle2 "\n--" . $mysep . "--\n";
while(<$input>) {
print $handle2 $_;
}

&write_part($handle2,$output,undef,$type,$subtype,$mysep,
*headers,*values,*comments,0);

}
elsif (2 == $sub) { # Message content type
# Message/rfc822 supposed here
local($kehlist_notice) = '';
local($ok,@headers2,$a);
local ($have_mime) = 0;

$ok = &eat_mime_headers($input,*headers2);

if ($ok) {
for $a (@headers2) {
if ($a =~ /^([^ :]+):(.*)$/) {
$h = $1;
$t = $2;
($c = $h) =~ tr/A-Z/a-z/;
$t =~ tr/\n\t/ /;

if ($c eq 'mime-version') {
local($comm,$vers);
$comm = '';
$vers = &eat_addr(*t,'',*comm,undef,undef);
if ($vers ne '1.0') {
&notice("Unsupported MIME version: $vers");
$ok = 0;
}
$have_mime = 1;
}
}
}
}

if (!$ok) {
for $a (@headers2) {
print $handle2 "$a\n";
}
print $handle2 "\n";
while (<$input>) {
print $handle2 $_;
}
} else {
while(<$input>) {
if (!print $handle $_) {
print STDERR "$0: Failed to write tmpfile: $name: $!\n";
exit $e_tmpfail; # Try again later
# Disk full ?
}
}

if (!seek($handle,0,0)) {
print STDERR "$0: Failed to seek beginning of tmpfile: $name: $!\n";
exit $e_system;
}

if ($have_mime) {
&handle_body_part($handle,$handle2,
*headers2,$mode,0);
} else {
&convert_to_mime($handle,$handle2,*headers2,$mode);
}
}
&write_part($handle2,$output,undef,$type,$subtype,undef,
*headers,*values,*comments);
}
elsif (0 == $sub) {
if ($mode eq '8BIT' && ($encoding eq 'quoted-printable'
|| $encoding eq 'base64' ) &&
$type eq 'text') {
local($z);
local($pos) = tell($input);
local($work) = $handle2;
if (!defined $pos) {
print STDERR "Failed to read position if input: $!\n";
exit $e_system;
}
if ($encoding eq 'base64' && defined $charset
&& !$safe_charset{$charset}) {
&notice("Conversion from $encoding to " .
"8bit disabled.\n" .
"Charset " . $charset .
" is unsafe or unknown.");
$work = $input;
} else {

if ($encoding eq 'base64') {
$z = 'base64';
&decode_base64($input,$handle2,0);
} else {
$z = 'quoted-printable';
&decode_quoted_printable($input,$handle2);
}
if (!seek($handle2,0,0)) {
print STDERR "Seeking to beginning of tmpfile failed: $name2: $!\n";
exit $e_system;
}
$encoding = &check_body($handle2);
if ($encoding eq 'binary') {
&notice("Binary data detected.\n" .
"Conversion from $z to 8bit canceled.");
$encoding = $z;
$work = $input;
} else {
&notice("Conversion from $z to $encoding");
}
}
&write_part($work,$output,$encoding,$type,$subtype,undef,
*headers,*values,*comments);
} elsif ($mode eq 'QP' && ($encoding eq '8bit' ||
$encoding eq 'binary')) {
local($work) = $handle2;
&code_quoted_printable($input,$handle2);
&notice("Conversion from $encoding to quoted-printable");
$encoding = 'quoted-printable';
&write_part($handle2,$output,$encoding,$type,$subtype,undef,
*headers,*values,*comments);
} else {

&write_part($input,$output,$encoding,$type,$subtype,undef,
*headers,*values,*comments);
}
} else {
print STDERR "$0: Unexpected \$sub = $sub \n";
exit $e_software;
}
}
# We no longer need workfiles
close($handle) if ($handle_o);
close($handle2) if ($handle2_o);
}

sub feed_it {
local($mail,$mode,$is_list) = @_;

print "feed_it: mail: $mail: mode: $mode: is_list: $is_list\n"
if ($debug > 2);

print "feed_it: mail: $mail == " . tell($mail) .
", BODY == " . tell (BODY) . "\n" if ($debug > 3);

for $h ( @headers_head ) {
print $mail "$h\n";
}

@reply_to = &filter_addresses(*reply_to);
@wide_reply_to = &filter_addresses(*wide_reply_to);

if($group_reply_mode) {
&print_header($mail,'Reply-To',*orig_reply_to);
} else {
&print_header($mail,'Reply-To',*reply_to);
}

&print_header($mail,'Wide-Reply-To',*wide_reply_to)
if($group_reply_mode || $was_wide_reply_to);
&print_header($mail,'Errors-To',*errors_to) if ($errors_to);
&print_header($mail,'X-kehlist-ring',*x_kehlist_ring)
if ($is_list && $#x_kehlist_ring >= 0);
print $mail "X-kehlist-no-member: <$sub_nomember>\n"
if ($is_list && defined $sub_nomember);

if ($resent && ($is_list != 2)) {
&print_header($mail,'Resent-From',*resent_from);
&print_header($mail,'Resent-To',*resent_to);

$resent_id="kehlist.$list_local." . $time . ".$$" . $domain;
print $mail "Resent-Message-ID: <$resent_id>\n";
if ($group_reply_mode) {
if ($#r_reply_to < 0) {
&print_header($mail,'Resent-Reply-To',*from) if ($#from >=0);
if (defined $fromorig) {
print $mail "Resent-Reply-To: <$fromorig>\n"
if ($#from <0);
} else {
print $mail "Resent-Reply-To: $from\n" if ($#from <0);
}
} else {
&print_header($mail,'Resent-Reply-To',*r_reply_to);
}
} else {
&print_header($mail,'Resent-Reply-To',*reply_to);
}
&print_header($mail,'Resent-Wide-Reply-To',*wide_reply_to)
if($group_reply_mode || $was_wide_reply_to);
print $mail "Resent-Date: $time_s\n";
}

print $mail "Precedence: $precedence\n" if ($set_precedence);
print $mail "X-kehlist-notice: $kehlist_notice\n"
if ($kehlist_notice ne '');
print $mail "X-List-Processor: kehlist ${version}\n";
if (!$drop_resent || $is_list == 2) {
for $h ( @headers_dropped ) {
print $mail "$h\n";
}
}
for $h ( @headers_tail ) {
print $mail "$h\n";
}
if ($no_tmpfile) {
print $mail "\n";

while (<BODY>) {
print $mail $_;
}
} elsif (!$have_mime){
&convert_to_mime('BODY',$mail,*top_mime_headers,$mode);
} else {
&handle_body_part('BODY',$mail,*top_mime_headers,$mode,0);
}
}

sub deliver_report {
local($mail,$mode) = @_;
local($MAIN_notice) = $kehlist_notice;
local($kehlist_notice) = "";
local(@headers,$type,$subtype,%values,%comments);

local($id);
local($handle_o) = 0;
local($handle2_o) = 0;

++$fh;
local($handle) = 'FILE' . $fh;
local($name) = $tmpdir . '/kehlist' . $$ . $fh;

++$fh;
local($handle2) = 'FILE' . $fh;
local($name2) = $tmpdir . '/kehlist' . $$ . $fh;

local($mysep) = '=_KEHList#'. $$ . '%' . time .
'#' . $fh . '_=';

if (!$no_tmpfile) {

if (!open ($handle,"+>$name")) {
print STDERR "Can't open $name: $!\n";
return 0;
} else {
unlink $name;
$handle_o = 1;
}
if (!open ($handle2,"+>$name2")) {
print STDERR "Can't open $name2: $!\n";
close($handle);
return 0;
} else {
unlink $name2;
$handle2_o = 1;
}
}

print $mail "From: $full <$list>\n";
print $mail "Subject: Delivery report: Your mail is delivered to list\n";
print $mail "Reply-To: $bumerangfull <$bumerang>\n";
if (defined $message_id) {
print $mail "In-Reply-To: Your mail <$message_id>\n";
print $mail "References: <$message_id>\n" ;
}
&print_header($mail,'To',*return_copy);
&print_header($mail,'Errors-To',*errors_to) if ($errors_to);
$id="kehlist.$list_local.RR." . $time . ".$$" . $domain;
print $mail "Message-ID: <$id>\n";
print $mail "Precedence: $precedence\n" if ($set_precedence);
print $mail "X-List-Processor: kehlist ${version}\n";

if ($no_tmpfile) {
print $mail "\n";
$handle=$mail;
} else {
print $handle2 "This is a MIME encapsulated message.\n";
print $handle2 "\n--" . $mysep . "\n";
}

if (defined $message_id) {
print $handle "Your article <$message_id> is delivered to\n";
} else {
print $handle "Your article is delivered to\n";
}
print $handle "list: $full <$list>\n";
print $handle "In list there was NO receivers left for your mail.\n"
if ($eated);
print $handle "\n";
if (!$member) {
if (defined $fromorig) {
print $handle "You <$fromorig> are not member of the list.\n";
} else {
print $handle "You <$from> are not member of the list.\n";
}
print $handle "\n";
}
if (!$no_tmpfile) {
print $handle "Your article follows:\n";

if (!seek($handle,0,0)) {
print STDERR "$0: Failed to seek beginning of tmpfile: $name: $!\n";
close($handle);
close($handle2);
return 0;
}
@headers = ( );
&write_part($handle,$handle2,undef,'Text','Plain',undef,
*headers,%values,%comments);

print $handle2 "\n--" . $mysep . "\n";
if (!seek($handle,0,0)) {
print STDERR "$0: Failed to seek beginning of tmpfile: $name: $!\n";
close($handle);
close($handle2);
return 0;
}
open(FOO,"+>&${handle}");
if (!truncate(FOO,0)) {
print STDERR "Can't truncate workfile: $name: $!\n";
close($handle);
close(FOO);
close($handle2);
return 0;
}
close(FOO);

$kehlist_notice = $MAIN_notice;
&feed_it($handle,$mode,0);
$kehlist_notice = "";

@headers = ();
%values = ();
%comments = ();
&write_part($handle,$handle2,undef,'Message','RFC822',undef,
*headers,*values,*comments);

print $handle2 "\n--" . $mysep . "--\n";

@headers = ( "MIME-Version: 1.0" );
%values=();
%comments=();
&write_part($handle2,$mail,undef,'Multipart','Mixed',$mysep,
*headers,*values,*comments);

close($handle) if ($handle_o);
close($handle2) if ($handle2_o);
}
return 1;
}

sub run_sendmail {
local ($mail,$sendmail,*args,$target,$dbg) = @_;
local($pid,$i);
local(@arglist) = ();
local(@addr) = split("\t",$target);

push (@arglist,$sendmail);
push (@arglist,@args);
push (@arglist,@addr);
if ($dbg ne '') {
@addr = split("\t",$dbg);
push (@arglist,@addr);
}

select (STDERR); $| = 1;
select (STDOUT); $| = 1;

if ($debug) {
print "Arguments of sendmail ($sendmail):\n";
for ($i = 0; $i <= $#arglist; $i++) {
printf "%3d: %s\n",$i,$arglist[$i];
}
}
$pid = open($mail,"|-");
if (!defined $pid) {
print STDERR "Failed to open pipe for $sendmail: $!\n";
exit $e_system;
}
if (0 == $pid) {
if ($debug > 1) {
print "C: Doing exec /bin/sed instead (debug -- no sendmail) \n";
print "C: pid $$\n";
print "C: ------------------------------------------\n";
exec '/bin/sed', 's/^/C: /g;';
print STDERR "Failed to exec /bin/sed: $!\n";
exit $e_system;
} else {
print "C: execing sendmail ...\n" if ($debug); $|=1;
exec $sendmail @arglist;
print STDERR "Failed to exec sendmail: $sendmail: $!\n";
exit $e_system;
}
}
print "Sendmail's ($sendmail) pid is $pid\n" if ($debug);
print STDERR "run_sendmail: mail: $mail (return)\n" if ($debug > 2);
$| = 1;
return $pid;
}

sub mail_it {
local($target,$dbg,$mode,$report,$islist) = @_;
local (@args) = ();
local($mail) = 'MAIL';
local($pid);

print "mail_it: target: $target: dbg: $dbg: mode: $mode: report: $report: islist: $islist\n" if ($debug > 2);

print "mail_it: BODY == " . tell(BODY) . "\n" if ($debug > 3);

push(@args,"-oi");
push(@args,"-f<${bumerang}>");

if ($debug) {
print "Mode: $mode\n";
print "Target: $target\n";
print "Dbg Target: $dbg\n";
}

$pid = &run_sendmail($mail,'/usr/lib/sendmail',*args,$target,$dbg);

print "---------------------------------------------------\n"
if ($debug);

if ($report) {
&deliver_report($mail,$mode);
} else {
&feed_it($mail,$mode,$islist);
}

close($mail);

print "---------------------------------------------------\n"
if ($debug);

if (0 != ($? & 255)) {
printf STDERR "%s: Sendmail was died with signal %d\n",$0,$? & 255;
exit $e_system;
}
$status = ($? >> 8);
print "Sendmail's exit status=$status\n" if ($debug);

exit $status if ($status != 0);
}

close (BODY);

exit 0;

EOM
exit 0

[Robert A. Rosenberg]

In article <4dnbh8$18...@ausnews.austin.ibm.com>,
sur...@austin.ibm.com (Suresh Kolichala) wrote:

>We have a strange requirement of defining a mail alias combining two mailing
>lists, such that any mail sent to this mail alias would reach to the members
>of both the mailing lists. Now, we have a problem with "Reply-To:" field.
[snip]

Maybe I am missing something but so long as the mailing list software does
NOT trash&replace an existent Reply-To Header (or can be set to not trash
it and insert one of its own, based on the address in the incoming
message's header), all that would be needed would be to make the alias a
mailing list with only two subscribers - List1 and List2. It will read the
user's message and echo it to each of the lists which will then send it out
to their subscribers. I seem to have the impression that there are already
a number of lists which allow you to subscribe a ML exploder address in
your organization and the ML will just forward the messages to your
Exploder which will then handle the actual distribution (and Sub/Unsub)
while maintaining the original ML as the Reply-To target for Replies.

[Marcel Carrière]