Subject: adcomplain - a tool for reporting inappropriate postings/e-mail
Newsgroups: alt.sources

[Last modified 10-May-99]

Adcomplain is posted to alt.sources at the beginning of each month.
It can can also be retrieved from my web page:
http://www.rdrop.com/users/billmc

Tired of spam and other net abuse?  Report it!  Most service providers
terminate accounts used for such purposes.

Adcomplain is a tool for reporting inappropriate commercial e-mail and
usenet postings, as well as chain letters and "make money fast" postings.

It automatically analyzes the message, composes an abuse report, and mails
the report to the offender's internet service provider.  The report is
displayed for your approval prior to mailing.  Adcomplain can be invoked
from the command line or automatically from many news and mail readers.

Adcomplain runs under Unix, Windows-NT, and Windows-95.  Adcomplain does
_not_ currently run on Macintosh systems.

You must have Perl installed on your system to run this.  (Either perl
version, 4 or 5, will work.)  Perl can be obtained at:
http://www.perl.com/

A csh version of adcomplain is also available.  It is much slower but does
not require Perl.  However, it is not being maintained--you must install
the Perl version to get the latest features.  For more information, see:
http://www.rdrop.com/users/billmc

adcomplain.pl  Version: 3.52

#!/bin/sh
# This is a shell archive (produced by shar 3.49)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 05/10/1999 23:25 UTC by bill@tiktok
# Source directory /login/bill/src/usenet/adcomplain
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
# 151070 -rwxr-xr-x adcomplain.pl
#
# ============= adcomplain.pl ==============
if test -f 'adcomplain.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping adcomplain.pl (File already exists)'
else
echo 'x - extracting adcomplain.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'adcomplain.pl' &&
#! /bin/sh -- # -*- perl -*-
# first line invokes sh.  Some systems may need to refer to perl directly, i.e.:
X
#! /bin/perl
X
# But the first way is preferable, because we have a trick (below) that
# allows perl to be _anywhere_ in the user's path.  The intent is to reduce
# the need to edit this file.
X
eval 'exec perl $0 ${1+"$@"}'
if 0;  # tee hee! This is on a separate line, so /bin/sh never sees it.
X
# use strict;
X
#-----------------------------------------------
# DESCRIPTION
X
# Tired of spam and other net abuse?  Report it!  Most service providers
# terminate accounts used for such purposes.
X
# Adcomplain is a tool for reporting inappropriate commercial e-mail and
# Usenet postings, as well as chain letters and "make money fast" postings.
X
# It automatically analyzes the message, composes an abuse report, and mails
# the report to the offender's internet service provider.  The report is
# displayed for your approval prior to mailing.  Adcomplain can be invoked
# from the command line or automatically from many news and mail readers.
X
# Adcomplain runs under Unix, Windows-NT, Windows-95, and OS/2.  Adcomplain
# does _not_ currently run on Macintosh systems.  [URL for a Macintosh solution
# TBA...]
X
# You must have Perl  installed on your system to run this.  (Either perl
# version, 4 or 5, will work.)  Perl can be obtained at:  http://www.perl.com/
X
# adcomplain was created in the belief that a single concise message is the
# most appropriate way to complain.  Mail bombing (e-mailing megabytes of
# useless data) and public flaming (replying on Usenet, causing your complaint
# to be duplicated on every machine in the network) are discouraged.
X
# The default letter meets ISP standards (such as those required by netcom) for
# abuse reports.  The letter hopefully makes its point without wasting value
# computer or human bandwidth.  It marks itself as being machine-generated, so
# that system administrators can quickly recognize its format and content.
X
# A third-party forwarding service called "abuse.net" is used for complaints to
# the offender's provider.  This ensures that the best known complaint address
# is used.  The first time you use abuse.net, you will receive a message asking
# you to register.  See http://www.abuse.net for more information.
X
#-----------------------------------------------
# USAGE
# Pipe the Usenet posting or e-mail into this program.  It may detect
# mail forgeries or other problems and ask you to confirm by pressing return.
# It will then compose the message and display it for approval before mailing.
# You have opportunities to edit or list the message, or to just abort.
X
# SYNOPSIS
# adcomplain [-b] [-c] [-f template] [-m] [-o outname] [-p inname] [-q] [-s]
#	[-u] [-v] [newsgroup]
X
# OPTIONS
# Any combination of options may be used together. For example, -c and
# -m may be used together to complain about a chain letter received via
# e-mail.
X
# You may supply a newsgroup name (or comma separated newsgroups list)
# as the last argument. If not supplied, the contents of the
# 'Newsgroups' header, if present, will be used. 
X
# -b
#   Batch mode.  This is not recommended; adcomplain is not as smart as
#   a human, and automated responses will often be sent to an inappropriate
#   site.  This switch has been added by user demand, but your are implored
#   in the strongest possible terms to originate, examine, and approve each
#   one of your complaints individually.  Violations of terms of service are
#   serious offenses, and each complaint deserves your personal attention.
X
# -c
#   Chain letter mode. Composes and mails a complaint about chain
#   letters, such as Make Money Fast.
X
# -f template
#   Use the contents of the specified file as the complaint text.
#   The contents of this file will have perl variables expanded before
#   proceeding.  Some useful ones are:
#
#   $header_analysis -- list of header anomalies in the message
#   $newsgroups -- news groups this was posted to
#   $postmaster -- postmaster at the originator's site
X
# -l
#   (Legal letter)  Set this if the e-mail or posting is legal, but
#   merely inappropriate.  If this is not set, mail will be cc'd to
#   the authorities (see $authorities).
X
# -m
#   Force the input to be regarded as a mail message.  This is not
#   necessary in most instances; adcomplain will correctly infer whether the
#   message is a mail or a Usenet message.
X
# -o outname
# 	Specify a file in which to place the generated complaint message;
#	this option also prevents adcomplain from mailing the complaint.
X
# -p inname
#  Read the ad from given file.  You _must_ use this option on
#  Windows-NT, Windows-95, and OS/2 systems.
X
# -q
#   Quiet mode.  Doesn't ask any questions except whether to send the message.
#   You must still examine the message, and you are given an opportunity to
#   modify the message or abort it.
X
# -s
#   Don't append your .signature.  Adcomplain normally appends your signature
#   (though this behavior can be changed at configuration time);  this switch
#   ensures that your signature is omitted.
X
# -u
#   Don't resolve.  Regard the message syntactically, i.e. don't try to confirm
#   host names and domains.  This is useful if you are behind a firewall
#   and have absolutely no way to confirm the hostnames within the message.
X
# -v
#   Verbose mode. Diagnostic messages will be printed.
X
# NOTE: the -t switch is a regression test mode.  It runs the header analysis
# in verbose mode and stops before sending the message.  It is not intended
# for normal use.
X
#-----------------------------------------------
# ENVIRONMENT VARIABLES
# The following environment variables influence the operation:
X
# $ADCOMPLAIN_DOMAINS is used to set a list of domain names that should _not_
# be construed as valid origination domains for spam.  The default is
# empty.  The list should be space-delimited, i.e.,
#
# (in Windows-NT, Windows-95, and OS/2):
# set ADCOMPLAIN_DOMAINS=domain1.com domain2.com
# (Unix, ksh):
# export ADCOMPLAIN_DOMAINS="domain1.com domain2.com"
X
# $ADCOMPLAIN_FROM will specify the "From:" address in the resulting complaint
# message.  This is a convenience for individuals who use adcomplain in
# multiple mail domains but want to register with abuse.net only once.
# Users on Windows-95 _must_ set this.
X
# $ADCOMPLAIN_HOSTS is a file that is searched before the regular
# gethostbyname() # and gethostbyaddr() functions are called.  (This is
# mainly used by adcomplain's internal regression test suite.)
X
# $ADCOMPLAIN_MAILHOST is the name of the host to use to relay (SMTP)
# our complaints.  The default is the current host or the value of $mailhost
# in the configuration section below.
# Win-95 and Win-NT users must almost always set this, because these systems
# do not have a sendmail daemon.
X
# $ADCOMPLAIN_MDOMAIN will specify your mail domain.  The intended use
# for this would be in a shared installation where multiple hosts use one
# copy of this script, but adcomplain is unable to determine your mail domain
# on its own.  This is not needed if $ADCOMPLAIN_FROM is set.  Administrators
# may wish to set this parameter directly in the script, i.e.:
#  $ENV{'ADCOMPLAIN_MDOMAIN'} = 'juno.com';
X
# $ADCOMPLAIN_OPTS is an additional list of switches that should be added to
# every invocation of adcomplain.
X
# $EDITOR -- the editor to use to edit the message, if $VISUAL is not
# defined.  If not defined, the default is "vi" on Unix, "notepad" on
# win32, and "e" on OS/2.
X
# $PAGER -- The message is always displayed prior to mailing using this
# program.  If $PAGER is not defined, the default is "more" on Unix,
# and the internal pager on Windows-NT, Windows-95, and OS/2.  You can specify
# the builtin pager by setting $PAGER to "builtin".
X
# $SIGNATURE -- name of a file that holds your signature.  The default
# is $HOME/.signature.
X
# $VISUAL -- the editor to use to edit the message, when an editor is requested.
# If not defined, $EDITOR is used.
X
#-----------------------------------------------
# INSTALLATION
# You must have either perl 4.036 or perl 5.0 installed.
# Perl can be obtained at:  http://www.perl.com/
X
# Installation on Windows-NT, Windows-95, and OS/2 Systems:
# --------------------------------------------------
# Save this script in a convenient place on your system.
X
# Make sure your system is configured to run TCP/IP, and that you
# have perl5 installed or your system.
X
# If you are running on Windows 95, you _must_ set the following
# environment variables:
#	COMPUTERNAME -- the name of your host, as used in TCP/IP
#	ADCOMPLAIN_FROM -- your return e-mail address
X
# If you are running on OS/2, you _must_ set the following environment
# variables:
#	HOSTNAME -- the name of your host, as used in TCP/IP
#	ADCOMPLAIN_FROM -- your return e-mail address
X
# You can either put a line like
#	$ENV{'ADCOMPLAIN_FROM'} = [email-masked]';
# in the configuration section, or put "set" commands in your autoexec file
# and reboot.  Your pick.
X
# Examine the configuration section carefully and adjust to taste.  Note
# that you _must_ set $mailhost, unless you've actually bought and
# installed a sendmail program on your machine.
X
# To test, send an e-mail message to yourself, save the message in a
# file, and type "adcomplain -p file", where "file" is the file in which
# you saved the message.  Edit the resulting message to send the complaint
# to yourself, and let adcomplain mail the message.  You should receive the
# mail message shortly.
X
# Installation on Unix Systems:
# -----------------------------
# Type "echo $PATH" to list the directories in your search path.
#
# Go to one of those directories and save this script in a file named
# "adcomplain".
#
# Examine the Configuration Section and make sure it is correct for your
# system.  You will probably want to change the value for $mailhost to
# match your system.
#
# Type "chmod +x adcomplain" to make it executable.
#
# Type "rehash" to add it to the search path.
#
# To test, send an e-mail message to yourself, save the message in a
# file, and type "adcomplain <file", where "file" is the file in which
# you saved the message.  Edit the resulting message to send the complaint
# to yourself, and let adcomplain mail the message.  You should receive the
# mail message shortly.
X
# There are reports that the complex "#!" exec-line causes trouble on some
# primitive BSD systems.  You may have to find perl (try "/bin/which perl"
# "/usr/bin/which perl", or "type perl") and modify the first line per the
# comments at the front of this file.
X
#-----------------------------------------------
# NEWSREADER CONFIGURATION
# You can configure many newsreaders to allow easy response to Usenet spam.
X
# =================
# rn, trn, and strn:
X
# Put the following in your ~/.rnmac file to map adcomplain to the 'a' key:
#
# a %(%m=[pa]?|adcomplain %C\n:a)
#
# In addition, rn users can complain about chain letters by mapping the
# 'A' key as follows:
#
# A %(%m=[pa]?|adcomplain -c\n:A)
#
# rn users can also customize the message based on the current newsgroup
#   by using adcomplain's -f mode as shown in the following example:
#
# Z %(%m=[pa]?%(%C=aaa.forsale?|adcomplain -f aaa_complaint\n:%(%C=bbb.forsale?|adcomplain -f bbb_complaint\n:%(%C=ccc.forsale?|adcomplain -f ccc_complaint\n:%(%C=ddd.forsale?|adcomplain -f ddd_complaint\n:Z)))))
#
# When 'Z' is pressed, the above macro checks the newsgroup name, and if
# it matches one of four choices (aaa.forsale, bbb.forsale, ccc.forsale,
# ddd.forsale), uses a complaint message specific to that newsgroup.
# You can use it to complain about foreign postings in local newsgroups,
# for example (e.g., "aaa.forsale is for items for sale in the Podunk
# area.")
X
# =================
# nn:
X
# Put the following in your ~/.nn/init file to map adcomplain
# to ctrl-A and chain mail complain to ctrl-B:
# 
# map both ^A (
# :!! cat /dev/null > /tmp/junk$(USER)
# save-full "//tmp/junk$(USER)"
# :! echo; adcomplain $G < /tmp/junk$(USER)
# :!! rm -rf /tmp/junk$(USER)
# )
# map both ^B (
# :!! cat /dev/null > /tmp/junk$(USER)
# save-full "//tmp/junk$(USER)"
# :! echo; adcomplain -c $G < /tmp/junk$(USER)
# :!! rm -rf /tmp/junk$(USER)
# )
#
X
# =================
# tin:
X
# Type "|" at the article level to pipe the article into
# adcomplain. Type "adcomplain" when it asks for the command name.
X
# =================
# SLRN newsreader (thanks to Ralf Hildebrandt <[email-masked]>)
X
# Put an additional line in the ~/.slrnrc :
#	interpret ".slrn.sl"
#
# The file ~/.slrn.sl contains:
#
# define pipe_to_adcomplain ()
# {
#    pipe_article ("adcomplain -q");
# }
# definekey ("pipe_to_adcomplain", "S", "article");
#
# This binds the key "S" to adcomplain -q "article".
X
#-----------------------------------------------
# DISCLAIMER, LICENSE, AND TERMS OF USE
X
# The latest version of the Gnu Copyright ("copyleft") hereby constitutes
# your terms of use and redistribution.  The Gnu Copyright, which is included
# with each Free Software Foundation distribution, is available from your
# favorite Gnu archive.
X
# IN NON-LEGAL TERMS, the Gnu Copyright gives you the right to use,
# redistribute, modify, or even borrow part or all of this program.  You
# are explicitly prohibited from selling this program or incorporating parts
# of it in software for profit.  Read the copyright for the exact terms and
# conditions.
X
# When you use this program you assume all risk and liability; it has no
# warranty.  A portion of the Gnu Copyright addressing the warranty is herein
# reproduced:
X
#                             NO WARRANTY
# 
#   11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
# FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
# OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
# PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
# OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
# TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
# PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
# REPAIR OR CORRECTION.
# 
#   12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
# WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
# REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
# INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
# OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
# TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
# YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
# PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGES.
X
#-----------------------------------------------
# BACKGROUND, CREDITS, and BUG REPORTING
X
# adcomplain is the brainchild of "Bill McFadden" [email-masked],
# who wrote it originally in csh (!!!).
X
# "D. Jason Penney" <[email-masked]> transcribed it to run in perl,
# significantly augmented the header processing, and added domain name
# verification.
X
# Acknowledgements and thanks also go out to:
#   "Denis N. Antonioli" <[email-masked]>
#   "Andrey A. Chernov" <[email-masked]>
#   "Jeff Salisbury" <[email-masked]>
#   "Kelly Roach" <[email-masked]>
#   "Martin Ward" <[email-masked]>
#   "Wolfgang Weisselberg" <[email-masked]>
#   "Wm" <[email-masked]>
X
# The latest version of this file is available at:
# http://www.rdrop.com/users/billmc
X
# Please mail ideas and bug reports to
# [email-masked] or [email-masked].
X
# Be sure to include the version number and a test case in your bug report.
X
# $Id: adcomplain.pl,v 3.52 1999/05/10 16:51:28 jason Exp $
#-----------------------------------------------
local(
X  $addsig, 		# set if you want ~/.signature to be added
X  $cc, 			# list of cc'd recipiets
X  $complaintFile, 	# predefined complaint text, if you don't like ours
X  $fqdnWithoutHost,	# whether the fqdn should include the name of the host
X  $mailhost, 		# host that is running your sendmail daemon
X  $mailscript, 		# program for delivering the mail
X  @mydomains, 		# list of domains that map to your current domain
X  $noinclude, 		# set if you don't want to copy the ad in the letter
X  $recipient		# whether it should go to poster, postmaster, or both
X  );
X
#-----------------------------------------------
# CONFIGURATION SECTION
#-----------------------------------------------
X
# This section allows you to customize the default operation at your site.
# Example lines are included in comments, and a normal set of defaults are
# currently active.  Please examine each default and make a decision if
# the current settings are appropriate to your system.
X
# Default host for smtp traffic?  This is specific to GemStone; you
# will probably want to delete this.  This is overridden by
# $ADCOMPLAIN_MAILHOST.
#$mailhost = "mailhost";
X
# Include your .signature file?
# Set to 0 if you don't want to include your signature.
# Normally, adcomplain will append your signature unless -s is specified.
# $addsig = 0;
$addsig = 1;
X
# Are there authorities to which you should report illegal e-mails such
# as pyramid schemes and unsolicited commercial e-mail?  Comma-separated
# if more than one.
$authorities = "uce\@ftc.gov"; # Consult http://www.ftc.gov for details.
# $authorities = ""; # ...ftc.gov is only appropriate if your are in the USA.
X
# CC List -- Do you want a copy of the complaint sent to someone else?
# This is comma-separated if there is more than one.
$cc = "";
X
# Customize your complaint text?
# This is the default name of the file to use for the complaint text.  If the
# file name is empty, the default text will be used.  Override with the
# "-f <filename>" switch.
$complaintFile = "";
X
# Customize mail delivery?
# Adcomplain normally contacts a mail delivery agent directly.  If $mailscript
# is set, adcomplain runs the specified program directly instead, once per
# recipient.  Two arguments are passed:
#   1. The name of a file to send.  It contains all of the sendmail headers,
#      so your program will have to use or modify them appropriately.
#   2. "batch" or "interactive", in case the script wants to make
#      different UI decisions
# Suggested usage: PGP-signing the mail message, ...?
# $mailscript = "/usr/lib/sendmail -t <";
X
# Friendly Mail Domains?
# One spammer trick is to directly originate the mail message on your local
# host.  In other words, they contact the MTA at your mail site directly and
# originate the message at your site.  This is similar to the way adcomplain
# sends your response ;-).  If your MTA does not have appropriate security
# measures, adcomplain might decide that your complaint should be addressed to
# your own postmaster!  This is a list of domain names for your system; names
# in this list are excluded from consideration when selecting a complaint
# address.
#
# It may also be desirable to set this list if your domain has multiple names,
# or if you regularly get mail forwarded from another domain.
#
# If the ADCOMPLAIN_DOMAINS environment variable is set, it will be read
# as a space-delimited list of domains to use and will be _added_ to the
# default list set here.
#
# an example:  @mydomains = ('gemstone.com', 'slc.com');
@mydomains = ();
X
# Always include a copy of the offending message?
# Set to 0 to include a copy of the posting every time.
# Ordinarily this is not done unless you choose to notify the provider.
# $noinclude = 0;
$noinclude = 1;
X
# Default Recipient(s)
# Do you want to complain to the poster, to his mail domain, or both?
# $recipient = 1; # ($complain_to_only) only to the authorities;
# $recipient = 2; # ($poster_only) only to the poster
# $recipient = 3; # ($poster_and_complain_to) both 
$recipient = 1; # ($complain_to_only) only to the authorities;
X
# Degree of qualification of the hostname
# Some domains require the fqdn to include the name of the
# computer to correctly deliver the mail. Others don't.
$fqdnWithoutHost = 0;
#$fqdnWithoutHost = 1;
X
#-----------------------------------------------
# NO USER SERVICEABLE PARTS INSIDE
#-----------------------------------------------
local(
X  $adcomplain_name,     # revision number of this adcomplain
X  $adcomplain_revision, # revision number of this adcomplain
X  $EXEMPT_LIST, 	# list of domains we don't send complaints to
X  %available_hosts, 	# list of possible sites to complain to
X  $batchmode, 		# control flag, indicates no interactive input
X  $bullet, 		# constant, used when formatting letter
X  $bullet2,		# constant, used when formatting letter
X  $chainmode, 		# control flag, indicates this is a chain letter
X  $complain_to, 	# name we chose to send the complaint to
X  $complain_to_only, 	# constant value for $recipient: no complaints to poster
X  $dont_resolve, 	# control flag, indicates don't try gethostbyname() etc.
X  $editor, 		# name of your editor, for editing the letter
X  $from, 		# your e-mail address
X  $header_analysis, 	# list of non-RFC compliant problems with the ad
X  $hosts_file, 		# list of hosts to be tried before gethostbyname()
X  %hosts_to_ips, 	# cached list of results from gethostbyname()
X  %ips_to_hosts, 	# cached list of results from gethostbyaddr()
X  $local_hostname,	# name of this host (best guess)
X  $mailmode,		# optional control flag, indicates this is not USEnet
X  @monthNames, 		# constant list of months, as per RFC 822
X  $newsgroup,		# name of the newsgroup(s) this ad was posted to
X  $omit_signature, 	# control flag, ensures ~/.signature not in your letter
X  $opt_err,		# getopt; indicates error parsing options
X  $opt_b, 		# getopt (-b, sets $batchmode)
X  $opt_c, 		# getopt (-c, sets $chainmode)
X  $opt_f, 		# getopt (-f, sets $complaintFile)
X  $opt_h, 		# getopt (-h, prints help and exits)
X  $opt_l,		# getopt (-l, sets $legal_mode)
X  $opt_m, 		# getopt (-m, sets $mailmode)
X  $opt_o, 		# getopt (-o, sets $outmode and $outfile)
X  $opt_p, 		# getopt (-p)
X  $opt_q, 		# getopt (-q, sets $quiet)
X  $opt_s,		# getopt (-s, sets $omit_signature)
X  $opt_t, 		# getopt (-t, clears $quiet, sets $verbose, $testMode)
X  $opt_u, 		# getopt (-u, sets $dont_resolve)
X  $opt_v, 		# getopt (-v, sets $verbose)
X  $os_kind, 		# the type of OS we're running on
X  $outfile, 		# file we write letter to, if $outmode set
X  $outmode, 		# control flag, letter gets saved to file, not mailed
X  $pager,		# name of your paging program, for displaying letter
X  $poster, 		# our guess as to the name of the poster
X  $poster_and_complain_to, # constant value for $recipient
X  $poster_only, 	# constant value for $recipient
X  $postmaster,		# name of postmaster at complaint address
X  $quiet, 		# control flag, limits interaction and output
X  %rematch_aliases,	# heuristic list, resets priority of another header
X  $response, 		# text of letter we will send
X  $site, 		# site we will send the complaint to
X  @site_exceptions,	# sites that have irregular syntactic form
X  $subject, 		# subject header of the ad
X  $tempname, 		# name of a temp file, esp. for displaying the letter
X  $testMode,		# control flag, omits the mail sending step
X  %timezones, 		# constant list of RFC-822 compliant time zone names
X  @valid_domains,	# the known valid domain suffixes for countries
X  $verbose, 		# control flag, gives noisy narrative of analysis
X  @wdayNames, 		# constant list of RFC-822 compliant week day names
X  );
X
&initialize();		# set up our constants, lists, environment
&process_inputs(); 	# parse command line options, read the message
&parse_headers();	# Analyze the message
&check_hosts();		# Analyze the list of possible hosts
&summarize();		# brief discussion of problems found
X
$response = &compose_message();	# Create the text of the message.
X
# Place a copy of the message on the disk
open(TEXTFILE, ">$tempname") || die "cannot open $tempname: $!";
printf TEXTFILE "%s", $response;
close TEXTFILE;
X
# Display the message
if (!$batchmode && !$outmode) {
X  print "\n";
X  &moref($tempname);
X  }
X
&deliver_message();	# Display, mail, edit, abort...
X
print "\n";
unlink $tempname;
Xexit 0;
X
#-----------------------------------------------
# Process command line options, read the input file.
sub process_inputs {
X  local($junk, @junk, $i);
X
X  $junk = $ENV{"ADCOMPLAIN_OPTS"};
X  if (defined($junk) && $junk ne "") {
X    @junk = split(/\s/, $junk);
X    # push(@ARGV, @junk);
X    unshift(@ARGV, @junk); # make sure that non-dash opts stay at end
X    }
X  &Getopts('bcf:hlmo:p:qstuv');
X  if ((defined($opt_h) && $opt_h) || $opt_err) {
X    print "Usage: $0 [-b] [-c] [-f template] [-o outfile] [-p infile]\n";
X    print "                   [-hmqv] [newsgroup]\n";
X    print " -b -- batch mode (not recommended)\n";
X    print " -c -- chain letter\n";
X    print " -f -- text to use instead of standard blurb\n";
X    print " -h -- this message\n";
X    print " -l -- legal mode, don't cc the authorities ($authorities)\n";
X    print " -m -- force input to be regarded as a mail message\n";
X    print " -o -- write mail message to a file and quit without mailing\n";
X    print " -p -- read the ad from given file\n";
X    print " -q -- ask no unnecessary questions\n";
X    print " -s -- Omit .signature from resulting letter.\n";
X    # -t undocumented: it is a test-mode switch: adcomplain stops after
X    # composing the letter but before attempting to mail it.  It is used
X    # internally for regression testing.
X    print " -u -- Don't attempt to use gethostbyaddr name resolution\n";
X    print " -v -- verbose\n";
X    print "\n";
X    print "Version: $adcomplain_revision\n";
X    exit 0;
X    }
X
X  $batchmode = 0; $batchmode = 1 if defined($opt_b) && $opt_b;
X  $chainmode = 0; $chainmode = 1 if defined($opt_c) && $opt_c;
X  $complaintFile = "";
X  $complaintFile = $opt_f if (defined($opt_f) && $opt_f ne "");
X
X  $legal_letter = 0; $legal_letter = 1 if defined($opt_l) && $opt_l;
X  $mailmode = 0; $mailmode = 1 if defined($opt_m) && $opt_m;
X  if (defined($opt_o) && $opt_o ne "") {
X    $outfile = $opt_o;
X    $outmode = 1;
X    }
X  else {
X    $outfile = "";
X    $outmode = 0;
X    }
X  $quiet = 0; $quiet = 1 if defined($opt_q) && $opt_q;
X  $omit_signature = 0; $omit_signature = 1 if defined($opt_s) && $opt_s;
X  $dont_resolve = 0; $dont_resolve = 1 if defined($opt_u) && $opt_u;
X  $verbose = 0; $verbose = 1 if defined($opt_v) && $opt_v;
X
X  # Resolve conflicting modes
X  if (defined($opt_t) && $opt_t) { # test mode
X    $quiet = 0;
X    $verbose = 1;	# print traces
X    $testMode = 1;# quits without mailing
X    }
X
X  $junk = $ENV{"ADCOMPLAIN_DOMAINS"};
X  if (defined($junk) && $junk ne "") {
X    @junk = split(/\s/, $junk);
X    push(@mydomains, @junk);
X    for ($i = 0; $i < @mydomains; $i ++) {
X      $mydomains[$i] = &find_site($mydomains[$i]);
X      }
X    }
X  if (@mydomains != 0 && $verbose) {
X    print "adcomplain: home domains: ";
X    for (@mydomains) {
X      print "$_ ";
X      }
X    print "\n";
X    }
X
X  # copy original Usenet posting from stdin
X  if ($opt_p) {
X    open(MSG, "<$opt_p") || die "cannot open $opt_p: $!";
X    @original = <MSG>;
X    close MSG;
X    }
X  elsif ($os_kind eq "unix") {
X    @original = <STDIN>;
X    if (!$batchmode) {
X      open(STDIN, $CONSOLE) || die "cannot reopen tty"; # UNIX dependency...
X      }
X    }
X  elsif ($os_kind eq "winnt" || $os_kind eq "win32" || $os_kind eq "os2") {
X    die "The -p option is required." unless defined($opt_p) && $opt_p ne "";
X    }
X  else {
X    die "Don't know how to scarf stdin and reset console on this os ($os_kind)";
X    }
X  }
X
#-----------------------------------------------
# Finish up list of complaints about the message, make sure user sees them.
sub summarize {
X  local($ans);
X
X  for (sort(keys(%hosts_to_ips))) {
X    $junk = $hosts_to_ips{$_};
X    next if $junk ne "";
X    $header_analysis .= "${bullet}I cannot find the IP of $_.\n\n";
X    }
X  for (sort(keys(%ips_to_hosts))) {
X    $junk = $ips_to_hosts{$_};
X    next if $junk ne "";
X    $header_analysis .=
X	"${bullet}I cannot convert IP \"$_\" to a host name.\n\n";
X    }
X
X  if (!$batchmode) {
X    if ($header_analysis ne "") {
X      $poster = "";
X      $junk = &fmt($header_analysis, 72);
X      print "adcomplain: header analysis:\n";
X      print "----------------\n";
X      print "$junk";
X      print "----------------\n";
X      }
X    if ($verbose || $header_analysis ne "") {
X      print "\nSummary of Potential Addressees: (\"$site\" recommended)\n";
X      for (sort(keys(%available_hosts))) {
X	printf "  %25s %s\n", $_, $available_hosts{$_};
X	}
X      }
X    }
X
X  # Limit the options
X  if ($complain_to eq "" && $poster eq "") {
X    if ($batchmode) {
X      print "ERROR: adcomplain did not detect a valid recipient.\n";
X      exit 1;
X      }
X    else {
X      print "ERROR: no valid recipients; edit and correct before sending.\n";
X      }
X    }
X  elsif ($complain_to eq "") {
X    $recipient = $poster_only;
X    }
X  elsif ($poster eq "") {
X    $recipient = $complain_to_only;
X    }
X
X  if ($testMode) {
X    print "TEST MODE: early exit\n";
X    exit 0;
X    }
X
X  # Make sure critical messages are seen
X  if ($quiet || $batchmode) {
X    }
X  elsif ($poster eq "" || $complain_to eq "" || $header_analysis ne "") {
X    print "Press enter to continue.... ";
X    $ans = <STDIN>;
X    }
X  }
X
#-----------------------------------------------
# send, abort, edit, or list the message
sub deliver_message {
X  local($send_to, $cc_to, $each, $ok);
X
X  for (;;) {
X    if ($batchmode) {
X      $ans = "s";
X      }
X    else {
X      print "\n";
X      $ans = &get_answer("Send, abort, edit, or list (s/a/e/l)?", "a");
X      }
X    if ($ans =~ /s.*/ || $ans =~ /y.*/) {
X      # re-extract the addressee from the body
X      local(@junk, $junk);
X     
X      # we only need the headers, so that's all we read. We want to be able
X      # to understand continued lines as well.
X      open(F, "<$tempname") || die "temp file $tempname has disappeared!";
X      for (;;) {	# load the headers
X	$junk = <F>;
X      	if (!defined($junk) || $junk =~ /^$/) { # end of headers
X          push(@junk, $last_line) if $last_line ne "";
X          last;
X	  }
X        if ($junk =~ /^(\S+: .*)/) {   # normal header line
X         push(@junk, $last_line) if $last_line ne "";
X         $last_line = $junk;
X         next;
X	 }
X       if ($junk =~ /^\s+(.*)/) { # continued header line
X         chop $last_line;    # kill the newline
X         $last_line .= " "; 
X         $last_line .= $1;
X         next;
X	 }
X       }	# load the headers
X      close F;
X
X      $send_to = $cc_to = "";
X      foreach $each (@junk) {
X	last if $each =~ /^$/;		# end of headers
X	if ($each =~ /^To: (.*)/i) {
X	  $send_to = $1;
X	  }
X	elsif ($each =~ /^Cc: (.*)/i) {
X	  $cc_to = $1;
X	  }
X	}
X      if ($send_to eq "") {
X	if ($batchmode) {
X	  print "adcomplain: fatal error (no addressee)\n";
X	  last;
X	  }
X	print "no addressee! re-edit and continue\n";
X	next;
X	}
X      if ($outmode) {
X	local(@out_array) = ();
X	open(OUTFILE, "<$tempname") || die "error opening $tempname: $!";
X	@out_array = <OUTFILE>;
X	close(OUTFILE);
X	open(OUTFILE, ">$outfile") || die "error creating $outfile: $!";
X	print OUTFILE @out_array;
X	close(OUTFILE);
X	print "written to $outfile\n";
X	last;  # all done!
X	}
X
X      $ok = &send_to_list($from, "$send_to, $cc_to", $tempname);
X      if (!$ok) {
X	print "send to $send_to failed\n";
X	if ($batchmode) {
X	  unlink $tempname;
X	  exit 1;		# good exit status
X	  }
X	next;
X	}
X      print "sent to: $send_to\n";
X      last;
X      }
X    if ($ans =~ /a.*/) {
X      print "aborted\n";
X      last;
X      }
X    if ($ans =~ /e.*/) {
X      system "$editor $tempname <$CONSOLE";
X      next;
X      }
X    if ($ans =~ /l.*/) {
X      &moref($tempname);
X      next;
X      }
X    print "what?\n";
X    } # for
X  }
X
#-----------------------------------------------
# Chop newline, respecting RFC-821 end of line conventions
sub rfc822_chop {
X  local($text) = @_;
X
X  for (;;) {
X    return $text if $text !~ /[\n\r]$/;
X    chop($text);
X    }
X  }
X
#-----------------------------------------------
# Exchange a line of text with an SMTP daemon
sub send_line {
X  local($text) = @_;
X  local($response);
X
X  print S "$text\r\n";	# RFC-821, ^M^J is end of line!
X  $response = <S>;
X  $response = &rfc822_chop($response);
X  return $response if $response =~ /^500/;
X  print "send_line: response \"$response\"\n" if $verbose;
X  return "";
X  }
X
#-----------------------------------------------
# Relay a mail message through an SMTP daemon.
# Note: this is for use with perl-4.  I _know_ perl-5 has better routines.
sub do_sendmail {
X  local($from, $body, @list) = @_;
X  local ($each);
X
X  local($sockaddr) = 'S n a4 x8';	# magic spell to pack an inet_addr
X  local($name, $aliases, $type, $len, $thisaddr, $thataddr);
X  local($local_inetaddr, $remote_inetaddr);
X  local($targetPort) = "smtp";	# or 25, world-wide standard
X  local($response);
X  local($local_prot) = (getprotobyname('tcp'))[2];
X
X  if (defined($mailscript) && $mailscript ne "") {
X    $name = "$mailscript $body ";
X    if ($batchmode) {
X      $name .= "batch";
X      }
X    else {
X      $name .= "interactive";
X      }
X    print "mail command: $name\n" if $verbose;
X    $response = system($name) >> 256;
X    if ($response != 0) {
X      print "mail command \"$name\" failed!\n";
X      return 0;
X      }
X    return 1;
X    }
X
X  ($name, $aliases, $targetPort) = getservbyname($targetPort, 'tcp')
X      unless $targetPort =~ /^\d+$/;
X
X  # Fill out local side of connection
X  ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($local_hostname);
X
X  # Fill out remote side
X  if ($mailhost =~ /\d+\.\d+\.\d+\.\d+/) {
X    local($a, $b, $c, $d) = split(/\./, $mailhost);
X    $thataddr = pack("C4", $a, $b, $c, $d);
X    }
X  else {
X    ($name, $aliases, $type, $len, $thataddr) = gethostbyname($mailhost);
X    if (!defined($name) || $name eq "") {
X      # $! doesn't have error return here.  Sigh.
X      print STDERR "cannot find \"$mailhost\" (gethostbyname)\n";
X      return 0;
X      }
X    }
X  
X  $local_inetaddr = pack($sockaddr, &AF_INET, 0, $thisaddr);
X  $remote_inetaddr = pack($sockaddr, &AF_INET, $targetPort, $thataddr);
X  
X  #MAKE the socket filehandle.
X  if ( ! socket( S, &AF_INET, &SOCK_STREAM, $local_prot)) {
X    print STDERR "socket() failure: $!\n";
X    return 0;
X    }
X  
X  #GIVE the socket an address.
X  if (! bind(S, $local_inetaddr)) {
X    print STDERR "bind() failure: $!\n";
X    return 0;
X    }
X  
X  #Call up the server.
X  if (! connect( S, $remote_inetaddr)) {
X    print STDERR "unable to connect() to \"$mailhost\": $!\n";
X    return 0;
X    }
X  print "do_sendmail: contacted \"$mailhost\"\n" if $verbose;
X  
X  #Set socket to be command buffered.
X  select(S); $| =1; select(STDOUT);
X
X  # sometimes you have to be aggressive to get the daemon to talk?
X  # print S "\r\nHELO $local_hostname\r\n";
X  # $response = <S>;
X  # print "do_sendmail: throw-away response \"$response\"\n" if $verbose;
X
X  # Start the dance....
X  print S "HELO $local_hostname\r\n";
X
X  # Try to get the initial acknowledgement.  Some SMTP servers are silent
X  # until you speak first.  Others speak without being prompted.  The best way
X  # out of this ambiguity is to just eat until we see the banner.  We
X  # do _not_ check for 500 errors here.
X  for (;;) {
X    $response = <S>;
X    $response = &rfc822_chop($response);
X    print "do_sendmail: initial response \"$response\"\n" if $verbose;
X    last if $response =~ /^220 /;
X    last if $response =~ /^250 /;
X    last if $response =~ /^SMTP/;
X    }
X
X  $response = &send_line("MAIL FROM: <$from>");
X  if ($response ne "") {
X    print "do_sendmail: error(MAIL FROM) \"$response\" from sendmail\n";
X    close S;
X    return 0;
X    }
X
X  foreach $each (@list) {
X    $response = &send_line("RCPT TO: $each");
X    if ($response ne "") {
X      print "do_sendmail: error(RCPT TO $each) \"$response\" from sendmail\n";
X      close S;
X      return 0;
X      }
X    }
X
X  $response = &send_line("DATA");
X  if ($response ne "") {
X    print "do_sendmail: error(DATA) \"$response\" from sendmail\n";
X    close S;
X    return 0;
X    }
X
X  if (!open(F, "<$body")) {
X    print "do_sendmail: cannot open $body\n";
X    close S;
X    return 0;
X    }
X  for (;;) {
X    $body = <F>;
X    last if !defined($body);
X    $body = &rfc822_chop($body);	# put our _own_ line terminator on it
X    $body = ".$body" if $body =~ /^\..*/; # rfc821 sec. 4.5.2 transparency
X    print S "$body\r\n";
X    }
X  close F;
X
X  $response = &send_line(".");
X  if ($response ne "") {
X    print "do_sendmail: error(final) \"$response\" from sendmail\n";
X    close S;
X    return 0;
X    }
X
X  $response = &send_line("QUIT");
X  if ($response ne "") {
X    print "do_sendmail: error(QUIT) \"$response\" from sendmail\n";
X    close S;
X    return 0;
X    }
X  close S;
X
X  return 1;
X  }
X
#-----------------------------------------------
# Deliver text to everyone on a list
sub send_to_list {
X  local($from, $send_to, $body) = @_;
X  local($ok);
X  local(@list) = split(/[ \t\n,]+/, $send_to);
X
X  $ok = &do_sendmail($from, $body, @list);
X  return $ok;
X  }
X
#-----------------------------------------------
# getopts.pl - a better getopt.pl.  The one shipped with perl has bugs.
X
# Usage:
# do Getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
# # side effect.
# $opt_err set nonzero in case of error.
X
sub Getopts {
X  local($optlist) = @_;
X  local(@args, $_, $first, $rest, $pos);
X  local(@new_argv, @unused_argv);
X  local(@active_argv) = ();
X
X  # Gather up the argv's that we should be examining
X  for (;;) {
X    last if !@ARGV;
X    $each = shift(@ARGV);
X    last if ($each eq "--"); # POSIX convention
X    push(@active_argv, $each);
X    }
X  @unused_argv = @ARGV; # remaining args unprocessed
X  @new_argv = ();
X
X  $opt_err = 0;
X  @args = split(/ */, $optlist);
X  for (;;) { # process argv
X    last if !@active_argv;
X
X    if (($_ = $active_argv[0]) !~ /^-(.)(.*)/) {
X      # Allow non-switch args, as in gnu getopt
X      push(@new_argv, $active_argv[0]);
X      shift(@active_argv);
X      next;
X      }
X    ($first,$rest) = ($1,$2);
X
X    $pos = index($optlist, $first);
X    if ($pos < 0) {
X      print STDERR "Unknown option: $first\n";
X      ++$opt_err;
X      if($rest ne '') {
X	$active_argv[0] = "-$rest";
X	}
X      else {
X	shift(@active_argv);
X	}
X      next;
X      }
X
X    if (!defined($args[$pos + 1]) ||
X	$args[$pos + 1] ne ':') { # simple switch argument
X      eval "\$opt_$first = 1";
X      if ($rest eq '') {
X	shift(@active_argv);
X	}
X      else {
X	$active_argv[0] = "-$rest";
X	}
X      next;
X      }
X
X    # switch takes argument
X    if ($rest ne '') {
X      eval "\$opt_$first = \"$rest\"";
X      shift(@active_argv);
X      next;
X      }
X
X    shift(@active_argv);
X    if ($rest eq '') { # argument is $active_argv[0]
X      if (!@active_argv) {
X	print STDERR "-$first: argument missing\n";
X	$opt_err ++;
X	last;
X	}
X      $rest = shift(@active_argv);
X      if ($rest eq "--") {
X	print STDERR "-$first: argument missing\n";
X	$opt_err ++;
X	last;
X	}
X      } # argument is $active_argv[0]
X    eval "\$opt_$first = \$rest;";
X    } # process argv
X
X  # Remaining args are left for caller...
X  @ARGV = (@new_argv, @unused_argv);;
} # Getopts
X
#-----------------------------------------------
# Find the first line that matches the given header and return it.
sub extract_header {
X  local($pattern) = @_;
X  local($result);
X
X  $result = "";
X  for (@original) {
X    last if length($_) == 1; # RFC-822: end of headers at first blank line
X    if ($result ne "") {
X      last if $_ !~ /^\s+(.*)/;	# not a continued header, and we're done.
X      $result .= " "; 
X      $result .= $1;
X      chop($result);
X      }
X    elsif ($_ =~ /$pattern/i) { # RFC-822 says case-independent
X      $result = $_;
X      chop($result);
X      $result =~ s/$pattern\s*(.*)/$1/i;
X      }
X    }
X  return $result;
} # extract_header
X
#-----------------------------------------------
# Return true if the given pattern is a private (intra-net) IP
# (from RFC 1597)
# ---------
# 3. Private Address Space 
#    
#    The Internet Assigned Numbers Authority (IANA) has reserved the
#    following three blocks of the IP address space for private networks:
#    
#         10.0.0.0        -   10.255.255.255
#         172.16.0.0      -   172.31.255.255
#         192.168.0.0     -   192.168.255.255
X
sub is_private_inet_addr {
X  local($pat) = @_;
X
X  return 0 unless $pat =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/;
X  return 1 if $1 == 10;
X  return 1 if $1 == 172 && $2 >= 16 && $2 <= 31;
X  return 1 if $1 == 192 && $2 == 168;
X  return 0;
X  }
X
#-----------------------------------------------
# Return true if the given pattern is an inet address, e.g. "192.83.233,4"
sub is_inet_addr {
X  local ($pat) = @_;
X
X  return 0 unless $pat =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/;
X  return 0 if $1 > 255;
X  return 0 if $2 > 255;
X  return 0 if $3 > 255;
X  return 0 if $4 > 255;
X  return 1;
X  }
X
#-----------------------------------------------
# return the connecting SMTP agent's name for itself
sub helo_name {
X  local ($text) = @_;
X  local ($probe);
X
X  return "" unless $text =~ /.*from\s*[\w\.-]+.*/;
X  ($probe = $text) =~ s/.*from\s*([\w\.-]+).*/$1/;	# get first word
X
X  $probe =~ s/^\((.*)\).*/$1/;	# turn (host) into host
X  $probe =~ s/(.*)\(.*\).*/$1/;	# turn host(inet_addr) into host
X  $probe =~ s/^(\S+)\s+.*/$1/;	# get first word
X  $probe = &good_hostname($probe, 0);	# don't require this name to exist
X  return "" if $probe eq "";
X
X  return $probe;
X  }
X
#-----------------------------------------------
# Return name of recipient machine ("by" clause in "Received:" header)
sub by_name {
X  local ($text) = @_;
X  local ($probe);
X
X  return "" unless $text =~ /.*by\s+([\w\.-]+).*/;
X  $probe = &good_hostname($1, 0);	# peer must exist!
X  return $probe;
X  }
X
#-----------------------------------------------
# Return (name, inet_addr) of peer name out of received header if they exist
sub received_peer_name {
X  local ($text) = @_;
X  local ($probe, $probe2);
X  local ($peer_name, $inet_addr);
X
X  return ("", "") unless $text =~ /.*from\s*[^(]*\([^)]*\)/;
X
X  $probe = $text;
X
X  # a _very_ thorny problem.  Extract the from-clause (stuff between parens).
X  # Ignore any by-clause.
X  if ($probe =~ /\(peer crosschecked as: (.*)\)/)  {
X    # new stuff from uunet, yay!  Sep '97, they're finally hitting back.
X    $probe = $1;
X    }
X  else {
X    $probe =~ s/.*\bfrom\s+(.*)\s+by\s.*/$1/;  # by-clause after from-clause
X    $probe =~ s/.*\bby\s+.*\s+from\s+(.*)/$1/;  # from-clause after by-clause
X    return "" unless $probe =~ /[^(]*\(([^)]*)\).*/; # must have parens here.
X    $probe = $1;			# stuff between parens
X    }
X
X  $inet_addr = $probe;
X  $probe =~ s/\s*(\S+).*/$1/; # grab first word
X  return ("", "") if $probe =~ /.*smail.*/i;  # strange smail header
X  return ("", "") if $probe =~ /.*smtp.*/i;  # strange smtpd header
X  return ("", "") if $probe =~ /^\d\.\d/;  # strange sendmail header
X
X  # Get the internet address.
X  $inet_addr =~ s/^[^[]*\[(.*)\]/$1/;
X  $inet_addr = "" if !&is_inet_addr($inet_addr);
X
X  $probe =~ s/^([^[]*)\[.*\]/$1/; # ignore bracketed inet address
X  if (&is_inet_addr($probe)) { # mailhost was as puzzled as we are
X    $inet_addr = $probe;
X    $probe = "";
X    }
X
X  $probe = &good_hostname($probe, 0);
X  if ($probe eq "localhost" || $inet_addr eq "127.0.0.1") {
X    $probe = $inet_addr = "";
X    }
X  return ($probe, $inet_addr);
X  }
X
#-----------------------------------------------
X
sub dict_at {
X  local($pos) = @_;
X  local($b1, $b2, $b3, $b4);
X
X  $pos *= 4;
X  $b1 = ord(substr($EXEMPT_LIST, $pos, 1));
X  $b2 = ord(substr($EXEMPT_LIST, $pos + 1, 1));
X  $b3 = ord(substr($EXEMPT_LIST, $pos + 2, 1));
X  $b4 = ord(substr($EXEMPT_LIST, $pos + 3, 1));
X
X  return ($b1 << 24) | ($b2 << 16) | ($b3 << 8) | $b4;
X  }
X
sub dawg_check {
X  local($word) = @_;
X  local($edgePos);
X  local($wordChar, $wordPos);
X
X  $edgePos = 1;			# root node
X
X  $wordPos = 0;
X  $wordChar = ord(substr($word, $wordPos, 1));
X  for (;;) {
X    if ($wordChar == ((&dict_at($edgePos) >> 24) & 0xff)) {
X				# character match
X      $wordPos ++;		# extract next char in word
X      $wordChar = ord(substr($word, $wordPos, 1));
X      $wordChar = 0 if !defined($wordChar);
X      if ($wordChar == 0) {	# end of word
X	return (&dict_at($edgePos) & 0x800000) != 0;
X        }
X      else {			# jump to new node
X        $edgePos = &dict_at($edgePos) & 0x1ffff;
X	last if $edgePos == 0;	# null pointer, we're done
X	next;
X	}
X      }
X    last if (&dict_at($edgePos) & 0x400000) != 0;	# end of node, no match
X    $edgePos ++;		# next entry in this node
X    }
X  return 0;			# not found
X  }
X
#-----------------------------------------------
# Return 1 if the given name is in the list of exempt sites.
sub is_exempt {
X  local ($name) = @_;
X  local ($site);
X
X  return 0 if $name eq "";
X  $name =~ y/A-Z/a-z/;		# canonicalize to lower case
X  $site = &find_site($name);	# site, not host.
#  $site = $name;
X
X  return 0 if !&dawg_check($site);
X  print "found exempt domain \"$site\".\n" if $verbose;
X  return 1;
}
X
#-----------------------------------------------
# Return 1 if arg begins with a valid month (RFC-822)
sub is_month {
X  local ($text) = @_;
X  local ($probe, $each, $result);
X
X  ($probe = $text) =~ s/^\s*(\S\S\S)\s+.*/$1/;
X  for (@monthNames) {
X    return 1 if $_ =~ /$probe/i;
X    }
X  return 0;
}
X
#-----------------------------------------------
# Return 1 if the arg is a legal (RFC-822) day of the week.
sub is_day {
X  local ($text) = @_;
X  local ($probe, $result);
X
X  ($probe = $text) =~ s/^\s*(\S\S\S).*/$1/;
X  $probe =~ s/(\W)/\\$1/g;		# remove special characters
X  for (@wdayNames) {
X    return 1 if $_ =~ /$probe/i;
X    }
X  return 0;
X  }
X
#-----------------------------------------------
# Is time zone believable?
sub zone_check {
X  local ($datepart) = @_;
X  local ($hour_offset, $zone, $zoneStr);
X  local (@zone_list, $each);
X
X  $hour_offset = $zone = $datepart;
X  if ($hour_offset =~ /(-\d\d\d\d)/) {
X    $hour_offset = $1;
X    }
X  elsif ($hour_offset =~ /\+(\d\d\d\d)/) {
X    $hour_offset = $1;
X    }
X  else {
X    $hour_offset =~ s/^.*\D(\d\d\d\d).*/$1/;
X    }
X  return 1 if $hour_offset eq $datepart;
X
X  # $pattern = "^.*" . $hour_offset . "\s*\(([^)]+)\).*";
X  # $zone =~ s/$pattern/$1/;
X  $zone =~ s/^.*$hour_offset\s*\(([^)]+)\).*/$1/;
X  return 1 if $zone eq $datepart;
X
X  $zoneStr = $timezones{$hour_offset};
X  if ($zoneStr eq "") {
X    print
X      "zone_check:  Unknown time zone \"$hour_offset\" in date \"$datepart\"\n"
X	if $verbose;
X    $header_analysis .=
X	"${bullet}I cannot confirm that the time zone \"$zone\" in \"Received:\"\n";
X    $header_analysis .= "header \"$datepart\"\n";
X    $header_analysis .= "should have an hour offset of \"$hour_offset\".\n\n";
X    return 1;
X    }
X  @zone_list = split(/,\s*/, $zoneStr);
X  for (@zone_list) {
X    return 1 if $_ =~ /^$zone$/i; # OK, let it be case-insensitive
X    }
X
X  if ($verbose) {
X    print "zone_check: hour offset $hour_offset has zone $zone, ";
X    print "expected one of: $zoneStr\n";
X    }
X
X  # prettify for the message
X  $zoneStr = "";
X  for (@zone_list) {
X    $zoneStr .= ", " if $zoneStr ne "";
X    $zoneStr .= "\"$_\"";
X    }
X  if ($zoneStr =~ /^[^,]+,[^,]+$/) {
X    $zoneStr =~ s/(.*), ([^,]*)$/$1 or $2/g;
X    }
X  else {
X    $zoneStr =~ s/(.*), ([^,]*)$/$1, or $2/g;
X    }
X
X  $header_analysis .= "${bullet}Time zone in \"Received:\" header \"$datepart\"\n";
X  $header_analysis .=
X    "is \"$zone\" when it should be one of: $zoneStr.\n";
X  $header_analysis .=
X	"(This is the signature of the \"Stealth\" spam mailer.)\n"
X	if $zone eq "EST";
X  $header_analysis .= "\n";
X
X  return 0;
}
X
X
#-----------------------------------------------
# Return 1 if the header parses properly
sub parse_received_header {
X  local ($text) = @_;
X  local ($datepart, $probe, $probe2, $each);
X
# From rfc822:
# TO DO:  note that "from" must be first, etc.
#     received    =  "Received"    ":"            ; one per relay
#                       ["from" domain]           ; sending host
#                       ["by"   domain]           ; receiving host
#                       ["via"  atom]             ; physical path
#                      *("with" atom)             ; link/mail protocol
#                       ["id"   msg-id]           ; receiver msg id
#                       ["for"  addr-spec]        ; initial form
#                        ";"    date-time         ; time received
#     date        =  1*2DIGIT month 2DIGIT        ; day month year
#                                                 ;  e.g. 20 Jun 82
#     date-time   =  [ day "," ] date time        ; dd mm yy
#                                                 ;  hh:mm:ss zzz
#     day         =  "Mon"  / "Tue" /  "Wed"  / "Thu"
#                 /  "Fri"  / "Sat" /  "Sun"
#     hour        =  2DIGIT ":" 2DIGIT [":" 2DIGIT]
#                                                 ; 00:00:00 - 23:59:59
#     month       =  "Jan"  /  "Feb" /  "Mar"  /  "Apr"
#                 /  "May"  /  "Jun" /  "Jul"  /  "Aug"
#                 /  "Sep"  /  "Oct" /  "Nov"  /  "Dec"
#     time        =  hour zone                    ; ANSI and Military
#     zone        =  "UT"  / "GMT"                ; Universal Time
#                                                 ; North American : UT
#                 /  "EST" / "EDT"                ;  Eastern:  - 5/ - 4
#                 /  "CST" / "CDT"                ;  Central:  - 6/ - 5
#                 /  "MST" / "MDT"                ;  Mountain: - 7/ - 6
#                 /  "PST" / "PDT"                ;  Pacific:  - 8/ - 7
#                 /  1ALPHA                       ; Military: Z = UT;
X  if ($text !~ /;/) {
X    $header_analysis .= "${bullet}\"Received:\" header \"$text\"\n";
X    $header_analysis .= "has no mandatory semicolon (see RFC-822).\n\n";
X    return 0;
X    }
X
X  # But does it really have a time?
X  ($datepart = $text) =~ s/.*;\s*(.*)/$1/;
X  $probe = $datepart;
X
X  # Remove comments (thanks to Andrey A. Chernov for this)
X  $probe =~ s/(\([^)]*\))//g;
X
X  if ($probe =~ /,/) {
X    # process the day field
X    ($probe2 = $probe) =~ s/^\s*([^,\s]+)\s*,.*/$1/;
X    if (!&is_day($probe)) {
X      $header_analysis .=
X	  "${bullet}Day of week in \"Received:\" header, \"$datepart\",\n";
X      $header_analysis .=
X	  "is not standard (see RFC-822).\n\n";
X      return 0;
X      }
X    $probe =~ s/[^,\s]+\s*,(.*)/$1/;  # now looking at date + time
X    }
X  else {
X    # Nonstandard netcom header
X    $probe =~ s/^\s*...\s+(.*)/$1/ if &is_day($probe);
X    }
X
X  $probe =~ s/^\s*(.*)/$1/; # remove leading spaces
X
X  if ($probe =~ /^\d+\s+(.*)/) { # standard day-month-year
X    $probe = $1;		# now must have month
X
X    if (!&is_month($probe)) {
X      $header_analysis .=
X	"${bullet}Date in \"Received:\" header, \"$datepart\", is not\n";
X      $header_analysis .= "standard (see RFC-822).\n\n";
X      return 0;
X      }
X    $probe =~ s/^...\s+(.*)/$1/;
X    }
X  elsif (&is_month($probe)) {
X    # Netcom has non-standard month-day-year
X    $probe =~ s/^...\s+(.*)/$1/;
X    if ($probe !~ /^\d/) {
X      $header_analysis .= "${bullet}(Netcom-style) ";
X      $header_analysis .=
X	  "date in \"Received:\" header, \"$datepart\", is not standard;\n";
X      $header_analysis .= "cannot find day of month (see RFC-822).\n\n";
X      return 0;
X      }
X    }
X  else {
X    $header_analysis .=
X	"${bullet}Date in \"Received:\" header, \"$datepart\", is not\n";
X    $header_analysis .= "standard; cannot find day of month (see RFC-822).\n\n";
X    return 0;
X    }
X
X  # Now for year
X  $probe =~ s/^...\s+(.*)/$1/;
X  if ($probe !~ /^\d+/) {
X    $header_analysis .=
X	"${bullet}Date in \"Received:\" header, \"$datepart\", is not\n";
X    $header_analysis .= "standard; cannot find the year (see RFC-822).\n\n";
X    return 0;
X    }
X  $probe =~ s/^\d+\s+(.*)/$1/;  # anything left?
X  if ($probe !~ /^\d\d:\d\d/) {
X    $header_analysis .=
X	"${bullet}Date in \"Received:\" header, \"$datepart\", is not\n";
X    $header_analysis .= "standard; time is not hh:mm:ss (see RFC-822).\n\n";
X    return 0;
X    }
X
X  # in practice, time zones are not very consistent, but we'll do our best.
X  return 0 if !&zone_check($datepart);
X
X  return 1;
X  }
X
#-----------------------------------------------
# Indicate if the Received: header is forged.
sub forged_received_header {
X  local ($text) = @_;
X  local ($possibleName);
X  local ($probe, $probe2, $result);
X
X  # Many ad hoc checks for a bogus Received: header.
X  # Plenty of work needs to be done here.
X  # See http://oasis.ot.com/~dmuth/spam-l
X
X  # everything after the 'from'
X  ($possibleName = $text) =~ s/^Received:\s*(.*)/$1/i;
X
X  $result = 0;
X
X  for ("CLOAKED!", "may be forged", "unknown host") {
X    next unless $possibleName =~ /$_/i;
X    print "forged_received_header: found \"$_\" in header.\n" if $verbose;
X    $header_analysis .=
X	"${bullet}\"Received:\" header has suspicious text: \"$_\".\n\n";
X    $result = 1;
X    }
X
X  # look for impossible IP address
X  $probe2 = $probe = $possibleName;
X  for (;;) {
X    local ($str1, $str2, $str3, $str4);
X
X    # last if !($probe =~ /\d+\.\d+\.\d+\.\d+/);
X    last unless $probe =~ /[\[(]\s*(\d+\.\d+\.\d+\.\d+)\s*[\])]/;
X    # idea: require that the inet_addr have enclosing brackets?
X
X    ($str1 = $probe2 = $1) =~ s/\./\\./g;
X    $probe =~ s/^(.*)$str1(.*)/$1$2/;	# remove it
X
X    ($str1, $str2, $str3, $str4) = ($probe2 =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)/);
X
X    if ($probe2 =~ /^0\d/ || $probe2 =~ /\.0\d/ ||
X      $str1 > 255 || $str2 > 255 || $str3 > 255 || $str4 > 255) {
X      print "forged_received_header: impossible IP \"$probe2\".\n" if $verbose;
X      $header_analysis .=
X	  "${bullet}\"Received:\" header has impossible IP \"$probe2\".\n\n";
X      $result = 1;
X      }
X    }
X
X  $result = 1 if !&parse_received_header($possibleName);
X  # bogus Received: header won't have a for-clause with _your_ name in it.
X  # for now, just see if it has the right domain name.
X  # I wish a Received: header _always_ had a for-clause!
# too aggressive.  How can I make this right?
#    if ($possibleName =~ /for\s+<[^>]+>;/) {
#      $probe = $possibleName;
#      $probe =~ s/.*\sfor\s+<([^>]+)>;.*/$1/;
#      if (!&home_domain($probe)) {
#	print 
#	    "forged_received_header: bogus for-clause <$probe>\n"
#		if $verbose;
#	$header_analysis .= "${bullet}\"Received:\" header has bogus for-clause <$probe>.\n\n";
#	$result = 1;
#        }
#      }
X
X  # bogus Received: header often has incorrect SMTP id
# Relies too much on the implementation of SMTP.
#    if ($possibleName =~ /with smtp id/i) {
#      local ($smtp_id, $smtp_char, $smtp_time, $smtp_hour);
#
#      $smtp_id = $possibleName;
#      $smtp_id =~ s/.*with smtp id (\w+).*/$1/i;
#      $smtp_char = $smtp_id;
#      $smtp_char =~ s/^(.).*$/$1/;
#      $smtp_time = $possibleName;
#      $smtp_time =~ s/.*with smtp id [^;]+;(.*)/$1/i; # entire end of header
#      $smtp_time =~ s/.*\s([0-2]\d:\d\d:\d\d).*/$1/;  # just want hh:mm:ss
#      $smtp_hour = $smtp_time;
#      $smtp_hour =~ s/^([0-2]\d):.*/$1/;	# just the hour
#      if ($smtp_chars{$smtp_char} ne $smtp_hour) {
#	if ($verbose) {
#	  print "forged_received_header: SMTP id \"$smtp_id\" does";
#	  print "    not match time \"$smtp_time\"\n";
#	  }
#	$header_analysis .=
#"${bullet}\"Received:\" header with SMTP id \"$smtp_id\" mismatches \"$smtp_time\".\n\n";
#	$result = 1;
#	}
#      }
X
X  return $result;
X  }
X
#-----------------------------------------------
# Find a line in hosts
sub findLine {
X  local ($text) = @_;
X  local ($result, $line);
X
X  return "" if $hosts_file eq "";
X  open(HOSTS, "<$hosts_file") || die "cannot open $hosts_file: $!";
X  $result = "";
X  while (<HOSTS>) {
X    $line = $_;
X    chop($line);
X    next if $line =~ /^\s*#.*/;
X    # how else do I specify \< and \>?  I miss vi's regex, for once.
X    if ($line =~ /^$name$/i ||
X        $line =~ /^$name\s+/i ||
X        $line =~ /\s+$name$/i ||
X        $line =~ /\s+$name\s+/i) {
X      $result = $line;
X      last;
X      }
X    next;
X    }
X
X  close HOSTS;
X  return $result;
X  }
X
#-----------------------------------------------
# search the hosts file.  addrToName looks here first
sub fakeAddrToName {
X  local($name) = @_;
X  local($result);
X
X  $name =~ s/(\W)/\\$1/g;		# remove special characters
X  $result = &findLine($name);
X
X  $result =~ s/^\d+\.\d+\.\d+\.\d+\s+(\S+).*/$1/;
X  return $result;
X  }
X
#-----------------------------------------------
# search the hosts file.  nameToAddr looks here first
sub fakeNameToAddr {
X  local($name) = @_;
X  local($result);
X
X  $name =~ s/(\W)/\\$1/g;		# remove special characters
X  $result = &findLine($name);
X  $result =~ s/^(\d+\.\d+\.\d+\.\d+)\s+.*/$1/;
X  return $result;
X  }
X
#-----------------------------------------------
# Cache the relationship between the given hostname and IP
sub log_mapping {
X  local($name, $ip, $type) = @_;
X
X  $ips_to_hosts{$ip} = $name if $ip ne "";
X  $hosts_to_ips{$name} = $ip if $name ne "";
X  $name = "?" if $name eq "";
X  $ip = "?" if $ip eq "";
X  print "  $ip -> $name\t# $type\n" if $verbose;
X  }
X
X
#-----------------------------------------------
# Try to turn an address into a hostname (cover for gethostbyaddr)
sub addrToName {
X  local ($text) = @_;
X  local ($name, $aliases, $addrtype, $length, @addrs);
X  local ($addr_int);
X  local ($a, $b, $c, $d);
X
X  $name = $ips_to_hosts{$text};
X  return $name if defined($name) && $name ne "";
X
X  $name = &fakeAddrToName($text);
X  if ($name ne "") {
X    $name = "" if $name eq "BOGUS";
X    &log_mapping($name, $text, "hosts");
X    return $name;
X    }
X
X  ($a, $b, $c, $d) = split(/\./, $text);
X  $addr_int = pack("C4", $a, $b, $c, $d);
X
X  ($name, $aliases, $addrtype, $length, @addrs) =
X	gethostbyaddr($addr_int, &AF_INET);
X  if (defined($name) && $name ne "") {
X    &log_mapping($name, $text, "gethostbyaddr");
X    return $name;
X    }
X
X  &log_mapping("", $text, "gethostbyaddr");
X  return "";
X  }
X
#-----------------------------------------------
# Try to turn a hostname into an address (cover for gethostbyname)
sub nameToAddr {
X  local ($text) = @_;
X  local ($name, $aliases, $addrtype, $length, @addrs);
X  local ($a, $b, $c, $d);
X
X  $name = $hosts_to_ips{$text};
X  return $name if defined($name) && $name ne "";
X
X  $name = &fakeNameToAddr($text);
X  if (defined($name) && $name ne "") {
X    $name = "" if $name eq "0.0.0.0";
X    &log_mapping($text, $name, "hosts");
X    return $name;
X    }
X
X  ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname($text);
X  if (defined($name) && $name ne "") {
X    ($a, $b, $c, $d) = unpack('C4', $addrs[0]);
X    $name = "$a.$b.$c.$d";
X    &log_mapping($text, $name, "gethostbyname");
X    return $name;
X    }
X
X  &log_mapping($text, "", "gethostbyname");
X  return "";
X  }
X
#-----------------------------------------------
# return 1 if this hostname resolves
sub real_host {
X  local ($host) = @_;
X  local ($junk);
X
X  return 1 if $dont_resolve;
X  $junk = &nameToAddr($host);
X  return 0 if $junk eq "";
X  return 1;
X  }
X
X
#-----------------------------------------------
# return "", or best domain from the "Received: from" headers
# The algorithm is fairly involved.  Basically, start with the newest
# Received: header and process until the last one a bogus one is found.
sub do_received {
X  local ($message_host) = @_;
X  local ($message_site, $inet_addr);
X  local ($result, $previous_peer);
X  local ($probe, $probe2, $possibleName);
X  local ($this, $i, $each);
X  local (@all_headers);
X  local ($peer_name, $helo_name, $by_name);
X  local ($peer_site, $helo_site, $by_site);
X  local ($junk2, $peer_is_exempt, $found_public_addr);
X
X  $message_site = &find_site($message_host);
X
X  # get "Received: " headers for later perusal.
X  for ($i = 0; $i < @original; $i ++) {
X    $line = $original[$i];
X    last if length($line) == 1; # RFC-822: end of headers at first blank line
X    next unless $line =~ /^Received:\s*/i;	# RFC-822 says case-independent
X    $this = $line;
X    chop($this);
X    while ($i < @original) { # collect multi-line header
X      $line = $original[$i + 1];
X      last unless $line =~ /^[\s]+/;
X      chop($line);
X      $this .= $line;
X      $i ++;
X      }
X    $this =~ s/^Received:\s*(.*)/$1/i;
X    last if &forged_received_header($this); # don't _even_ put in the list
X    push(@all_headers, $this);
X    }
X
X  $peer_name = $result = "";
X  $found_public_addr = 0;
X
X  # Analyze the headers
X  NEXT_HEADER: for ($i = 0; $i < @all_headers; $i ++) {
X    $possibleName = $all_headers[$i];
X
X    $previous_peer = $peer_name if $peer_name ne "";
X    ($peer_name, $inet_addr) = &received_peer_name($possibleName);
X    $helo_name = &helo_name($possibleName);
X    $by_name = &by_name($possibleName);
X    if ($verbose) {
X      print "received:  \"$peer_name\"";
X      print " inet: \"$inet_addr\"" if defined($inet_addr) && $inet_addr ne "";
X      print " by: \"$by_name\"" if $by_name ne "";
X      print " helo: \"$helo_name\"" if $helo_name ne "";
X      print "\n";
X      }
X    if (defined($inet_addr) && $inet_addr ne "") {
X      local($is_private) = &is_private_inet_addr($inet_addr);
X
X      if (!$is_private) {
X	# we're in the part of the received: path that was on the Internet
X        $found_public_addr = 1;
X        }
X      elsif ($found_public_addr) {
X	# we've fallen into the private intranet on the other end.  Stop.
X	print "  do_received: found sender's intranet $inet_addr\n"
X	  if $verbose;
X	last NEXT_HEADER;
X	}
X      else {
X	# we're in the private intranet at the receiving end.  Skip.
X	print "  do_received: found receiver's intranet $inet_addr\"\n"
X	  if $verbose;
X	next NEXT_HEADER;
X	}
X      }
X    $peer_site = &find_site($peer_name);
X    &good_hostname($peer_name, 1);	# adds complaint if can't confirm
X    $peer_is_exempt = &is_exempt($peer_name);
X    $peer_site = "" if $peer_is_exempt;
X
X    $helo_site = &find_site($helo_name);
X    # &good_hostname($helo_name, 1);	# adds complaint if can't confirm
X
X    $by_site = &find_site($by_name);
X    &good_hostname($by_name, 1);	# adds complaint if can't confirm
X
X    # analyze inet_addr, upgrade notion of peer_name
X    if (defined($inet_addr) && $inet_addr ne "" && !$dont_resolve) {
X      $probe2 = &addrToName($inet_addr);
X      if ($peer_name ne "" && $probe2 eq "") {
X	$header_analysis .=
X	    "${bullet}Unable to confirm $peer_name is $inet_addr.\n\n";
X	$peer_name = $previous_peer if $peer_name eq "";
X	}
X      elsif ($peer_name ne "" && $probe2 ne "" && !&home_domain($peer_name)) {
X	$junk2 = &find_site($probe2);
X	if (!$peer_is_exempt && $peer_site ne $junk2) {
X	  $header_analysis .= "${bullet}\"Received:\" header says that peer is \"$peer_name\",\n";
X	  $header_analysis .= "but address $inet_addr resolves to $probe2.\n\n";
X	  $result = $probe2;
X	  last NEXT_HEADER;
X	  }
X	}
X      if ($probe2 ne "") {
X	if ($peer_name eq "") {
X	  $header_analysis .= 
X	      "${bullet}\"Received:\" header has empty peer name, but\n";
X	  $header_analysis .= "address $inet_addr resolves to $probe2.\n\n";
X	  }
X	$peer_name = $probe2;
X	}
X      } # $inet_addr ne ""
X
X    # ignore this header if it comes through/from/by a exempt domain
X    if ($peer_is_exempt) {
X      $result = $by_name if $by_name ne "";
X      last NEXT_HEADER;
X      }
X    $peer_site = &find_site($peer_name);
X
X    # Look at helo_name.  Don't trust it very far, really.
X    if ($helo_name ne "" && $helo_site eq "") {
X      $header_analysis .=
X	  "${bullet}HELO name \"$helo_name\" is not a valid host name.\n\n";
X      print "  do_received: queer helo_name $helo_name\"\n" if $verbose;
X      }
X    elsif (&is_exempt($helo_name)) {
X      $result = $peer_site if $peer_site ne "";  # end of the road
X      last NEXT_HEADER;
X      }
X    elsif ($helo_name ne "" && $helo_name ne $peer_name) { # analyze helo_name
X      # Does the helo_name matches the peer_name?
X      if ($peer_site ne "" && $helo_site ne $peer_site) {
X	$header_analysis .=
X	  "${bullet}\"Received:\" header's HELO name \"$helo_name\" significantly\n";
X	$header_analysis .= "differs from peer_name \"$peer_name\".\n\n";
X	print "  do_received: helo $helo_name != peer $peer_name\n" if $verbose;
X        $result = $peer_site;  # end of the road
X	last NEXT_HEADER;
X	}
X      } # analyze helo_name
X
X    # Attempt to match the name of this host with the by_name of the next header
X    if ($helo_name ne "" &&
X	$i != $#all_headers) { # not oldest header, verification possible
X      # Attempt to match the helo_name with the by_name of the next header
X      $probe = &by_name($all_headers[$i + 1]);
X      $probe2 = &find_site($probe);
X      if ($probe2 eq "") {
X	print
X	    "adcomplain: unable to confirm $helo_name against origination.\n";
X	}
X      elsif ($helo_site ne "" && $probe2 ne $helo_site) {
X	$header_analysis .=
X	   "${bullet}HELO name \"$helo_name\" does not match prior header's\n";
X	$header_analysis .= "by-name \"$probe\"\n\n";
X	print
X	    "do_received: helo $helo_name does not match next by_name $probe\n"
X	    if $verbose;
X	# HELO name is a little queer, so tolerate this, with a comment.
X	}
X      elsif ($peer_site ne "" && $probe2 ne $peer_site) {
X	$header_analysis .=
X	   "${bullet}Peer name \"$peer_name\" does not match prior header's\n";
X	$header_analysis .= "by-name name \"$probe\"\n\n";
X	print
X	    "do_received: peer $peer_name does not match by_name $probe\n"
X	    if $verbose;
X	$result = $peer_site;
X	last NEXT_HEADER;	# This is serious!
X	}
X      } # not oldest header
X
X    # Check for spam insertion that created a Message-Id
X    if ($result ne "" && $result eq $message_site &&
X	$peer_site ne "" && $peer_site ne $message_site) {
X      # No valid message has a Message-Id created on it mid-stream.  If we
X      # get here, we have the spam insertion.  Let the victimized postmaster
X      # be held accountable.
X      $header_analysis .=
X	  "${bullet}Message-Id site \"$message_site\" is not at the start"
X		. " of the chain of Received: headers.\n\n";
X      print 
X	"do_received: Message-Id site \"$message_site\" found.\n" if $verbose;
X      $result = $peer_site if $peer_site ne "";
X      last NEXT_HEADER;
X      }
X
X    # $peer_name is definitely the way to go:
X    if ($peer_name ne "") {
X      $result = $peer_site;
X      next NEXT_HEADER;
X      }
X
X    # no reverse address.  Could be bogus, DNS transient oddness, or
X    # simply that we are behind a firewall.
X
X    # Plan B: use the by-name
X    last NEXT_HEADER if &is_exempt($by_name);
X    if ($by_name ne "") {
X      $result = $by_name;
X      next NEXT_HEADER;
X      }
X
X    # Go for the helo name (yuccch)
X    next NEXT_HEADER if $helo_name eq "";
X    last NEXT_HEADER if &is_exempt($helo_name);
X
X    print "do_received: relying on helo_name \"$helo_name\"\n" if $verbose;
X    $result = $helo_name;
X    } # NEXT_HEADER
X
X  return "" if $result eq "";
X  $result = "" if &home_domain($result);
X  if ($result ne "") {
X    &register_host("Received:", $result);
X    print "do_received: result is \"$result\"\n";
X    }
X
X  if ($result ne "" && $message_host ne "") {
X    $probe = &find_site($result);
X    if ($message_site ne $probe) {
X      $header_analysis .=
X	  "${bullet}Site in \"Message-Id:\" \"$message_site\" does not match\n";
X      $header_analysis .=
X	  "\"Received:\" origin \"$result\".\n\n";
X      print "  do_received: Message-Id site $message_site != result $result\n"
X	  if $verbose;
X      }
X    }
X
X  return $result;
X  }
X
#-----------------------------------------------
# The following headers are scanned, in order, to determine the poster:
#   NNTP-Posting-User:
#   Return-Path:
#   Reply-To:
#   From:
#
# A poster's address be of the form user@domain, where domain is
# a legal domain name.  The domain is rejected if it matches our domain.
#
# If the address is of form "user,id <xxx@site>", the
# message will be addressed to xxx@site.
# If the address is of form "Name <address>", set to "address".
# If the address is of form "(address)", set to "address".
# If the address is of form "address(Name)", set to "address".
# Remove extra words, in case header is of form "address (Name)"
X
sub find_poster {
X  local ($this, $junk, $junkhost, $result);
X  local (@headers, @search_patterns);
X
X  @headers = ("NNTP-Posting-User:", "Return-Path:", "Reply-To:", "From:");
X  @search_patterns = ( '.*NNTP-Posting-User: ',
X      '^Return-Path:', '^Reply-To:', '^From:');
X  $result = "";
X  for (@search_patterns) {
X    $this = $headers[0];
X    shift @headers;
X    $junk = &extract_header($_); 
X    next if $junk eq "";
X
X    # Validate the name
X    $junk =~ s/[^<]*<([^>]*)>.*/$1/;		# remove angle brackets
X    $junk =~ s/([^(\s]*)\s*\([^)]*\)/$1/;	# remove parenthesized name
X    ($junkhost = $junk) =~ s/.*@(.*)/$1/;
X    $junkhost =~ s/([^\s]*) *\(.*\)/$1/;	# remove proper name
X    $junkhost = &good_hostname($junkhost, 0);
X    next if $junkhost eq "";
X    $result = $junk if $result eq "";	# take first available
X    &register_host($this, $junkhost);
X    print "find_poster: found '$this' host $junk\n" if $verbose;
X    }
X  if ($result !~ /.*,.*/) {
X    # remove angle brackets from poster's name
X    $result =~ s/.*<(.*)>.*/$1/;
X    }
X  if ($result eq "") {
X    print "\nadcomplain: WARNING: cannot determine poster's address.\n\n";
X    $result = "";
X    }
X  else {
X    print "find_poster: poster is '$result'\n" if $verbose;
X    }
X  return $result;
X  }
X
#-----------------------------------------------
# Analyze the "Path:" header, return best possible host
# Basically, we're looking for the oldest (believable) host in the path.
# I used to process the path from left-to-right, with the idea that I
# could stop before the first unconfirmable host.  In practice, it seems
# to be better to just go from the right and stop with the first believable
# one (though I still have reservations about that).
sub do_path {
X  local ($path, $result, $chunk, $junk);
X  local (@chunks);
X
X  $path = &extract_header("^Path:");
X  return "" if $path eq "";
X  @chunks = reverse(split(/!/, $path));
X
X  foreach $chunk (@chunks) {
X    $chunk = &addrToName($chunk) if &is_inet_addr($chunk);
X    $chunk = &good_hostname($chunk, 1);
X    # $chunk = &good_hostname($chunk, 0);	# don't require host to exist.
X    next if $chunk eq "";
X    next if &is_exempt($chunk);
X    $result = $chunk;
X    last;
X    }
X
X  if ($result ne "") {
X    print "do_path: Path origin is $result\n" if $verbose;
X    &register_host("Path:", $result);
X    return $result;
X    }
X  return "";
X  }
X
#-----------------------------------------------
# Examine and return a hostname based on given header
sub try_host {
X  local($pat, $name) = @_;
X  local($junk, $junk2);
X
X  $junk = &extract_header($pat);
X  return "" if $junk eq "";
X  print "try_host: \'$name\' is $junk\n" if $verbose;
X  if (&is_inet_addr($junk) && !$dont_resolve) {
X    $junk2 = &addrToName($junk);
X    $junk = $junk2;
X    }
X  else {
X    $junk = &good_hostname($junk, 0);
X    }
X  return "" if $junk eq "";
X  return "" if &home_domain($junk);
X  &register_host($name, $junk);
X  return $junk;
}
X
#-----------------------------------------------
# I've seen these headers and I want to check for them:
# X-Authentication-Warning: quick.t-1net.com: b142.ecom.net [207.13.225.142] didn't use HELO protocol
#X-Authentication-Warning: communique-tech.co.uk: 
#	Host 1Cust40.max15.los-angeles.ca.ms.uu.net [153.34.77.168] claimed 
#	to be hotmail.com
# X-Authentication-Warning: gatekeeper.smltd.com: 
#	mail set sender to <[email-masked]> using -f
# X-Authentication-Warning: ns.internetmedia.net: 
#	weginc owned process doing -bs
sub do_auth_warning {
X  local ($junk, $junk_site, $name_site);
X  local ($name, $inet_addr, $result);
X
X  $junk = &extract_header("X-Authentication-Warning:");
X  return "" if $junk eq "";
X
X  $inet_addr = "";
X  if ($junk =~ /didn't use HELO protocol/) {
X    $junk =~ s/^[^:]+: (.*) didn't use HELO protocol/$1/i;
X    $name = $inet_addr = $junk;
X
X    $name =~ s/^\s*([\w\.-]+)\s*.*/$1/;
X    $inet_addr =~ s/^.*\[(.*)\].*/$1/;	# remove bracketed name
X    $name =~ s/^(.*)\[.*\].*/$1/;	# remove bracketed name
X    }
X  elsif ($junk =~ /claimed to be/) {
#	Host 1Cust40.max15.los-angeles.ca.ms.uu.net [153.34.77.168] claimed 
# or:
#	oncidium: Host x.y..net claimed to be usinet cziegle
X
X    ($name = $junk) =~ s/.*Host\s+(\S+).*/$1/;
X
X    ($inet_addr = $junk) =~ s/.*\[([^]]*)\].*/$1/
X	if $junk =~ /\[\d+\.\d+\.\d+\.\d+\]/;
X    }
X  elsif ($junk =~ / set sender to /) {
X    # nothing else warranted
X    $name = "";
X    }
X  elsif ($junk =~ / owned process doing /) {
X    # is this useful?  For now, do nothing.
X    $name = "";
X    }
X  else {
X    print "adcomplain: new X-Authentication-Warning header\n";
X    print "  Please send this test case to the adcomplain authors.\n";
X    return "";
X    }
X
X  $result = $name;
X  if ($inet_addr ne "" && !$dont_resolve) {
X    $junk = &addrToName($inet_addr);
X    if ($name ne "" && $junk eq "") {
X      $header_analysis .= "${bullet}Unable to confirm $name is $inet_addr.\n\n";
X      }
X    elsif ($name ne "" && !&home_domain($name)) {
X      $result = $junk;
X      $junk_site = &find_site($junk);
X      $name_site = &find_site($name);
X      if ($name_site ne $junk_site) {
X	$header_analysis .= "${bullet}\"X-Authentication-Warning:\" header says that peer is \"$name\",\n";
X	$header_analysis .= "but address $inet_addr resolves to $junk.\n\n";
X	}
X      }
X    } # $inet_addr ne ""
X  print "do_auth_warning: found \"$result\"\n" if $verbose;
X  &register_host("X-Authentication-Warning:", $result) if $result ne "";
X  return $result;
X  }
X
X
#-----------------------------------------------
# The following order of preference is used to determine the originating host:
#   the host in the "NNTP-Posting-Host:" header;
#   the host in the "Path:" header;
#   the host in the "Received:" headers;
#   the host in the "Message-Id:" header;
#   the host in the "Sender:" header; else
#   the host of the poster
#
# In any event, recognize and reduce hostnames of the form
#   <id@host>
#   (id@host)
#   host(inet_addr)  [reduce to "host"]
# Make sure to remove extra words, i.e., "address (Name)"
# A hostname must have valid syntax and not match the current domain.
X
sub find_host {
X  local ($message_host, $junk, $this, $result);
X
X  $postmaster = "";
X  $complain_to = "";
X  $result = "";
X
X  # NNTP-Posting-Host: is first choice.
X  $junk = &try_host(".*NNTP-Posting-Host:", "NNTP-Posting-Host:");
X  $junk = "" if &home_domain($junk);
X  $result = $junk if $result eq "" && $junk ne "";
X
X  $junk = &do_path;	# Path: header is the next most reliable.
X  $junk = "" if &home_domain($junk);
X  $result = $junk if $result eq "" && $junk ne "";
X
X  # This is used in do_received, so figure it out now.
X  $message_host = &try_host("^Message-Id:", "Message-Id:");
X
X  $junk = &do_auth_warning();
X  $junk = "" if &home_domain($junk);
X  $result = $junk if $result eq "" && $junk ne "";
X
X  $junk = &do_received($message_host);	# ...then, try Received:
X  $junk = "" if &home_domain($junk);
X  $result = $junk if $result eq "" && $junk ne "";
X  print "adcomplain: WARNING: cannot use \"Received:\" headers.\n"
X      if $junk eq "" && $mailmode;
X
X  # Now curry any remaining possibilities....
X  $result = $message_host if $result eq "" && $message_host ne "";
X
X  $junk = &try_host("^Sender:", "Sender:");
X  $result = $junk if $result eq "" && $junk ne "";
X
X  if ($poster ne "") {
X    print "find_host: trying poster \"$poster\"...\n" if $verbose;
X    $junk = &good_hostname($poster, 0);
X    &register_host("Poster:", $junk) if $junk ne "";
X    $junk = "" if &home_domain($junk);
X    $result = $junk if $result eq "" && $junk ne "";
X    }
X
X  if ($result eq "") {
X    print "\nadcomplain: WARNING: no valid host name was found\n";
X    }
X  else {
X    print "find_host: host is '$result'\n" if $verbose;
X    }
X  return $result;
X  }
X
#-----------------------------------------------
# Revise the site name based on some exceptions and known aliases.
sub revise_site {
X  local ($site) = @_;
X  local ($redirect, $junk);
X
X  $redirect = "";
X  ($junk = $site) =~ s/(\W)/\\$1/g;	# remove special characters
X  for (keys(%rematch_aliases)) {
X    if ($_ =~ /$junk/) {
X      $redirect = $_;
X      last;
X      }
X    }
X  if ($redirect ne "") {
X    $junk = $rematch_aliases{$redirect};
X    print "revise_site: $site redirected: '$junk'\n" if $verbose;
X    $redirect = &extract_header($junk);
X    }
X  if ($redirect ne "") {
X    $site = &find_site($redirect);
X    print "revise_site:  '$redirect' is '$site'\n" if $site ne "" && $verbose;
X    }
X  return $site;
X  }
X
#-----------------------------------------------
# Get all of the sites feasible from the Complain-To headers
sub do_complain_to {
X  local ($junk, $junk2);
X  local (@list, $i, $j, $each);
X
X  $complain_to = "";
X  for ("Complain-To", "Report-Abuse-To", "X-Complaints-To"
X	) { # alternatives
X    $junk = &extract_header("^.*$_:");
X    next if  $junk eq "";
X    print "do_complain_to: $_: is $junk\n" if $verbose;
X    @list = split(/[\s,]+/, $junk);
X    for ($i = 0; $i < @list; $i ++) { # process list
X      $junk2 = &good_hostname($list[$i], 0);
X      if ($junk2 ne "") { # good hostname
X	if ($i == 0 && $#list == 0) {
X	  &register_host("$_:", $junk2);
X	  }
X	else {
X	  $j = $i + 1;
X	  &register_host("$_-$j:", $junk2);
X	  }
X	$complain_to = $junk if $complain_to eq "";
X	} # good hostname
X      } # process list
X    } # alternatives
X
X  if ($complain_to eq "") {
X    if ($site eq "") {
X      print "\nadcomplain: WARNING: no valid complain_to address was found\n";
X      }
X    else {
X      print "do_complain_to: setting complain_to to site name.\n" if $verbose;
X      $complain_to = "$site\@abuse.net";
X      }
X    }
X  else {
X    if ($site eq "") {
X      @list = split(/[\s,]+/, $complain_to);
X      $site = &good_hostname($list[0], 0);
X      print "do_complain_to: setting site to $site.\n" if $verbose;
X      }
X    }
X
X  $complain_to =~ s/,/ /g;     # turn all commas to spaces
X  $complain_to =~ s/\s+/, /g;  # and then back to commas
X  print "do_complain_to: complain_to is '$complain_to'\n"
X      if $complain_to ne "" && $verbose;
X  }
X
#-----------------------------------------------
# Top-level routine that reads and extracts the headers from the message
sub parse_headers {
X  local ($this);
X
X  $subject = &extract_header("^Subject:");
X  if ($subject eq "") {
X    print "\nadcomplain: WARNING: subject not found\n\n";
X    }
X  else {
X    print "subject is '$subject'\n" if $verbose;
X    }
X
X  if ($mailmode) {
X    # mail mode forced
X    if ($ARGV[0] ne "") {
X      print 
X	  "\nadcomplain: ERROR choose at most one of -m and a newsgroup name\n";
X      exit 1;
X      }
X    $newsgroup = "";
X    print "This is a mail message.\n" if $verbose;
X    }
X  else {
X    $this = &extract_header("^Path:");
X    $newsgroup = &extract_header("^Newsgroups:");
X    if (defined($ARGV[0]) && $ARGV[0] ne "") {
X      $newsgroup = $ARGV[0];
X      print "newsgroup is from command line argument.\n" if $verbose;
X      }
X    if ($newsgroup eq "") {
X      $mailmode = 1;
X      print "Inferring that this is a mail message.\n" if $verbose;
X      }
X    else {
X      $newsgroup =~ s/,/, /g;
X      if ($newsgroup =~ /^[^,]+,[^,]+$/) {
X	$newsgroup =~ s/(.*), ([^,]*)$/$1 or $2/g;
X	}
X      else {
X	$newsgroup =~ s/(.*), ([^,]*)$/$1, or $2/g;
X	}
X      print "newsgroup is '$newsgroup'\n" if $verbose;
X      }
X    }
X
X  $poster = &find_poster;
X  $host = &find_host;
X
X  $site = &find_site($host);
X  if ($site ne "") {
X    print "site is '$site'\n" if $verbose;
X
X    $site = &revise_site($site);
X    $postmaster = "postmaster\@$site";
X    print "postmaster is '$postmaster'\n" if $verbose;
X    }
X
X  &do_complain_to;
X
X  $site = "INSERT_SITE_NAME_HERE" if $site eq "";
} # parse_headers
X
#-----------------------------------------------
# return 1 if site is in list of exceptions
sub is_exception_site {
X  local($site) = @_;
X
X  #for (@site_exceptions) { return 1 if $site =~ /$_$/; }
X  #return 0;
X
X  local ($u, $l, $i, $pat);
X
X  return 0 if $site eq "";
X  $site =~ y/A-Z/a-z/;		# canonicalize to lower case
X  $l = 0;
X  $u = $#site_exceptions;
X  for (;;) {
X    return 0 if $u < $l;
X    $i = int(($l + $u) / 2);
X
X    # End if a pattern match is successful
X    $pat = $site_exceptions[$i];
X    $pat =~ s/(\W)/\\$1/g;		# remove special characters
X    $pat = "$pat\$";
X    if ($site =~ /$pat/i) {
X      print "found exception site \"$site\".\n" if $verbose;
X      return 1;
X      }
X
X    if ($site lt $site_exceptions[$i]) {
X      $u = $i - 1;
X      }
X    elsif ($site gt $site_exceptions[$i]) {
X      $l = $i + 1;
X      }
X    else {
X      die "internal error in is_exception_site(\"$site\")";
X      }
X    }
X  }
X
#-----------------------------------------------
# Return "" if the given address has a valid suffix, else the invalid
# suffix.
sub is_valid_domain {
X  local($host) = @_;
X  local($junk);
X
X  ($junk = $host) =~ s/.*\.([^.\s]*)\s*/$1/;	# get that tail
X  # for (@valid_domains) { return "" if $junk eq $_; }
X  # return $junk;
X
X  local ($u, $l, $i, $pat);
X
X  return "." if $junk eq "";	# empty suffix...
X  $junk =~ y/A-Z/a-z/;		# canonicalize to lower case
X  $l = 0;
X  $u = $#valid_domains;
X  for (;;) {
X    return ".$junk" if $u < $l;
X    $i = int(($l + $u) / 2);
X
X    # End if a pattern match is successful
X    $pat = $valid_domains[$i];
X    $pat =~ y/A-Z/a-z/;		# canonicalize to lower case
X    if ($junk eq $pat) {
X      # print "found valid domain \"$junk\".\n" if $verbose;
X      return "";
X      }
X
X    if ($junk lt $pat) {
X      $u = $i - 1;
X      }
X    elsif ($junk gt $pat) {
X      $l = $i + 1;
X      }
X    else {
X      die "internal error in is_valid_domain(\"$host\")";
X      }
X    }
X  }
X
#-----------------------------------------------
# returns 0 or else a cleaned up hostname
sub good_hostname {
X  local ($host, $must_be_real) = @_;
X  local ($junk, $each);
X
X  # clean up the hostname
X  $host =~ s/.*<(.*)>.*/$1/;	# remove angle brackets, if any
X  $host =~ s/.*\((.*)\).*/$1/;	# remove parens, if any
X  $host =~ s/\(.*\)//;		# remove parenthesized text
X  $host =~ s/.*@(.*)/$1/;
X  $host =~ y/A-Z/a-z/;		# lowercase
X
X  # print "good_hostname: $host $must_be_real\n";
X  # return "" if !($host =~ /^[A-Z]/i);  # hostname must begin with a letter
X  return "" unless $host =~ /.*\..*/;    # hostname must have at least one dot
X  return "" if &is_inet_addr($host);
X
X  # check for illegal characters
X  for (
X	# from rfc822
X	"\\(", "\\)", "<", ">", "@", ",", ";", ":", "\\\\", "\\\"",
X	"\\[", "\\]", # ".",
X	# questionable ones added by Jason
X	"#", "\\^", "\\&", "\\*", "=", "\\+", "\\|", "\\?", "`", "~", "\\/") {
X    if ($host =~ /$_/) {
X      print "good_hostname: \"$host\" has illegal char \"$_\".\n" if $verbose;
X      return "";
X      }
X    }
X
X  # Look at the irregular site names first.
X  return $host if &is_exception_site($host);
X
X  $junk = &is_valid_domain($host);
X  if ($junk ne "") {
X    print "good_hostname: \"$host\" has invalid suffix \"$junk\"\n" if $verbose;
X    return "";
X    }
X
X  if ($must_be_real && !&home_domain($host)) {
X    $host = "" if !&real_host($host);
X    }
X
X  return $host;
X  }
X
#-----------------------------------------------
# Reduce a hostname to a site; i.e.:
#   If last field of $host >= 3 characters long (e.g., "com", "edu"),
#     set $site to last two fields (e.g., "company.com" or "college.edu")
#     unless three field version found in exceptions list,
#   otherwise, set $site to last three fields (e.g., "canadian.site.ca")
#     unless two field version found in exceptions list.
sub find_site {
X  local ($host) = @_;
X  local ($site, $site2, $site3, $junk);
X
X  $host =~ s/<(.*)>/$1/;		# remove angle brackets
X  $host =~ s/[^@]*@(\S*)\s*/$1/;	# extract domain-name part
X
X  ($site2 = $host) =~ s/.*\.(.*\..*)/$1/;
X  ($site3 = $host) =~ s/.*\.(.*\..*\..*)/$1/;
X  ($junk = $host) =~ s/.*\.(.*)/$1/;
X  if (length($junk) >= 3) {
X    ($junk = $site3) =~ s/(\W)/\\$1/g;	# remove special characters
X
X    if (grep(/^$junk$/, @site_exceptions) != 0) {
X      $site = $site3;
X      }
X    else {
X      $site = $site2;
X      }
X    }
X  else {
X    ($junk = $site2) =~ s/(\W)/\\$1/g;	# remove special characters
X
X    if (grep(/^$junk$/, @site_exceptions) != 0) {
X      $site = $site2;
X      }
X    else {
X      $site = $site3;
X      }
X    }
X  $site =~ y/A-Z/a-z/;		# lowercase
X  return $site;
X  }
X
#-----------------------------------------------
# Add the given site to the list of sites
sub register_host {
X  local ($key, $value) = @_;
X
X  $available_hosts{$key} = &find_site($value);
X  }
X
#-----------------------------------------------
# Analyze the list of available hosts.  Generate diagnostic if 
# headers are inconsistent.
sub check_hosts {
X  local ($firstkey, $secondkey, $firstval, $secondval);
X  local (@order) = ("Path:", "Received:", # "NNTP-Posting-Host:",
X	# "Message-Id:", "Sender:", "NNTP-Posting-User:",
X	# "Return-Path", "Reply-To:", "From:"
X	);
X
X  foreach $firstkey (@order) {
X    $firstval = $available_hosts{$firstkey};
X    next if !defined($firstval) || $firstval eq "";
X    foreach $secondkey (@order) {
X      $secondval = $available_hosts{$secondkey};
X      next if !defined($secondval) || $secondval eq "";
X      if ($firstval ne $secondval) {
X	$header_analysis .= "${bullet}Site implied by \"$firstkey\" header ($firstval)";
X	$header_analysis .= " is not consistent with site implied by";
X	$header_analysis .= " \"$secondkey\" header ($secondval).\n\n";
X	return;
X	}
X      }
X    }
X  }
X
#-----------------------------------------------
# Return 1 if the argument refers to the home domain
sub home_domain {
X  local ($probe) = @_;
X  local ($each);
X
X  for (@mydomains) {
X    return 1 if $probe =~ /$_$/i;
X    }
X  return 0;
X  }
X
#-----------------------------------------------
# perl code by Denis N. Antonioli <[email-masked]>
# original C code by David Laur, Rainsound, 9/96,
# posted in comp.sys.sgi.apps <[email-masked]>
X
# original comments:
# attempt to construct a fully-qualified hostname
# not likely to work on multi-homed or multi-addressed machines
sub fqdn_name {
X  local($in) = @_;
X  local($result) = $in;
X  local($name, $aliases, $addrtype, $length, @addrs);
X  local($nd, $cd);
X
X  # Jason's original hack:  a reverse-DNS lookup often yields
X  # a better (FQDN) name.
X  ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname($in);
X  $result = $name if defined($name) && $name ne "";
X
X  local($nd) = ($in =~ tr/././);
X  local($cd) = ($name =~ tr/././);
X  if ($cd > $nd) { # authorized name is longer; take it.
X    $nd = $cd;
X    $result = $name;
X    }
X  # Pick the alias with the _most_ dots
X  local($alias);
X  foreach $alias (split(' ', $aliases)) {
X    $cd = ($alias =~ tr/././);
X    if ($cd > $nd) {
X      $result = $alias;
X      $nd = $cd;
X      }
X    }
X
X  # If our name has two or more dots, we're done!
X  return $result if $nd >= 2;
X
X  # Need to add the domain name to the host name.
X  # ADCOMPLAIN_MDOMAIN env variable?
X  local($domain) = $ENV{'ADCOMPLAIN_MDOMAIN'} || '';
X  local($etc);
X
X  if ($os_kind eq "unix") {
X    $etc = "/etc";
X    }
X  elsif ($os_kind eq "os2") {
X    $etc = $ENV{"ETC"};
X    }
X  elsif ($os_kind eq "winnt" || $os_kind eq "win32") {
X    $etc = "";	# I might be able to do better here....
X    }
X  else {
X    die "does $os_kind have an etc directory?";
X    }
X
X  # Try /etc/resolv.conf.  This will work on a surprising number of
X  # machines!
X  if ($domain eq '' && $etc ne "") {
X    if (open(FD, "$etc/resolv.conf")) {
X      while (<FD>) {
X	if (/^domain\s+(\S+)\s*$/) {
X	  $domain = $1;
X	  last;
X	  }
X	# N.B. -- it is against BIND rules to have both 'domain' and 'search'
X	# directives.
X	if (/^search\s+(\S+)\s*$/) {
X	  $domain = $1;
X	  last;
X	  }
X	}
X      close(FD);
X      }
X    }
X
X  # Try /etc/defaultdomain.  This is much more questionable; this returns the
X  # name of the NIS domain, which may or may not have anything to do with the
X  # mail domain.  On the other hand, if we get this far, we're pretty stuck,
X  # so we have nothing to lose....
X  if ($domain eq '' && $etc ne "") {
X    if (open(FD, "$etc/defaultdomain")) {
X      $domain = <FD>;
X      close(FD);
X      }
X    }
X  $domain =~ s/^\s*(\S+)\s*/$1/g unless $domain eq '';
X  $result .= '.' . $domain unless $domain eq '';
X  return $result;
X  }
X
#-----------------------------------------------
# Initialize the constants and lists.  Also sets $os_kind, because it's
# needed quite early.
sub get_constants_and_environment {
X  local ($dollar_control_O);
X
X  # control characters don't survive shar very well!
X  $dollar_control_O = "\$dollar_control_O = \$\017;";
X  eval $dollar_control_O;	# will be empty in perl4
X
X  # Start by figuring out which OS we're on.  Fortunately, we don't
X  # need to distinguish different Unixes (that would be the problem if
X  # we used $^O, which is only in perl5 anyway).
X  if (defined($ENV{"OS"}) && $ENV{"OS"} eq "Windows_NT") {
X    # Always set by the operating system
X    $os_kind = "winnt";
X    }
X  elsif (defined($ENV{"OS2_SHELL"}) && $ENV{"OS2_SHELL"} ne "") {
X    # Always set by the operating system
X    $os_kind = "os2";
X    }
X  elsif (defined($dollar_control_O) && $dollar_control_O eq "MSWin32") {
X    # Windows 95.  Same perl as above, but %OS% will not be set.
X    $os_kind = "win32";
X    }
X  elsif (-x "/bin/uname") { # SVr4
X    $os_kind = "unix";
X    }
X  elsif (-x "/usr/bin/uname") { # BSD
X    $os_kind = "unix";
X    }
X  else {
X    die "what is your os?";
X    }
X
X  # Fix AF_INET and SOCK_STREAM
X  if ($os_kind eq "unix") {
X    # an apology here: the Unix perl4's at gemstone.com were installed _many_
X    # years ago by someone who _really_ didn't know what he was doing.
X    # The host-specific libraries just aren't, and reinstalling
X    # _all_ of the perls for _all_ of the architectures is not worth my time.
X
X    # So, what we'll do is make sure the values are properly set for my
X    # Greatest Hits list of architectures.
X
X    $junk = -x "/bin/uname" ? `/bin/uname -rs` : `/usr/bin/uname -rs`;
X
X    if ($junk =~ /^SunOS 5.*/		# Solaris
X       || $junk =~ /^IRIX*/i		# IRIX
X	) {
X      # solaris and irix just _had_ to be different
X      eval 'sub AF_INET { return 2; }';
X      eval 'sub SOCK_STREAM { return 2; }';
X      }
X    elsif ($junk =~ /^HP-UX.*/i  	# HP-UX
X	|| $junk =~ /^AIX.*/i 		# AIX
X	|| $junk =~ /^SunOS 4.*/i 	# SunOS
X        || $junk =~ /^OSF1.*/i 		# OSF1
X	|| $junk =~ /^Linux*/i          # Linux
X	) {
X      # the rest of the world, it seems
X      eval 'sub AF_INET { return 2; }';
X      eval 'sub SOCK_STREAM { return 1; }';
X      }
X    else {
X      # Sorry, can't guess.  Your perl better be properly installed.
X      require "sys/socket.ph";
X      }
X    }
X  elsif ($os_kind eq "winnt" || $os_kind eq "win32" || $os_kind eq "os2") {
X    # from winsock.h
X    eval 'sub AF_INET { return 2; }';
X    eval 'sub SOCK_STREAM { return 1; }';
X    }
X  else {
X    die "cannot set AF_INET and SOCK_STREAM properly";
X    }
X
X  @monthNames = (
X	"Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep",
X	"Oct", "Nov", "Dec");
X  @wdayNames = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat");
X
X  # Now that I've discovered IEEE 1003.1, I just want to cry.  But here's
X  # a modest attempt at time zones.  Complain away if you think it's wrong....
X  %timezones = (
X    "-1200", "IDLW, M",		# International Date Line West
X    "-1100", "NT, SST, L",	# Nome, Samoa
X    "-1000", "HST, AHST, CAT, HAST, K", # Hawaii Standard
X    "-0900", "YST, HDT, AKADT, HADT, I", # Yukon Standard
X    "-0800", "AKDT, PST, YDT, H", # Pacific Standard, Yukon Daylight
X    "-0700", "MST, PDT, G",	# Mountain Standard, Pacific Daylight
X    "-0600", "CST, MDT, F", 	# Central Standard, Mountain Daylight
X    "-0500", "EST, CDT, AST, E",# Eastern Standard, Central Daylight,
X				# Brazil/Acre
X    "-0400", "AST, EDT, WST, ADT, CST, D",
X				# Atlantic Standard, Eastern Daylight,
X				# Brazil Western, Brazil/Acre, Chile Standard
X    "-0330", "NST, CDT",	# Newfoundland Standard, Chile Daylight
X    "-0300", "ADT, EST, WDT, C",# Atlantic Daylight, Brazil
X    "-0230", "NDT",		# Newfoundland Daylight
X    "-0200", "EDT, FST, AT, B",	# Brazil Eastern Daylight, Brazil/deNoronha,
X				# Azores
X    "-0100", "FDT, WAT, A",	# Brazil/deNoronha, West Africa
X    "0000", "GMT, UTC, WET, UT, Z", # Greenwich Mean,
X				# Universal Time, Western Europe
X    "0100", "BST, WET DST, MET, CET, FWT, MEWT, SWT, N", 
X				# Western Daylight, Middle Europe
X    "0200", "EET, MET DST, METDST, MEST, MESZ, SST, FST, O, SAT, CEST, IST",
X				# Middle Europe Daylight
X				# Swedish Summer Time, French Summer Time,
X				# South African Time, Israel
X    "0300", "IDT, EET DST, MSK, BT, P", # Israel Daylight, Turkey, Moscow
X    "0330", "IT",		# Iran?
X    "0400", "MSD, ZP4, Q",
X    "0500", "ZP5, R",		# USSR Zone 4
X    "0530", "IST",		# India Standard Time
X    "0600", "ZP6, S",		# USSR Zone 5
X    "0630", "NST",		# North Sumatra?
X    "0700", "WAST, T",		# Western Austrailia
X    "0730", "JT",		# Java?
X    "0800", "CST, SST, SGT, HKT, WST, CCT, WADT, U, MYT", # China & Taiwan,
X				# Singapore Standard, Hong Kong, West Australia,
X				# Maylasia
X    "0900", "KST, CDT, JST, V",	# Korea, China, Japan
X    "0930", "CST, CAST",	# North Australia, South Australia
X    "1000", "KDT, EAST, EST, GST, W",
X				# Korea,  Eastern Australia, Guam
X    "1100", "EDT, EADT, X",
X    "1200", "NZST, IDLE, NZT, Y",# New Zealand, International Date Line East
X    "1300", "NZDT",		# New Zealand Daylight Time?
X    );
X
X  # Valid country domains
X  @valid_domains = (
X      # Countries
X      "uk",  # Non-standard but frequently used.
X      "su",  # Non-standard but frequently used.
X      "af", "al", "dz", "as", "ad", "ao", "ai", "aq", "ag", "ar", "am", "aw",
X      "au", "at", "az", "bs", "bh", "bd", "bb", "by", "be", "bz", "bj", "bm",
X      "bt", "bo", "ba", "bw", "bv", "br", "io", "bn", "bg", "bf", "bi", "kh",
X      "cm", "ca", "cv", "ky", "cf", "td", "cl", "cn", "cx", "cc", "co", "km",
X      "cg", "ck", "cr", "ci", "hr", "cu", "cy", "cz", "dk", "dj", "dm", "do",
X      "tp", "ec", "eg", "sv", "gq", "er", "ee", "et", "fk", "fo", "fj", "fi",
X      "fr", "fx", "gf", "pf", "tf", "ga", "gm", "ge", "de", "gh", "gi", "gr",
X      "gl", "gd", "gp", "gu", "gt", "gn", "gw", "gy", "ht", "hm", "hn", "hk",
X      "hu", "is", "in", "id", "ir", "iq", "ie", "il", "it", "jm", "jp", "jo",
X      "kz", "ke", "ki", "kp", "kr", "kw", "kg", "la", "lv", "lb", "ls", "lr",
X      "ly", "li", "lt", "lu", "mo", "mk", "mg", "mw", "my", "mv", "ml", "mt",
X      "mh", "mq", "mr", "mu", "yt", "mx", "fm", "md", "mc", "mn", "ms", "ma",
X      "mz", "mm", "na", "nr", "np", "nl", "an", "nc", "nz", "ni", "ne", "ng",
X      "nu", "nf", "mp", "no", "om", "pk", "pw", "pa", "pg", "py", "pe", "ph",
X      "pn", "pl", "pt", "pr", "qa", "re", "ro", "ru", "rw", "kn", "lc", "vc",
X      "ws", "sm", "st", "sa", "sn", "sc", "sl", "sg", "sk", "si", "sb", "so",
X      "za", "gs", "es", "lk", "sh", "pm", "sd", "sr", "sj", "sz", "se", "ch",
X      "sy", "tw", "tj", "tz", "th", "tg", "tk", "to", "tt", "tn", "tr", "tm",
X      "tc", "tv", "ug", "ua", "ae", "gb", "us", "um", "uy", "uz", "vu", "va",
X      "ve", "vn", "vg", "vi", "wf", "eh", "ye", "yu", "zr", "zm", "zw",
X
X      # Organization Domains
X      "com", "edu", "gov", "int", "mil", "net", "org",
X
X      # Following at http://www.edns.net/registries.htm
X      # unsanctioned but currently supported by a number of nameservers
X      "biz", "corp", "earth", "exp", "k12", "ltd", "lnx", "med", "nic", "npo", 
X      "per", "usa", "web", "xxx",
X
X      # Following at http://www.iahc.org/press-final.html, dated 4 Feb 97.
X      # Also want to hear more before accepting these....
X      # "arts", "firm", "info", "nom", "rec", "store", "web",
X      );
X  @valid_domains = sort @valid_domains;  # needed for bsearch to work
X
X  # mnemonics for $recipient
X  $complain_to_only = 1;
X  $poster_only = 2;
X  $poster_and_complain_to = 3;
X
X  # This is a simple way to match the first letter of an SMTP id with the
X  # expected hour of the day....
#  %smtp_chars = ( "A", "00", "B", "01", "C", "02", "D", "03", "E", "04",
#		  "F", "05", "G", "06", "H", "07", "I", "08", "J", "09",
#		  "K", "10", "L", "11", "M", "12", "N", "13", "O", "14",
#		  "P", "15", "Q", "16", "R", "17", "S", "18", "T", "19",
#		  "U", "20", "V", "21", "W", "22", "X", "23");
X
X  # Exceptions List
X  # Please mail additions and corrections to [email-masked].
X
X  # DESCRIPTION
X  # These are site names that don't follow the convention of two fields for
X  # names with three-letter suffixes (e.g., company.com) or three fields for
X  # names with two-letter suffixes (e.g., canadian.site.ca).
X
X  @site_exceptions = (
X	'ab.umd.edu',
X	'acc.ca',
X	'ada.se',
X	'adenet.es',
X	'ai.mit.edu',
X	'alameda-coe.k12.ca.us',
X	'algonet.se',
X	'austria.eu.net',
X	'aware.nl',
X	'banat-crisana.ro',
X	'bcm.tmc.edu',
X	'bctel.ca',
X	'berlingske.dk',
X	'bluewin.ch',
X	'bme.hu',
X	'bureau1.utcc.utoronto.ca',
X	'bureau2.utcc.utoronto.ca',
X	'bureau3.utcc.utoronto.ca',
X	'bureau4.utcc.utoronto.ca',
X	'bureau5.utcc.utoronto.ca',
X	'bureau6.utcc.utoronto.ca',
X	'bureau7.utcc.utoronto.ca',
X	'campus.mci.net',
X	'canit.se',
X	'casema.nl',
X	'casinos.at',
X	'c.4biz.net',
X	'.cc',
X	'ceta.es',
X	'chalmers.se',
X	'cisnews.cisnet.com',
X	'coast.to',
X	'columbus.rr.com',
X	'cs.umass.edu',
X	'ct.rr.com',
X	'cybernet.za',
X	'datanet.hu',
X	'demon.co.uk',
X	'dial-access.att.net',
X	'dial.pipex.com',
X	'digibel.be',
X	'direct.ca',
X	'dis.dk',
X	'easynet.de',
X	'econnect.ca',
X	'edcoe.k12.ca.us',
X	'egate.ca',
X	'elektrobit.fi',
X	'elp.rr.com',
X	'epfl.ch',
X	'escape.ca',
X	'eunet.be',
X	'eunet.ch',
X	'eunet.fi',
X	'expedia.msn.com',
X	'extrabit.fi',
X	'fastlane.ca',
X	'flashmail.cc',
X	'forfree.at',
X	'fun.ee',
X	'futurnet.es',
X	'germany.eu.net',
X	'get2net.dk',
X	'glo.be',
X	'glas.apc.org',
X	'glue.umd.edu',
X	'gmx.de',
X	'gnu.ai.mit.edu',
X	'greenhill.pvt.k12.tx.us',
X	'gregg.world-access.com',
X	'grolier.fr',
X	'gu.se',
X	'hawaii.rr.com',
X	'hl-technik.de',
X	'hol.fr',
X	'home.se',
X	'hungarnet.hu',
X	'hvu.nl',
X	'iaf.nl',
X	'ibernet.es',
X	'ican.ca',
X	'iif.hu',
X	'indigo.ie',
X	'inext.ro',
X	'innovplace.saskatoon.sk.ca',
X	'iol.ie',
X	'ireq.ca',
X	'isky.ca',
X	'istar.ca',
X	'iteso.mx',
X	'ivm.de',
X	'lakeheadu.ca',
X	'loki.silkspin.com',
X	'lserv.utcc.utoronto.ca',
X	'mail.icongrp.com',
X	'mail.memorystorage.com',
X	'maine.rr.com',
X	'med.wayne.edu',
X	'mediatech.de',
X	'messer.de',
X	'metronet.de',
X	'midsouth.rr.com',
X	'mpg.de',
X	'msfc.nasa.gov',
X	'nacamar.de',
X	'nemo.fi',
X	'netcom.ca',
X	'netinc.ca',
X	'netway.at',
X	'neuhaus.de',
X	'nordbayern.de',
X	'norgesnett.no',
X	'nstn.ca',
X	'.nu',
X	'nycap.rr.com',
X	'nym.alias.net',
X	'odn.de',
X	'on.the.net',
X	'online.no',
X	'oup.es',
X	'oupcan.mail.net',
X	'oupchile.cl',
X	'oxford.pl',
X	'oxford.satlink.net',
X	'oxford.spin.com.mx',
X	'pangea.ca',
X	'pi.se',
X	'pine.nl',
X	'ping.at',
X	'planet.eon.net',
X	'pluto.spearhead.net',
X	'pop.tc',
X	'psi.ca',
X	'postag.de',
X	'pubnet.sk',
X	'rba.ch',
X	'redestb.es',
X	'rmcs.cranfield.ac.uk',
X	'ruhr-uni-bochum.de',
X	'san.rr.com',
X	'schwaben.de',
X	'seicom.de',
X	'siemens.de',
X	'siemensnixdorf.de',
X	'sigov.si',
X	'silsoe.cranfield.ac.uk',
X	'sky.fr',
X	'smart.is',
X	'sn.no',
X	'snerpa.is',
X	'sni.de',
X	'sol.no',
X	'spectranet.ca',
X	'sprint.ca',
X	'sprintcanada.ca',
X	'.st',
X	'stack.nl',
X	'sun-denshi.co.jp',
X	'sunrise.it',
X	'sympatico.ca',
X	'sztaki.hu',
X	'tampabay.rr.com',
X	'tao.ca',
X	'tele2.dk',
X	'telegate.nl',
X	'telegate.se',
X	'teleglobe.ca',
X	'telepac.pt',
X	'terminal.cz',
X	'terranova.fi',
X	'tfi.be',
X	'tfi.de',
X	'tin.it',
X	'.tj',
X	'.to',
X	'tsqware.fr',
X	'twcny.rr.com',
X	'ualberta.ca',
X	'uk.uu.net',
X	'uni2.dk',
X	'uni-c.dk',
X	'unibe.ch',
X	'unicall.be',
X	'unik.no',
X	'uunet.ca',
X	'usask.ca',
X	'uvic.ca',
X	'varney.idbsu.edu',
X	'videotron.ca',
X	'vma.verio.net',
X	'wam.umd.edu',
X	'wanadoo.fr',
X	'windsor.igs.net',
X	'worldnet.att.net',
X	'worldnet.fr',
X	'worldonline.nl',
X	'wwonline.ca',
X	'wxs.nl',
X	'xs4all.nl',
X	);
X    @site_exceptions = sort @site_exceptions; # needed for bsearch to work
X
X    %rematch_aliases = (
X    'nonexistent.com',  'X-NNTP-Posting-Host:',
X    'nym.alias.net', 'Message-Id:',
X	);
X
# START EXEMPT LIST
$EXEMPT_LIST = <<'END';
*!3ER``+\>4`6P0``
END
# END EXEMPT LIST
X  $EXEMPT_LIST = unpack("u", $EXEMPT_LIST);
X  } # get_constants_and_environment
X
#-----------------------------------------------
# j-random initialization, including reading environment variables
# and initializing result data.
sub initialize {
X  local ($pat, $aliases, $addrtype, $length, @addrs);
X
X  # Determine the OS, set up networking constants, establish constant
X  # lists, such as legal mail domain suffixes.
X  &get_constants_and_environment();
X
X  $adcomplain_name = '$RCSfile: adcomplain.pl,v $';	# filled in by RCS
X  $pat = 'RCSfile:';				# have to fool rcs
X  $adcomplain_name =~ s/\$$pat (.*),v \$/$1/;
X  $adcomplain_revision = '$Revision: 3.52 $';	# filled in by RCS
X  $pat = 'Revision:';				# have to fool rcs
X  $adcomplain_revision =~ s/\$$pat (.*) \$/$1/;
X
X  # Determine the editor
X  $editor = $ENV{"VISUAL"};
X  $editor = $ENV{"EDITOR"} if !defined($editor) || $editor eq "";
X  if (!defined($editor) || $editor eq "") {
X    if ($os_kind eq "unix") {
X      $editor = "vi";
X      }
X    elsif ($os_kind eq "winnt" || $os_kind eq "win32") {
X      $editor = "notepad";
X      }
X    elsif ($os_kind eq "os2") {
X      $editor = "e";
X      }
X    else {
X      die "don't know default editor for os $os_kind";
X      }
X    }
X
X  # Determine the pager
X  $pager = $ENV{"PAGER"};
X  $pager = "" if !defined($pager);
X  if ($pager eq "" && $os_kind eq "unix") {
X    # better default on Unix
X    $pager = "more";
X    }
X  $pager = "" if $pager eq "builtin";
X
X  # Get $local_hostname
X  if ($os_kind eq "unix") {
X    local($hname) = "/bin/hostname";			# most unixes
X    $hname = "/usr/bsd/hostname" if ! -x $hname;	# irix :-(
X    die "Cannot find your hostname command" if ! -x $hname;
X
X    chop($local_hostname = `$hname`);
X    die "$hname failure" if $local_hostname eq "";
X    }
X  elsif ($os_kind eq "winnt") {
X    $local_hostname = $ENV{"COMPUTERNAME"};
X
X    die "%COMPUTERNAME% is not set, what's wrong with your installation?"
X	if $local_hostname eq "";
X    }
X  elsif ($os_kind eq "win32") {
X    # I wish there was a better way of doing this....
X    $local_hostname = $ENV{"COMPUTERNAME"};
X    
X    die "Please set the COMPUTERNAME environment variable"
X	if $local_hostname eq "";
X    }
X  elsif ($os_kind eq "os2") {
X    # I wish there was a better way of doing this....
X    $local_hostname = $ENV{"HOSTNAME"};
X    
X    die "Please set the HOSTNAME environment variable"
X	if $local_hostname eq "";
X    }
X  else {
X    die "cannot determine local hostname on this os ($os_kind)";
X    }
X
X  # Try to make it fully qualified
X  $local_hostname = &fqdn_name($local_hostname);
X  if (&good_hostname($local_hostname, 0) eq "") {
X    print "WARNING: unable to determine mail address of this computer.\n";
X    print "         (\"$local_hostname\" doesn't look right.)\n";
X    print "         Be sure to edit before sending.  Set ADCOMPLAIN_MDOMAIN\n";
X    print "         in your environment to permanently rectify this.\n";
X    }
X
X  # Don't pull the hostname off of the domain.  Some mail domains require
X  # even the computername in order to do proper delivery.
X  if ($fqdnWithoutHost && $local_hostname =~ /^[^\.]+\.(.+)$/) {
X    $local_hostname = $1;
X    }
X
X
X  $mailhost = $ENV{"ADCOMPLAIN_MAILHOST"}
X	if defined($ENV{"ADCOMPLAIN_MAILHOST"});
X  if (!defined($mailhost) || $mailhost eq "") {
X    if ($os_kind eq "unix") {
X      # Unix: assume sendmail is running locally
X      $mailhost = $local_hostname;
X      }
X    else {
X      die "configuration error: MAILHOST not set";
X      }
X    }
X
X  $SIG{'PIPE'} = 'IGNORE';
X  $header_analysis = "";
X  $bullet = "*  ";	# used in formatting header_analysis
X  $bullet2 = "   ";	# for hanging indent
X
X  # Make stderr and stdout unbuffered.
X  select(STDERR); $| = 1;
X  select(STDOUT); $| = 1;
X
X  if ($os_kind eq "unix") {
X    $tempname="/tmp/adcomplain-$$";
X    $CONSOLE = "/dev/tty";
X    }
X  elsif ($os_kind eq "winnt" || $os_kind eq "win32" || $os_kind eq "os2") {
X    # Two weird conventions for a temp directory on Windows NT
X    local($tmp) = $ENV{"TMP"};
X    $tmp = $ENV{"TEMP"} if !defined($tmp) || $tmp eq "";
X    $tempname="$tmp\\adcomplain-$$";	# ?? is there a better way?
X    $tempname =~ s#/#\\#g;	# in case Unix-isms crept in
X
X    $CONSOLE = "con:";
X    }
X  else {
X    die "need tempname and console for this os ($os_kind)";
X    }
X
X  $hosts_file = $ENV{"ADCOMPLAIN_HOSTS"};
X  $hosts_file = "" if !defined($hosts_file) || $hosts_file eq ""
X	|| ! -f $hosts_file;
X
X  %hosts_to_ips = ();
X  %ips_to_hosts = ();
X
X  $from = $ENV{"ADCOMPLAIN_FROM"};
X  if (!defined($from) || $from eq "") {
X    # username
X    if ($os_kind eq "unix") { # safe to call getpwuid
X      local($USER,@garbage) = getpwuid($<);
X      @garbage = @garbage;	# shut up perl -w
X      $from = $USER;
X      $from = $ENV{"USER"} if $from eq "";			# desperation
X      $from = $ENV{"LOGNAME"} if $from eq "";			# ...then panic
X      die "I can't figure out who you are!" if $from eq "";	# ...then death
X      }
X    elsif ($os_kind eq "winnt") {
X      $from = $ENV{"USERNAME"};
X      die "%USERNAME% is not set, what's wrong with your installation?"
X	  if $from eq "";
X      }
X    elsif ($os_kind eq "win32" || $os_kind eq "os2") {
X      # This might be buried in the registry somewhere....
X      $from = $ENV{"USERNAME"};
X      die "Please set %ADCOMPLAIN_FROM% or %USERNAME% in your autoexec"
X	  if $from eq "";
X      }
X    else {
X      die "how do I get your username on this os? ($os_kind)";
X      }
X    $from = "$from\@$local_hostname";
X    }
X  if (&good_hostname($from, 0) eq "") {
X    print "WARNING: your return address \"$from\" is not valid.\n";
X    print "         Be sure to edit before sending.  Set ADCOMPLAIN_FROM\n";
X    print "         (or ADCOMPLAIN_MDOMAIN) in your environment to\n";
X    print "         permanently rectify this.\n";
X    }
X
X  # This is a dictionary of the hostnames we've found.
X  %available_hosts = ();
X
} # initialize
X
#-----------------------------------------------
# Create standard text for a response.
sub insert_standard_text {
X  local ($response);
X
X  $response = "[generated by $adcomplain_name $adcomplain_revision]\n\n";
X
X  if ($header_analysis ne "") {
X    $response .= "I am complaining about ";
X    if ($chainmode) {
X      $response .= "an illegal chain letter ";
X      }
X    else {
X      $response .= "a commercial advertisement ";
X      }
X    if ($mailmode) {
X      $response .= "sent to my e-mail address.";
X      }
X    else {
X      $response .= "posted to $newsgroup.";
X      }
X    $response .= "\n";
X    $response .= <<'END';
This message apparently passed through your site.  It may even have originated
with you.  However, there are inconsistencies in the RFC-822 mail 
headers.  It is possible that a mail program was buggy or misconfigured, but it
is much more likely that the sender has intentionally obscured the message's
true origin.  It follows that the sender is aware of the dishonest and
illegal nature of this message.
X
The problems I see with these headers are:
X
END
X    $response .= "$header_analysis";
X    } # $header_analysis
X  else { # legit headers
X    $response .= "Please ";
X    if ($recipient != $complain_to_only) {
X      $response .= "don't ";
X      }
X    else {
X      $response .= "advise this user not to ";
X      }
X    if ($mailmode) {
X      $response .= "mail ";
X      }
X    else {
X      $response .= "post ";
X      }
X    $response .= "these ";
X    if ($chainmode) {
X      $response .= "illegal chain letters ";
X      }
X    else {
X      $response .= "unsolicited commercial advertisements ";
X      }
X    $response .= "to ";
X    if ($mailmode) {
X      $response .= "people's e-mail addresses.  ";
X      }
X    else {
X      $response .= "$newsgroup.  ";
X      }
X    $response .= "My site must pay to receive and store them.\n";
X    } # legit headers
X  if (!$chainmode && !$mailmode && !$quiet) {
X    $ans = &get_answer("Is \"$subject\" relevant to $newsgroup (y/n)?",
X	"n");
X    if ($ans eq "n") {
X      $response .= "\nIn addition, \"$subject\"\n";
X      $response .= "has nothing to do with $newsgroup.\n";
X      }
X    }
X  if (!$noinclude || $recipient ne $poster_only) {
X    $response .= "\nI forward the entire text of the message, with ";
X    $response .= "headers, to the end of this message.\n";
X    }
X  $response .= "\n";
X
X  if ($chainmode) {
X    $response .= <<'END';
This sort of chain letter is a pyramid scheme, which in turn is a form of fraud.
It violates a U.S. federal statute, 18 U.S.C. sec. 1343.
X
If at any point the U.S. Mail is used, this is also a violation of 18 U.S.C
sec. 1302, the Postal Lottery Statute.  See
X
X     http://www.usps.gov/websites/depart/inspect/chainlet.htm
X     http://www.usps.gov/websites/depart/inspect/usc18/mailfr.htm
X
This sort of chain letter is outlawed in Canada under the Section 206(1)(e) of
the Criminal Code and under Section 55 of the Competition Act.
X
END
X    }
X  else { # advertising
X    if ($mailmode) {
X      $response .= <<'END';
These advertisements are illegal in many countries; please consult an attorney
for your applicable statutes.
X
END
X      }
X    else { # Usenet
X      if ($recipient != $complain_to_only) {
X	$response .= <<'END';
The biz.marketplace and ads newsgroup hierarchies are the correct places for
commercial ads. (Ads may be inappropriate in some biz newsgroups, so please
check first.)
X
For more information about Usenet etiquette, see news.announce.newusers.
X
END
X	}
X      } # Usenet
X    } # advertising
X
X  if (!$mailmode && $recipient != $complain_to_only) { # cancel your post
X    $response .= <<'END';
Most text-based newsreaders will allow you to cancel a posting by finding your
article and pressing 'C' or 'D'.
X
(Netscape users can select 'Cancel Message' in the 'Edit' menu.)
If you need help, contact
END
X    if ($postmaster ne "") {
X      $response .= "your postmaster at\n\n";
X      $response .= "     <$postmaster>.\n";
X      }
X    else {
X      $response .= "postmaster.\n";
X      }
X    $response .= "\n";
X    } # cancel your post
X
X  $response .= "Thank you for your cooperation.\n\n";
X
X  # batchmode
X  if ($batchmode && !$outmode) {
X    $response .= <<'END';
X
P.S. -- I used the questionable "batch mode" in adcomplain to create
this message.  If this message was addressed improperly, it is because I
did not proofread the list of recipients before mailing.  Direct
your complaints to me, not to the authors of adcomplain.  Thank you.
END
X    }
X  # format the response
X  $response = &fmt($response, 72);
X
X  return $response;
X  }
X
#-----------------------------------------------
# compose a message out of all of the elements so far
sub compose_message {
X  local ($response);
X  local($header);
X
X  ## find out where to send message
X  if ($batchmode || $quiet) {
X    }
X  elsif ($poster ne "" && $complain_to ne "") {
X    print "Send to:\n";
X    print " 1 = $complain_to\n";
X    print " 2 = $poster\n";
X    print " 3 = both\n";
X    print " 4 = <abort>\n";
X    $ans = &get_answer("Send to whom?", $recipient);
X    if ($ans == 4) {
X      print "aborted\n";
X      exit 0;
X      }
X    $recipient = $ans if $ans ne "" && $ans >= 1 && $ans <= 3;
X    }
X
X  if ($complaintFile eq "") {
X    $response = &insert_standard_text;
X    }
X  else {
X    $response = "";
X    if ($complaintFile ne "") {
X      if (-f $complaintFile) {
X	if (!open(TEXTFILE, "$complaintFile")) {
X	  print "adcomplain: cannot open $complaintFile: $!\n";
X	  }
X	else {
X	  local(@text);
X	  @text = <TEXTFILE>;
X	  $response = join('', @text);
X	  close TEXTFILE;
X	  @text = (); # garbage collection
X	  }
X	}
X      else {
X	print "adcomplain: $complaintFile: no such file.\n";
X	#require "getcwd.pl";
X	#$cwd = &getcwd;
X	#print "adcomplain: (current directory is $cwd)\n";
X	}
X
X      # interpolate perl variables into the response string
X      $response = eval "\"" . "$response" . "\"";
X      }
X    } # $complaintFile given
X
X  ## include copy of posting if needed
X  if (!$noinclude || $recipient ne $poster_only) {
X    $response .= "\n--------forwarded message--------\n";
X    for (@original) {
X      $response .= $_;
X      }
X    $response .= "-----end of forwarded message-----\n\n";
X    }
X
X  ## append signature if needed
X  $siggie = $ENV{"SIGNATURE"};
X  if (!defined($siggie) || $siggie eq "") {
X    $siggie = $ENV{"HOME"};
X    $siggie .= "/.signature" if defined($siggie) && $siggie ne "";
X    }
X
X  if (!$omit_signature && $addsig && defined($siggie) && -f $siggie) {
X    if (!open(TEXTFILE, $siggie)) {
X      print "adcomplain: cannot open $siggie: $!\n";
X      }
X    else {
X      local(@text);
X
X      $response .= "-- \n";
X      @text = <TEXTFILE>;
X      # in case siggie already has the delim....
X      shift(@text) if $text[0] eq "-- \n" || $text[0] eq "--\n";
X      for (@text) {
X	$response .= $_;
X	}
X      close TEXTFILE;
X      @text = (); # garbage collection
X      }
X    }
X
X  ## prepend message header
X  $header = "";
X
X  { # Add RFC-822 "Date:" header
X    local ($Date);
X    local ($sec,$min,$hour,$mday,$mon,$year,$wday,$junk) = gmtime(time);
X
X    $junk = sprintf("%02d:%02d:%02d", $hour, $min, $sec);
X    $mday = sprintf("%02d", $mday);
X    $mon = $monthNames[$mon];
X    $year += 1900;
X    $wday = $wdayNames[$wday];
X
X    # TO DO:  we could actually put the time zone in.  For now, use GMT
X    $Date = "$wday, $mday $mon $year $junk +0000 (GMT)";
X    $header .= "Date: $Date\n";
X  }
X
X  # Add "From:"
X  $header .= "From: $from\n";
X
X  # who is it to?
X  if ($recipient == $complain_to_only) {
X    $header .= "To: $complain_to\n";
X    }
X  else {
X    $header .= "To: $poster\n";
X    }
X
X  # and who gets copies?
X  if (!$legal_letter) {
X    $cc = ", $cc" if $cc ne "";
X    $cc = "$authorities$cc";
X    }
X  if ($recipient == $poster_and_complain_to) {
X    $cc = ", $cc" if $cc ne "";
X    $cc = "$complain_to$cc";
X    }
X  $header .= "Cc: $cc\n" if $cc ne "";
X
X  $subject = "no subject" if $subject eq "";
X  $header .= "Subject: ";
X  if ($recipient == $complain_to_only) {
X    $header .= "Abuse report:  ";
X    }
X  else {
X    $header .= "Re: your ";
X    }
X  if ($mailmode) {
X    $header .= "email ";
X    }
X  else {
X    $header .= "Usenet article ";
X    }
X  $header .= "titled \"$subject\"\n";
X  $header .= "\n"; # RFC822 end of headers
X  $response = $header . $response;
X
X  return $response;
} # compose_message
X
#-----------------------------------------------
# Ask a question and get a reply from /dev/tty, use default if no reply given:
sub get_answer {
X  local($prompt, $default) = @_;
X  local($ans);
X  local($/) = "\n";
X
X  print "$prompt [$default] ";
X  $ans = <STDIN>;
X  chop($ans);
X  return $ans if ($ans ne "");
X  return $default;
X  }
X
#-----------------------------------------------
# format a string into paragraphs with given maximum line length.
sub fmt {
X  local($str, $len) = @_;
X  local(@lines) = split(/\n/, $str);
X  # local(@paras) = split(/\n{2,}/, $str);
X  local(@paras);
X  local($para, $result, $left, $word);
X  local($last_was_bullet, $is_bullet, $junk);
X
X  # split into paragraphs
X  @paras = ();
X  $para = "";
X  for (@lines) {
X    if ($_ eq "\n" || $_ eq "") {
X      # blank line delimits beginning of paragraph
X      push(@paras, $para);
X      push(@paras, "");
X      $para = "";
X      next;
X      }
X    $_ =~ s/\n/ /g;
X    if ($_ =~ /^[\s]+.*/) { # so does a line beginning with white space
X      push(@paras, $para) if $para ne "";
X      $para = "";
X      }
X
X    # Join the line, using proper respect for punctuation
X    if ($para =~ /.*\.\s*$/) { # ends in a period
X      $para =~ s/(.*\.)\s*$/$1  /;
X      }
X    elsif ($para =~ /.*:\s*$/) { # ends in a colon
X      $para =~ s/(.*:)\s*$/$1  /;
X      }
X    elsif ($para =~ /.*!\s*$/) { # ends in an exclamation
X      $para =~ s/(.*!)\s*$/$1  /;
X      }
X    else {
X      $para .= " " if $para ne "";
X      }
X    $para .= $_;
X    }
X  push(@paras, $para) if $para ne "";
X
X  # Reformat the paragraphs
X  $result = "";
X  $last_was_bullet = 0;
X  $junk = $bullet;
X  $junk =~ s/(\W)/\\$1/g;		# remove special characters
X  $junk = "^$junk.*";
X  for (@paras) {
X    $left = $len;
X    $is_bullet = ($_ =~ /$junk/) ? 1 : 0;
X
X    # special case:  indentation at beginning of paragraph is preserved
X    if ($_ =~ /^\s+/) {
X      ($word = $_) =~ s/^(\s+).*/$1/;
X      $left -= length($word);
X      $result .= $word;
X      }
X
X    # Now start adding the words
X    while ($_ =~ s/^\s*(\S+\s*)//) {
X      $word = $1;
X      if (length($word) < $left) {
X	$result .= $word;
X	$left -= length($word);
X	}
X      else {
X	if ($is_bullet) {
X	  $result .= "\n$bullet2$word";
X	  }
X	else {
X	  $result .= "\n$word";
X	  }
X	$left = $len - length($word);
X	}
X      }
X  $result .= "\n" if !$last_was_bullet;
X  $last_was_bullet = $is_bullet;
X  }
return $result;
}
X
#-----------------------------------------------
# display a screen's worth; used by moref().
sub display {
X  local($my_name, $start, $count, @lines) = @_;
X  local($i, $max);
X
X  if ($start + $count <= $#lines) {
X    $max = $start + $count;
X    }
X  else {
X    $max = $#lines;
X    }
X  for ($i = $start; $i < $max; $i ++) {
X    print $lines[$i];
X    }
X  printf "- $my_name: %d/$#lines: ", $start + 1;
X  }
X
#-----------------------------------------------
# a cheap internal pager
sub moref {
X  local($tempname) = @_;  # the file to display
X  local($my_name) = "moref";
X  local ($line_count) = 0;
X  local ($lines_per_screen) = 22;
X  local ($kbd_cmd, $front, $back);
X  local (@all_lines);
X
X  if ($pager ne "") {
X    if ($os_kind eq "unix") {
X      system "$pager $tempname <$CONSOLE";
X      }
X    elsif ($os_kind eq "winnt" || $os_kind eq "win32" || $os_kind eq "os2") {
X      system "$pager $tempname";
X      }
X    else {
X      die "how do I run your pager on this system?";
X      }
X    return;
X    }
X
X  if (defined($ENV{"LINES"}) && $ENV{"LINES"} != 0) {
X    # Unix termcap convention
X    $lines_per_screen = $ENV{"LINES"} - 1;
X    }
X
X  open (MOREF, "<$tempname") || die "$my_name: can't open $tempname:  $!"; 
X  @all_lines = <MOREF>;
X  close MOREF;
X
X  # At this point it's still possible that some of the lines may be oversize,
X  # because we don't format the original mail message from the sender; we go
X  # the entire message and break up any oversized lines.
X  for ($i = 0; $i <= $#all_lines; $i ++) {
X    next if length($all_lines[$i]) < 80;
X    $front = substr($all_lines[$i], 0, 79);
X    $back = substr($all_lines[$i], 79);
X    $all_lines[$i] = "$front\n";
X    splice(@all_lines, $i + 1, 0, $back);
X    }
X
X  $line_count = 0;
X  for (;;) {
X    &display($my_name, $line_count, $lines_per_screen, @all_lines);
X    $kbd_cmd = <STDIN>;
X    chop($kbd_cmd);
X    if ($kbd_cmd eq "") {
X      $line_count += $lines_per_screen;
X      $line_count = $#all_lines if $line_count > $#all_lines;
X      next;
X      }
X    elsif ($kbd_cmd =~ /^\?.*/) {
X      print "? - this message\n";
X      print "<enter> - next page\n";
X      print "b - back a page\n";
X      print "nnnn -- start with given number line\n";
X      print "q - quit\n";
X      print "press enter to continue... ";
X      $kbd_cmd = <STDIN>;
X      }
X    elsif ($kbd_cmd =~ /^b.*/i) {
X      $line_count -= $lines_per_screen;
X      $line_count = 0 if $line_count < 0;
X      next;
X      }
X    elsif ($kbd_cmd =~ /^q.*/i) {
X      last;
X      }
X    elsif ($kbd_cmd =~ /^\d+$/) {
X      $line_count = $kbd_cmd - 1;	# take input as one-based line number
X      $line_count = $#all_lines if $line_count > $#all_lines;
X      next;
X      }
X    else {
X      print "what? (\"?<Enter>\" at the prompt for help): ";
X      print "for now, press enter to continue... ";
X      $kbd_cmd = <STDIN>;
X      }
X    }
}
SHAR_EOF
chmod 0755 adcomplain.pl ||
echo 'restore of adcomplain.pl failed'
Wc_c="`wc -c < 'adcomplain.pl'`"
test 151070 -eq "$Wc_c" ||
	echo 'adcomplain.pl: original size 151070, current size' "$Wc_c"
fi
exit 0