#!/usr/bin/perl -w
#
# mtrack
# John Simpson <jms1@jms1.net> 2005-07-18
# Original: John Simpson <jms1@jms1.net> 1998-05-01
#
# reads qmail-send's log and gathers the lines pertaining to each message,
# allowing much easier tracking of messages as they go through the queue.
#
# 2005-07-18 jms1 - found this ancient script laying around and decided to
#     clean it up. what a trip down memory lane this is...
#   - removing old pattern-matching function- it makes more sense to grep
#     through this script's output.
#   - turned out to be easier to re-write than it was to try and bring the
#     old code up to date.
#
# 2005-11-07 jms1 - clarified timestamp removal code,
#   added the ability to (hopefully) read syslog-formatted lines
#
# 2009-06-01 jms1 - now that i'm using this script on a regular basis again,
#   i think having pattern-matching code within the program is pretty much a
#   necessity. adding "-p" option.
#
# 2009-11-15 jms1 - cleaning up the code, adding "-h" to show options
#
###############################################################################
#
# Copyright (C) 1998-2005,2009 John Simpson.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License, version 2, as
# published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
# or visit http://www.gnu.org/licenses/gpl.txt
#
###############################################################################

require 5.003 ;
use strict ;

use Getopt::Std ;

my $do_debug = 0 ;

my ( %mtext , %dmesg , %bouncing , %bqp , %opt , $pat ) ;

###############################################################################
#
# show usage

sub usage()
{
	print <<EOF ;
$0 [options] [inputfile [...]]

Reads qmail-send log lines from specified input file(s) (or from standard
input if no files are specified.) Prints the same lines to standard output,
grouped by which message they pertain to.

Options:

-d	Show debug messages.

-h	Show this help message.

-i	Pattern matching is NOT case-sensitive.

-p ___	Only show log line groups which contain this regular expression.
	Note that you may need to quote some regular expressions in order
	to keep the shell from trying to interpret them. Only one regular
	expression may be specified. If no pattern is specified, all groups
	will be shown.

-s	Show a "-------" line before showing any un-delivered messages.

-u	When all input log lines have been read, the log lines for any
	un-delivered messages (i.e. messages which are still in the queue,
	which haven't been fully delivered yet) will still be in memory.
	The program will print a "-------" line, followed by these groups.
	Normally the program will only show those groups which contain the
	search pattern, this option makes it show all un-delivered messages.

EOF
	exit 0 ;
}

###############################################################################
#
# debug routine

sub debug
{
	$do_debug && ( print @_ ) ;
}

###############################################################################
#
# function to MAYBE print a given set of log lines

sub maybe_show($;$)
{
	my $text  = shift ;
	my $force = ( shift || 0 ) ;

	if ( $force )
	{
		print $text , "\n" ;
	}
	elsif ( $pat )
	{
		if ( $opt{"i"} )
		{
			if ( $text =~ /$pat/i )
			{
				print $text , "\n" ;
			}
		}
		else
		{
			if ( $text =~ /$pat/ )
			{
				print $text , "\n" ;
			}
		}
	}
	else
	{
		print $text , "\n" ;
	}
}

###############################################################################
###############################################################################
###############################################################################
#
# get options
#
# -d	debug
# -h	help
# -i	case-INsensitive pattern matching
# -p___	pattern to match.
# -u	show all incomplete messages regardless of pattern match

getopts ( 'dhip:u' , \%opt ) ;
$opt{'h'} && usage() ;

$do_debug = ( $opt{'d'} ? 1 : 0 ) ;
$pat = ( $opt{'p'} || "" ) ;

while ( my $line = <> )
{
	my $oline = $line ;
	chomp $line ;

	my @w = split ( /\s+/ , $line ) ;

	########################################
	# ignore timestamp

	if ( $line =~ /^[A-Z]/ )		# syslog timestamp
	{
		shift @w ;
		shift @w ;
		shift @w ;
		shift @w ;
	}
	elsif ( $line =~ /^[0-9]/ )		# tai64nlocal output
	{
		shift @w ;
		shift @w ;
	}
	elsif ( $line =~ /^\@/ )		# raw multilog output
	{
		shift @w ;
	}

	########################################
	# process the line

	debug "[$line]\n" ;

	if ( $w[0] eq "new" )
	{
		# new msg {mmm}

		$mtext{$w[2]} .= $oline ;
	}
	elsif ( $w[0] eq "info" )
	{
		# info msg {mmm}: bytes {ccc} from <{sender}> qp {qqq} uid {?}

		$w[2] =~ s/\:// ;
		$mtext{$w[2]} .= $oline ;

		$line =~ / qp (\d+)/ ;
		my $q = ( $1 || 0 ) ;

		my $z = ( $bqp{$q} || "" ) ;
		debug "[-- \$bqp{$q}=[$z] --]\n" ;

		if ( $q && $bqp{$q} )
		{
			$mtext{$w[2]} = $mtext{$bqp{$q}} . $mtext{$w[2]} ;
			delete $mtext{$bqp{$q}} ;
			delete $bqp{$q} ;
		}
	}
	elsif ( $w[0] eq "starting" )
	{
		# starting delivery {ddd}: msg {mmm} to {local/remote} {recip}

		$w[2] =~ s/\:// ;
		$dmesg{$w[2]} = $w[4] ;
		$mtext{$w[4]} .= $oline ;
	}
	elsif ( $w[0] eq "delivery" )
	{
		# delivery {ddd}: {success/failure/deferral}: ...

		$w[1] =~ s/\:// ;
		my $m = ( $dmesg{$w[1]} || "" ) ;
		$mtext{$m} .= $oline ;
	}
	elsif ( $w[0] eq "end" )
	{
		# end msg {mmm}

		$mtext{$w[2]} .= $oline ;

		if ( ( exists $bouncing{$w[2]} ) && ( exists $bqp{$bouncing{$w[2]}} ) )
		{
			my $qp = $bouncing{$w[2]} ;

			debug "[-- \$qp=[$qp] \$bqp{$qp}=$bqp{$qp} --]\n" ;

			$mtext{$bqp{$qp}} = $mtext{$w[2]} ;

			debug "[-- \$mtext{$bqp{$qp}} = $mtext{$bqp{$qp}} --]\n" ;
		}
		else
		{
			maybe_show ( $mtext{$w[2]} ) ;
		}

		delete $mtext{$w[2]} ;
	}
	elsif ( $w[0] eq "bounce" )
	{
		# bounce msg {mmm} qp {qqq}

		$bqp{$w[4]} = "b" . $w[2] ;
		$bouncing{$w[2]} = $w[4] ;

		$mtext{$w[2]} .= $oline ;

		debug "[-- \$bqp{$w[4]} = [$bqp{$w[4]}] --]\n" ;
	}
	elsif ( $w[0] eq "triple" )
	{
		# triple bounce: discarding bounce/{mmm}

		$w[3] =~ s/bounce\/// ;
		$mtext{$w[3]} .= $oline ;
	}
}

my @zk = sort keys %mtext ;
if ( $#zk > -1 )
{
	$opt{'s'} && ( print "-" x 79 , "\n\n" ) ;

	map { maybe_show ( $mtext{$_} , $opt{'u'} ) } @zk ;
}