I'm guessing © C. Stewart - cms@balius.com

#!/usr/local/bin/perl
#
# ============== pmdflog.pl =================
# A simple program for gathering statistics from iMS mail.log* files.
# Sample usage:
# % imslog.pl < InstanceRoot/log/imta/mail.log_yesterday > IMTA.stats
#
# You must have at least V5.005 of perl to run this script. Specifically,
# there must be support for the "use vars qw" feature.
#
# To run it this tool nightly, you might make a small script, say
# collect_stats:
#
# #!/bin/csh
# /usr/local/bin/imslog.pl < InstanceRoot/log/imta/mail.log_current >& \
# /usr/tmp/mail_stats.log
# mailx -s "mail_stats, `date`" root@mynode.com < /usr/tmp/mail_stats.log
#
# Then make a crontab entry for root to launch it nightly:
# 15 0 * * * /usr/local/bin/collect_stats > /dev/null 2>&1
#
# ----------------------------------------------------------------------
#
# iMS mail.log file codes:
#
# A -- Print request failed, FAX temp failure, page aborted,
# or IMAP connection failed
# C -- Connection closed
# D -- Message dequeue
# E -- Message enqueue
# F -- Mailserv command or page failed
# I -- ETRN received
# J -- Connection rejected
# M -- Maximum number of FAX delivery attempts exceeded
# O -- Connection opened
# Q -- Message requeue
# R -- Paging switch rejected message
# S -- Print request, mailserv operation, or page sent success
# X -- Connection rejected
# Y -- Connection failed
# Z -- Delivery and reqeue (currently treated the same as a Q)
# ----------------
# Global Variables:
#
# %bad_domains - count of Q records caused by domains
# %chan_enq - time a particular message was enqueued
# %conn_close - count of closed connecions per server
# %conn_close_source - source of connection closes
# %conn_failed - number of failed connections per server
# %conn_fail_source - source of connection failures
# %conn_open - count of opened connections per server
# %conn_open_source - source of connection opens
# %conn_reject - count of connection rejects per server
# %conn_reject_source - source of connection rejects
# %delay_bins_chan - counts of messages based on delays per channel
# %delay_bins_host - counts of messages based on delays per host
# %dequeues_by_date - count of dequeues by date
# %etrn_domains - the domains that have requested etrn support
# %failed_messages - count of Q records by channel
# %fax_destinations - count of successful faxes sent by source address by phone number
# %fax_senders - count of successful faxes sent by source address
# %giant_messages - count of big message senders by source
# %in_messages - count of messages enqueued by channel
# %in_size - size of messages enqueued by channel
# %into_chan - count of messages enqueued to channel
# %into_size - size of messages enqueued to channel
# %mailserv_users - domains using the mailserv channel
# %max_chan_delay - maximum delay time between enqueues and dequeues
# %max_host_delay - maximum delay time between enqs and deqs, by host
# %out_messages - count of messages dequeued by channel
# %out_messages_host - count of messages sent to a particular host
# %out_size - size of messages dequeued by channel
# %pager_successes - count of successful pages sent by channel
# %rectypes - count of each type of record we find, keyed by record type
# %rejected_messages - count of R records per channel
# %warning_cnt - count of W records per channel
# %retries_done - number of times a channel took n retries to deliver a msg
# %retry_num - index of letters (Z..A) to numbers (0..26)
# %size_bins - counts of messages based on size
# %total_host_delay - total delay time by host
#
# @all_dates - list of dates covered by this log file
# @bin_names - list of names used as keys into size_bins
# @delay_bin_names - list of names used as keys into delay_bins
# @dequeues_per_hour - count of dequeus in an hour
# @retry_bin_names - names of bins used to count retries
#
# $etrn_count - the number of etrn requests received
# $fax_failures - count of failed fax channel attempts
# $fax_max_failures - count of maximum delivery attempts exceeded
# $fax_successes - count of successful fax channel uses
# $last_date - last date processed
# $line_count - current line number we're on
# $mailserv_failures - count of failed mailserv uses
# $mailserv_successes - count of successful mailserv channel uses
# $pager_failures - count of failed pager channel uses
# $pager_successes - count of successful pager channel uses
# $printer_failures - count of failures on printer channels
# $printer_successes - count of successful printer channel uses
# $total_dequeues - total number of dequeue operations performed
# $total_dequeue_size - total size of messages dequeued
#
# -------
# Updates:
#
# 15 December 97 - Added support for Y records. Thanks to Chris
# Pappagianis for this one.
# 15 December 97 - Added channel delay time processing.
# 16 December 97 - Added host delay time processing.
# 17 December 97 - Fixed a couple of bugs: failed connections weren't
# getting counted correctly; remove leading space from
# dates with single-digit days. Also did some minor
# efficiency enhancements.
# 22 December 97 - Added handling for F records with mailserv channels
# and A records with IMAP servers
# 29 December 97 - Added message size bins
# 31 December 97 - Added dequeues per hour recording
# 7 January 98 - Redid delay time processing -- keep counts in bins
# and display those numbers rather than averages
# 9 January 98 - Fixed a bug in timeinsecs()
# 18 February 98 - Added big message source records
# 6 March 98 - Fixed some printing ugliness; changed the format of
# printed enqueue statistics
# 26 March 98 - Fixed a bug in the big message source records -- when
# messages had an empty envelope from address, the
# destination showed as the source
# 6 November 98 - Add support for logs that include pid's, bfc
# 9 November 98 - Add support for uucp channels, bfc
# 13 November 98 - Add support for 'J' field, bfc
# 17 November 98 - Allow x400 channel to use 'A' record, add processing for
# W records, bfc
# 22 December 98 - Added support for FAX channels, specifically A, S,
# and M record types. (whm)
# 24 December 98 - Restructured the parsing of input records by centralizing
# the parse logic. Added VMS conditional logic for gethost
# routines. Optionally support the generation of mail or
# connection information.
# 8-JAN-1999:whm - Strip trailing '>' or '"' from hosts in transit
# summary. Fixed a typo in the server summary.
# 2-JUN-1999:whm - Comment out the VMS conditionals now that the latest
# perl for VMS has socket support via DECC.
# 3-Mar-2000:jwa - Added some support for PMDF 6.0 log file changes.
# Specifically the A and/or S that can be appended to
# E, D, and Q records is now tallied.
# 3-Mar-2000:jwa - Added support for debugging. If you set the environment
# variable PMDFLOGPLDEBUG to 1, the $debug varible will
# be set.
use vars qw(%bad_domains
%chan_enq
%conn_close
%conn_close_source
%conn_failed
%conn_fail_source
%conn_open
%conn_open_source
%conn_reject
%conn_reject_source
%delay_bins_chan
%delay_bins_host
%dequeues_by_date
%etrn_domains
%failed_messages
%fax_senders
%fax_destinations
%giant_messages
%in_messages
%in_size
%into_chan
%into_size
%mailserv_users
%max_chan_delay
%max_host_delay
%out_messages
%out_messages_host
%out_size
%pager_successes
%rectypes
%rejected_messages
%secure_connections
%warning_cnt
%retries_done
%retry_num
%size_bins
%total_host_delay
@all_dates
@bin_names
@delay_bin_names
@dequeues_per_hour
@retry_bin_names
@token
$connection_record
$debug
$etrn_count
$fax_failures
$fax_max_failures
$fax_successes
$generate_connection_report
$generate_mail_report
$last_date
$line_count
$mailserv_failures
$mailserv_successes
$pager_failures
$pager_successes
$printer_failures
$printer_successes
$processing_conninfo
$processing_date
$processing_host
$processing_inchan
$processing_outchan
$processing_pid
$processing_rectype
$processing_rectype_fld_no
$processing_server
$processing_size
$processing_time
$rest
$total_dequeues
$total_dequeue_size
);

