lib/Mail/Header.pm - metacpan.org

# Copyrights 1995-2016 by [Mark Overmeer <perl@overmeer.net>].
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
package Mail::Header;
use vars '$VERSION';
$VERSION = '2.18';


use strict;
use Carp;

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
#
our $FIELD_NAME = '[^\x00-\x1f\x7f-\xff :]+:';


##
## Private functions
##

sub _error { warn @_; () }

# tidy up internal hash table and list

sub _tidy_header
{   my $self    = shift;
    my $deleted = 0;

    for(my $i = 0 ; $i < @{$self->{mail_hdr_list}}; $i++)
    {   next if defined $self->{mail_hdr_list}[$i];

        splice @{$self->{mail_hdr_list}}, $i, 1;
        $deleted++;
        $i--;
    }

    if($deleted)
    {   local $_;
        my @del;

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

        delete $self->{'mail_hdr_hash'}{$_} for @del;
    }
}

# fold the line to the given length

my %STRUCTURE = map { (lc $_ => undef) }
  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;

    $_[0] =~ s/[\r\n]+//og;        # Remove new-lines
    $_[0] =~ s/\s*\Z/\n/so;        # End line with a EOLN

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

    if(length($_[0]) > $maxlen)
    {   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"]*(?:"[^"]*"[ \t]?[^\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)/$1\n$2/g;
            $_[0] =~ s/\s*$/\n/s;
        }
    }

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

# Tags are case-insensitive, but there is a (slightly) preferred construction
# 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.
# In general, this change of capitalization is a bad idea, but it is in
# the code for ages, and therefore probably crucial for existing
# applications.

sub _tag_case
{   my $tag = shift;
    $tag =~ s/\:$//;
    join '-'
      , map { /^[b-df-hj-np-tv-z]+$|^(?:MIME|SWE|SOAP|LDAP|ID)$/i
              ? uc($_) : ucfirst(lc($_))
            } split m/\-/, $tag, -1;
}

# 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 ($self, $tag, $line, $modify) = @_;
    $modify ||= $self->{mail_hdr_modify};
    my $ctag = undef;

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

    if(defined $tag && $tag =~ /^From /io && $self->{mail_hdr_mail_from} ne 'KEEP')
    {   if($self->{mail_hdr_mail_from} eq 'COERCE')
        {   $line =~ s/^From /Mail-From: /o;
            $tag = "Mail-From:";
        }
        elsif($self->{mail_hdr_mail_from} eq 'IGNORE')
        {   return ();
        }
        elsif($self->{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/([^ :])$/$1:/o if defined $ctag;
    }

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

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

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

    if ($modify && defined $maxlen)
    {   # folding will fix bad header continuations for us
        _fold_line $line, $maxlen;
    }
    elsif($line =~ /\r?\n\S/)
    {   return _error "Bad header continuation, skipping '$tag': ",
                      "no space after newline in '$line'\n";
    }


    $line =~ s/\n*$/\n/so;
    ($tag, $line);
}

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

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

    my $atend = $where == @{$self->{mail_hdr_list}};
    splice @{$self->{mail_hdr_list}}, $where, 0, $line;

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

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


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

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

    my $self = bless
      { mail_hdr_list     => []
      , mail_hdr_hash     => {}
      , mail_hdr_modify   => (delete $opt{Modify} || 0)
      , mail_hdr_foldlen  => 79
      , mail_hdr_lengths  => {}
      }, $class;

    $self->mail_from( uc($opt{MailFrom} || $MAIL_FROM) );

    $self->fold_length($opt{FoldLength})
        if exists $opt{FoldLength};

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

    $self;
}


sub dup
{   my $self = shift;
    my $dup  = ref($self)->new;

    %$dup    = %$self;
    $dup->empty;      # rebuild tables

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

    foreach my $ln ( @{$dup->{mail_hdr_list}} )
    {    my $tag = _tag_case +($ln =~ /^($FIELD_NAME|From )/oi)[0];
         push @{$dup->{mail_hdr_hash}{$tag}}, \$ln;
    }

    $dup;
}


sub extract
{   my ($self, $lines) = @_;
    $self->empty;

    while(@$lines)
    {   my $line = shift @$lines;
        last if $line =~ /^\r?$/;

        $line    =~ /^($FIELD_NAME|From )/o or next;
        my $tag  = $1;

        $line   .= shift @$lines
            while @$lines && $lines->[0] =~ /^[ \t]+/;

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

        _insert $self, $tag, $line, -1
            if defined $line;
    }

    $self;
}


sub read
{   my ($self, $fd) = @_;
    $self->empty;

    my ($ln, $tag, $line);
    while(1)
    {   $ln = <$fd>;

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

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

        last if !defined $ln || $ln =~ m/^\r?$/;

        $ln =~ /^($FIELD_NAME|From )/o or next;
        ($tag, $line) = ($1, $ln);
    }

    $self;
}


sub empty
{   my $self = shift;
    $self->{mail_hdr_list} = [];
    $self->{mail_hdr_hash} = {};
    $self;
}


