Initial Commit
This commit is contained in:
Riley Schneider
538
database/perl/vendor/lib/Email/Simple/Header.pm
vendored
Normal file
538
database/perl/vendor/lib/Email/Simple/Header.pm
vendored
Normal file
@@ -0,0 +1,538 @@
|
||||
use strict;
|
||||
use warnings;
|
||||
package Email::Simple::Header;
|
||||
# ABSTRACT: the header of an Email::Simple message
|
||||
$Email::Simple::Header::VERSION = '2.216';
|
||||
use Carp ();
|
||||
|
||||
require Email::Simple;
|
||||
|
||||
#pod =head1 SYNOPSIS
|
||||
#pod
|
||||
#pod my $email = Email::Simple->new($text);
|
||||
#pod
|
||||
#pod my $header = $email->header_obj;
|
||||
#pod print $header->as_string;
|
||||
#pod
|
||||
#pod =head1 DESCRIPTION
|
||||
#pod
|
||||
#pod This method implements the headers of an Email::Simple object. It is a very
|
||||
#pod minimal interface, and is mostly for private consumption at the moment.
|
||||
#pod
|
||||
#pod =method new
|
||||
#pod
|
||||
#pod my $header = Email::Simple::Header->new($head, \%arg);
|
||||
#pod
|
||||
#pod C<$head> is a string containing a valid email header, or a reference to such a
|
||||
#pod string. If a reference is passed in, don't expect that it won't be altered.
|
||||
#pod
|
||||
#pod Valid arguments are:
|
||||
#pod
|
||||
#pod crlf - the header's newline; defaults to CRLF
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
# We need to be able to:
|
||||
# * get all values by lc name
|
||||
# * produce all pairs, with case intact
|
||||
|
||||
sub new {
|
||||
my ($class, $head, $arg) = @_;
|
||||
|
||||
my $head_ref = ref $head ? $head : \$head;
|
||||
|
||||
my $self = { mycrlf => $arg->{crlf} || "\x0d\x0a", };
|
||||
|
||||
my $headers = $class->_header_to_list($head_ref, $self->{mycrlf});
|
||||
|
||||
# for my $header (@$headers) {
|
||||
# push @{ $self->{order} }, $header->[0];
|
||||
# push @{ $self->{head}{ $header->[0] } }, $header->[1];
|
||||
# }
|
||||
#
|
||||
# $self->{header_names} = { map { lc $_ => $_ } keys %{ $self->{head} } };
|
||||
$self->{headers} = $headers;
|
||||
|
||||
bless $self => $class;
|
||||
}
|
||||
|
||||
sub _header_to_list {
|
||||
my ($self, $head, $mycrlf) = @_;
|
||||
|
||||
my @headers;
|
||||
|
||||
my $crlf = Email::Simple->__crlf_re;
|
||||
|
||||
while ($$head =~ m/\G(.+?)$crlf/go) {
|
||||
local $_ = $1;
|
||||
|
||||
if (/^\s+/ or not /^([^:]+):\s*(.*)/) {
|
||||
# This is a continuation line. We fold it onto the end of
|
||||
# the previous header.
|
||||
next if !@headers; # Well, that sucks. We're continuing nothing?
|
||||
|
||||
(my $trimmed = $_) =~ s/^\s+//;
|
||||
$headers[-1][0] .= $headers[-1][0] =~ /\S/ ? " $trimmed" : $trimmed;
|
||||
$headers[-1][1] .= "$mycrlf$_";
|
||||
} else {
|
||||
push @headers, $1, [ $2, $_ ];
|
||||
}
|
||||
}
|
||||
|
||||
return \@headers;
|
||||
}
|
||||
|
||||
#pod =method as_string
|
||||
#pod
|
||||
#pod my $string = $header->as_string(\%arg);
|
||||
#pod
|
||||
#pod This returns a stringified version of the header.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
# RFC 2822, 3.6:
|
||||
# ...for the purposes of this standard, header fields SHOULD NOT be reordered
|
||||
# when a message is transported or transformed. More importantly, the trace
|
||||
# header fields and resent header fields MUST NOT be reordered, and SHOULD be
|
||||
# kept in blocks prepended to the message.
|
||||
|
||||
sub as_string {
|
||||
my ($self, $arg) = @_;
|
||||
$arg ||= {};
|
||||
|
||||
my $header_str = '';
|
||||
|
||||
my $headers = $self->{headers};
|
||||
|
||||
my $fold_arg = {
|
||||
# at => (exists $arg->{fold_at} ? $arg->{fold_at} : $self->default_fold_at),
|
||||
# indent => (exists $arg->{fold_indent} ? $arg->{fold_indent} : $self->default_fold_indent),
|
||||
at => $self->_default_fold_at,
|
||||
indent => $self->_default_fold_indent,
|
||||
};
|
||||
|
||||
for (my $i = 0; $i < @$headers; $i += 2) {
|
||||
if (ref $headers->[ $i + 1 ]) {
|
||||
$header_str .= $headers->[ $i + 1 ][1] . $self->crlf;
|
||||
} else {
|
||||
my $header = "$headers->[$i]: $headers->[$i + 1]";
|
||||
|
||||
$header_str .= $self->_fold($header, $fold_arg);
|
||||
}
|
||||
}
|
||||
|
||||
return $header_str;
|
||||
}
|
||||
|
||||
#pod =method header_names
|
||||
#pod
|
||||
#pod This method returns a list of the unique header names found in this header, in
|
||||
#pod no particular order.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub header_names {
|
||||
my $headers = $_[0]->{headers};
|
||||
|
||||
my %seen;
|
||||
grep { !$seen{ lc $_ }++ }
|
||||
map { $headers->[ $_ * 2 ] } 0 .. @$headers / 2 - 1;
|
||||
}
|
||||
|
||||
#pod =method header_raw_pairs
|
||||
#pod
|
||||
#pod my @pairs = $header->header_raw_pairs;
|
||||
#pod my $first_name = $pairs[0];
|
||||
#pod my $first_value = $pairs[1];
|
||||
#pod
|
||||
#pod This method returns a list of all the field/value pairs in the header, in the
|
||||
#pod order that they appear in the header. (Remember: don't try assigning that to a
|
||||
#pod hash. Some fields may appear more than once!)
|
||||
#pod
|
||||
#pod =method header_pairs
|
||||
#pod
|
||||
#pod L<header_pairs> is another name for L<header_raw_pairs>, which was the original
|
||||
#pod name for the method and which you'll see most often. In general, though, it's
|
||||
#pod better to be explicit and use L<header_raw_pairs>. (In Email::MIME,
|
||||
#pod L<header_str_pairs> exists for letting the library do the header decoding for
|
||||
#pod you.)
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub header_raw_pairs {
|
||||
my ($self) = @_;
|
||||
|
||||
my @pairs = map {; _str_value($_) } @{ $self->{headers} };
|
||||
|
||||
return @pairs;
|
||||
}
|
||||
|
||||
sub header_pairs {
|
||||
my ($self) = @_;
|
||||
$self->header_raw_pairs;
|
||||
}
|
||||
|
||||
#pod =method header_raw
|
||||
#pod
|
||||
#pod my $first_value = $header->header_raw($field);
|
||||
#pod my $nth_value = $header->header_raw($field, $index);
|
||||
#pod my @all_values = $header->header_raw($field);
|
||||
#pod
|
||||
#pod This method returns the value or values of the given header field. If the
|
||||
#pod named field does not appear in the header, this method returns false.
|
||||
#pod
|
||||
#pod =method header
|
||||
#pod
|
||||
#pod This method just calls C<header_raw>. It's the older name for C<header_raw>,
|
||||
#pod but it can be a problem because L<Email::MIME>, a subclass of Email::Simple,
|
||||
#pod makes C<header> return the header's decoded value.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub _str_value { return ref $_[0] ? $_[0][0] : $_[0] }
|
||||
|
||||
sub header_raw {
|
||||
my ($self, $field, $index) = @_;
|
||||
|
||||
my $headers = $self->{headers};
|
||||
my $lc_field = lc $field;
|
||||
|
||||
if (wantarray and not defined $index) {
|
||||
return map { _str_value($headers->[ $_ * 2 + 1 ]) }
|
||||
grep { lc $headers->[ $_ * 2 ] eq $lc_field } 0 .. @$headers / 2 - 1;
|
||||
} else {
|
||||
$index = 0 unless defined $index;
|
||||
my $max = @$headers / 2 - 1;
|
||||
my @indexes = $index >= 0 ? (0 .. $max) : reverse(0 .. $max);
|
||||
$index = -1-$index if $index < 0;
|
||||
for (@indexes) {
|
||||
next unless lc $headers->[ $_ * 2 ] eq $lc_field;
|
||||
return _str_value($headers->[ $_ * 2 + 1 ]) if $index-- == 0;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
*header = \&header_raw;
|
||||
|
||||
#pod =method header_raw_set
|
||||
#pod
|
||||
#pod $header->header_raw_set($field => @values);
|
||||
#pod
|
||||
#pod This method updates the value of the given header. Existing headers have their
|
||||
#pod values set in place. Additional headers are added at the end. If no values
|
||||
#pod are given to set, the header will be removed from to the message entirely.
|
||||
#pod
|
||||
#pod =method header_set
|
||||
#pod
|
||||
#pod L<header_set> is another name for L<header_raw_set>, which was the original
|
||||
#pod name for the method and which you'll see most often. In general, though, it's
|
||||
#pod better to be explicit and use L<header_raw_set>. (In Email::MIME,
|
||||
#pod L<header_str_set> exists for letting the library do the header encoding for
|
||||
#pod you.)
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
# Header fields are lines composed of a field name, followed by a colon (":"),
|
||||
# followed by a field body, and terminated by CRLF. A field name MUST be
|
||||
# composed of printable US-ASCII characters (i.e., characters that have values
|
||||
# between 33 and 126, inclusive), except colon. A field body may be composed
|
||||
# of any US-ASCII characters, except for CR and LF.
|
||||
|
||||
# However, a field body may contain CRLF when used in header "folding" and
|
||||
# "unfolding" as described in section 2.2.3.
|
||||
|
||||
sub header_raw_set {
|
||||
my ($self, $field, @data) = @_;
|
||||
|
||||
# I hate this block. -- rjbs, 2006-10-06
|
||||
if ($Email::Simple::GROUCHY) {
|
||||
Carp::croak "field name contains illegal characters"
|
||||
unless $field =~ /^[\x21-\x39\x3b-\x7e]+$/;
|
||||
Carp::carp "field name is not limited to hyphens and alphanumerics"
|
||||
unless $field =~ /^[\w-]+$/;
|
||||
}
|
||||
|
||||
my $headers = $self->{headers};
|
||||
|
||||
my $lc_field = lc $field;
|
||||
my @indices = grep { lc $headers->[$_] eq $lc_field }
|
||||
map { $_ * 2 } 0 .. @$headers / 2 - 1;
|
||||
|
||||
if (@indices > @data) {
|
||||
my $overage = @indices - @data;
|
||||
splice @{$headers}, $_, 2 for reverse @indices[ -$overage .. -1 ];
|
||||
pop @indices for (1 .. $overage);
|
||||
} elsif (@data > @indices) {
|
||||
my $underage = @data - @indices;
|
||||
for (1 .. $underage) {
|
||||
push @$headers, $field, undef; # temporary value
|
||||
push @indices, $#$headers - 1;
|
||||
}
|
||||
}
|
||||
|
||||
for (0 .. $#indices) {
|
||||
$headers->[ $indices[$_] + 1 ] = $data[$_];
|
||||
}
|
||||
|
||||
return wantarray ? @data : $data[0];
|
||||
}
|
||||
|
||||
sub header_set {
|
||||
my ($self, $field, @data) = @_;
|
||||
$self->header_raw_set($field, @data);
|
||||
}
|
||||
|
||||
#pod =method header_raw_prepend
|
||||
#pod
|
||||
#pod $header->header_raw_prepend($field => $value);
|
||||
#pod
|
||||
#pod This method adds a new instance of the name field as the first field in the
|
||||
#pod header.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub header_raw_prepend {
|
||||
my ($self, $field, $value) = @_;
|
||||
|
||||
Carp::confess("tried to prepend raw header with undefined field name")
|
||||
unless defined $field;
|
||||
|
||||
Carp::confess(qq{tried to prepend raw header "$field" with undefined value})
|
||||
unless defined $value;
|
||||
|
||||
unshift @{ $self->{headers} }, $field => $value;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
#pod =method crlf
|
||||
#pod
|
||||
#pod This method returns the newline string used in the header.
|
||||
#pod
|
||||
#pod =cut
|
||||
|
||||
sub crlf { $_[0]->{mycrlf} }
|
||||
|
||||
# =method fold
|
||||
#
|
||||
# my $folded = $header->fold($line, \%arg);
|
||||
#
|
||||
# Given a header string, this method returns a folded version, if the string is
|
||||
# long enough to warrant folding. This method is used internally.
|
||||
#
|
||||
# Valid arguments are:
|
||||
#
|
||||
# at - fold lines to be no longer than this length, if possible
|
||||
# if given and false, never fold headers
|
||||
# indent - indent lines with this string
|
||||
|
||||
# =cut
|
||||
|
||||
sub _fold {
|
||||
my ($self, $line, $arg) = @_;
|
||||
$arg ||= {};
|
||||
|
||||
$arg->{at} = $self->_default_fold_at unless exists $arg->{at};
|
||||
|
||||
$arg->{indent} = $self->_default_fold_indent unless exists $arg->{indent};
|
||||
|
||||
my $indent = $arg->{indent} || $self->_default_fold_indent;
|
||||
|
||||
# We will not folder headers if...
|
||||
# * the header has vertical whitespace
|
||||
# * all vertical whitespace is followed by horizontal whitespace or END
|
||||
if ($line =~ /\n/) {
|
||||
if ($line =~ s/\n([^\s\t])/\n$indent$1/g) {
|
||||
Carp::carp("bad space in header: newline followed by non-space: $line");
|
||||
} else {
|
||||
$line .= $self->crlf unless $line =~ /\n$/;
|
||||
return $line;
|
||||
}
|
||||
}
|
||||
|
||||
return $line . $self->crlf unless $arg->{at} and $arg->{at} > 0;
|
||||
|
||||
my $limit = ($arg->{at} || $self->_default_fold_at) - 1;
|
||||
|
||||
return $line . $self->crlf if length $line <= $limit;
|
||||
|
||||
return $self->__fold_objless($line, $limit, $indent, $self->crlf);
|
||||
|
||||
}
|
||||
|
||||
sub __fold_objless {
|
||||
my ($self, $line, $limit, $indent, $crlf) = @_;
|
||||
|
||||
# We know it will not contain any new lines at present
|
||||
my $folded = "";
|
||||
while (length $line) {
|
||||
if ($line =~ s/^(.{0,$limit})(\s|\z)//) {
|
||||
$folded .= $1 . $crlf;
|
||||
$folded .= $indent if length $line;
|
||||
} else {
|
||||
# Basically nothing we can do. :(
|
||||
$folded .= $line . $crlf;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
return $folded;
|
||||
}
|
||||
|
||||
# =method default_fold_at
|
||||
#
|
||||
# This method (provided for subclassing) returns the default length at which to
|
||||
# try to fold header lines. The default default is 78.
|
||||
#
|
||||
# =cut
|
||||
|
||||
sub _default_fold_at { 78 }
|
||||
|
||||
# =method default_fold_indent
|
||||
#
|
||||
# This method (provided for subclassing) returns the default string used to
|
||||
# indent folded headers. The default default is a single space.
|
||||
#
|
||||
# =cut
|
||||
|
||||
sub _default_fold_indent { " " }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Email::Simple::Header - the header of an Email::Simple message
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 2.216
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $email = Email::Simple->new($text);
|
||||
|
||||
my $header = $email->header_obj;
|
||||
print $header->as_string;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This method implements the headers of an Email::Simple object. It is a very
|
||||
minimal interface, and is mostly for private consumption at the moment.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new
|
||||
|
||||
my $header = Email::Simple::Header->new($head, \%arg);
|
||||
|
||||
C<$head> is a string containing a valid email header, or a reference to such a
|
||||
string. If a reference is passed in, don't expect that it won't be altered.
|
||||
|
||||
Valid arguments are:
|
||||
|
||||
crlf - the header's newline; defaults to CRLF
|
||||
|
||||
=head2 as_string
|
||||
|
||||
my $string = $header->as_string(\%arg);
|
||||
|
||||
This returns a stringified version of the header.
|
||||
|
||||
=head2 header_names
|
||||
|
||||
This method returns a list of the unique header names found in this header, in
|
||||
no particular order.
|
||||
|
||||
=head2 header_raw_pairs
|
||||
|
||||
my @pairs = $header->header_raw_pairs;
|
||||
my $first_name = $pairs[0];
|
||||
my $first_value = $pairs[1];
|
||||
|
||||
This method returns a list of all the field/value pairs in the header, in the
|
||||
order that they appear in the header. (Remember: don't try assigning that to a
|
||||
hash. Some fields may appear more than once!)
|
||||
|
||||
=head2 header_pairs
|
||||
|
||||
L<header_pairs> is another name for L<header_raw_pairs>, which was the original
|
||||
name for the method and which you'll see most often. In general, though, it's
|
||||
better to be explicit and use L<header_raw_pairs>. (In Email::MIME,
|
||||
L<header_str_pairs> exists for letting the library do the header decoding for
|
||||
you.)
|
||||
|
||||
=head2 header_raw
|
||||
|
||||
my $first_value = $header->header_raw($field);
|
||||
my $nth_value = $header->header_raw($field, $index);
|
||||
my @all_values = $header->header_raw($field);
|
||||
|
||||
This method returns the value or values of the given header field. If the
|
||||
named field does not appear in the header, this method returns false.
|
||||
|
||||
=head2 header
|
||||
|
||||
This method just calls C<header_raw>. It's the older name for C<header_raw>,
|
||||
but it can be a problem because L<Email::MIME>, a subclass of Email::Simple,
|
||||
makes C<header> return the header's decoded value.
|
||||
|
||||
=head2 header_raw_set
|
||||
|
||||
$header->header_raw_set($field => @values);
|
||||
|
||||
This method updates the value of the given header. Existing headers have their
|
||||
values set in place. Additional headers are added at the end. If no values
|
||||
are given to set, the header will be removed from to the message entirely.
|
||||
|
||||
=head2 header_set
|
||||
|
||||
L<header_set> is another name for L<header_raw_set>, which was the original
|
||||
name for the method and which you'll see most often. In general, though, it's
|
||||
better to be explicit and use L<header_raw_set>. (In Email::MIME,
|
||||
L<header_str_set> exists for letting the library do the header encoding for
|
||||
you.)
|
||||
|
||||
=head2 header_raw_prepend
|
||||
|
||||
$header->header_raw_prepend($field => $value);
|
||||
|
||||
This method adds a new instance of the name field as the first field in the
|
||||
header.
|
||||
|
||||
=head2 crlf
|
||||
|
||||
This method returns the newline string used in the header.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Simon Cozens
|
||||
|
||||
=item *
|
||||
|
||||
Casey West
|
||||
|
||||
=item *
|
||||
|
||||
Ricardo SIGNES
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is copyright (c) 2003 by Simon Cozens.
|
||||
|
||||
This is free software; you can redistribute it and/or modify it under
|
||||
the same terms as the Perl 5 programming language system itself.
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user