# Mail::Header.pm
#
# Copyright (c) 1995-2001 Graham Barr <gbarr@pobox.com>. All rights reserved.
# Copyright (c) 2002-2003 Mark Overmeer <mailtools@overmeer.net>
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

#
# The internals of this package are implemented in terms of a list of lines
# and a hash indexed by the tags. The hash contains a list of references to
# the actual SV's in the list. We therefore do our upmost to preserve this.
# anyone who delves into these structures deserve all they get.
#

package Mail::Header;

require 5.002;

use strict;
use Carp;
use vars qw($VERSION $FIELD_NAME);

$VERSION = "1.60";

my $MAIL_FROM = 'KEEP';
my %HDR_LENGTHS = ();

#
# Pattern to match a RFC822 Field name ( Extract from RFC #822)
#
#     field       =  field-name ":" [ field-body ] CRLF
#
#     field-name  =  1*<any CHAR, excluding CTLs, SPACE, and ":">
#
#     CHAR        =  <any ASCII character>        ; (  0-177,  0.-127.)
#     CTL         =  <any ASCII control           ; (  0- 37,  0.- 31.)
#		      character and DEL>          ; (    177,     127.)
# I have included the trailing ':' in the field-name
#
$FIELD_NAME = '[^\x00-\x1f\x7f-\xff :]+:';

##
## Private functions
##

sub _error { warn @_; return (wantarray ? () : undef) }

# tidy up internal hash table and list

sub _tidy_header
{
 my $me = shift;
 my($ref,$key);
 my $i;
 my $d = 0;

 for($i = 0 ; $i < scalar(@{$me->{'mail_hdr_list'}}) ; $i++)
  {
   unless(defined $me->{'mail_hdr_list'}[$i])
    {
     splice(@{$me->{'mail_hdr_list'}},$i,1);
     $d++;
     $i--;
    }
  }

 if($d)
  {
   local $_;
   my @del = ();

   while(($key,$ref) = each %{$me->{'mail_hdr_hash'}} )
    {
     push(@del, $key)
	unless @$ref = grep { ref($_) && defined $$_ } @$ref;
    }

   map { delete $me->{'mail_hdr_hash'}{$_} } @del;
  }
}

# fold the line to the given length

my %STRUCTURE;
@STRUCTURE{ map { lc } qw{
  To Cc Bcc From Date Reply-To Sender
  Resent-Date Resent-From Resent-Sender Resent-To Return-Path
  list-help list-post list-unsubscribe Mailing-List
  Received References Message-ID In-Reply-To
  Content-Length Content-Type Content-Disposition
  Delivered-To
  Lines
  MIME-Version
  Precedence
  Status
}} = ();

