File Coverage

blib/lib/Mail/Procmailrc.pm

Criterion	Covered	Total	%
statement	314	336	93.4
branch	154	180	85.5
condition	12	15	80.0
subroutine	45	47	95.7
pod	14	18	77.7
total	539	596	90.4

## Scott Wiersdorf
## Created: Thu Jan 24 11:29:59 MST 2002
## $Id: Procmailrc.pm,v 1.12 2002/07/30 17:59:19 scottw Exp $

##################################
package Mail::Procmailrc;
##################################

use strict;
use Carp qw(carp);

use vars qw( $VERSION $Debug %RE );

$VERSION = '1.09';
$Debug   = 0;
%RE      = (
	    'flags'    => qr/^\s*:0/o,                   ## flags
	    'flagsm'   => qr/^\s*(:0.*)$/o,              ## flags match
	    'var'      => qr/^\s*[^#\$=]+=.*/o,          ## var
	    'varm'     => qr/^\s*([^#\$=]+=.*)$/o,       ## var match
	    'varmlq'   => qr/^[^\"]+=[^\"]*"[^\"]*$/so,  ## var multiline quote
	    'blklinem' => qr/^\s*\{\s*(.*?)\s*\}\s*$/o,  ## block line match
	    'blkopen'  => qr/^\s*\{/o,                   ## block open
	    'blkclose' => qr/^\s*\}/o,                   ## block close
	    'blank'    => qr/^\s*$/o,                    ## blank line
	    'cont'     => qr/\\$/o,                      ## continuation
	    'comt'     => qr/^\s*\#/o,                   ## comment
	    'comm'     => qr/^\s*(\#.*)$/o,              ## comment match
	    'condm'    => qr/^\s*(\*.*)$/o,              ## condition match
	   );

sub new {
    my $self = bless { }, shift;
    my $data = shift;

    $self->init($data);
    return $self;
}

sub init {
    my $self = shift;
    my $data = shift;

    ## initialize data array
    $self->rc([]);   ## our internal keeper of the data

    #########################################
    ## set parameters
    #########################################

    ## named parameters
    if( 'HASH' eq ref($data) ) {
	$self->read( $data->{'file'} );
	$self->level( $data->{'level'} );
	$self->parse( $data->{'data'} ) if $data->{'data'};
    }

    ## just a filename
    else {
	$self->read($data);
    }

    return 1;
}

sub read {
    my $self = shift;
    my $file = shift;

    ## reset file
    return unless $file = $self->file($file);
    return unless -f $file;

    ## FIXME: advisory lock here?
    open FILE, $file
      or do {
	  carp( "Error reading file '$file': $!\n" );
	  return;
      };

    ## FIXME: this is bad... Should pass in a typeglob instead...
    $self->parse( [] );
    close FILE;
}

sub parse {
    my $self = shift;
    my $data = shift;  ## this may be a string or array reference
    my @data = ();     ## chunks to hand off to object creators

    ## state
    my %ST      = ( FILE     => 0,  0 => 'FILE',
		    VARIABLE => 1,  1 => 'VARIABLE',
		    RECIPE   => 2,  2 => 'RECIPE',
		    LITERAL  => 3,  3 => 'LITERAL',
		);
    my @state = ( $ST{FILE} );

    ## initialize our data
    $self->rc([]);

    ## make sure we're using an array reference
    if( 'ARRAY' eq ref($data) ) {
	chomp @$data;
    }
    else {
	## we don't know how to handle other kinds of refs here
	return if ref($data);

	## split the data (implicit chomping)
	$data = [split(/\n/, $data)];
    }

    ## this is the procmailrc parser
    my $line;
    while( defined ($line = shift @$data) ) {
	gubed( "LINE: $line" );

	## block line gets rewritten (but noted with $obj->blockline(1))
	if( $line =~ s/$RE{'blklinem'}/$1/ ) {
	    ## if $line is now an empty line (or whitespace only),
	    ## we'll take that into consideration in the blank line
	    ## case below
	    $self->blockline(1);
	}

	## found a recipe
	if( $line =~ s/$RE{'flagsm'}/$1/ ) {
	    unshift @$data, $line;
	    $self->push( Mail::Procmailrc::Recipe->new($data, {'level' => $self->level} ) );
	}

	## found a variable assignment
	elsif( $line =~ s/$RE{'varm'}/$1/ ) {
	    unshift @$data, $line;
	    $self->push( Mail::Procmailrc::Variable->new($data, {'level' => $self->level}) );
	}

	## a comment between chunks
	elsif( $line =~ /$RE{'comm'}/ ) {
	    $self->push( Mail::Procmailrc::Literal->new($line, {'level' => $self->level}) );
	}

	## completely blank line
	elsif( $line =~ /$RE{'blank'}/ ) {
	    ## if the next line is blank too...
	    if( defined $data->[0] && $data->[0] =~ /$RE{'blank'}/ ) {
		## skip blank lines (unless this line is a block line)
		next unless $self->blockline;
	    }
	    $self->push( Mail::Procmailrc::Literal->new($line, {'level' => $self->level}) );
	}

	## open block triggers special behavior for the object
	elsif( $line =~ /$RE{'blkopen'}/ ) {
	    $self->push( Mail::Procmailrc::Literal->new($line, {'level' => $self->level}) );
	    $self->level($self->level + 1);
	}

	## close block triggers special behavior for the object
	elsif( $line =~ /$RE{'blkclose'}/ ) {
	    $self->level($self->level - 1);
	    $self->push( Mail::Procmailrc::Literal->new($line, {'level' => $self->level}) );
	    last;
	}

	## something else
	else {
	    ## do nothing? Could push a literal here...
	}

	## bail if we only expected one line
	last if $self->blockline;
    }

    return 1;
}

## FIXME: should be checks here for array refs/lists
sub rc {
    my $self = shift;
    my $data = shift;

    return ( defined $data
	     ? $self->{RCDATA} = $data
	     : $self->{RCDATA} );
}

sub recipes {
    my $self = shift;
    return [ grep { $_->isa('Mail::Procmailrc::Recipe') } @{$self->rc} ];
}

sub variables {
    my $self = shift;
    return [ grep { $_->isa('Mail::Procmailrc::Variable') } @{$self->rc} ];
}

sub literals {
    my $self = shift;
    return [ grep { $_->isa('Mail::Procmailrc::Literal') } @{$self->rc} ];
}

sub push {
    my $self = shift;
    CORE::push @{$self->rc}, @_;
}

## FIXME: would be nice to do this w/o temporary arrays
sub delete {
    my $self  = shift;
    my $seek  = shift;
    my $found = 0;

    return unless $seek && ref($seek);

    my @tmp = ();
    for my $obj ( @{$self->rc} ) {
	CORE::push @tmp, $obj;
	next if $found;
	next unless $obj == $seek;
	pop @tmp;
	$found++;
    }
    $self->rc(\@tmp);
}

sub stringify {
    return $_[0]->dump;
}

sub dump {
    my $self = shift;
    my $output = '';
    my $sp     = ( defined $self->level ? $self->level * 2 : 0 );

    ## only one element in our list
    if( $self->blockline ) {
	$output .= (' ' x $sp) . "\{ " . $self->rc->[0]->stringify . ' }';
	$output =~ s/\{\s*\}/{ }/;  ## squeeze empties
    }

    ## dump our stack
    else {
	for my $elem ( @{$self->rc} ) {
	    next unless defined $elem;
	    $output .= $elem->dump;
	}
    }

    return $output;
}

sub flush {
    my $self = shift;
    my $file = shift;

    ## reset the file attribute
    $file = $self->file($file);

    ## flush the object to disk
    if( $file ) {
	open FILE, ">$file"
	  or do {
	      carp "Could not open '$file' for write: $!\n";
	      return;
	  };
    }

    ## no file, flush to stdout
    else {
	open FILE, ">&STDOUT" unless $file;
    }
    print FILE $self->dump;
    close FILE;

    return 1;
}

sub debug {
    my $self  = shift;
    my $debug = shift;

    return ( defined $debug ? $Debug = $debug : $Debug );
}

sub file {
    my $self = shift;
    my $file = shift;

    return ( defined $file ? $self->{File} = $file : $self->{File} );
}

sub level {
    my $self = shift;
    my $level = shift;

    return ( defined $level
	     ? $self->{Level} = $level
	     : ( defined $self->{Level}
		 ? $self->{Level}
		 : 0 ) );
}

sub blockline {
    my $self = shift;
    my $blockline = shift;

    return ( defined $blockline ? $self->{Blockline} = $blockline : $self->{Blockline} );
}

sub gubed {
    return unless $Debug;

    my $msg = shift;
    chomp $msg;
    print STDERR "$msg\n";
}

##################################
package Mail::Procmailrc::Literal;
##################################

sub new {
    my $self = bless { }, shift;
    my $data = shift;
    my $defs = shift;

    ## set defaults
    $self->defaults($defs) if ref $defs;

    ## FIXME: would be simple to make a super object and have literal,
    ## variable, and recipe inherit from it... Or recipe components
    ## inherit from it... I should be careful here and in documenting
    ## it so that I only mention the minimum necessary to keep a
    ## consistent interface.

    $self->literal($data);

    return $self;
}

sub defaults {
    my $self     = shift;
    my $defaults = shift;
    my $value    = shift;

    ## nada: return whole hashref
    unless( $defaults ) {
	return $self->{DEFAULTS};
    }

    ## no hashref: return element of hashref
    unless( ref($defaults) ) {
	return ( defined $self->{DEFAULTS}->{$defaults}
		 ? ( defined $value
		     ? $self->{DEFAULTS}->{$defaults} = $value
		     : $self->{DEFAULTS}->{$defaults} )
		 : undef );
    }

    ## hashref: assign hashref
    return $self->{DEFAULTS} = $defaults;
}

sub literal {
    my $self = shift;
    my $data = shift;

    ## clean data
    chomp $data       if $data;
    $data =~ s/^\s*// if $data;
    $data =~ s/\s*$// if $data;

    return ( defined $data ?
	     $self->{DATA} = $data
	     : ( $self->{DATA} ? $self->{DATA} : '' ) );
}

sub stringify {
    return $_[0]->literal;
}

sub dump {
    my $self = shift;
    my $sp   = ( defined $self->defaults('level') ? $self->defaults('level') * 2 : 0 );
    return (' ' x $sp) . $self->stringify . "\n";
}

##################################
package Mail::Procmailrc::Variable;
##################################
use Carp qw(carp);

## FIXME: handle comments on the assignment line

use vars qw($Debug); $Debug = 0;

sub new {
    my $self = bless { }, shift;
    my $data = shift;
    my $defs = shift;  ## defaults

    $self->defaults($defs) if $defs;
    $self->init($data);
    return $self;
}

sub defaults {
    my $self     = shift;
    my $defaults = shift;
    my $value    = shift;

    ## nada: return whole hashref
    unless( $defaults ) {
	return $self->{DEFAULTS};
    }

    ## no hashref: return element of hashref
    unless( ref($defaults) ) {
	return ( defined $self->{DEFAULTS}->{$defaults}
		 ? ( defined $value
		     ? $self->{DEFAULTS}->{$defaults} = $value
		     : $self->{DEFAULTS}->{$defaults} )
		 : undef );
    }

    ## hashref: assign hashref
    return $self->{DEFAULTS} = $defaults;
}

sub init {
    my $self = shift;
    my $data = shift;
    my $line;

    return unless defined $data;

    ## get a variable declaration
    $line .= shift @$data;

    ## check assignment
    unless( $line =~ /$Mail::Procmailrc::RE{'var'}/ ) {
	carp "Could not init: bad pattern in '$line'\n";
	return;
    }

    ## check for multiline quote
    if( $line =~ $Mail::Procmailrc::RE{'varmlq'} ) {
	while( @$data && $line =~ $Mail::Procmailrc::RE{'varmlq'} ) {
	    $line .= "\n";
	    $line .= shift @$data;
	}
    }

    else {
	## check for continuation
	while( $line =~ /$Mail::Procmailrc::RE{'cont'}/ ) {
	    $line .= "\n";
	    $line .= shift @$data;
	}
    }

    $self->variable($line);

    return 1;
}

sub lval {
    my $self = shift;
    my $data = shift;
    chomp $data if $data;

    return ( defined $data ? $self->{LVAL} = $data : $self->{LVAL} );
}

sub rval {
    my $self = shift;
    my $data = shift;
    chomp $data if $data;

    return ( defined $data ? $self->{RVAL} = $data : $self->{RVAL} );
}

sub variable {
    my $self = shift;
    my $data = shift;

    if( $data ) {
	chomp $data;
	my( $lval, $rval ) = split(/=/, $data, 2);
	$self->lval($lval);
	$self->rval($rval);
    }

    return join('=', $self->lval, $self->rval);
}

sub stringify {
    return $_[0]->variable;
}

sub dump {
    my $self = shift;
    my $sp   = ( defined $self->defaults('level') ? $self->defaults('level') * 2 : 0 );
    return (' ' x $sp) . $self->stringify . "\n";
}

## debug output
sub gubed {
    return unless $Debug;

    my $msg = shift;
    chomp $msg;
    print STDERR "$msg\n";
}

##################################
package Mail::Procmailrc::Recipe;
##################################

## FIXME: handle comments on the flags line

use Carp qw(carp);

sub new {
    my $self = bless { }, shift;
    my $data = shift;
    my $defs = shift;  ## defaults

    $self->defaults($defs) if $defs;
    $self->init($data);
    return $self;
}

sub defaults {
    my $self     = shift;
    my $defaults = shift;
    my $value    = shift;

    ## nada: return whole hashref
    unless( $defaults ) {
	return $self->{DEFAULTS};
    }

    ## no hashref: return element of hashref
    unless( ref($defaults) ) {
	return ( defined $self->{DEFAULTS}->{$defaults}
		 ? ( defined $value
		     ? $self->{DEFAULTS}->{$defaults} = $value
		     : $self->{DEFAULTS}->{$defaults} )
		 : undef );
    }

    ## hashref: assign hashref
    return $self->{DEFAULTS} = $defaults;
}

sub init {
    my $self = shift;
    my $data = shift;
    my $line;

    $self->{FLAGS}      = undef;
    $self->{INFO}       = undef;
    $self->{CONDITIONS} = undef;
    $self->{ACTION}     = undef;

    ## init members
    $self->flags('');
    $self->info([]);
    $self->conditions([]);
    $self->action('');

    return unless defined $data;

    if( 'ARRAY' eq ref($data) ) {
	chomp @$data;
    }
    else {
	## we don't know how to handle other kinds of refs here
	return if ref($data);

	## split the data (implicit chomping)
	$data = [split(/\n/, $data)];
    }

    ## required: FLAGS
  FLAGS: {
	$line = shift @$data;
	$line =~ s/^\s*//;
	unless( $line =~ /$Mail::Procmailrc::RE{'flags'}/ ) {
	    carp( "Not a recipe: $line\n" );
	    return;
	}
	$self->flags($line);
    }

    ## optional: INFO
  INFO: {
	## get a line
	$line = shift @$data;
	last INFO unless defined $line;
	$line =~ s/^\s*//;

	## comment/info
	if( $line =~ s/$Mail::Procmailrc::RE{'comm'}/$1/ ) {
	    push @{$self->info}, $line;
	    redo INFO;
	}

	## skip empty lines
	if( $line =~ /$Mail::Procmailrc::RE{'blank'}/ ) {
	    redo INFO;
	}

	## a non-empty, non-comment line. Maybe it's a condition...
	unshift @$data, $line;
    }

    ## optional: CONDITIONS
  CONDITIONS: {
	## get a line
	$line = shift @$data;
	last CONDITIONS unless defined $line;
	$line =~ s/^\s*//;

	## check for condition
	if( $line =~ s/$Mail::Procmailrc::RE{'condm'}/$1/ ) {
	    while( $line =~ /$Mail::Procmailrc::RE{'cont'}/ ) {
		$line .= "\n";         ## tack on the newline for quoted lines
		$line .= shift @$data;
	    }

	    push @{$self->conditions}, $line;
	    redo CONDITIONS;
	}

	## check for embedded comments and skip them
	if( $line =~ /$Mail::Procmailrc::RE{'comt'}/ ) {
	    redo CONDITIONS;
	}

	## check for empty lines and skip them
	if( $line =~ /$Mail::Procmailrc::RE{'blank'}/ ) {
	    redo CONDITIONS;
	}

	## non-empty, non-comment, non-condition. Maybe it's an action...
	unshift @$data, $line;
    }

    ## required: ACTION
  ACTION: {
	## get a line
	$line = shift @$data;
	last ACTION unless defined $line;
	$line =~ s/^\s*//;

	## if contains a '{' we pass it to Procmailrc
	if( $line =~ /$Mail::Procmailrc::RE{'blkopen'}/ ) {
	    unshift @$data, $line;
	    $self->action( Mail::Procmailrc->new( { 'data' => $data,
						    'level' => $self->defaults('level') } ));
	}

	## this is a plain old action line
	else {
	    while( $line =~ /$Mail::Procmailrc::RE{'cont'}/ ) {
		$line .= "\n";
		$line .= shift @$data;
	    }
	    $self->action($line);
	}
    }

    return 1;
}

sub stringify {
    my $self   = shift;
    my $output = '';

    $output = $self->flags . "\n";

    $output   .= ( scalar(@{$self->info})
		   ? join( "\n", @{$self->info} ) . "\n"
		   : '' );
    $output   .= ( scalar(@{$self->conditions})
		   ? join( "\n", @{$self->conditions} ) . "\n"
		   : '' );
    $output   .= ( ref($self->action)
		   ? $self->action->stringify
		   : $self->action );

    return $output;
}

sub dump {
    my $self   = shift;
    my $sp   = ( defined $self->defaults('level') ? $self->defaults('level') * 2 : 0 );
    my $output = '';

    ## flags
    $output = (' ' x $sp) . $self->flags . "\n";

    ## info
    $output   .= ( scalar(@{$self->info})
		   ? (' ' x $sp) . join( "\n" . (' ' x $sp), @{$self->info} ) . "\n"
		   : '' );

    ## conditions
    $output   .= ( scalar(@{$self->conditions})
		   ? (' ' x $sp) . join( "\n" . (' ' x $sp), @{$self->conditions} ) . "\n"
		   : '' );

    ## action
    $output   .= ( ref($self->action)
		   ? $self->action->dump
		   : (' ' x $sp) . $self->action );

    ## kludge: we do this because sometimes the action object is
    ## dumped and other times it is just a string. When we nest a few
    ## of these, the newlines pile up and leave a lot of whitespace
    ## at the end of the recipe dump.
    chomp $output;
    $output .= "\n";

    return $output;
}

## data will be a scalar like :0B:
sub flags {
    my $self = shift;
    my $data = shift;

    return ( defined $data
	     ? $self->{FLAGS} = Mail::Procmailrc::Literal->new($data)
	     : $self->{FLAGS}->stringify );
}

## data will be an array ref; if the data is a scalar, split it and
## make it a list ref
sub info {
    my $self = shift;
    my $data = shift;

    if( defined $data && !ref($data) ) {
	$data = [split(/\n/, $data)];
    }

    return ( defined $data ? $self->{INFO} = $data : $self->{INFO} );
}

## data will be an array ref upon which we push lines like '* 1^0 foo'
## FIXME: do we want to split scalars like we do for 'info'?
sub conditions {
    my $self = shift;
    my $data = shift;

    return ( defined $data ? $self->{CONDITIONS} = $data : $self->{CONDITIONS} );
}

## data will be scalar, possibly multiline; could be another rc object
sub action {
    my $self = shift;
    my $data = shift;
    chomp $data if $data && !ref($data);

    return ( defined $data ? $self->{ACTION} = $data : $self->{ACTION} );
}

1;
__END__