Initial class construction
This commit is contained in:
João Narciso
636
Git/usr/share/perl5/vendor_perl/Mail/Header.pm
Normal file
636
Git/usr/share/perl5/vendor_perl/Mail/Header.pm
Normal file
@ -0,0 +1,636 @@
|
||||
# Copyrights 1995-2018 by [Mark Overmeer].
|
||||
# For other contributors see ChangeLog.
|
||||
# See the manual pages for details on the licensing terms.
|
||||
# Pod stripped from pm file by OODoc 2.02.
|
||||
# This code is part of the bundle MailTools. Meta-POD processed with
|
||||
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
|
||||
# Licensed under the same terms as Perl itself.
|
||||
|
||||
package Mail::Header;
|
||||
use vars '$VERSION';
|
||||
$VERSION = '2.20';
|
||||
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
|
||||
my $MAIL_FROM = 'KEEP';
|
||||
my %HDR_LENGTHS = ();
|
||||
|
||||
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 an 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;
|
||||
Reference in New Issue
Block a user