sub _fold_line
{
 my($ln,$maxlen) = @_;

 $maxlen = 20
    if($maxlen < 20);

 my $max = int($maxlen - 5);         # 4 for leading spcs + 1 for [\,\;]
 my $min = int($maxlen * 4 / 5) - 4;
 my $ml = $maxlen;

 $_[0] =~ s/\s*[\r\n]+\s*/ /og; # Compress any white space around a newline
 $_[0] =~ s/\s*\Z/\n/so;        # End line with a EOLN

 return if $_[0] =~ /^From\s/io;

 if(length($_[0]) > $ml)
  {
   if ($_[0] =~ /^([-\w]+)/ && exists $STRUCTURE{ lc $1 } )
    {
     #Split the line up
     # first bias towards splitting at a , or a ; >4/5 along the line
     # next split a whitespace
     # else we are looking at a single word and probably don't want to split
     my $x = "";

     $x .= "$1\n    "
	while($_[0] =~ s/^\s*(
			   [^"]{$min,$max}?[\,\;]
			  |[^"]{1,$max}\s
			  |[^\s"]*(?:"[^"]*"[^\s"]*)+\s
			  |[^\s"]+\s
			  )
			//x);
     $x .= $_[0];
     $_[0] = $x;
     $_[0] =~ s/(\A\s+|[\t ]+\Z)//sog;
     $_[0] =~ s/\s+\n/\n/sog;
    }
   else
    {
      $_[0] =~ s/(.{$min,$max})\s+/$+\n    /g;
      $_[0] =~ s/\s*$/\n/s;
    }
  }

 $_[0] =~ s/\A(\S+)\n\s*(?=\S)/$1 /so; 
}

# attempt to change the case of a tag to that required by RFC822. That
# being all characters are lowercase except the first of each word. Also
# if the word is an `acronym' then all characters are uppercase. We decide
# a word is an acronym if it does not contain a vowel.

sub _tag_case
{
 my $tag = shift;
 $tag =~ s/\:$//;

 join('-',
     map { /^[b-df-hj-np-tv-z]+$|^(?:MIME|SWE|SOAP|LDAP)$/i
         ? uc($_) : ucfirst(lc($_)) }
              split('-', $tag));
}

# format a complete line
#  ensure line starts with the given tag
#  ensure tag is correct case
#  change the 'From ' tag as required
#  fold the line

sub _fmt_line
{
 my $me = shift;
 my $tag = shift;
 my $line = shift;
 my $modify = shift || $me->{'mail_hdr_modify'};
 my $ctag = undef;

 ($tag) = $line =~ /\A($FIELD_NAME|From )/oi
    unless(defined $tag);

 if($tag =~ /\AFrom /io && $me->{'mail_hdr_mail_from'} ne 'KEEP')
  {
   if ($me->{'mail_hdr_mail_from'} eq 'COERCE')
    {
     $line =~ s/^From /Mail-From: /o;
     $tag = "Mail-From:";
    }
   elsif ($me->{'mail_hdr_mail_from'} eq 'IGNORE')
    {
     return ();
    }
   elsif ($me->{'mail_hdr_mail_from'} eq 'ERROR')
    {
     return _error "unadorned 'From ' ignored: <$line>"
    }
  }

 if(defined $tag)
  {
   $tag = _tag_case($ctag = $tag);

   $ctag = $tag
   	if($modify);

   $ctag =~ s/([^ :])\Z/$1:/o if defined $ctag;
  }

 croak( "Bad RFC822 field name '$tag'\n")
   unless(defined $ctag && $ctag =~ /\A($FIELD_NAME|From )/oi);

 # Ensure the line starts with tag
 if(defined($ctag) && ($modify || $line !~ /\A\Q$ctag\E/i))
  {
   my $xtag;
   ($xtag = $ctag) =~ s/\s*\Z//o;
   $line =~ s/\A(\Q$ctag\E)?\s*/$xtag /i;
  }

 my $maxlen = $me->{'mail_hdr_lengths'}{$tag}
		|| $HDR_LENGTHS{$tag}
		|| $me->fold_length;

 _fold_line($line,$maxlen)
    if $modify && defined $maxlen;

 $line =~ s/\n*\Z/\n/so;

 ($tag, $line);
}

sub _insert
{
 my($me,$tag,$line,$where) = @_;

 if($where < 0)
  {
   $where = @{$me->{'mail_hdr_list'}} + $where + 1;

   $where = 0
	if($where < 0);
  }
 elsif($where >= @{$me->{'mail_hdr_list'}})
  {
   $where = @{$me->{'mail_hdr_list'}};
  }

 my $atend = $where == @{$me->{'mail_hdr_list'}};

 splice(@{$me->{'mail_hdr_list'}},$where,0,$line);

 $me->{'mail_hdr_hash'}{$tag} ||= [];
 my $ref = \${$me->{'mail_hdr_list'}}[$where];

 if($me->{'mail_hdr_hash'}{$tag} && $where)
  {
   if($atend)
    {
     push(@{$me->{'mail_hdr_hash'}{$tag}}, $ref);
    }
   else
    {
     my $i = 0;
     foreach my $ln (@{$me->{'mail_hdr_list'}})
      {
       my $r = \$ln;
       last if($r == $ref);
       $i++ if($r == $me->{'mail_hdr_hash'}{$tag}[$i]);
      }
     splice(@{$me->{'mail_hdr_hash'}{$tag}},$i,0,$ref);
    }
  }
 else
  {
   unshift(@{$me->{'mail_hdr_hash'}{$tag}}, $ref);
  }
}

##
## Constructor
##

sub new
{
 my $self = shift;
 my $type = ref($self) || $self;
 my $arg = @_ % 2 ? shift : undef;
 my %arg = @_;

 $arg{Modify} = delete $arg{Reformat} unless exists $arg{Modify};

 my %hash = (
	mail_hdr_list     => [],
	mail_hdr_hash     => {},
	mail_hdr_modify   => delete $arg{Modify} || 0,
	mail_hdr_foldlen  => 79,
	mail_hdr_lengths  => {}
	);

 my $me = bless \%hash, $type;

 $me->mail_from( uc($arg{'MailFrom'} || $MAIL_FROM) );

 $me->fold_length($arg{FoldLength})
    if exists $arg{FoldLength};

 if(ref $arg)
  {
   if(ref($arg) eq 'ARRAY')
    {
     $me->extract([ @{$arg} ]);
    }
   elsif(defined fileno($arg))
    {
     $me->read($arg);
    }
  }

 $me;
}

sub modify
{
 my $me = shift;
 my $old = $me->{'mail_hdr_modify'};

 $me->{'mail_hdr_modify'} = 0 + shift
	if @_;

 $old;
}

sub mail_from
{
 my $me = shift;
 my $choice = uc(shift);

 $choice =~ /^(IGNORE|ERROR|COERCE|KEEP)$/ 
	or die "bad Mail-From choice: '$choice'";

 if(ref($me))
  {
   $me->{'mail_hdr_mail_from'} = $choice;
  }
 else
  {
   $MAIL_FROM = $choice;
  }

 $me;
}

sub fold
{
 my $me = shift;
 my $maxlen = shift;
 my($tag,$list,$ln);

 while(($tag,$list) = each %{$me->{'mail_hdr_hash'}})
  {
   my $len = $maxlen
		|| $me->{'mail_hdr_lengths'}{$tag}
		|| $HDR_LENGTHS{$tag}
		|| $me->fold_length;

   foreach $ln (@$list)
    {
     _fold_line($$ln,$len)
        if defined $ln;
    }
  }

 $me;
}

sub unfold
{
 my $me = shift;
 my($tag,$list,$ln);

 if(@_)
  {
   $tag = _tag_case(shift);
   return $me unless exists $me->{'mail_hdr_hash'}{$tag};
   $list = $me->{'mail_hdr_hash'}{$tag};
   foreach $ln (@$list)
    {
     $$ln =~ s/\r?\n\s+/ /sog
	if defined $ln && defined $$ln;
    }
  }
 else
  {
   while(($tag,$list) = each %{$me->{'mail_hdr_hash'}})
    {
     foreach $ln (@$list)
      {
       $$ln =~ s/\r?\n\s+/ /sog
	if defined $ln && defined $$ln;
      }
    }
  }
 $me;
}

sub extract
{
 my $me = shift;
 my $arr = shift;
 my $line;

 $me->empty;

 while(scalar(@{$arr}) && $arr->[0] =~ /\A($FIELD_NAME|From )/o)
  {
   my $tag = $1;

   $line = shift @{$arr};
   $line .= shift @{$arr}
       while(scalar(@{$arr}) && $arr->[0] =~ /\A[ \t]+/o);

   ($tag,$line) = _fmt_line($me,$tag,$line);

   _insert($me,$tag,$line,-1)
      if defined $line;
  }

 shift @{$arr}
  if(scalar(@{$arr}) && $arr->[0] =~ /\A\s*\Z/o);

 $me;
}

sub read
{
 my $me = shift;
 my $fd = shift;

 $me->empty;

 my $line = undef;
 my $ln = "";
 my $tag = undef;

 while(1)
  {
   $ln = <$fd>;

   if(defined $ln && defined $line && $ln =~ /\A[ \t]+/o)
    {
     $line .= $ln;
     next;
    }

   if(defined $line)
    {
     ($tag,$line) = _fmt_line($me,$tag,$line);
      _insert($me,$tag,$line,-1)
	if defined $line;
    }

   last
     unless(defined $ln && $ln =~ /\A($FIELD_NAME|From )/o);

   $tag  = $1;
   $line = $ln;
  }

 $me;
}

sub empty
{
 my $me = shift;

 $me->{'mail_hdr_list'} = [];
 $me->{'mail_hdr_hash'} = {};

 $me;
}

sub header
{
 my $me = shift;

 $me->extract(@_)
	if(@_);

 $me->fold
    if $me->{'mail_hdr_modify'};

 # Must protect ourself against corruption as the hash contains refs to the
 # SV's in the list, if the user modifies this list we are really screwed :-

 [ @{$me->{'mail_hdr_list'}} ];
}

# Return/set headers by hash reference.  This can probably be
# optimized. I didn't want to mess much around with the internal
# implementation as for now...
# -- Tobias Brox <tobix@cpan.org>

sub header_hashref {
 my $me = shift;
 my $hashref = shift;

 # Extract the input data
 for my $hdrkey (keys %$hashref) {
   for (ref $hashref->{$hdrkey} 
	? @{$hashref->{$hdrkey}} 
	: $hashref->{$hdrkey}) {
     $me->add($hdrkey, $_);
   }
 }

 $me->fold
    if $me->{'mail_hdr_modify'};

 # Build a hash
 my $hash={ map { $_ => [ $me->get($_) ] } keys %{$me->{'mail_hdr_hash'}} }; 

 return $hash;
}

sub add
{
 my $me = shift;
 my($tag,$text,$where) = @_;
 my $line;
 ($tag,$line) = _fmt_line($me,$tag,$text);

 # Must have a tag and text to add
 return undef
	unless(defined $tag && defined $line);

 $where = -1
	unless defined $where;

 _insert($me,$tag,$line,$where);

 $line =~ /^\S+\s(.*)/os;
 return $1;
}

sub replace
{
 my $me = shift;
 my $idx = 0;
 my($tag,$line);

 $idx = pop @_
    if(@_ % 2);

TAG:
 while(@_)
  {
   ($tag,$line) = _fmt_line($me,splice(@_,0,2));

   return undef
        unless(defined $tag && defined $line);

   if(exists $me->{'mail_hdr_hash'}{$tag} &&
      defined $me->{'mail_hdr_hash'}{$tag}[$idx])
    {
     ${$me->{'mail_hdr_hash'}{$tag}[$idx]} = $line;
    }
   else
    {
     _insert($me,$tag,$line,-1);
    }
  }

 $line =~ /^\S+\s*(.*)/os;
 return $1;
}

sub combine
{
 my $me  = shift;
 my $tag = _tag_case(shift);
 my $with = shift || ' ';
 my $line;

 return _error "unadorned 'From ' ignored"
	if($tag =~ /^From /io && $me->{'mail_hdr_mail_from'} ne 'KEEP');

 return undef
    unless exists $me->{'mail_hdr_hash'}{$tag};

 if(scalar(@{$me->{'mail_hdr_hash'}{$tag}}) > 1)
  {
   my @lines = $me->get($tag);

   chomp(@lines);

   map { $$_ = undef } @{$me->{'mail_hdr_hash'}{$tag}};

   $line = ${$me->{'mail_hdr_hash'}{$tag}[0]} = 
        (_fmt_line($me,$tag, join($with,@lines),1))[1];

   _tidy_header($me);
  }
 else
  {
   return $me->{'mail_hdr_hash'}{$tag}[0];
  }

 return $line;		# post-match
}

sub get
{
 my $me = shift;
 my $tag = _tag_case(shift);
 my $idx = shift;

 return wantarray ? () : undef
    unless exists $me->{'mail_hdr_hash'}{$tag};

 my $l = length($tag);
 $l += 1 unless $tag =~ / \Z/o;

 $idx = 0
    unless defined $idx || wantarray;

 if(defined $idx)
  { 
   return defined $me->{'mail_hdr_hash'}{$tag}[$idx]
        ?  eval { # why won't do work here ??
	       my $tmp = substr(${$me->{'mail_hdr_hash'}{$tag}[$idx]}, $l);
	      $tmp =~ s/^\s+//;
	      $tmp;
	  }
        : undef;
  }

 return  map {
		my $tmp = substr($$_,$l);
		$tmp =~ s/^\s+//;
		$tmp
	     } @{$me->{'mail_hdr_hash'}{$tag}};
}

sub count
{
 my $me = shift;
 my $tag = _tag_case(shift);

 exists $me->{'mail_hdr_hash'}{$tag}
	? scalar(@{$me->{'mail_hdr_hash'}{$tag}})
	: 0;
}

sub exists
{
 carp "Depriciated use of Mail::Header::exists, use count" if $^W;
 count(@_);
}

sub delete
{
 my $me  = shift;
 my $tag = _tag_case(shift);
 my $idx = shift;
 my @val = ();

 if(defined $me->{'mail_hdr_hash'}{$tag})
  {
   my $l = length($tag);
   $l += 2 unless $tag =~ / \Z/o;

   if(defined $idx)
    {
     if(defined $me->{'mail_hdr_hash'}{$tag}[$idx])
      {
       push(@val, substr(${$me->{'mail_hdr_hash'}{$tag}[$idx]},$l));
       undef ${$me->{'mail_hdr_hash'}{$tag}[$idx]};
      }
    }
   else
    {
     local $_;
     @val = map {
                 my $x = substr($$_,$l);
                 undef $$_;
                 $x
                } @{$me->{'mail_hdr_hash'}{$tag}};
    }

   _tidy_header($me);
  }

 return @val;
}

sub print
{
 my $me = shift;
 my $fd = shift || \*STDOUT;
 my $ln;

 foreach $ln (@{$me->{'mail_hdr_list'}})
  {
   next
    unless defined $ln;
   print $fd $ln or
    return 0;
  }

 1;
}

sub as_string
{
 my $me = shift;

 join('', grep { defined } @{$me->{'mail_hdr_list'}});
}

sub fold_length
{
 my $me  = shift;
 my $old;

 if(@_ == 2)
  {
   my($tag,$len) = @_;

   my $hash = ref($me) ? $me->{'mail_hdr_lengths'} : \%HDR_LENGTHS;

   $tag = _tag_case($tag);

   $old = $hash->{$tag} || undef;
   $hash->{$tag} = $len > 20 ? $len : 20;
  }
 else
  {
   my $len = shift;

   $old = $me->{'mail_hdr_foldlen'};

   if(defined $len)
    {
     $me->{'mail_hdr_foldlen'} = $len > 20 ? $len : 20;
     $me->fold if $me->{'mail_hdr_modify'};
    }
  }

 $old;
}

sub tags
{
 my $me = shift;

 keys %{$me->{'mail_hdr_hash'}};
}

sub dup
{
 my $me = shift;
 my $type = ref($me) || croak "Cannot dup without an object";
 my $dup = new $type;

 %$dup = %$me;
 $dup->empty;

 $dup->{'mail_hdr_list'} = [ @{$me->{'mail_hdr_list'}} ];

 my $ln;
 foreach $ln ( @{$dup->{'mail_hdr_list'}} )
  {
   my $tag = _tag_case(($ln =~ /\A($FIELD_NAME|From )/oi)[0]);

   $dup->{'mail_hdr_hash'}{$tag} ||= [];
   push(@{$dup->{'mail_hdr_hash'}{$tag}}, \$ln);
  }

 $dup;
}

sub cleanup
{
 my $me = shift;
 my $d = 0;
 my $key;

 foreach $key (@_ ? @_ : keys %{$me->{'mail_hdr_hash'}})
  {
   my $arr = $me->{'mail_hdr_hash'}{$key};
   my $ref;
   foreach $ref (@$arr)
    {
     unless($$ref =~ /\A\S+\s+\S/soi)
      {
       $$ref = undef;
       $d++;
      }
    }
  }

 _tidy_header($me)
	if $d;

 $me;  
}

1; # keep require happy


=head1 NAME

Mail::Header - manipulate mail RFC822 compliant headers

=head1 SYNOPSIS

    use Mail::Header;
    
    $head = new Mail::Header;
    $head = new Mail::Header \*STDIN;
    $head = new Mail::Header [<>], Modify => 0;

=head1 DESCRIPTION

This package provides a class object which can be used for reading, creating,
manipulating and writing RFC822 compliant headers.

=head1 CONSTRUCTOR

=over 4

=item new ( [ ARG ], [ OPTIONS ] )

C<ARG> may be either a file descriptor (reference to a GLOB)
or a reference to an array. If given the new object will be
initialized with headers either from the array of read from 
the file descriptor.

C<OPTIONS> is a list of options given in the form of key-value
pairs, just like a hash table. Valid options are

=over 8

=item B<Modify>

If this value is I<true> then the headers will be re-formatted,
otherwise the format of the header lines will remain unchanged.

=item B<MailFrom>

This option specifies what to do when a header in the form `From '
is encountered. Valid values are C<IGNORE> - ignore and discard the header,
C<ERROR> - invoke an error (call die), C<COERCE> - rename them as Mail-From
and C<KEEP> - keep them.

=item B<FoldLength>

The default length of line to be used when folding header lines

=back

=back

=head1 METHODS

=over 4

=item modify ( [ VALUE ] )

If C<VALUE> is I<false> then C<Mail::Header> will not do any automatic
reformatting of the headers, other than to ensure that the line
starts with the tags given.

=item mail_from ( OPTION )

C<OPTION> specifies what to do when a C<`From '> line is encountered.
Valid values are C<IGNORE> - ignore and discard the header,
C<ERROR> - invoke an error (call die), C<COERCE> - rename them as Mail-From
and C<KEEP> - keep them.

=item fold ( [ LENGTH ] )

Fold the header. If C<LENGTH> is not given then C<Mail::Header> uses the
following rules to determine what length to fold a line.

The fold length for the tag that is begin processed

The default fold length for the tag that is being processed

The default fold length for the object

=item extract ( ARRAY_REF )

Extract a header from the given array. C<extract> B<will modify> this array.
Returns the object that the method was called on.

=item read ( FD )

Read a header from the given file descriptor.

=item empty ()

Empty the C<Mail::Header> object of all lines.

=item header ( [ ARRAY_REF ] )

C<header> does multiple operations. First it will extract a header from
the array, if given. It will the reformat the header, if reformatting
is permitted, and finally return a reference to an array which
contains the header in a printable form.

=item header_hashref ( [ HASH_REF ] )

As C<header>, but it will eventually set headers from a hash
reference, and it will return the headers as a hash reference.

The values in the hash might either be a scalar or an array reference,
as an example:

    $hashref->{From}='Tobias Brox <tobix@cpan.org>';
    $hashref->{To}=['you@somewhere', 'me@localhost'];

=item add ( TAG, LINE [, INDEX ] )

Add a new line to the header. If C<TAG> is I<undef> the the tag will be
extracted from the beginning of the given line. If C<INDEX> is given
the new line will be inserted into the header at the given point, otherwise
the new line will be appended to the end of the header.

=item replace ( TAG, LINE [, INDEX ] )

Replace a line in the header.  If C<TAG> is I<undef> the the tag will be
extracted from the beginning of the given line. If C<INDEX> is given
the new line will replace the Nth instance of that tag, otherwise the
first instance of the tag is replaced. If the tag does not appear in the
header then a new line will be appended to the header.

=item combine ( TAG [, WITH ] )

Combine all instances of C<TAG> into one. The lines will be
joined togther with C<WITH>, or a single space if not given. The new
item will be positioned in the header where the first instance was, all
other instances of <TAG> will be removed.

=item get ( TAG [, INDEX ] )

Get the text form a line. If C<INDEX> is given then the text of the Nth
instance will be returned. If it is not given the return value depends on the
context in which C<get> was called. In an array context a list of all the
text from all the instances of C<TAG> will be returned. In a scalar context
the text for the first instance will be returned.

=item delete ( TAG [, INDEX ] )

Delete a tag from the header. If C<INDEX> id given then the Nth instance
of the tag will be removed. If C<INDEX> is not given all instances
of tag will be removed.

=item count ( TAG )

Returns the number of times the given atg appears in the header

=item print ( [ FD ] )

Print the header to the given file descriptor, or C<STDOUT> if no
file descriptor is given.

=item as_string ()

Returns the header as a single string.

=item fold_length ( [ TAG ], [ LENGTH ] )

Set the default fold length for all tags or just one. With no arguments
the default fold length is returned. With two arguments it sets the fold
length for the given tag and returns the previous value. If only C<LENGTH>
is given it sets the default fold length for the current object.

In the two argument form C<fold_length> may be called as a static method,
setting default fold lengths for tags that will be used by B<all>
C<Mail::Header> objects. See the C<fold> method for
a description on how C<Mail::Header> uses these values.

=item tags ()

Retruns an array of all the tags that exist in the header. Each tag will
only appear in the list once. The order of the tags is not specified.

=item dup ()

Create a duplicate of the current object.

=item cleanup ()

Remove any header line that, other than the tag, only contains whitespace

=item unfold ( [ TAG ] )

Unfold all instances of the given tag so that they do not spread across
multiple lines. IF C<TAG> is not given then all lines are unfolded.

=back

=head1 AUTHOR

Graham Barr.  Maintained by Mark Overmeer <mailtools@overmeer.net>

=head1 COPYRIGHT

Copyright (c) 2002-2003 Mark Overmeer, 1995-2001 Graham Barr. All rights
reserved. This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut