procmail-lib 1:2009.1202-2 / usr / bin / proclint

#!/usr/bin/perl
#
# proclint [-[no]list] [-[no]includerc] [-procmailrc] rcfiles ...
#
# Copyright
#
#	Copyright (C) 2006-2010 Jari Aalto <jari.aalto@cante.net>
#	Copyright (C) 1995-2010 Alan Stebbens <aks@sgi.com>
#
# License
#
#	This program is free software; you can redistribute it and/or
#	modify it under the terms of the GNU General Public License as
#	published by the Free Software Foundation; either version 2 of the
#	License, or (at your option) any later version
#
#	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 at
#	Visit <http://www.gnu.org/copyleft/gpl.html>.
#
# Description by Alan Stebbens
#
#	By default, -noincluderc and -nolist are set.
#
#	Because debugging procmailrc scripts is difficult
#	I try to encode checks into this script.
#
#	If -list given, list all lines of the recipe, numbered, and
#	with levels and a type flag character.
#
#	Current errors caught:
#
#	'{' and '}' nesting errors.
#	Missing '*' on conditions
#	Lines which aren't recipes or assignments
#	Unterminated recipes

my($DIR,$PROG)	= $0 =~ m,^(.*/)?([^/]+)$,;
$DIR		=~ s,/$,, || chomp($DIR = qx(pwd));
my $FH_TEMPLATE = 'fh00';
my $ERROR       = 0;
$|		= 1;

sub Usage (;$)
{
    my $code = shift || 0;

    print <<"EOF"; exit $code;
usage: $PROG [options] <rcfiles ...>
Check procmail rc files for proper syntax, recipe nesting, etc.
Options (default are marked with '*'):

    -h, --help         This message
    -i, --includerc    Scan and possibly list files included with INCLUDERC
    -I, --noinclude*   Do not scan INCLUDERC references
    -l, --list         List lines in the procmail recipe files.
    -L, --nolist*      Do not list lines, except for errors.
    -p, --procmailrc   Check \$HOME/.procmailrc

The output consists of: 'LINE-NUMBER:FLAG:DEPTH: text'.
FLAG is one of:

    'R'         recipe
    'C'         condition
    'A'         action (redirect, '!', or pipe, '|')
    'F'         folder
    '='         assignment
    '+'         continuation
    'E'         *line may be erroneous*

DEPTH indicates the depth of the recipe nesting and is shown only
when greater than zero.
EOF
}

sub Untab ($)
{
    local $_ = shift;

    while (($x = index($_,"\t")) >= $[)
    {
        substr($_,$x,1) = " " x (((($x / 8) + 1) * 8) - $x)
    }

    $_;
}

sub Eval
{
    my $val = shift;

    while( ( $val =~ /\$(\w+)/ ) )
    {
        if( defined( $Assigns{$1} ) )
	{
            $val = $` . $Assigns{$1} . $';
        }
        elsif( defined( $ENV{$1} ) )
        {
            $val = $` . $ENV{$1} . $';
        }
	else
	{
            $val = $` . $';     # omit the variable -- it's empty
        }
    }

    $val;
}

sub Scan ($; $$);

sub Scan ($; $$)
{
    my $file      = shift;
    my $fileLevel = shift || 0;
    my $mainLevel = shift || 0;

    return if $Scanned{$file};

    $Scanned{$file}++;

    my($type, $count, $conditions, $var, $val);
    my($includefile, $depth);
    my($level) = $mainLevel;
    local $_;

    unless ($quiet)
    {
        print "\n" if $listlines;
        print (" " x $fileLevel);
        print "Scanning file $file:";
    }

    local($FH) = $FH_TEMPLATE++;

    open( $FH , $file )  or  do
    {
        print "Can't open $file: $!\n";
	$ERROR = 1;
        return;
    };

    print "\n" unless $quiet;
    my $recipe		= '';
    my $errs		= '';
    my $continuation	= '';
    my $line		= '';

    while( <$FH> )
    {
        chomp;

        $_ = Untab $_ if /\t/;

        if( $continuation )
	{
            $line .= "\n".$_;
            $_     = $line;
            $line  = '';
            $continuation = '';
        }

        if( /\\$/ )
	{				# continuation?
            $continuation = 1;
            chop;			# remove the trailing slash
            $line = $_;			# make the continuation
            next;
        }

        $type = ' ';

        if( /^\s*\#/  or  /^\s*$/ )
	{			      # ignore comments or blank lines
            $type = ' ';
            $_ = ' ' unless length;
        }
        elsif( ! $recipe  or  /^\s*:/) # are we looking for a recipe?
	{
            # This is a state driven scanner
            # State     Parse   Next    What
            #   0        :       1      Start recipe parse
            #   1        *       1      Parse condition
            #   1    !   0      Parse redirect
            #   1        |       0      Parse pipe
            #   1    {   0      Increment recipe level, parse sub-recipe
            #   1        <other> 0      Parse filename path

            if( /^\s*:\s*(\S.*)?/ )	# recipe start?
	    {
                $flags = $1;    # get flags
                $count = $flags =~ /^(\d+)/ ? $1 :
                         $flags =~ /[eEaA]/ ? 0 : 1;
                $recipe = $.;   # we're in a recipe
                $conditions = 0;
                $type = 'R';    # set the type
            } elsif( /^\s*}/ )	# end of a nested recipe?
	    {
                $level--;
                $type = 'R';

                if ($level < 0)
		{
                    $errs .= "Too many close brackets!\n";
                    $level = 0;
                }
            }
	    elsif( /^\s*(\w+)\s*=\s*(\S.*)?/ )  # an assignment?
	    {
                $type = '=';                    # assignment
                ($var,$val) = ($1,$2);

                if( $includerc )
		{
                    $Assigns{$var} = $val;

                    if( $var eq 'INCLUDERC' )
		    {
                        $newfile = Eval $val;

                        if( $newfile && -f $newfile )
			{
                            $includefile = $newfile;
                        }
			elsif ( $newfile )
			{
                            $errs .= "Included file \"$newfile\" does not exist.\n";
                        }
                    }
                }
            }
	    elsif( /^\s*(\w+)\s*$/ )	# an un-assignment?
	    {
                $type = '=';		# unassignment
            }
	    else
	    {
                $errs .= "Bad recipe line: \"$_\"\n";
                $type = 'E';
            }
        }
	else
	{
            if( /^\s*\*/ )		# a condition?
	    {
                $conditions++;
                $type = 'C';		# condition
                $count--;
            }
	    elsif ( /^\s*!/ && $count <= 0) # a redirection?
	    {
                $recipe = '';   # an action, we're out of the recipe
                $type = 'A';    # Action
            }
	    elsif ( /^\s*\|/ )	# a pipe?
	    {
                $recipe = '';   # another action
                $type = 'A';    # Action
            }
	    elsif ( /^\s*{/ )		# a subrecipe
	    {
                $level++;		# increment the level
                $recipe = '';		# and we're out of the recipe
                $type = 'A';		# Action
                $level-- if /\s+}/;     # decrement count if one-liner
            }
	    elsif ( --$count >= 0 && !/^\s*[\|{]/) # more conditions?
	    {
                $conditions++;
                $type = 'C';		# assume condition
            }
	    else			# default is path
	    {
                $type = 'F';    # folder

                # make reasonable mistake guess
                if ( /^\s*[\#*(){}|!?]|^\s*\w+ \w+/ )
		{
                    $errs .= "Possibly bad folder name?\n";
                }

                $recipe = '';
            }
        }

      Print:
        if ( $listlines  or  $errs )
	{
            @lines = split /\n/;
            $depth = $level > 0 ? sprintf("<%d>",$level) : "   ";

            while ($_ = shift(@lines))
	    {
                print (" " x $fileLevel);
                $_ .= "\\" if @lines;
                printf "%3d:%1s%s %s\n",$.,$type,$depth,$_;
                $type = '+';
            }
        }

        if( $errs )
	{
            print $errs;
            $ERROR = 1;
            $errs = '';
        }

        if ($includefile)
	{
            Scan( $includefile, $fileLevel + 1, $level );

            unless ($quiet)
	    {
                print "\n" if $listlines;
                print (" " x $fileLevel);
                print "Back to file $file:\n";
            }

            $includefile = '';
        }
    }

    if ($recipe)
    {
        print "$file: EOF: recipe at line $recipe never terminated.\n";
        $ERROR = 1;
    }

    if ($level > $mainLevel)
    {
        print "$file: EOF: Unterminated nested recipies.\n";
        $ERROR = 1;
    }

    close $FH;
}

sub Main ()
{
    unless ($#ARGV >= $[)
    {
	Usage 1;
    }

    while( $_ = shift @ARGV )
    {
	if ( /^(-h|--help)/ )
	{
	    Usage;
	}
	elsif (  /^(-l|--list)/ )
	{
	    $listlines++;
	}
	elsif ( /^(-L|--nolist)/ )
	{
	    $listlines = '';
	}
	elsif ( /^(-i|--includerc)/ )
	{
	    $includerc++;
	}
	elsif ( /^(-I|--noincluderc)/ )
	{
	    $includerc = '';
	}
	elsif ( /^(-p|--procmailrc)/ )
	{
	    $HOME = $ENV{'HOME'} || (getpwuid($>))[7];
	    push(@ARGV,"$HOME/.procmailrc");
	}
	elsif ( /^-/ )
	{
	    print "Unknown option: '$_'\n";
	    next;
	}
	else
	{
	    Scan $_;
	}
    }

    return $ERROR;
}

Main();

# End of file