use Time::Local;
use strict;

sub process_enqueue {
my ($local_part, $end, $host, $source_host, $source_local, $tmp);
my ($id);

$secure_connections{"Auth"} += 1 if ($processing_rectype =~ /A/);
$secure_connections{"Secure"} += 1 if ($processing_rectype =~ /S/);

if (($rest =~ /^\s/) || ($rest =~ /^<>/)) {
$source_host = "Empty envelope from address";
($host, $end) = split / /o, $rest, 2;
}
else {
if ($processing_outchan eq 'l') {
$host = 'local delivery';
($source_host, $end) = split / /o, $rest, 2;
}
else {
($source_local, $end) = split /@/o, $rest, 2;
($source_host, $tmp) = split / /o, $end, 2;
if ($processing_outchan =~ /uucp/) {
# A uucp_* channel, will be in the form host!user
($host,$local_part,$tmp) = split /\s+|\!/o,$tmp,3;
$host = lc($host);
$source_host = $host.'!'.$local_part;
}
else {
($local_part, $end) = split /@/o, $tmp, 2;
($host, $tmp) = split / /o, $end, 2;
$host = lc($host);
$source_host = $source_local.'@'.$source_host;
}
}
}

$end =~ /(<[^>]+>)/o;
$id = $1;

$in_messages{$processing_inchan}++;
$in_size{$processing_inchan} += $processing_size;
$into_chan{$processing_outchan}++;
$into_size{$processing_outchan} += $processing_size;

if ($processing_size > 1000) {
$giant_messages{$source_host}++;
}

$chan_enq{$processing_outchan}{$id}
= timeinsecs($processing_date, $processing_time)
if (not exists $chan_enq{$processing_outchan}{$id});
}

