| Current Path : /usr/share/perl5/vendor_perl/Mail/ |
Linux gator3171.hostgator.com 4.19.286-203.ELK.el7.x86_64 #1 SMP Wed Jun 14 04:33:55 CDT 2023 x86_64 |
| Current File : //usr/share/perl5/vendor_perl/Mail/Header.pm |
# Copyrights 1995-2012 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.00.
package Mail::Header;
use vars '$VERSION';
$VERSION = '2.12';
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) prefered 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 capitization 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 && $lines->[0] =~ /^($FIELD_NAME|From )/o)
{ my $tag = $1;
my $line = shift @$lines;
$line .= shift @$lines
while @$lines && $lines->[0] =~ /^[ \t]+/o;
($tag, $line) = _fmt_line $self, $tag, $line;
_insert $self, $tag, $line, -1
if defined $line;
}
shift @$lines
if @$lines && $lines->[0] =~ /^\s*$/o;
$self;
}
sub read
{ my ($self, $fd) = @_;
$self->empty;
my ($tag, $line);
my $ln = '';
while(1)
{ $ln = <$fd>;
if(defined $ln && defined $line && $ln =~ /\A[ \t]+/o)
{ $line .= $ln;
next;
}
if(defined $line)
{ ($tag, $line) = _fmt_line $self, $tag, $line;
_insert $self, $tag, $line, -1
if defined $line;
}
defined $ln && $ln =~ /^($FIELD_NAME|From )/o
or last;
($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}} ];
}
### text kept, for educational purpose... originates from 2000/03
# 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 ($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;