summaryrefslogtreecommitdiff
path: root/cpan/lib/Mail/Header.pm
diff options
context:
space:
mode:
Diffstat (limited to 'cpan/lib/Mail/Header.pm')
-rw-r--r--cpan/lib/Mail/Header.pm1257
1 files changed, 437 insertions, 820 deletions
diff --git a/cpan/lib/Mail/Header.pm b/cpan/lib/Mail/Header.pm
index ca864212..a999f656 100644
--- a/cpan/lib/Mail/Header.pm
+++ b/cpan/lib/Mail/Header.pm
@@ -1,166 +1,126 @@
-# Mail::Header.pm
-#
-# Copyright (c) 1995-2001 Graham Barr <gbarr@pobox.com>. All rights reserved.
-# 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.
-#
-
+# Copyrights 1995-2017 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.19';
-require 5.002;
use strict;
use Carp;
-use vars qw($VERSION $FIELD_NAME);
-
-$VERSION = "1.52";
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 :]+:';
+our $FIELD_NAME = '[^\x00-\x1f\x7f-\xff :]+:';
+
##
## Private functions
##
-sub _error { warn @_; return (wantarray ? () : undef) }
+sub _error { warn @_; () }
# tidy up internal hash table and list
sub _tidy_header
-{
- my $me = shift;
- my($ref,$key);
- my $i;
- my $d = 0;
-
- for($i = 0 ; $i < scalar(@{$me->{'mail_hdr_list'}}) ; $i++)
- {
- unless(defined $me->{'mail_hdr_list'}[$i])
- {
- splice(@{$me->{'mail_hdr_list'}},$i,1);
- $d++;
- $i--;
- }
- }
+{ my $self = shift;
+ my $deleted = 0;
- if($d)
- {
- local $_;
- my @del = ();
+ for(my $i = 0 ; $i < @{$self->{mail_hdr_list}}; $i++)
+ { next if defined $self->{mail_hdr_list}[$i];
- while(($key,$ref) = each %{$me->{'mail_hdr_hash'}} )
- {
- push(@del, $key)
- unless @$ref = grep { ref($_) && defined $$_ } @$ref;
+ splice @{$self->{mail_hdr_list}}, $i, 1;
+ $deleted++;
+ $i--;
}
- map { delete $me->{'mail_hdr_hash'}{$_} } @del;
- }
+ 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;
-@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
-}} = ();
+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;
- 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;
+{ 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;
+ $_[0] =~ s/\A(\S+)\n\s*(?=\S)/$1 /so;
}
-# attempt to change the case of a tag to that required by RFC822. That
+# 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/:\Z//o;
-
- # Change the casing of the tag, eg "Message-Id"
- # Bug in unicode \U, perl 5.8.0 requires an extra \u
- $tag =~ s/\b([a-z]+)/\L\u\u$1/gio;
- $tag =~ s/\b([b-df-hj-np-tv-z]+|MIME)\b/\U\u$1/gio
- if $tag =~ /-/;
-
- $tag;
+{ 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
@@ -170,846 +130,503 @@ sub _tag_case
# 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>"
+{ 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/([^ :])\Z/$1:/o if defined $ctag;
- }
+ if(defined $tag)
+ { $tag = _tag_case($ctag = $tag);
+ $ctag = $tag if $modify;
+ $ctag =~ s/([^ :])$/$1:/o if defined $ctag;
+ }
- croak( "Bad RFC822 field name '$tag'\n")
- unless(defined $ctag && $ctag =~ /\A($FIELD_NAME|From )/oi);
+ 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 !~ /\A\Q$ctag\E/i))
- {
- my $xtag;
- ($xtag = $ctag) =~ s/\s*\Z//o;
- $line =~ s/\A(\Q$ctag\E)?\s*/$xtag /i;
- }
+ # 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 = $me->{'mail_hdr_lengths'}{$tag}
- || $HDR_LENGTHS{$tag}
- || $me->fold_length;
+ my $maxlen = $self->{mail_hdr_lengths}{$tag}
+ || $HDR_LENGTHS{$tag}
+ || $self->fold_length;
- _fold_line($line,$maxlen)
- if $modify && defined $maxlen;
+ 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*\Z/\n/so;
- ($tag, $line);
+ $line =~ s/\n*$/\n/so;
+ ($tag, $line);
}
sub _insert
-{
- my($me,$tag,$line,$where) = @_;
-
- if($where < 0)
- {
- $where = @{$me->{'mail_hdr_list'}} + $where + 1;
+{ my ($self, $tag, $line, $where) = @_;
- $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($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}};
+ }
- if($me->{'mail_hdr_hash'}{$tag} && $where)
- {
- if($atend)
- {
- push(@{$me->{'mail_hdr_hash'}{$tag}}, $ref);
+ 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
- {
- 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 @$def, $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);
- }
- }
+{ my $call = shift;
+ my $class = ref($call) || $call;
+ my $arg = @_ % 2 ? shift : undef;
+ my %opt = @_;
- $me;
-}
+ $opt{Modify} = delete $opt{Reformat}
+ unless exists $opt{Modify};
-sub modify
-{
- my $me = shift;
- my $old = $me->{'mail_hdr_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;
- $me->{'mail_hdr_modify'} = 0 + shift
- if @_;
+ $self->mail_from( uc($opt{MailFrom} || $MAIL_FROM) );
+
+ $self->fold_length($opt{FoldLength})
+ if exists $opt{FoldLength};
- $old;
+ if(!ref $arg) {}
+ elsif(ref($arg) eq 'ARRAY') { $self->extract( [ @$arg ] ) }
+ elsif(defined fileno($arg)) { $self->read($arg) }
+
+ $self;
}
-sub mail_from
-{
- my $me = shift;
- my $choice = uc(shift);
- $choice =~ /^(IGNORE|ERROR|COERCE|KEEP)$/
- or die "bad Mail-From choice: '$choice'";
+sub dup
+{ my $self = shift;
+ my $dup = ref($self)->new;
- if(ref($me))
- {
- $me->{'mail_hdr_mail_from'} = $choice;
- }
- else
- {
- $MAIL_FROM = $choice;
- }
+ %$dup = %$self;
+ $dup->empty; # rebuild tables
- $me;
-}
+ $dup->{mail_hdr_list} = [ @{$self->{mail_hdr_list}} ];
-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;
+ foreach my $ln ( @{$dup->{mail_hdr_list}} )
+ { my $tag = _tag_case +($ln =~ /^($FIELD_NAME|From )/oi)[0];
+ push @{$dup->{mail_hdr_hash}{$tag}}, \$ln;
}
- }
- $me;
+ $dup;
}
-sub unfold
-{
- my $me = shift;
- my($tag,$list,$ln);
-
- if(@_)
- {
- $tag = _tag_case(shift);
- return $me unless exists $me->{'mail_hdr_hash'}{$tag};
- $list = $me->{'mail_hdr_hash'}{$tag};
- foreach $ln (@$list)
- {
- $$ln =~ s/\r?\n\s+/ /sog
- if defined $ln && defined $$ln;
- }
- }
- else
- {
- while(($tag,$list) = each %{$me->{'mail_hdr_hash'}})
- {
- foreach $ln (@$list)
- {
- $$ln =~ s/\r?\n\s+/ /sog
- if defined $ln && defined $$ln;
- }
- }
- }
- $me;
-}
+#------------
sub extract
-{
- my $me = shift;
- my $arr = shift;
- my $line;
-
- $me->empty;
+{ my ($self, $lines) = @_;
+ $self->empty;
- while(scalar(@{$arr}) && $arr->[0] =~ /\A($FIELD_NAME|From )/o)
- {
- my $tag = $1;
+ while(@$lines)
+ { my $line = shift @$lines;
+ last if $line =~ /^\r?$/;
- $line = shift @{$arr};
- $line .= shift @{$arr}
- while(scalar(@{$arr}) && $arr->[0] =~ /\A[ \t]+/o);
+ $line =~ /^($FIELD_NAME|From )/o or next;
+ my $tag = $1;
- ($tag,$line) = _fmt_line($me,$tag,$line);
+ $line .= shift @$lines
+ while @$lines && $lines->[0] =~ /^[ \t]+/;
- _insert($me,$tag,$line,-1)
- if defined $line;
- }
+ ($tag, $line) = _fmt_line $self, $tag, $line;
- shift @{$arr}
- if(scalar(@{$arr}) && $arr->[0] =~ /\A\s*\Z/o);
+ _insert $self, $tag, $line, -1
+ if defined $line;
+ }
- $me;
+ $self;
}
+
sub read
-{
- my $me = shift;
- my $fd = shift;
+{ my ($self, $fd) = @_;
+ $self->empty;
- $me->empty;
+ my ($ln, $tag, $line);
+ while(1)
+ { $ln = <$fd>;
- my $line = undef;
- my $ln = "";
- my $tag = undef;
+ if(defined $ln && defined $line && $ln =~ /^[ \t]+/)
+ { $line .= $ln; # folded line
+ next;
+ }
- while(1)
- {
- $ln = <$fd>;
+ if(defined $line)
+ { ($tag, $line) = _fmt_line $self, $tag, $line;
+ _insert $self, $tag, $line, -1
+ if defined $line;
+ ($tag, $line) = ();
+ }
- if(defined $ln && defined $line && $ln =~ /\A[ \t]+/o)
- {
- $line .= $ln;
- next;
- }
+ last if !defined $ln || $ln =~ m/^\r?$/;
- if(defined $line)
- {
- ($tag,$line) = _fmt_line($me,$tag,$line);
- _insert($me,$tag,$line,-1)
- if defined $line;
+ $ln =~ /^($FIELD_NAME|From )/o or next;
+ ($tag, $line) = ($1, $ln);
}
- last
- unless(defined $ln && $ln =~ /\A($FIELD_NAME|From )/o);
-
- $tag = $1;
- $line = $ln;
- }
-
- $me;
+ $self;
}
-sub empty
-{
- my $me = shift;
-
- $me->{'mail_hdr_list'} = [];
- $me->{'mail_hdr_hash'} = {};
- $me;
+sub empty
+{ my $self = shift;
+ $self->{mail_hdr_list} = [];
+ $self->{mail_hdr_hash} = {};
+ $self;
}
-sub header
-{
- my $me = shift;
- $me->extract(@_)
- if(@_);
+sub header
+{ my $self = shift;
- $me->fold
- if $me->{'mail_hdr_modify'};
+ $self->extract(@_)
+ if @_;
- # 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 :-
+ $self->fold
+ if $self->{mail_hdr_modify};
- [ @{$me->{'mail_hdr_list'}} ];
+ [ @{$self->{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 header_hashref {
- my $me = shift;
- my $hashref = shift;
+sub header_hashref
+{ my ($self, $hashref) = @_;
- # Extract the input data
- for my $hdrkey (keys %$hashref) {
- for (ref $hashref->{$hdrkey}
- ? @{$hashref->{$hdrkey}}
- : $hashref->{$hdrkey}) {
- $me->add($hdrkey, $_);
- }
- }
+ while(my ($key, $value) = each %$hashref)
+ { $self->add($key, $_) for ref $value ? @$value : $value;
+ }
- $me->fold
- if $me->{'mail_hdr_modify'};
+ $self->fold
+ if $self->{mail_hdr_modify};
- # Build a hash
- my $hash={ map { $_ => [ $me->get($_) ] } keys %{$me->{'mail_hdr_hash'}} };
+ defined wantarray # MO, added minimal optimization
+ or return;
- return $hash;
+ +{ map { ($_ => [$self->get($_)] ) } # MO: Eh?
+ keys %{$self->{mail_hdr_hash}}
+ };
}
-sub add
-{
- my $me = shift;
- my($tag,$text,$where) = @_;
- my $line;
- ($tag,$line) = _fmt_line($me,$tag,$text);
-
- # Must have a tag and text to add
- return undef
- unless(defined $tag && defined $line);
-
- $where = -1
- unless defined $where;
+#------------
- _insert($me,$tag,$line,$where);
-
- $line =~ /^\S+\s(.*)/os;
- return $1;
-}
+sub modify
+{ my $self = shift;
+ my $old = $self->{mail_hdr_modify};
-sub replace
-{
- my $me = shift;
- my $idx = 0;
- my($tag,$line);
-
- $idx = pop @_
- if(@_ % 2);
-
-TAG:
- while(@_)
- {
- ($tag,$line) = _fmt_line($me,splice(@_,0,2));
-
- return undef
- unless(defined $tag && defined $line);
-
- if(exists $me->{'mail_hdr_hash'}{$tag} &&
- defined $me->{'mail_hdr_hash'}{$tag}[$idx])
- {
- ${$me->{'mail_hdr_hash'}{$tag}[$idx]} = $line;
- }
- else
- {
- _insert($me,$tag,$line,-1);
- }
- }
+ $self->{mail_hdr_modify} = 0 + shift
+ if @_;
- $line =~ /^\S+\s*(.*)/os;
- return $1;
+ $old;
}
-sub combine
-{
- my $me = shift;
- my $tag = _tag_case(shift);
- my $with = shift || ' ';
- my $line;
-
- return _error "unadorned 'From ' ignored"
- if($tag =~ /^From /io && $me->{'mail_hdr_mail_from'} ne 'KEEP');
-
- return undef
- unless exists $me->{'mail_hdr_hash'}{$tag};
- if(scalar(@{$me->{'mail_hdr_hash'}{$tag}}) > 1)
- {
- my @lines = $me->get($tag);
-
- chomp(@lines);
-
- map { $$_ = undef } @{$me->{'mail_hdr_hash'}{$tag}};
+sub mail_from
+{ my $thing = shift;
+ my $choice = uc shift;
- $line = ${$me->{'mail_hdr_hash'}{$tag}[0]} =
- (_fmt_line($me,$tag, join($with,@lines),1))[1];
+ $choice =~ /^(IGNORE|ERROR|COERCE|KEEP)$/
+ or die "bad Mail-From choice: '$choice'";
- _tidy_header($me);
- }
- else
- {
- return $me->{'mail_hdr_hash'}{$tag}[0];
- }
+ if(ref $thing) { $thing->{mail_hdr_mail_from} = $choice }
+ else { $MAIL_FROM = $choice }
- return $line; # post-match
+ $thing;
}
-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 count
-{
- my $me = shift;
- my $tag = _tag_case(shift);
- exists $me->{'mail_hdr_hash'}{$tag}
- ? scalar(@{$me->{'mail_hdr_hash'}{$tag}})
- : 0;
-}
+sub fold_length
+{ my $thing = shift;
+ my $old;
-sub exists
-{
- carp "Depriciated use of Mail::Header::exists, use count" if $^W;
- count(@_);
-}
+ if(@_ == 2)
+ { my $tag = _tag_case shift;
+ my $len = shift;
-sub delete
-{
- my $me = shift;
- my $tag = _tag_case(shift);
- my $idx = shift;
- my @val = ();
-
- if(defined $me->{'mail_hdr_hash'}{$tag})
- {
- my $l = length($tag);
- $l += 2 unless $tag =~ / \Z/o;
-
- if(defined $idx)
- {
- if(defined $me->{'mail_hdr_hash'}{$tag}[$idx])
- {
- push(@val, substr(${$me->{'mail_hdr_hash'}{$tag}[$idx]},$l));
- undef ${$me->{'mail_hdr_hash'}{$tag}[$idx]};
- }
+ my $hash = ref $thing ? $thing->{mail_hdr_lengths} : \%HDR_LENGTHS;
+ $old = $hash->{$tag};
+ $hash->{$tag} = $len > 20 ? $len : 20;
}
- else
- {
- local $_;
- @val = map {
- my $x = substr($$_,$l);
- undef $$_;
- $x
- } @{$me->{'mail_hdr_hash'}{$tag}};
+ 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};
+ }
}
- _tidy_header($me);
- }
-
- return @val;
-}
-
-sub print
-{
- my $me = shift;
- my $fd = shift || \*STDOUT;
- my $ln;
-
- foreach $ln (@{$me->{'mail_hdr_list'}})
- {
- next
- unless defined $ln;
- print $fd $ln or
- return 0;
- }
-
- 1;
-}
-
-sub as_string
-{
- my $me = shift;
-
- join('', grep { defined } @{$me->{'mail_hdr_list'}});
+ $old;
}
-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'};
+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;
+ }
}
- }
- $old;
+ $self;
}
-sub tags
-{
- my $me = shift;
- keys %{$me->{'mail_hdr_hash'}};
-}
-
-sub dup
-{
- my $me = shift;
- my $type = ref($me) || croak "Cannot dup without an object";
- my $dup = new $type;
-
- %$dup = %$me;
- $dup->empty;
-
- $dup->{'mail_hdr_list'} = [ @{$me->{'mail_hdr_list'}} ];
-
- my $ln;
- foreach $ln ( @{$dup->{'mail_hdr_list'}} )
- {
- my $tag = _tag_case(($ln =~ /\A($FIELD_NAME|From )/oi)[0]);
+sub unfold
+{ my $self = shift;
- $dup->{'mail_hdr_hash'}{$tag} ||= [];
- push(@{$dup->{'mail_hdr_hash'}{$tag}}, \$ln);
- }
+ if(@_)
+ { my $tag = _tag_case shift;
+ my $list = $self->{mail_hdr_hash}{$tag}
+ or return $self;
- $dup;
-}
+ foreach my $ln (@$list)
+ { $$ln =~ s/\r?\n\s+/ /sog
+ if defined $ln && defined $$ln;
+ }
-sub cleanup
-{
- my $me = shift;
- my $d = 0;
- my $key;
-
- foreach $key (@_ ? @_ : keys %{$me->{'mail_hdr_hash'}})
- {
- my $arr = $me->{'mail_hdr_hash'}{$key};
- my $ref;
- foreach $ref (@$arr)
- {
- unless($$ref =~ /\A\S+\s+\S/soi)
- {
- $$ref = undef;
- $d++;
- }
+ return $self;
}
- }
- _tidy_header($me)
- if $d;
+ while( my ($tag, $list) = each %{$self->{mail_hdr_hash}})
+ { foreach my $ln (@$list)
+ { $$ln =~ s/\r?\n\s+/ /sog
+ if defined $ln && defined $$ln;
+ }
+ }
- $me;
+ $self;
}
-1; # keep require happy
-
-
-=head1 NAME
-
-Mail::Header - manipulate mail RFC822 compliant headers
-
-=head1 SYNOPSIS
-
- use Mail::Header;
-
- $head = new Mail::Header;
- $head = new Mail::Header \*STDIN;
- $head = new Mail::Header [<>], Modify => 0;
-
-=head1 DESCRIPTION
-
-This package provides a class object which can be used for reading, creating,
-manipulating and writing RFC822 compliant headers.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ ARG ], [ OPTIONS ] )
-
-C<ARG> may be either a file descriptor (reference to a GLOB)
-or a reference to an array. If given the new object will be
-initialized with headers either from the array of read from
-the file descriptor.
-
-C<OPTIONS> is a list of options given in the form of key-value
-pairs, just like a hash table. Valid options are
-=over 8
-
-=item B<Modify>
-
-If this value is I<true> then the headers will be re-formatted,
-otherwise the format of the header lines will remain unchanged.
-
-=item B<MailFrom>
-
-This option specifies what to do when a header in the form `From '
-is encountered. Valid values are C<IGNORE> - ignore and discard the header,
-C<ERROR> - invoke an error (call die), C<COERCE> - rename them as Mail-From
-and C<KEEP> - keep them.
-
-=item B<FoldLength>
-
-The default length of line to be used when folding header lines
-
-=back
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item modify ( [ VALUE ] )
-
-If C<VALUE> is I<false> then C<Mail::Header> will not do any automatic
-reformatting of the headers, other than to ensure that the line
-starts with the tags given.
-
-=item mail_from ( OPTION )
-
-C<OPTION> specifies what to do when a C<`From '> line is encountered.
-Valid values are C<IGNORE> - ignore and discard the header,
-C<ERROR> - invoke an error (call die), C<COERCE> - rename them as Mail-From
-and C<KEEP> - keep them.
-
-=item fold ( [ LENGTH ] )
-
-Fold the header. If C<LENGTH> is not given then C<Mail::Header> uses the
-following rules to determine what length to fold a line.
-
-The fold length for the tag that is begin processed
-
-The default fold length for the tag that is being processed
+sub add
+{ my ($self, $tag, $text, $where) = @_;
+ ($tag, my $line) = _fmt_line $self, $tag, $text;
-The default fold length for the object
+ defined $tag && defined $line
+ or return undef;
-=item extract ( ARRAY_REF )
+ defined $where
+ or $where = -1;
-Extract a header from the given array. C<extract> B<will modify> this array.
-Returns the object that the method was called on.
+ _insert $self, $tag, $line, $where;
-=item read ( FD )
+ $line =~ /^\S+\s(.*)/os;
+ $1;
+}
-Read a header from the given file descriptor.
-=item empty ()
+sub replace
+{ my $self = shift;
+ my $idx = @_ % 2 ? pop @_ : 0;
-Empty the C<Mail::Header> object of all lines.
+ my ($tag, $line);
+ TAG:
+ while(@_)
+ { ($tag,$line) = _fmt_line $self, splice(@_,0,2);
-=item header ( [ ARRAY_REF ] )
+ defined $tag && defined $line
+ or return undef;
-C<header> does multiple operations. First it will extract a header from
-the array, if given. It will the reformat the header, if reformatting
-is permitted, and finally return a reference to an array which
-contains the header in a printable form.
+ my $field = $self->{mail_hdr_hash}{$tag};
+ if($field && defined $field->[$idx])
+ { ${$field->[$idx]} = $line }
+ else { _insert $self, $tag, $line, -1 }
+ }
-=item header_hashref ( [ HASH_REF ] )
+ $line =~ /^\S+\s*(.*)/os;
+ $1;
+}
-As C<header>, but it will eventually set headers from a hash
-reference, and it will return the headers as a hash reference.
-The values in the hash might either be a scalar or an array reference,
-as an example:
+sub combine
+{ my $self = shift;
+ my $tag = _tag_case shift;
+ my $with = shift || ' ';
- $hashref->{From}='Tobias Brox <tobix@cpan.org>';
- $hashref->{To}=['you@somewhere', 'me@localhost'];
+ $tag =~ /^From /io && $self->{mail_hdr_mail_from} ne 'KEEP'
+ and return _error "unadorned 'From ' ignored";
-=item add ( TAG, LINE [, INDEX ] )
+ my $def = $self->{mail_hdr_hash}{$tag}
+ or return undef;
-Add a new line to the header. If C<TAG> is I<undef> the the tag will be
-extracted from the beginning of the given line. If C<INDEX> is given
-the new line will be inserted into the header at the given point, otherwise
-the new line will be appended to the end of the header.
+ return $def->[0]
+ if @$def <= 1;
-=item replace ( TAG, LINE [, INDEX ] )
+ my @lines = $self->get($tag);
+ chomp @lines;
-Replace a line in the header. If C<TAG> is I<undef> the the tag will be
-extracted from the beginning of the given line. If C<INDEX> is given
-the new line will replace the Nth instance of that tag, otherwise the
-first instance of the tag is replaced. If the tag does not appear in the
-header then a new line will be appended to the header.
+ my $line = (_fmt_line $self, $tag, join($with,@lines), 1)[1];
-=item combine ( TAG [, WITH ] )
+ $self->{mail_hdr_hash}{$tag} = [ \$line ];
+ $line;
+}
-Combine all instances of C<TAG> into one. The lines will be
-joined togther with C<WITH>, or a single space if not given. The new
-item will be positioned in the header where the first instance was, all
-other instances of <TAG> will be removed.
-=item get ( TAG [, INDEX ] )
+sub get
+{ my $self = shift;
+ my $tag = _tag_case shift;
+ my $idx = shift;
-Get the text form a line. If C<INDEX> is given then the text of the Nth
-instance will be returned. If it is not given the return value depends on the
-context in which C<get> was called. In an array context a list of all the
-text from all the instances of C<TAG> will be returned. In a scalar context
-the text for the first instance will be returned.
+ my $def = $self->{mail_hdr_hash}{$tag}
+ or return ();
-=item delete ( TAG [, INDEX ] )
+ my $l = length $tag;
+ $l += 1 if $tag !~ / $/o;
-Delete a tag from the header. If C<INDEX> id given then the Nth instance
-of the tag will be removed. If C<INDEX> is not given all instances
-of tag will be removed.
+ if(defined $idx || !wantarray)
+ { $idx ||= 0;
+ defined $def->[$idx] or return undef;
+ my $val = ${$def->[$idx]};
+ defined $val or return undef;
-=item count ( TAG )
+ $val = substr $val, $l;
+ $val =~ s/^\s+//;
+ return $val;
+ }
-Returns the number of times the given atg appears in the header
+ map { my $tmp = substr $$_,$l; $tmp =~ s/^\s+//; $tmp } @$def;
+}
-=item print ( [ FD ] )
-Print the header to the given file descriptor, or C<STDOUT> if no
-file descriptor is given.
-=item as_string ()
+sub count
+{ my $self = shift;
+ my $tag = _tag_case shift;
+ my $def = $self->{mail_hdr_hash}{$tag};
+ defined $def ? scalar(@$def) : 0;
+}
-Returns the header as a single string.
-=item fold_length ( [ TAG ], [ LENGTH ] )
-Set the default fold length for all tags or just one. With no arguments
-the default fold length is returned. With two arguments it sets the fold
-length for the given tag and returns the previous value. If only C<LENGTH>
-is given it sets the default fold length for the current object.
+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);
+ }
-In the two argument form C<fold_length> may be called as a static method,
-setting default fold lengths for tags that will be used by B<all>
-C<Mail::Header> objects. See the C<fold> method for
-a description on how C<Mail::Header> uses these values.
+ @val;
+}
-=item tags ()
-Retruns an array of all the tags that exist in the header. Each tag will
-only appear in the list once. The order of the tags is not specified.
-=item dup ()
+sub print
+{ my $self = shift;
+ my $fd = shift || \*STDOUT;
-Create a duplicate of the current object.
+ foreach my $ln (@{$self->{mail_hdr_list}})
+ { defined $ln or next;
+ print $fd $ln or return 0;
+ }
-=item cleanup ()
+ 1;
+}
-Remove any header line that, other than the tag, only contains whitespace
-=item unfold ( [ TAG ] )
+sub as_string { join '', grep {defined} @{shift->{mail_hdr_list}} }
-Unfold all instances of the given tag so that they do not spread across
-multiple lines. IF C<TAG> is not given then all lines are unfolded.
-=back
+sub tags { keys %{shift->{mail_hdr_hash}} }
-=head1 AUTHOR
-Graham Barr. Maintained by Mark Overmeer <mailtools@overmeer.net>
+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++;
+ }
+ }
-=head1 COPYRIGHT
+ _tidy_header $self
+ if $deleted;
-Copyright (c) 1995-2001 Graham Barr. All rights reserved. This program is free
-software; you can redistribute it and/or modify it under the same terms
-as Perl itself.
+ $self;
+}
-=cut
+1;
generated by cgit v1.2.1 (git 2.18.0) at 2026-09-02 19:27:36 +0000