sub process_dequeue {
my ($local_part, $end, $host, $id, $deqtime, $delta, $tmp);
my ($hours, $minutes, $seconds, $bin, $num_retries, $found_file);

$secure_connections{"Auth"} += 1 if ($processing_rectype =~ /A/);
$secure_connections{"Secure"} += 1 if ($processing_rectype =~ /S/);

# Increment the message count for the hour

($hours, $minutes, $seconds) = split /:/o, $processing_time;
$dequeues_per_hour[$hours]++;

# Split the record into two parts: before and after the @ sign that
# should be in the destination address

if ($processing_outchan !~ /uucp/) {
($local_part, $end) = split /@/o, $_, 2;
}

# Now grab the host name from the destination address

if ($processing_outchan eq 'l') {
$host = 'local delivery';
}
elsif ($processing_outchan =~ /uucp/) {
($local_part,$end) = split /\!/o, $_, 2;
$local_part =~ /(.*)([\s]+)([\S]+)/;
$host = $3;
$host = lc($host);
}
else {
($host, $tmp) = split / /o, $end, 2;
($local_part, $end) = split /@/o, $tmp, 2;
($host, $tmp) = split / /o, $end, 2;
$host = lc($host);
}
$host =~ s/>$//;
$host =~ s/\"$//;

# Look for the message ID, enclosed in angle brackets
$end =~ /(<[^>]+>)/o;
$id = $1;

$out_messages{$processing_outchan}++;
$out_messages_host{$host}++;
$out_size{$processing_outchan} += $processing_size;
$total_dequeues++;
$total_dequeue_size += $processing_size;
if ($processing_date ne $last_date) {
$last_date = $processing_date;
push @all_dates, $last_date;
}
$dequeues_by_date{$processing_date}++;

# Increment the proper bin counter

if ($processing_size < 2) {
$size_bins{'Less than 2K'}++;
}
elsif ($processing_size < 10) {
$size_bins{'2K - 10K'}++;
}
elsif ($processing_size < 100) {
$size_bins{'10K - 100K'}++;
}
elsif ($processing_size < 1000) {
$size_bins{'100K - 1M'}++;
}
else {
if ($processing_size < 10000) {
$size_bins{'1M - 10M'}++;
}
else {
$size_bins{'Over 10M'}++;
}
}

# See if we have an enqueue time for this message. If so, compute
# the delay time ($delta) and increment the proper bin for the channel
# and the host. Also keep track of the maximum delay time per
# channel and host.

if (exists $chan_enq{$processing_outchan}{$id}) {
$deqtime = timeinsecs($processing_date, $processing_time);
$delta = $deqtime - $chan_enq{$processing_outchan}{$id};

# Initialize the bin counters to zero if this is a newly seen
# channel or host

if (not exists $delay_bins_chan{$processing_outchan}) {
foreach $bin (@delay_bin_names) {
$delay_bins_chan{$processing_outchan}{$bin} = 0;
}
}
if (not exists $delay_bins_host{$host}) {
foreach $bin (@delay_bin_names) {
$delay_bins_host{$host}{$bin} = 0;
}
}

if ($delta < 2) {
$delay_bins_chan{$processing_outchan}{'<2 sec'}++;
$delay_bins_host{$host}{'<2 sec'}++;
}
elsif ($delta < 10) {
$delay_bins_chan{$processing_outchan}{'<10 sec'}++;
$delay_bins_host{$host}{'<10 sec'}++;
}
elsif ($delta < 60) {
$delay_bins_chan{$processing_outchan}{'<1 min'}++;
$delay_bins_host{$host}{'<1 min'}++;
}
elsif ($delta < 300) {
$delay_bins_chan{$processing_outchan}{'<5 mins'}++;
$delay_bins_host{$host}{'<5 mins'}++;
}
elsif ($delta < 3600) {
$delay_bins_chan{$processing_outchan}{'<1 hour'}++;
$delay_bins_host{$host}{'<1 hour'}++;
}
else {
$delay_bins_chan{$processing_outchan}{'>1 hour'}++;
$delay_bins_host{$host}{'>1 hour'}++;
}

if ((not (exists $max_chan_delay{$processing_outchan})) or
($delta > $max_chan_delay{$processing_outchan})) {
$max_chan_delay{$processing_outchan} = $delta;
}

if ((not (exists $max_host_delay{$host})) or
($delta > $max_host_delay{$host})) {
$max_host_delay{$host} = $delta;
}

# We keep a total delay time for hosts because we display the top
# 20 hosts by total delay time

$total_host_delay{$host} += $delta;
}

# If file name logging is on, then we can track messages by number
# of retries before delivery

# Look for a VMS-style file name first

$found_file = 0;
if ($_ =~ /PMDF_QUEUE:\[.*\]([A-Z])([A-Z])/) {
$num_retries = $retry_num{$1}*26 + $retry_num{$2};
$found_file = 1;
}
elsif ($_ =~ /imta\/queue\/.*\/([A-Z][A-Z])/) {
$num_retries = $retry_num{$1}*26 + $retry_num{$2};
$found_file = 1;
}
if ($found_file) {
if (not exists $retries_done{$processing_outchan}) {
foreach $bin (@retry_bin_names) {
$retries_done{$processing_outchan}{$bin} = 0;
}
}

if ($num_retries == 0) {
$retries_done{$processing_outchan}{'1st time'}++;
}
elsif ($num_retries == 1) {
$retries_done{$processing_outchan}{'2nd time'}++;
}
elsif ($num_retries < 5) {
$retries_done{$processing_outchan}{'<5 times'}++;
}
else
{
$retries_done{$processing_outchan}{'>5 times'}++;
}
}
}

sub process_requeue {
my ($from_address, $to_address, $other, $mbx, $domain);

if ($rest =~ /^\s/) {
$other = $rest;
$other =~ s/^ //;
$from_address = "";
} elsif ($rest =~ /^<>/) {
$other = $rest;
$other =~ s/^<>//;
$from_address = "";
} else {
($mbx,$other) = split /@/o, $rest, 2;
($domain, $other) = split / /o, $other, 2;
$from_address = $mbx . "@" .$domain;
}

# Check for header to, otherwise use envelope to
if ($other =~ /^rfc822;/) {
$other =~ s/^rfc822;//;
($mbx, $other) = split /@/o, $other, 2;
($domain, $other) = split / /o, $other, 2;
$to_address = $mbx . "@" . $domain;
} else {
# Envelope to might not have a domain
($to_address, $other) = split / /o, $other, 2;
if ($to_address =~ /@/o ) {
($mbx, $domain) = split /@/o, $to_address;
} else {
$domain = $to_address;
}
}

$domain =~ s/>$//;
$domain =~ s/\"$//;

$failed_messages{$processing_inchan}++;
$bad_domains{lc($domain)}++;
}

sub process_success {
my ($address, $other, $user, $domain);
my ($tag);

($address, $other) = split / /o, $rest, 2;

# S records are only defined for mailserv, printer, FAX,
# and pager channels
# If we find something else, make a note of it for future extension

if ($processing_inchan =~ /^mailserv/io) {
$mailserv_successes++;
($user, $domain) = split /@/o, $address;
$mailserv_users{lc($domain)}++;
}
elsif ($processing_inchan =~ /^printer/io) {
$printer_successes++;
}
elsif ($processing_inchan =~ /^pager/io) {
$pager_successes{$processing_inchan}++;
}
elsif ($processing_inchan =~ /^g3/io) {
($tag, $other) = split / /o, $other, 2;
$other =~ m/^([\d| |-]+)/o;
$fax_destinations{$address}{$1}++;
$fax_senders{$address}++;
$fax_successes++;
}
else {
print "Unexpected channel $processing_inchan in S record at line $line_count\n";
}
}

sub process_failure {
# F records can be generated by the printer, pager, or mailserv channel

# We only record the number of failures, no more.

if ($processing_inchan =~ /^printer/io) {
$printer_failures++;
}
elsif ($processing_inchan =~ /^pager/io) {
$pager_failures++;
}
elsif ($processing_inchan =~ /^mailserv/io) {
$mailserv_failures++;
}
else {
print "** Found unexpected channel $processing_inchan in F record\n";
}
}

sub process_abort {
# A records can be generated by the printer channel, the pager channel,
# the fax channel, an IMAP server, or an X400 channel. If it's an IMAP
# server, we'll call the connection fail routine. Otherwise this routine
# is currently just like process_failure; they are separate in case
# additional data can be extracted from the different records

if ($processing_inchan =~ /^printer/io) {
$printer_failures++;
}
elsif ($processing_inchan =~ /^pager/io) {
$pager_failures++;
}
elsif ($processing_inchan =~ /^g3/io) {
$fax_failures++;
}
elsif ($processing_inchan =~ /^IMAP/io) {
&process_connfail;
}
elsif ($processing_inchan =~ /POP3/io) {
# successful login, ignore for now, bfc ; this was fixed in a later
# version of POP, but let's make allowances..
;
}
elsif ($processing_inchan =~ /x400/io) {
# ignore for now, probably just an aborted connection
;
}
else {
print "Unexpected channel $processing_inchan in A record at line $line_count\n";
}
}

