#! /bin/perl

#                         P R O B E L I S T

#          Send Traceable Probe to Mailing List Subscribers
#                     Version 1.2  --  March MIM

#                           by John Walker
#                      http://www.fourmilab.ch/

#   Tested with Perl 5.004 on Sun Solaris/SPARC 7 (aka 2.7).

#   Dear Sysadmin: many little details in this script may need
#   tweaking to adapt to details on your site.  So before you
#   blast thousands of E-mails to your list subscribers, it's
#   a good idea to test this with a test list to which only
#   you subscribe.  For a realistic test, it's best to use a
#   test list containing:
#
#       yourself
#       a valid account you maintain at another site (you
#           can use a Yahoo or Iname address if you don't
#           have an off-site account).
#       A bogus off-site address.

    # Directory where lists reside

    $dir = "/files/people/majordomo/lists";

    #   Program to use to send mail.  Must accept "-s" option
    #   to supply subject on command line.

    $mailer = "mailx";                # May be "Mail" on some systems

    #   Domain name for originating host.  If your system
    #   can't get this automatically with the following
    #   code, hard-code the value.

    $domain = `domainname`;
    chop($domain);
    $domain =~ s/\w+\.//;             # Prune host name most systems return
#print("Domain name = \"$domain\"\n");

    #   Seconds to sleep between sending successive mail messages.
    #   Setting this to a modest value will keep this program from
    #   overwhelming the mailer on your machine.  Set to zero to
    #   blast away without any delay.

    $interval = 10;

    #   Directory in which to create log file

    $logdir = "/tmp";

    #   Template for message to be sent to subscribers

    $message = <<'EOF';
"This is an automated message from the mailing list manager
at $domain.  You are subscribed to the mailing list:

    $list\@$domain

under the name:

    $l

If you received this message properly and wish to remain
a subscriber to this list, simply delete this message.

If you wish to unsubscribe from the $list list, send an
E-mail message to:

    $list-request\@$domain

containing the word:

    unsubscribe

in the body of the message, *not as the subject*.

Please excuse the distraction of this administrative
message; sending this message to each individual name
on the $list mailing list is the only way to purge the
list of bad addresses forwarded to names other than
those on the list, and of addresses at sites which
provide insufficient information for failed mail to
determine which address to remove from the list.

Thank you in advance for your comprehension.
"
EOF

    while (1) {
        print("Mailing list: ");
        $list = <>;
        if (!$list || (chop($list), ($list =~ m/^\s*$/))) {
            exit(0);
        }
 
        #   If list name is "?", show lists and number of users in each

        if ($list eq '?') {
            open(LISTDIR, "ls -1 $dir | fgrep -v . |")
                || die "Cannot open list directory $dir";
            while ($f = <LISTDIR>) {
                chop($f);
                if (-f "$dir/$f") {
                    $n = `wc -l $dir/$f`;
                    chop($n);
                    $n =~ s/^\s*//;
                    $n =~ s/\s.*$//;
                    print("$f: $n subscribers.\n");
                }
            }
            close(LISTDIR);
            next;
        }

        #   Verify that specified list actually exists

        if (!(-f "$dir/$list")) {
            print("No list named \"$list\" in $dir.\n");
            print("Enter ? to print names of all existing lists.\n");
            next;
        }

        open(F, "$dir/$list") || die("Cannot open list file $dir/$list: $!");

        #   Create log directory

        $logname = "$logdir/$list-probe.log";
        system("rm -rf $logname");
        system("mkdir $logname");

        #   The "$ndex" code may look a little strange, but it can
        #   be a lifesaver when addresses on your list point to sites
        #   which provide little or no clue as to the original
        #   destination of the mail, or when tracking down cases
        #   where somebody has subscribed their own list to yours.
        #   That little parenthesised number at the start of the
        #   "Subject:" is extremely likely to survive all but the
        #   most opaque bounce messages, and permits you to go back
        #   to the log directory (where it appears on the first
        #   line of each file, before the address from the list) and
        #   find the address on your list which resulted in the bounce.

        $ndex = 0;
        while ($l = <F>) {
            chop($l);
#print("Name \"$l\"\n");
            $safel = $l;
            $safel =~ s/\W/-/g;
            $m = eval($message);
#           print("$m");
            $ndex++;
            system("echo '($ndex) $l' >$logname/$safel");
            system("echo >>$logname/$safel");
            system("echo \'$m\' | $mailer -v -s \"($ndex) Test to $l for $list\@$domain\" $l >>$logname/$safel\n");
            print("Mailed $l ($ndex)\n");
            if ($interval > 0) {
                sleep($interval);
            }
        }
        close(F);
    }
