# 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.58";

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
##

# tidy up internal hash table and list

# 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$/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 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 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 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 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;
}


1; # keep require happy