sub process_max_fax {
# M records are generated when the FAX channel finally gives up
# trying to deliver faxen.

my ($address, $other);

($address, $other) = split / /o, $rest, 2;

if ($processing_inchan =~ /^g3/io) {
$fax_max_failures++;
}
else {
print "Unexpected channel $processing_inchan in M record at line $line_count\n";
}
}

sub process_etrn {
my ($sourceip, $tmp, $domain);

$processing_conninfo =~
/(^TCP\|)(\d+\.\d+\.\d+\.\d+\|)(\d+\|)(\d+\.\d+\.\d+\.\d+)(\|.)/o;
$sourceip = $4;
($tmp, $domain) = split / /o, $rest, 2;
$etrn_count++;
$etrn_domains{$sourceip}{$domain}++;
}

sub process_reject {
$rejected_messages{$processing_inchan}++;
}

sub process_warning {
$warning_cnt{$processing_inchan}++;
}

sub process_open {
my ($sourceip);

$processing_conninfo =~
/(^TCP\|)(\d+\.\d+\.\d+\.\d+\|)(\d+\|)(\d+\.\d+\.\d+\.\d+)(\|.)/o;
$sourceip = $4;
$conn_open{$processing_server}++;
$conn_open_source{$processing_server}{$sourceip}++;
}

sub process_close {
my ($sourceip);

$processing_conninfo =~
/(^TCP\|)(\d+\.\d+\.\d+\.\d+\|)(\d+\|)(\d+\.\d+\.\d+\.\d+)(\|.)/o;
$sourceip = $4;
$conn_close{$processing_server}++;
$conn_close_source{$processing_server}{$sourceip}++;
}

sub process_connreject {
my ($sourceip);

$processing_conninfo =~
/(^TCP\|)(\d+\.\d+\.\d+\.\d+\|)(\d+\|)(\d+\.\d+\.\d+\.\d+)(\|.)/o;
$sourceip = $4;
$conn_reject{$processing_server}++;
$conn_reject_source{$processing_server}{$sourceip}++;
}

sub process_connfail {
my ($sourceip);

$processing_conninfo =~
/(^TCP\|)(\d+\.\d+\.\d+\.\d+\|)(\d+\|)(\d+\.\d+\.\d+\.\d+)(\|.)/o;
$sourceip = $4;
$conn_failed{$processing_server}++;
$conn_fail_source{$processing_server}{$sourceip}++;
}
#
# MAIN PROGRAM BEGINS
#
# Note: if this process_table gets additions, you must also edit the
# RECORD TYPE CHECK if statement further below.
#
my %process_table = (
'E' => \&process_enqueue,
'D' => \&process_dequeue,
'Q' => \&process_requeue,
'Z' => \&process_requeue,
'S' => \&process_success,
'F' => \&process_failure,
'A' => \&process_abort,
'R' => \&process_reject,
'O' => \&process_open,
'C' => \&process_close,
'X' => \&process_connreject,
'Y' => \&process_connfail,
'J' => \&process_reject,
'W' => \&process_warning,
'M' => \&process_max_fax,
'I' => \&process_etrn,
);

# List of valid records follows. To add support for new or unsupported
# record types, just add the type to the list and add a processing
# routine to %process_table. Also change the pattern below where we
# check for the record type we found. The fact that you have to change
# 3 things might indicate that this could be done better...

my @valid_records = ('E','D','Q','Z','S','F','A','R','O','C','X','Y','J','W','M','I');
my %valid_records;
my ($date_printed, $rectype, $last_record, $i);

$debug = $ENV{PMDFLOGPLDEBUG};
print "Debugging is on\n" if $debug;
print ">>> imslog.pl v: 3-MAR-2000\n";

# Initialize the size bins

%size_bins = (
'Less than 2K' => 0,
'2K - 10K' => 0,
'10K - 100K' => 0,
'100K - 1M' => 0,
'1M - 10M' => 0,
'Over 10M' => 0,
);
@bin_names = ('Less than 2K',
'2K - 10K',
'10K - 100K',
'100K - 1M',
'1M - 10M',
'Over 10M',);

@delay_bin_names = ('<2 sec',
'<10 sec',
'<1 min',
'<5 mins',
'<1 hour',
'>1 hour');

@retry_bin_names = ('1st time',
'2nd time',
'<5 times',
'>5 times');

# Construct a hash to use when computing number of retries

$i=25;
for ('A'..'Z') {
$retry_num{$_} = $i--;
}

# Construct a hash of valid record types. This speeds up record type
# validation.
for (@valid_records) {
$valid_records{$_}++;
}

# Keep track of information by day. Even "single day" logs often have
# remnants of the previous day in them.

$last_date = '1-JAN-1900';
$generate_mail_report = 0;
$generate_connection_report = 0;