sub header
{   my $self = shift;

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

    $self->fold
        if $self->{mail_hdr_modify};

    [ @{$self->{mail_hdr_list}} ];
}


sub header_hashref
{   my ($self, $hashref) = @_;

    while(my ($key, $value) = each %$hashref)
    {   $self->add($key, $_) for ref $value ? @$value : $value;
    }

    $self->fold
        if $self->{mail_hdr_modify};

    defined wantarray  # MO, added minimal optimization
        or return;

    +{ map { ($_ => [$self->get($_)] ) }   # MO: Eh?
           keys %{$self->{mail_hdr_hash}}
     }; 
}


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

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

    $old;
}


sub mail_from
{   my $thing  = shift;
    my $choice = uc shift;

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

    if(ref $thing) { $thing->{mail_hdr_mail_from} = $choice }
    else           { $MAIL_FROM = $choice }

    $thing;
}


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

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

        my $hash = ref $thing ? $thing->{mail_hdr_lengths} : \%HDR_LENGTHS;
        $old     = $hash->{$tag};
        $hash->{$tag} = $len > 20 ? $len : 20;
    }
    else
    {   my $self = $thing;
        my $len  = shift;
        $old = $self->{mail_hdr_foldlen};

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

    $old;
}


sub fold
{   my ($self, $maxlen) = @_;

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

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

    $self;
}


sub unfold
{   my $self = shift;

    if(@_)
    {   my $tag  = _tag_case shift;
        my $list = $self->{mail_hdr_hash}{$tag}
            or return $self;

        foreach my $ln (@$list)
        {   $$ln =~ s/\r?\n\s+/ /sog
                if defined $ln && defined $$ln;
        }

        return $self;
    }

    while( my ($tag, $list) = each %{$self->{mail_hdr_hash}})
    {   foreach my $ln (@$list)
        {   $$ln =~ s/\r?\n\s+/ /sog
	        if defined $ln && defined $$ln;
        }
    }

    $self;
}


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

    defined $tag && defined $line
        or return undef;

    defined $where
        or $where = -1;

    _insert $self, $tag, $line, $where;

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


sub replace
{   my $self = shift;
    my $idx  = @_ % 2 ? pop @_ : 0;

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

        defined $tag && defined $line
            or return undef;

        my $field = $self->{mail_hdr_hash}{$tag};
        if($field && defined $field->[$idx])
             { ${$field->[$idx]} = $line }
        else { _insert $self, $tag, $line, -1 }
    }

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


sub combine
{   my $self = shift;
    my $tag  = _tag_case shift;
    my $with = shift || ' ';

    $tag =~ /^From /io && $self->{mail_hdr_mail_from} ne 'KEEP'
        and return _error "unadorned 'From ' ignored";

    my $def = $self->{mail_hdr_hash}{$tag}
        or return undef;

    return $def->[0]
        if @$def <= 1;

    my @lines = $self->get($tag);
    chomp @lines;

    my $line = (_fmt_line $self, $tag, join($with,@lines), 1)[1];

    $self->{mail_hdr_hash}{$tag} = [ \$line ];
    $line;
}


sub get
{   my $self = shift;
    my $tag = _tag_case shift;
    my $idx = shift;

    my $def = $self->{mail_hdr_hash}{$tag}
        or return ();

    my $l = length $tag;
    $l   += 1 if $tag !~ / $/o;

    if(defined $idx || !wantarray)
    {    $idx ||= 0;
         defined $def->[$idx] or return undef;
         my $val = ${$def->[$idx]};
         defined $val or return undef;

	 $val = substr $val, $l;
	 $val =~ s/^\s+//;
         return $val;
    }

    map { my $tmp = substr $$_,$l; $tmp =~ s/^\s+//; $tmp } @$def;
}



sub count
{   my $self = shift;
    my $tag  = _tag_case shift;
    my $def  = $self->{mail_hdr_hash}{$tag};
    defined $def ? scalar(@$def) : 0;
}



sub delete
{   my $self = shift;
    my $tag  = _tag_case shift;
    my $idx  = shift;
    my @val;

    if(my $def = $self->{mail_hdr_hash}{$tag})
    {   my $l = length $tag;
        $l   += 2 if $tag !~ / $/;

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

        _tidy_header($self);
    }

    @val;
}



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

    foreach my $ln (@{$self->{mail_hdr_list}})
    {   defined $ln or next;
        print $fd $ln or return 0;
    }

    1;
}


sub as_string { join '', grep {defined} @{shift->{mail_hdr_list}} }


sub tags { keys %{shift->{mail_hdr_hash}} }


sub cleanup
{   my $self = shift;
    my $deleted = 0;

    foreach my $key (@_ ? @_ : keys %{$self->{mail_hdr_hash}})
    {   my $fields = $self->{mail_hdr_hash}{$key};
        foreach my $field (@$fields)
        {   next if $$field =~ /^\S+\s+\S/s;
            undef $$field;
            $deleted++;
        }
    }

    _tidy_header $self
        if $deleted;

    $self;  
}

1;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)