File Coverage

blib/lib/Mail/Spool/Node.pm

Criterion	Covered	Total	%
statement	66	84	78.5
branch	14	28	50.0
condition	6	12	50.0
subroutine	15	20	75.0
pod	10	11	90.9
total	111	155	71.6

# -*- perl -*-
#
#  Mail::Spool::Node - adpO - Mail::Spool inode encapsulization
#
#  $Id: Node.pm,v 1.1 2001/12/08 05:52:59 rhandom Exp $
#
#  Copyright (C) 2001, Paul T Seamons
#                      [e-mail]
#                      http://seamons.com/
#
#  This package may be distributed under the terms of either the
#  GNU General Public License
#    or the
#  Perl Artistic License
#
#  All rights reserved.
#
#  Please read the perldoc Mail::Spool::Node
#
################################################################

package Mail::Spool::Node;

use strict;
use vars qw($AUTOLOAD $VERSION);
use File::NFSLock 1.10 ();
use IO::File ();

$VERSION = $Mail::Spool::VERSION;

###----------------------------------------------------------------###

sub new {
  my $type  = shift;
  my $class = ref($type) || $type || __PACKAGE__;
  my $self  = @_ && ref($_[0]) ? shift() : {@_};

  bless $self, $class;

  if( ! $self->load_node_properties ){
    return undef;
  }

  return $self;
}

###----------------------------------------------------------------###

sub load_node_properties {
  my $node = shift;

  return undef if $node->name =~ /\.NFSLock$/i; # skip lock files
  return undef if $node->name =~ /^\.+$/;       # skip root directory nodes
  return undef if -d $node->filename;           # skip directories

  # looking for stuff like 995909015-80EA68E2D942BA85-forward@[e-mail]
  if( $node->name !~ /^(\d+)-([^\-]+)-([^\-]+)-([^\-]*)$/ ){
    die "Strange file found in spool dir \"".$node->filename."\"\n";
  }

  my($time,$message_id,$to_addr,$from_addr) = ($1,$2,$3,$4);
  $from_addr ||= ''; # allow for undeliverables

  ### unencode the to and from
  foreach ( $to_addr, $from_addr ){
    s/%([a-f0-9]{2})/chr(hex($1))/eig;
  }

  ### store some properties
  $node->time( $time );
  $node->id( $message_id );
  $node->to( $to_addr );
  $node->from( $from_addr );

  return 1;
}

###----------------------------------------------------------------###

### is this node up for processing
sub can_process {
  my $node = shift;

  die "No wait property found in mail spool handle"
    if ! defined $node->msh->wait;

  return (time() - $node->time >= $node->msh->wait);
}

sub size {
  my $node = shift;
  return -s $node->filename || 0;
}

###----------------------------------------------------------------###

### exclusive lock (NFS or not)
sub lock_node {
  my $node = shift;
  my $lock = File::NFSLock->new($node->filename,
                                "NONBLOCKING",
                                0,
                                ($node->msh->spool->max_connection_time+2),
                                );
  $node->{lock_error} = $File::NFSLock::errstr;
  return $lock;
}

sub lock_error {
  return shift()->{lock_error};
}

###----------------------------------------------------------------###

sub filehandle {
  my $node = shift;
  my $mode = shift;
  $mode = 'r' if ! $mode || $mode !~ /^(a|w|r|wr)$/;

  my $fh = IO::File->new($node->filename,$mode);

  if( ! $fh ){
    warn "Couldn't open file ".$node->filename." [$!]";
    return undef;
  }
  return $fh;
}

sub filename {
  my $node = shift;
  return $node->msh->spool_dir .'/'. $node->name;
}

sub fallback_filename {
  my $node = shift;
  my $name = join("-",time(),$node->id,$node->to,$node->from);
  return undef if ! defined $node->msh->fallback_dir;
  return $node->msh->fallback_dir .'/'. $name;
}

sub fallback {
  my $node = shift;

  if( ! rename($node->filename,
               $node->fallback_filename) ){
    warn "Couldn't rename ".$node->filename." to ".$node->fallback_filename." [$!]";
    unlink $node->filename; # maybe some more error checking
  }
}

sub delete_node {
  my $node = shift;
  unlink $node->filename;
}

###----------------------------------------------------------------###

sub AUTOLOAD {
  my $node = shift;
  my ($method) = $AUTOLOAD =~ /([^:]+)$/;
  die "No method found in \$AUTOLOAD \"$AUTOLOAD\"" unless defined $method;

  ### allow for dynamic installation of some subs
  if( $method =~ /^(to|from|id|time|msh|name)$/ ){
    no strict 'refs';
    * { __PACKAGE__ ."::". $method } = sub {
      my $self = shift;
      my $val = $self->{$method};
      $self->{$method} = shift if @_;
      return $val;
    };
    use strict 'refs';

    ### now that it is installed, call it again
    return $node->$method( @_ );
  }

  die "Unknown method \"$method\"";
}

sub DESTROY {}

1;



__END__