log_read:
while (<>) {

# Single-digit days have a space prepended. Take it off.
s/^ //;

$line_count++;

# One reasonably consistent feature of the log is that the date and time
# seem to always be the first two fields.
($processing_date, $processing_time, $rest) = split / /o,$_,3;
if (!$date_printed) {
print "\n Log started on $processing_date at $processing_time\n";
$date_printed = 1;
}

# RECORD TYPE CHECK
# We'll assume that a single upper-case character in the set of things
# we regard as valid record types occuring between two spaces is a real
# record type identifier

# PMDF v6.0 change -- record types are no longer always a single
# character. E, D, and Q records can be followed by A (authenticated)
# and/or S (secure)

if (/(\s+)([EDQZSFAROCXYJWMI]|[EDQ][AS]+)(\s+)/o) {
$processing_rectype = $2;
} else {
print "Found an unsupported record type in line $line_count\n";
print "$_\n" if $debug;
next log_read;
}

# Now that we know what the record type is find out what field
# number it is. This is required since we do not know if we have
# to deal with a host and/or a pid. Note we start at 2 because
# we have already pulled off the date and time.
$processing_rectype_fld_no = 2;
find_rectype:
while (1==1) {
$processing_rectype_fld_no++;
($token[$processing_rectype_fld_no],$rest) = split /\s+/io,$rest,2;
if ($token[$processing_rectype_fld_no] eq $processing_rectype)
{last find_rectype;}
if ($processing_rectype_fld_no > 7) {
print "Unknown record type at line $line_count\n";
next log_read;
}
}

$connection_record = 0;
if ($processing_rectype =~ "D") {
# dequeue records have one less field
$processing_inchan = "";
dequeue_field_case: {

if ($processing_rectype_fld_no == 6) {
# both a host name and a pid are present
$processing_host = $token[3];
$processing_pid = $token[4];
$processing_outchan = $token[5];
last dequeue_field_case;}

if ($processing_rectype_fld_no == 4) {
# neither host or pid are present
$processing_host = "";
$processing_pid = "";
$processing_outchan = $token[3];
last dequeue_field_case;}

if ($token[3] =~ /^([a-f0-9]*\.[a-f0-9])/io) {
# looks like a pid, so that is what we guess
$processing_host = "";
$processing_pid = $token[3];
$processing_outchan = $token[4];
last dequeue_field_case;}

# doesn't look like a pid, must be a host
$processing_host = $token[3];
$processing_pid = "";
$processing_outchan = $token[4];
}
} elsif (($processing_rectype eq "Q")
|| ($processing_rectype eq "Z")
|| ($processing_rectype eq "J")
|| ($processing_rectype eq "R")
|| ($processing_rectype eq "W")) {

# delivery attempts have one less field as well
$processing_outchan = "";
dequeue_field_case: {

if ($processing_rectype_fld_no == 6) {
# both a host name and a pid are present
$processing_host = $token[3];
$processing_pid = $token[4];
$processing_inchan = $token[5];
last dequeue_field_case;}

if ($processing_rectype_fld_no == 4) {
# neither host or pid are present
$processing_host = "";
$processing_pid = "";
$processing_inchan = $token[3];
last dequeue_field_case;}

if ($token[3] =~ /^([a-f0-9]*\.[a-f0-9])/io) {
# looks like a pid, so that is what we guess
$processing_host = "";
$processing_pid = $token[3];
$processing_inchan = $token[4];
last dequeue_field_case;}

# doesn't look like a pid, must be a host
$processing_host = $token[3];
$processing_pid = "";
$processing_inchan = $token[4];
}

} else {
$connection_record = 1 if (($processing_rectype eq "O")
|| ($processing_rectype eq "C")
|| ($processing_rectype eq "I")
|| ($processing_rectype eq "X")
|| ($processing_rectype eq "Y"));
field_case: {

if ($processing_rectype_fld_no == 7) {
# both a host name and a pid are present
$processing_host = $token[3];
$processing_pid = $token[4];
if ($connection_record) {
$processing_server = $token[5];
$processing_inchan = "";
$processing_outchan = "";
} else {
$processing_server = "";
$processing_inchan = $token[5];
$processing_outchan = $token[6];
}
last field_case;}

if ($processing_rectype_fld_no == 5) {
# neither host or pid are present
$processing_host = "";
$processing_pid = "";
if ($connection_record) {
$processing_server = $token[3];
$processing_inchan = "";
$processing_outchan = "";
} else {
$processing_server = "";
$processing_inchan = $token[3];
$processing_outchan = $token[4];
}
last field_case;}

if ($token[3] =~ /^([a-f0-9]*\.[a-f0-9])/io) {
# looks like a pid, so that is what we guess
$processing_host = "";
$processing_pid = $token[3];
if ($connection_record) {
$processing_server = $token[4];
$processing_inchan = "";
$processing_outchan = "";
} else {
$processing_server = "";
$processing_inchan = $token[4];
$processing_outchan = $token[5];
}
last field_case;}

# doesn't look like a pid, must be a host
$processing_host = $token[3];
$processing_pid = "";
if ($connection_record) {
$processing_server = $token[4];
$processing_inchan = "";
$processing_outchan = "";
} else {
$processing_server = "";
$processing_inchan = $token[4];
$processing_outchan = $token[5];
}
}
}

if ($connection_record) {
# Get rid of the annoying NULL in IMAP records. Note that this was
# a bug in the logging software, but it does occur in some versions
# of PMDF
$rest =~ s/\0/ /g;
$processing_server =~ s/\0/ /g;
($processing_conninfo, $rest) = split /\s/io,$rest,2;
$processing_size = "";
$generate_connection_report = 1;
} else {
$processing_server = "";
$processing_conninfo = "";
($processing_size, $rest) = split /\s/io,$rest,2;
if (!($processing_inchan =~ /^IMAP/io) &
!($processing_inchan =~ /POP3/io) &
! ($processing_inchan =~ /x400/io)) {
$generate_mail_report = 1;
}
}

# Bump the record type counter (we don't do anything we this, but
# we keep it anyway). Then call the appropriate routine to deal with
# this record.

$rectypes{$processing_rectype}++;

# The hash test is just paranoia; it could be removed. Since we
# checked for a valid record type above, we shouldn't get here unless
# we have a handling routine for this record. Still...

# PMDF v6.0 change -- the substr() fxn is used in case we have a
# D or E record with an A and/or S appended.

if ($valid_records{substr ($processing_rectype, 0, 1)}) {
&{$process_table{substr ($processing_rectype, 0, 1)}};
}
else {
print "There's no processing routine for $processing_rectype records\n";
}
$last_record = $_;
}

$last_record =~ s/^\s+//;
($processing_date, $processing_time, $rest) = split / /o, $last_record;
print " Log ended on $processing_date at $processing_time\n\n";

if ($generate_mail_report) {print_mail_report();}
if ($generate_connection_report) {print_connection_report();}
#
# MAIN PROGRAM ENDS
#

# All the report printing stuff can probably be done better with formats,
# but I read through the format part in the camel book and came away
# baffled. So converting this over to using formats is left as an
# exercise for the reader.

sub print_mail_report {

my ($key, $channel, $avg_delay, $avg_delay_string, $max_delay_string,
$i, $host, $server, $source, $hostname, $msg_total, $header_printed,
$first, $sender, $number, $tmp, $last);
my (@all_servers);
my (%printed);

print "\n\n Enqueue Statistics\n\n";
printf "%15s %8s %14s %8s %14s\n", "Channel","Messages"," ",
"Messages", " ";
printf "%15s %8s %14s %8s %14s\n", " Name ","Q'd from","Size (Kbytes)",
"Q'd to ", "Size (Kbytes)";
printf "%15s %8s %14s %8s %14s\n", '-'x7, '-'x8, '-'x13, '-'x8, '-'x13;

foreach $key (sort keys %in_messages) {
printf "%15s %8d %14d %8d %14d\n",
$key, $in_messages{$key}, $in_size{$key},
($into_chan{$key} ? $into_chan{$key} : 0),
($into_size{$key} ? $into_size{$key} : 0);
$printed{$key} = ' ';
}

# print "\n\n Messages Enqueued to:\n\n";
# printf "%15s %8s %14s\n", "Channel","Messages","Size (Kbytes)";
# printf "%15s %8s %14s\n", '-'x7, '-'x8, '-'x13;
foreach $key (sort keys %into_chan) {
if (!$printed{$key}) {
printf "%15s %8d %14d %8d %14d\n",
$key, 0, 0, $into_chan{$key}, $into_size{$key};
}
}

print "\n\n Dequeue statistics:\n\n";
printf "%15s %8s %14s\n", "Channel","Messages","Size (Kbytes)";
printf "%15s %8s %14s\n", '-'x7, '-'x8, '-'x13;
foreach $key (sort keys %out_messages) {
printf "%15s %8d %14d\n", $key, $out_messages{$key}, $out_size{$key};
}

print "\n\n Secure connections:\n\n";
print "$secure_connections{Auth} connections were authenticated\n";
print "$secure_connections{Secure} connections were secure\n";

print "\n\n Trouble statistics:\n\n";
printf "%15s %13s\n", "Channel", "Retry Entries";
printf "%15s %13s\n", '-'x7, '-'x13;
foreach $key (sort keys %failed_messages) {
printf "%15s %13d\n", $key, $failed_messages{$key};
}

print "\n Top 10 requeues by domain/user:\n\n";
printf " %11s %35s\n", 'Domain/User', 'Num Retries';
printf " %11s %35s\n", '-'x11, '-'x11;
$i = 1;
foreach $key (sort bynum keys %bad_domains) {
printf " %-35.35s %d\n", $key, $bad_domains{$key};
last if $i++ == 10;
}

if (keys %rejected_messages) {
print "\n\n Rejected Messages \n\n";
printf "%15s %14s\n", "Channel", "Reject Entries";
printf "%15s %14s\n", '-'x7, '-'x14;
foreach $key (sort keys %rejected_messages) {
printf "%15s %14d\n", $key, $rejected_messages{$key};
}
}

if (keys %warning_cnt) {
print "\n\n Warnings \n\n";
printf "%15s %14s\n", "Channel", "Warnings";
printf "%15s %14s\n", '-'x7, '-'x14;
foreach $key (sort keys %warning_cnt) {
printf "%15s %14d\n", $key, $warning_cnt{$key};
}
}

if ($printer_successes || $mailserv_successes ||
$printer_failures || $mailserv_failures) {
print "\n\n Mailserv, Pager, and Printer Channels:\n\n";

print " There were $printer_successes successful uses of the printer channel\n"
if $printer_successes;

print " There were $printer_failures attempts to use the printer channel that failed\n"
if $printer_failures;

print " There were $pager_successes successful uses of pager channels\n"
if $pager_successes;

print " There were $pager_failures attempts to use pager channels that failed\n"
if $pager_failures;

if ($mailserv_successes) {
print " There were $mailserv_successes successful uses of the mailserv channel\n";
printf " Users were from %d different domains. Top 10 domains follow.\n\n", scalar keys %mailserv_users;
printf " %6s %40s\n", 'Domain', 'Num Accesses';
printf " %6s %40s\n", '-'x6, '-'x12;
$i=1;
foreach $key (sort byuse keys %mailserv_users) {
printf " %-35.35s %d\n", $key, $mailserv_users{$key};
last if $i++==10;
}
}
print "\nThere were $mailserv_failures attempts to use the mailserv channel that failed\n"
if $mailserv_failures;
}

if ($fax_successes || $fax_failures || $fax_max_failures) {
print "\n FAX Summary\n\n";
}
if ($fax_failures > 0) {
printf "%4s %4s %-60s\n",
" ", $fax_failures, "delivery attempts by FAX channels failed.";
}
if ($fax_max_failures > 0) {
printf "%4s %4s %-60s\n",
" ", $fax_max_failures, "FAXes exceeded the maximum number of delivery attemps.";
}
if ($fax_successes > 0) {
printf "%4s %4s %-60s\n",
" ", $fax_successes, "FAXes were successfully delivered.";

# Uncomment the following if you want more fax details
# print "\n";
# printf "%7s %32s %6s %-24s\n",
# " ", "Source", "Count", "Destination";
# printf "%7s %32s %6s %-24s\n",
# " ", "-"x32, "-"x6 , "-"x24;
# foreach $sender (sort keys %fax_destinations) {
# $last = " ";
# foreach $number (keys %{$fax_destinations{$sender}}) {
# $tmp = $sender;
# if ($sender eq $last) {$tmp = " ";}
# printf "%7s %32s %6s %-24s\n",
# " ", $sender, $fax_destinations{$sender}{$number}, $number;
# $last = $sender;
# }
# }

# comment the following if you are printing more fax details
$i=1;
print "\n";
printf "%7s %s\n\n", " ", "Top 10 FAX users where:";
printf "%7s %32s %6s\n",
" ", "Source", "Count";
printf "%7s %32s %6s\n",
" ", "-"x32, "-"x6;
foreach $key (sort byfaxsource keys %fax_senders) {
printf "%7s %32s %6s\n",
" ", $key, $fax_senders{$key};
last if $i++ == 10;
}

}

print "\n\n Messaging Summary \n\n";
print " $total_dequeues messages were dequeued. Total size was $total_dequeue_size Kbytes\n";

print "\n Message sizes:\n\n";
foreach $key (@bin_names) {
printf " %12.12s: %d\n", $key, $size_bins{$key};
}

$i=1;
foreach $key (sort bycount keys %giant_messages) {
if ($i == 1) {
print "\n Top 10 sources of large messages (>1M)\n\n";
printf " %6s %57s\n", 'Originator', 'Num Enqueues';
printf " %6s %57s\n", '-'x10, '-'x12;
}
printf " %-55.55s %d\n", $key, $giant_messages{$key};
last if $i++ == 10;
}

print "\n\n Message load by channel (dequeues):\n\n";
printf "%15s %8s\n", "Channel","% of dequeues";
printf "%15s %8s\n", '-'x7, '-'x13;
foreach $key (sort {$out_messages{$b} <=> $out_messages{$a}}
keys %out_messages) {
printf "%15s %5.2f%%\n", $key, ($out_messages{$key}/$total_dequeues)*100.00;
}
printf "\n\n Message load by day (dequeues):\n\n";
printf "%15s %8s\n", "Date ","# of dequeues";
printf "%15s %8s\n", '---- ', '-'x13;
while ($tmp = pop @all_dates) {
printf "%15s %8d\n", $tmp, $dequeues_by_date{$tmp};
}

print "\n\n Message load by hour (dequeues):\n\n";
printf "%15s %8s %15s %8s\n",
"Hour ","# of dequeues","Hour ","# of dequeus";
printf "%15s %8s %15s %8s\n",
'---- ','-------------','---- ','------------';
for ($i=0; $i<12; $i++) {
printf "%10.2d %11d %17.2d %11d\n", $i, $dequeues_per_hour[$i],
$i+12, $dequeues_per_hour[$i+12];
}

printf "\n\n Message delays (time from enqueue to dequeue):\n\n";
printf " %14.14s %7.7s %7.7s %7.7s %7.7s %7.7s %7.7s %7.7s\n",
"Channel ","<2 sec ","<10 sec","<1 min ","<5 mins","<1 hour",">1 hour","Max ";
printf " %14.14s %7.7s %7.7s %7.7s %7.7s %7.7s %7.7s %7.7s\n",
'-'x14,'-'x7,'-'x7,'-'x7,'-'x7,'-'x7,'-'x7,'-'x7;
foreach $channel (sort keys %delay_bins_chan) {
printf " %14.14s", $channel;

# We print out a percentage, so total up the number of messages first
# then compute the percentage of the total in a second loop

$msg_total = 0;
foreach $key (@delay_bin_names) {
$msg_total += $delay_bins_chan{$channel}{$key};
}
foreach $key (@delay_bin_names) {
printf " %5.1f%% ", ($delay_bins_chan{$channel}{$key}/$msg_total)*100;
}
if ($max_chan_delay{$channel} > 3600) {
$max_delay_string = sprintf "%2.2f hours", $max_chan_delay{$channel}/3600;
}
elsif ($max_chan_delay{$channel} > 60) {
$max_delay_string = sprintf "%2.2f mins", $max_chan_delay{$channel}/60;
}
else {
$max_delay_string = sprintf "%d secs", $max_chan_delay{$channel};
}
print " $max_delay_string\n";
}

printf "\n\n Message transit times\n Time from enqueue to dequeue, top 20 hosts by total transit time):\n\n";
printf " %14.14s %7.7s %7.7s %7.7s %7.7s %7.7s %7.7s %7.7s\n",
"Host ","<2 sec ","<10 sec","<1 min ","<5 mins","<1 hour",">1 hour","Max ";
printf " %14.14s %7.7s %7.7s %7.7s %7.7s %7.7s %7.7s %7.7s\n",
'-'x14,'-'x7,'-'x7,'-'x7,'-'x7,'-'x7,'-'x7,'-'x7;
$i = 1;
foreach $host (sort bydelay keys %total_host_delay) {
last if $i++ == 20;
printf " %s\n %14.14s", $host, ' 'x14;
$msg_total = 0;
foreach $key (@delay_bin_names) {
$msg_total += $delay_bins_host{$host}{$key};
}
foreach $key (@delay_bin_names) {
printf " %5.1f%% ", ($delay_bins_host{$host}{$key}/$msg_total)*100;
}
if ($max_host_delay{$host} > 3600) {
$max_delay_string = sprintf "%2.2f hours", $max_host_delay{$host}/3600;
}
elsif ($max_host_delay{$host} > 60) {
$max_delay_string = sprintf "%2.2f mins", $max_host_delay{$host}/60;
}
else {
$max_delay_string = sprintf "%d secs", $max_host_delay{$host};
}
print " $max_delay_string\n";
}

print "\n\n Retry counts\n\n";
printf " %14.14s %9.9s %9.9s %9.9s %9.9s\n",
"Channel ","1st time ","2nd time ","<5 times ",">5 times ";
printf " %14.14s%9.9s %9.9s %9.9s %9.9s\n",
'-'x14,'-'x8,'-'x8,'-'x8,'-'x8;
foreach $channel (sort keys %retries_done) {
printf " %14.14s", $channel;
foreach $key (@retry_bin_names) {
printf "%9d ", $retries_done{$channel}{$key};
}
print "\n";
}

}

sub print_connection_report {

my ($key, $channel, $avg_delay, $avg_delay_string, $max_delay_string,
$i, $host, $server, $source, $hostname, $msg_total, $header_printed,
$first, $sender, $number, $tmp, $last);
my (@all_servers);
my (%printed);

print "\n\n >> Server Summary <<\n\n";

print "\n\n Connections:\n\n";
printf " %-15.15s %-6.6s %-6.6s %-8.8s %-6.6s\n", "Server", "Opened",
"Closed", "Rejected", "Failed";
printf " %-15.15s %-6.6s %-6.6s %-8.8s %-6.6s\n",
'-'x6, '-'x6, '-'x6, '-'x8, '-'x6;
foreach $key (keys %conn_open) {
next if grep /$key/, @all_servers;
push @all_servers, $key;
}
foreach $key (keys %conn_close) {
next if grep /$key/, @all_servers; # had to do this to grep
# a '+', may miss other keys?
push @all_servers, $key;
}
foreach $key (keys %conn_reject) {
next if grep /$key/, @all_servers;
push @all_servers, $key;
}
foreach $key (keys %conn_failed) {
next if grep /$key/, @all_servers;
push @all_servers, $key;
}

foreach $server (@all_servers) {
printf " %-15.15s %6d %6d %8d %6d\n", $server,
(exists $conn_open{$server}) ? $conn_open{$server} : 0,
(exists $conn_close{$server}) ? $conn_close{$server} : 0,
(exists $conn_reject{$server}) ? $conn_reject{$server} : 0,
(exists $conn_failed{$server}) ? $conn_failed{$server} : 0;
}

if ($etrn_count) {
print "\n ERTN request sources:\n\n";
printf " %6s %-17s %-48s\n",
"Count", " Source IP", "Requested Domain";
printf " %6s %-17s %-48s\n",
'-'x6, '-'x17, "-"x48;
foreach $source (sort keys %etrn_domains) {
foreach $tmp (sort keys %{$etrn_domains{$source}}) {
printf " %6s %-17s %-48s\n",
$etrn_domains{$source}{$tmp}, "[".$source."]", $tmp;
}
}
}

$first = 1;
foreach $server (sort keys %conn_open_source) {
print "\n Connection open sources:\n" if $first;
$first = 0;
print "\n $server\n";
printf " %s\n", '-' x length($server);
# if ($^O eq "VMS") {
# foreach $source (sort keys %{$conn_open_source{$server}}) {
# print " [$source]: \t$conn_open_source{$server}{$source}\n";
# }
# } else {
foreach $source (sort keys %{$conn_open_source{$server}}) {
$hostname = gethostbyip ($source);
printf (" %17.17s %-32s %7s\n", "[".$source."]", $hostname,
$conn_open_source{$server}{$source});
# }
}
}

$first = 1;
foreach $server (sort keys %conn_close_source) {
print "\n\n Connection close sources:\n" if $first;
$first = 0;
print "\n $server\n";
printf " %s\n", '-' x length($server);
# if ($^O eq "VMS") {
# foreach $source (sort keys %{$conn_close_source{$server}}) {
# print " [$source]: \t$conn_close_source{$server}{$source}\n";
# }
# } else {
foreach $source (sort keys %{$conn_close_source{$server}}) {
$hostname = gethostbyip ($source);
printf (" %17.17s %-32s %7s\n", "[".$source."]", $hostname,
$conn_close_source{$server}{$source});
# }
}
}

$first = 1;
foreach $server (sort keys %conn_reject_source) {
print "\n Connection reject sources:\n" if $first;
$first = 0;
print "\n $server\n";
printf " %s\n", '-' x length($server);
# if ($^O eq "VMS") {
# foreach $source (sort keys %{$conn_reject_source{$server}}) {
# print " [$source]: \t$conn_reject_source{$server}{$source}\n";
# }
# } else {
foreach $source (sort keys %{$conn_reject_source{$server}}) {
$hostname = gethostbyip ($source);
printf (" %17.17s %-32s %7s\n", "[".$source."]", $hostname,
$conn_reject_source{$server}{$source});
# }
}
}

$first = 1;
foreach $server (sort keys %conn_fail_source) {
print "\n Connection fail sources:\n" if $first;
$first = 0;
print "\n $server\n";
printf " %s\n", '-' x length($server);
# if ($^O eq "VMS") {
# foreach $source (sort keys %{$conn_fail_source{$server}}) {
# print " [$source]: \t$conn_fail_source{$server}{$source}\n";
# }
# } else {
foreach $source (sort keys %{$conn_fail_source{$server}}) {
$hostname = gethostbyip ($source);
printf (" %17.17s %-32s %7s\n", "[".$source."]", $hostname,
$conn_fail_source{$server}{$source});
# }
}
}
}

# Utility routines follow

# timeinsecs takes a date and time as found in the log file (nn-MMM-yyyy)
# and (hh:mm:ss) and computes a seconds since 1970 value

sub timeinsecs {
my $date = shift;
my $time = shift;
my ($hours, $mins, $secs, $day, $mon, $year, $monthnum, $computed_time);

my %monthnums = ("JAN" => 0,
"FEB" => 1,
"MAR" => 2,
"APR" => 3,
"MAY" => 4,
"JUN" => 5,
"JUL" => 6,
"AUG" => 7,
"SEP" => 8,
"OCT" => 9,
"NOV" => 10,
"DEC" => 11);

($hours, $mins, $secs) = split /:/, $processing_time;
# truncate any fractional seconds
$secs =~ s/\..*//;
($day, $mon, $year) = split /-/, $processing_date;
$monthnum = $monthnums{$mon};

if ($day < 1 or $day > 31) {
print "Found bogus day $day at line $line_count\n";
$day = 1;
}
$computed_time = timelocal($secs, $mins, $hours, $day, $monthnum, $year);

return $computed_time;
}

# gethostbyip takes a dot-separated IP address (10.20.30.40) as an
# argument and returns the associated host name

sub gethostbyip {
my $ipaddr = shift;
my ($a, $b, $c, $d, $hostname);

($a, $b, $c, $d) = split /\./, $ipaddr;
$hostname = gethostbyaddr (pack ("c4", $a,$b,$c,$d), 2);
if ($hostname) {
return $hostname;
} else {
return "Unknown";
}
}

# A couple of comparison routines to use in sorts:

sub bynum {
$bad_domains{$b} <=> $bad_domains{$a}
or
$a cmp $b;
}
sub byuse {
$mailserv_users{$b} <=> $mailserv_users{$a}
or
$a cmp $b;
}
sub bydelay {
$total_host_delay{$b} <=> $total_host_delay{$a}
or
$a cmp $b;
}
sub bycount {
$giant_messages{$b} <=> $giant_messages{$a}
or
$a cmp $b;
}
sub byfaxsource {
$fax_senders{$b} <=> $fax_senders{$a}
or
$a cmp $b;
}