diff options
Diffstat (limited to 'cpan/lib')
32 files changed, 4256 insertions, 3577 deletions
diff --git a/cpan/lib/Mail/Address.pm b/cpan/lib/Mail/Address.pm index 6fa1f1c9..13b2ff7d 100644 --- a/cpan/lib/Mail/Address.pm +++ b/cpan/lib/Mail/Address.pm @@ -1,27 +1,32 @@ -# Mail::Address.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. - +# 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::Address; +use vars '$VERSION'; +$VERSION = '2.19'; + use strict; use Carp; -use vars qw($VERSION); -use locale; -$VERSION = "1.52"; -sub Version { $VERSION } +# use locale; removed in version 1.78, because it causes taint problems -# -# given a comment, attempt to extract a person's name -# +sub Version { our $VERSION } + + +# given a comment, attempt to extract a person's name sub _extract_name -{ - local $_ = shift || ''; - +{ # This function can be called as method as well + my $self = @_ && ref $_[0] ? shift : undef; + + local $_ = shift + or return ''; + + # Using encodings, too hard. See Mail::Message::Field::Full. + return '' if m/\=\?.*?\?\=/; + # trim whitespace s/^\s+//; s/\s+$//; @@ -30,391 +35,242 @@ sub _extract_name # Disregard numeric names (e.g. 123456.1234@compuserve.com) return "" if /^[\d ]+$/; - # remove outermost parenthesis - s/^\(|\)$//g; - - # remove outer quotation marks - s/^"|"$//g; - - # remove embedded comments - s/\(.*\)//g; - - # reverse "Last, First M." if applicable - s/^([^\s]+) ?, ?(.*)$/$2 $1/; + s/^\((.*)\)$/$1/; # remove outermost parenthesis + s/^"(.*)"$/$1/; # remove outer quotation marks + s/\(.*?\)//g; # remove minimal embedded comments + s/\\//g; # remove all escapes + s/^"(.*)"$/$1/; # remove internal quotation marks + s/^([^\s]+) ?, ?(.*)$/$2 $1/; # reverse "Last, First M." if applicable s/,.*//; - # Set the case of the name to first char upper rest lower - # Upcase first letter on name - s/\b(\w+)/\L\u$1/igo; - - # Scottish names such as 'McLeod' - s/\bMc(\w)/Mc\u$1/igo; - - # Irish names such as 'O'Malley, O'Reilly' - s/\bo'(\w)/O'\u$1/igo; - - # Roman numerals, eg 'Level III Support' - s/\b(x*(ix)?v*(iv)?i*)\b/\U$1/igo; + # Change casing only when the name contains only upper or only + # lower cased characters. + unless( m/[A-Z]/ && m/[a-z]/ ) + { # Set the case of the name to first char upper rest lower + s/\b(\w+)/\L\u$1/igo; # Upcase first letter on name + s/\bMc(\w)/Mc\u$1/igo; # Scottish names such as 'McLeod' + s/\bo'(\w)/O'\u$1/igo; # Irish names such as 'O'Malley, O'Reilly' + s/\b(x*(ix)?v*(iv)?i*)\b/\U$1/igo; # Roman numerals, eg 'Level III Support' + } # some cleanup s/\[[^\]]*\]//g; s/(^[\s'"]+|[\s'"]+$)//g; s/\s{2,}/ /g; - return $_; + $_; } -sub _tokenise { - local($_) = join(',', @_); - my(@words,$snippet,$field); - - s/\A\s+//; - s/[\r\n]+/ /g; +sub _tokenise +{ local $_ = join ',', @_; + my (@words,$snippet,$field); - while ($_ ne '') - { - $field = ''; - if( s/^\s*\(/(/ ) # (...) - { - my $depth = 0; + s/\A\s+//; + s/[\r\n]+/ /g; + + while ($_ ne '') + { $field = ''; + if(s/^\s*\(/(/ ) # (...) + { my $depth = 0; PAREN: while(s/^(\(([^\(\)\\]|\\.)*)//) - { - $field .= $1; - $depth++; - while(s/^(([^\(\)\\]|\\.)*\)\s*)//) - { - $field .= $1; - last PAREN unless --$depth; - $field .= $1 if s/^(([^\(\)\\]|\\.)+)//; + { $field .= $1; + $depth++; + while(s/^(([^\(\)\\]|\\.)*\)\s*)//) + { $field .= $1; + last PAREN unless --$depth; + $field .= $1 if s/^(([^\(\)\\]|\\.)+)//; + } + } + + carp "Unmatched () '$field' '$_'" + if $depth; + + $field =~ s/\s+\Z//; + push @words, $field; + + next; } - } - - carp "Unmatched () '$field' '$_'" - if $depth; - $field =~ s/\s+\Z//; - push(@words, $field); + if( s/^("(?:[^"\\]+|\\.)*")\s*// # "..." + || s/^(\[(?:[^\]\\]+|\\.)*\])\s*// # [...] + || s/^([^\s()<>\@,;:\\".[\]]+)\s*// + || s/^([()<>\@,;:\\".[\]])\s*// + ) + { push @words, $1; + next; + } - next; + croak "Unrecognised line: $_"; } - s/^("([^"\\]|\\.)*")\s*// # "..." - || s/^(\[([^\]\\]|\\.)*\])\s*// # [...] - || s/^([^\s\Q()<>\@,;:\\".[]\E]+)\s*// - || s/^([\Q()<>\@,;:\\".[]\E])\s*// - and do { push(@words, $1); next; }; - - croak "Unrecognised line: $_"; - } - - push(@words, ","); - - \@words; -} - -sub _find_next { - my $idx = shift; - my $tokens = shift; - my $len = shift; - while($idx < $len) { - my $c = $tokens->[$idx]; - return $c if($c eq "," || $c eq "<"); - $idx++; - } - return ""; -} - -sub _complete { - my $pkg = shift; - my $phrase = shift; - my $address = shift; - my $comment = shift; - my $o = undef; - - if(@{$phrase} || @{$comment} || @{$address}) { - $o = $pkg->new(join(" ",@{$phrase}), - join("", @{$address}), - join(" ",@{$comment})); - @{$phrase} = (); - @{$address} = (); - @{$comment} = (); - } - - return $o; + push @words, ","; + \@words; } +sub _find_next +{ my ($idx, $tokens, $len) = @_; -sub new { - my $pkg = shift; - my $me = bless [@_], $pkg; - return $me; -} - + while($idx < $len) + { my $c = $tokens->[$idx]; + return $c if $c eq ',' || $c eq ';' || $c eq '<'; + $idx++; + } -sub parse { - my $pkg = shift; - my @line = grep { defined $_} @_; - my $line = join '', @line; - - local $_; - - my @phrase = (); - my @comment = (); - my @address = (); - my @objs = (); - my $depth = 0; - my $idx = 0; - my $tokens = _tokenise(@line); - my $len = @$tokens; - my $next = _find_next($idx,$tokens,$len); - - for( ; $idx < $len ; $idx++) { - $_ = $tokens->[$idx]; - - if(substr($_,0,1) eq "(") { - push(@comment,$_); - } - elsif($_ eq '<') { - $depth++; - } - elsif($_ eq '>') { - $depth-- if $depth; - } - elsif($_ eq ',') { - warn "Unmatched '<>' in $line" if($depth); - my $o = _complete($pkg,\@phrase, \@address, \@comment); - push(@objs, $o) if(defined $o); - $depth = 0; - $next = _find_next($idx+1,$tokens,$len); - } - elsif($depth) { - push(@address,$_); - } - elsif($next eq "<") { - push(@phrase,$_); - } - elsif( /\A[\Q.\@:;\E]\Z/ || !@address || $address[-1] =~ /\A[\Q.\@:;\E]\Z/) { - push(@address,$_); - } - else { - warn "Unmatched '<>' in $line" if($depth); - my $o = _complete($pkg,\@phrase, \@address, \@comment); - push(@objs, $o) if(defined $o); - $depth = 0; - push(@address,$_); - } - } - @objs; + ""; } -sub set_or_get { - my $me = shift; - my $i = shift; - my $val = $me->[$i]; +sub _complete +{ my ($class, $phrase, $address, $comment) = @_; - $me->[$i] = shift if(@_); + @$phrase || @$comment || @$address + or return undef; - $val; + my $o = $class->new(join(" ",@$phrase), join("",@$address), join(" ",@$comment)); + @$phrase = @$address = @$comment = (); + $o; } +#------------ -sub phrase { set_or_get(shift,0,@_) } -sub address { set_or_get(shift,1,@_) } -sub comment { set_or_get(shift,2,@_) } - - -sub format { - my @fmts = (); - my $me; - - foreach $me (@_) { - my($phrase,$addr,$comment) = @{$me}; - my @tmp = (); - - if(defined $phrase && length($phrase)) { - push(@tmp, $phrase); - push(@tmp, "<" . $addr . ">") if(defined $addr && length($addr)); - } - else { - push(@tmp, $addr) if(defined $addr && length($addr)); - } - if(defined($comment) && $comment =~ /\S/) { - $comment =~ s/^\s*\(?/(/; - $comment =~ s/\)?\s*$/)/; - } - push(@tmp, $comment) if(defined $comment && length($comment)); - push(@fmts, join(" ", @tmp)) if(scalar(@tmp)); - } - - return join(", ", @fmts); +sub new(@) +{ my $class = shift; + bless [@_], $class; } -sub name -{ - my $me = shift; - my $phrase = $me->phrase; - my $addr = $me->address; - - $phrase = $me->comment unless(defined($phrase) && length($phrase)); - - my $name = _extract_name($phrase); - - # first.last@domain address - if($name eq '' && $addr =~ /([^\%\.\@_]+([\._][^\%\.\@_]+)+)[\@\%]/o) - { - ($name = $1) =~ s/[\._]+/ /go; - $name = _extract_name($name); - } - - if($name eq '' && $addr =~ m#/g=#oi) - # X400 style address - { - my ($f) = $addr =~ m#g=([^/]*)#oi; - my ($l) = $addr =~ m#s=([^/]*)#io; - - $name = _extract_name($f . " " . $l); - } - - return length($name) ? $name : undef; -} +sub parse(@) +{ my $class = shift; + my @line = grep {defined} @_; + my $line = join '', @line; + my (@phrase, @comment, @address, @objs); + my ($depth, $idx) = (0, 0); -sub host { - my $me = shift; - my $addr = $me->address; - my $i = rindex($addr,'@'); + my $tokens = _tokenise @line; + my $len = @$tokens; + my $next = _find_next $idx, $tokens, $len; - my $host = ($i >= 0) ? substr($addr,$i+1) : undef; + local $_; + for(my $idx = 0; $idx < $len; $idx++) + { $_ = $tokens->[$idx]; - return $host; + if(substr($_,0,1) eq '(') { push @comment, $_ } + elsif($_ eq '<') { $depth++ } + elsif($_ eq '>') { $depth-- if $depth } + elsif($_ eq ',' || $_ eq ';') + { warn "Unmatched '<>' in $line" if $depth; + my $o = $class->_complete(\@phrase, \@address, \@comment); + push @objs, $o if defined $o; + $depth = 0; + $next = _find_next $idx+1, $tokens, $len; + } + elsif($depth) { push @address, $_ } + elsif($next eq '<') { push @phrase, $_ } + elsif( /^[.\@:;]$/ || !@address || $address[-1] =~ /^[.\@:;]$/ ) + { push @address, $_ } + else + { warn "Unmatched '<>' in $line" if $depth; + my $o = $class->_complete(\@phrase, \@address, \@comment); + push @objs, $o if defined $o; + $depth = 0; + push @address, $_; + } + } + @objs; } +#------------ -sub user { - my $me = shift; - my $addr = $me->address; - my $i = index($addr,'@'); +sub phrase { shift->set_or_get(0, @_) } +sub address { shift->set_or_get(1, @_) } +sub comment { shift->set_or_get(2, @_) } - my $user = ($i >= 0) ? substr($addr,0,$i) : $addr; +sub set_or_get($) +{ my ($self, $i) = (shift, shift); + @_ or return $self->[$i]; - return $user; + my $val = $self->[$i]; + $self->[$i] = shift if @_; + $val; } -sub path { - return (); -} +my $atext = '[\-\w !#$%&\'*+/=?^`{|}~]'; +sub format +{ my @addrs; + foreach (@_) + { my ($phrase, $email, $comment) = @$_; + my @addr; -sub canon { - my $me = shift; - return ($me->host, $me->user, $me->path); -} + if(defined $phrase && length $phrase) + { push @addr + , $phrase =~ /^(?:\s*$atext\s*)+$/o ? $phrase + : $phrase =~ /(?<!\\)"/ ? $phrase + : qq("$phrase"); -1; - - -__END__ - -=head1 NAME + push @addr, "<$email>" + if defined $email && length $email; + } + elsif(defined $email && length $email) + { push @addr, $email; + } -Mail::Address - Parse mail addresses + if(defined $comment && $comment =~ /\S/) + { $comment =~ s/^\s*\(?/(/; + $comment =~ s/\)?\s*$/)/; + } -=head1 SYNOPSIS + push @addr, $comment + if defined $comment && length $comment; - use Mail::Address; - - my @addrs = Mail::Address->parse($line); - - foreach $addr (@addrs) { - print $addr->format,"\n"; + push @addrs, join(" ", @addr) + if @addr; } -=head1 DESCRIPTION - -C<Mail::Address> extracts and manipulates RFC822 compilant email -addresses. As well as being able to create C<Mail::Address> objects -in the normal manner, C<Mail::Address> can extract addresses from -the To and Cc lines found in an email message. - -=head1 CONSTRUCTORS - -=over 4 - -=item new( PHRASE, ADDRESS, [ COMMENT ]) - - Mail::Address->new("Perl5 Porters", "perl5-porters@africa.nicoh.com"); - -Create a new C<Mail::Address> object which represents an address with the -elements given. In a message these 3 elements would be seen like: - - PHRASE <ADDRESS> (COMMENT) - ADDRESS (COMMENT) - -=item parse( LINE ) - - Mail::Address->parse($line); - -Parse the given line a return a list of extracted C<Mail::Address> objects. -The line would normally be one taken from a To,Cc or Bcc line in a message - -=back - -=head1 METHODS - -=over 4 - -=item phrase () - -Return the phrase part of the object. - -=item address () - -Return the address part of the object. - -=item comment () - -Return the comment part of the object - -=item format () - -Return a string representing the address in a suitable form to be placed -on a To,Cc or Bcc line of a message - -=item name () - -Using the information contained within the object attempt to identify what -the person or groups name is - -=item host () - -Return the address excluding the user id and '@' - -=item user () + join ", ", @addrs; +} -Return the address excluding the '@' and the mail domain +#------------ -=item path () +sub name +{ my $self = shift; + my $phrase = $self->phrase; + my $addr = $self->address; -Unimplemented yet but should return the UUCP path for the message + $phrase = $self->comment + unless defined $phrase && length $phrase; -=item canon () + my $name = $self->_extract_name($phrase); -Unimplemented yet but should return the UUCP canon for the message + # first.last@domain address + if($name eq '' && $addr =~ /([^\%\.\@_]+([\._][^\%\.\@_]+)+)[\@\%]/) + { ($name = $1) =~ s/[\._]+/ /g; + $name = _extract_name $name; + } -=back + if($name eq '' && $addr =~ m#/g=#i) # X400 style address + { my ($f) = $addr =~ m#g=([^/]*)#i; + my ($l) = $addr =~ m#s=([^/]*)#i; + $name = _extract_name "$f $l"; + } -=head1 AUTHOR + length $name ? $name : undef; +} -Graham Barr. Maintained by Mark Overmeer <mailtools@overmeer.net> -=head1 COPYRIGHT +sub host +{ my $addr = shift->address || ''; + my $i = rindex $addr, '@'; + $i >= 0 ? substr($addr, $i+1) : undef; +} -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. -=cut +sub user +{ my $addr = shift->address || ''; + my $i = rindex $addr, '@'; + $i >= 0 ? substr($addr,0,$i) : $addr; +} +1; diff --git a/cpan/lib/Mail/Address.pod b/cpan/lib/Mail/Address.pod new file mode 100644 index 00000000..e3eeb066 --- /dev/null +++ b/cpan/lib/Mail/Address.pod @@ -0,0 +1,164 @@ +=encoding utf8 + +=head1 NAME + +Mail::Address - parse mail addresses + +=head1 SYNOPSIS + + use Mail::Address; + my @addrs = Mail::Address->parse($line); + + foreach $addr (@addrs) { + print $addr->format,"\n"; + } + +=head1 DESCRIPTION + +C<Mail::Address> extracts and manipulates email addresses from a message +header. It cannot be used to extract addresses from some random text. +You can use this module to create RFC822 compliant fields. + +Although C<Mail::Address> is a very popular subject for books, and is +used in many applications, it does a very poor job on the more complex +message fields. It does only handle simple address formats (which +covers about 95% of what can be found). Problems are with + +=over 4 + +=item * + +no support for address groups, even not with the semi-colon as +separator between addresses; + +=item * + +limited support for escapes in phrases and comments. There are +cases where it can get wrong; and + +=item * + +you have to take care of most escaping when you create an address yourself: +C<Mail::Address> does not do that for you. + +=back + +Often requests are made to the maintainers of this code improve this +situation, but this is not a good idea, where it will break zillions +of existing applications. If you wish for a fully RFC2822 compliant +implementation you may take a look at L<Mail::Message::Field::Full>, +part of MailBox. + +B<. Example> + + my $s = Mail::Message::Field::Full->new($from_header); + # ref $s isa Mail::Message::Field::Addresses; + + my @g = $s->groups; # all groups, at least one + # ref $g[0] isa Mail::Message::Field::AddrGroup; + my $ga = $g[0]->addresses; # group addresses + + my @a = $s->addresses; # all addresses + # ref $a[0] isa Mail::Message::Field::Address; + +=head1 METHODS + +=head2 Constructors + +=over 4 + +=item Mail::Address-E<gt>B<new>( PHRASE, ADDRESS, [ COMMENT ] ) + +Create a new C<Mail::Address> object which represents an address with the +elements given. In a message these 3 elements would be seen like: + + PHRASE <ADDRESS> (COMMENT) + ADDRESS (COMMENT) + +example: + + Mail::Address->new("Perl5 Porters", "perl5-porters@africa.nicoh.com"); + +=item $obj-E<gt>B<parse>(LINE) + +Parse the given line a return a list of extracted C<Mail::Address> objects. +The line would normally be one taken from a To,Cc or Bcc line in a message + +example: + + my @addr = Mail::Address->parse($line); + +=back + +=head2 Accessors + +=over 4 + +=item $obj-E<gt>B<address>() + +Return the address part of the object. + +=item $obj-E<gt>B<comment>() + +Return the comment part of the object + +=item $obj-E<gt>B<format>( [ADDRESSes] ) + +Return a string representing the address in a suitable form to be placed +on a C<To>, C<Cc>, or C<Bcc> line of a message. This method is called on +the first ADDRESS to be used; other specified ADDRESSes will be appended, +separated with commas. + +=item $obj-E<gt>B<phrase>() + +Return the phrase part of the object. + +=back + +=head2 Smart accessors + +=over 4 + +=item $obj-E<gt>B<host>() + +Return the address excluding the user id and '@' + +=item $obj-E<gt>B<name>() + +Using the information contained within the object attempt to identify what +the person or groups name is. + +B<Note:> This function tries to be smart with the "phrase" of the +email address, which is probably a very bad idea. Consider to use +L<phrase()|Mail::Address/"Accessors"> itself. + +=item $obj-E<gt>B<user>() + +Return the address excluding the '@' and the mail domain + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + diff --git a/cpan/lib/Mail/Cap.pm b/cpan/lib/Mail/Cap.pm index c9dbae45..12dbbb4f 100644 --- a/cpan/lib/Mail/Cap.pm +++ b/cpan/lib/Mail/Cap.pm @@ -1,277 +1,169 @@ - +# 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::Cap; -use strict; - -use vars qw($VERSION $useCache); - -$VERSION = "1.52"; -sub Version { $VERSION; } - -=head1 NAME - -Mail::Cap - Parse mailcap files - -=head1 SYNOPSIS - - my $mc = new Mail::Cap; +use vars '$VERSION'; +$VERSION = '2.19'; - $desc = $mc->description('image/gif'); - - print "GIF desc: $desc\n"; - - $cmd = $mc->viewCmd('text/plain; charset=iso-8859-1', 'file.txt'); - -=head1 DESCRIPTION - -Parse mailcap files as specified in RFC 1524 - I<A User Agent -Configuration Mechanism For Multimedia Mail Format Information>. In -the description below C<$type> refers to the MIME type as specified in -the I<Content-Type> header of mail or HTTP messages. Examples of -types are: +use strict; - image/gif - text/html - text/plain; charset=iso-8859-1 +sub Version { our $VERSION } -=cut -$useCache = 1; # don't evaluate tests every time +our $useCache = 1; # don't evaluate tests every time my @path; - -if($^O eq "MacOS") { - @path = split(/,/, $ENV{MAILCAPS} || - "$ENV{HOME}mailcap"); -} else { - @path = split(/:/, $ENV{MAILCAPS} || - # this path is specified under RFC 1524 appendix A - ( defined($ENV{HOME}) - ? "$ENV{HOME}/.mailcap:/etc/mailcap:/usr/etc/mailcap:/usr/local/etc/mailcap" - : "/etc/mailcap:/usr/etc/mailcap:/usr/local/etc/mailcap")); +if($^O eq "MacOS") +{ @path = split /\,/, $ENV{MAILCAPS} || "$ENV{HOME}mailcap"; +} +else +{ @path = split /\:/ + , ( $ENV{MAILCAPS} || (defined $ENV{HOME} ? "$ENV{HOME}/.mailcap:" : '') + . '/etc/mailcap:/usr/etc/mailcap:/usr/local/etc/mailcap' + ); # this path is specified under RFC1524 appendix A } - -=head1 METHODS - -=head2 new(OPTIONS) - - $mcap = new Mail::Cap; - $mcap = new Mail::Cap "/mydir/mailcap"; - $mcap = new Mail::Cap filename => "/mydir/mailcap"; - $mcap = new Mail::Cap take => 'ALL'; - $mcap = Mail::Cap->new(take => 'ALL'); - -Create and initialize a new Mail::Cap object. If you give it an -argument it will try to parse the specified file. Without any -arguments it will search for the mailcap file using the standard -mailcap path, or the MAILCAPS environment variable if it is defined. - -There is currently two OPTION implemented: - -=over 4 - -=item * take =E<gt> 'ALL'|'FIRST' - -Include all mailcap files you can find. By default, only the first -file is parsed, however the RFC tells us to include ALL. To maintain -backwards compatibility, the default only takes the FIRST. - -=item * filename =E<gt> FILENAME - -Add the specified file to the list to standard locations. This file -is tried first. - -=back - -=cut +#-------- sub new -{ - my $class = shift; +{ my $class = shift; - if(@_ % 2 == 1) {unshift @_, 'filename'} - my %args = @_; + unshift @_, 'filename' if @_ % 2; + my %args = @_; my $take_all = $args{take} && uc $args{take} eq 'ALL'; - my $self = bless {}, $class; - $self->{_count} = 0; + my $self = bless {_count => 0}, $class; - if (defined($args{filename}) && -r $args{filename}) { - $self->_process_file($args{filename}); - } + $self->_process_file($args{filename}) + if defined $args{filename} && -r $args{filename}; - if ( !defined($args{filename}) || $take_all) - { my $fname; - foreach $fname (@path) { - if (-r $fname) { - $self->_process_file($fname); - last unless $take_all; - } - } + if(!defined $args{filename} || $take_all) + { foreach my $fname (@path) + { -r $fname or next; + + $self->_process_file($fname); + last unless $take_all; + } } - unless ($self->{_count}) { - # Set up default mailcap - $self->{'audio/*'} = [{'view' => "showaudio %s"}]; - $self->{'image/*'} = [{'view' => "xv %s"}]; - $self->{'message/rfc822'} = [{'view' => "xterm -e metamail %s"}]; + unless($self->{_count}) + { # Set up default mailcap + $self->{'audio/*'} = [{'view' => "showaudio %s"}]; + $self->{'image/*'} = [{'view' => "xv %s"}]; + $self->{'message/rfc822'} = [{'view' => "xterm -e metamail %s"}]; } $self; } sub _process_file -{ - my $self = shift; - my $file = shift; - unless($file) { return;} +{ my $self = shift; + my $file = shift or return; local *MAILCAP; - if(open(MAILCAP, $file)) { - $self->{'_file'} = $file; - local($_); - while (<MAILCAP>) { - next if /^\s*#/; # comment - next if /^\s*$/; # blank line - while (s/\\\s*$//) { # continuation line - $_ .= <MAILCAP>; - } - chomp; - s/\0//g; # ensure no NULs in the line - s/([^\\]);/$1\0/g; # make field separator NUL - my @parts = split(/\s*\0\s*/, $_); - my $type = shift(@parts); - $type .= "/*" unless $type =~ m,/,; - my $view = shift(@parts); - $view =~ s/\\;/;/g; - my %field = ('view' => $view); - for (@parts) { - my($key,$val) = split(/\s*=\s*/, $_, 2); - if (defined $val) { - $val =~ s/\\;/;/g; - } else { - $val = 1; - } - $field{$key} = $val; - } - if ($field{'test'}) { - my $test = $field{'test'}; - unless ($test =~ /%/) { - # No parameters in test, can perform it right away - system $test; - next if $?; - } - } - # record this entry - unless (exists $self->{$type}) { - $self->{$type} = []; - $self->{_count}++; - } - push(@{$self->{$type}}, \%field); - } - close(MAILCAP); + open MAILCAP, $file + or return; + + $self->{_file} = $file; + + local $_; + while(<MAILCAP>) + { next if /^\s*#/; # comment + next if /^\s*$/; # blank line + $_ .= <MAILCAP> # continuation line + while s/(^|[^\\])((?:\\\\)*)\\\s*$/$1$2/; + chomp; + s/\0//g; # ensure no NULs in the line + s/(^|[^\\]);/$1\0/g; # make field separator NUL + my ($type, $view, @parts) = split /\s*\0\s*/; + + $type .= "/*" if $type !~ m[/]; + $view =~ s/\\;/;/g; + $view =~ s/\\\\/\\/g; + my %field = (view => $view); + + foreach (@parts) + { my($key, $val) = split /\s*\=\s*/, $_, 2; + if(defined $val) + { $val =~ s/\\;/;/g; + $val =~ s/\\\\/\\/g; + $field{$key} = $val; + } + else + { $field{$key} = 1; + } + } + + if(my $test = $field{test}) + { unless ($test =~ /\%/) + { # No parameters in test, can perform it right away + system $test; + next if $?; + } + } + + # record this entry + unless(exists $self->{$type}) + { $self->{$type} = []; + $self->{_count}++; + } + push @{$self->{$type}}, \%field; } -} - -=head2 view($type, $file) - -=head2 compose($type, $file) -=head2 edit($type, $file) - -=head2 print($type, $file) - -These methods invoke a suitable progam presenting or manipulating the -media object in the specified file. They all return C<1> if a command -was found, and C<0> otherwise. You might test C<$?> for the outcome -of the command. - -=cut + close MAILCAP; +} -sub view { my $self = shift; $self->_run($self->viewCmd(@_)); } -sub compose { my $self = shift; $self->_run($self->composeCmd(@_)); } -sub edit { my $self = shift; $self->_run($self->editCmd(@_)); } -sub print { my $self = shift; $self->_run($self->printCmd(@_)); } +#------------------ -=head2 viewCmd($type, $file) +sub view { my $self = shift; $self->_run($self->viewCmd(@_)) } +sub compose { my $self = shift; $self->_run($self->composeCmd(@_)) } +sub edit { my $self = shift; $self->_run($self->editCmd(@_)) } +sub print { my $self = shift; $self->_run($self->printCmd(@_)) } -=head2 composeCmd($type, $file) +sub _run($) +{ my ($self, $cmd) = @_; + defined $cmd or return 0; -=head2 editCmd($type, $file) + system $cmd; + 1; +} -=head2 printCmd($type, $file) +#------------------ -These methods return a string that is suitable for feeding to system() -in order to invoke a suitable progam presenting or manipulating the -media object in the specified file. It will return C<undef> if no -suitable specification exists. +sub viewCmd { shift->_createCommand(view => @_) } +sub composeCmd { shift->_createCommand(compose => @_) } +sub editCmd { shift->_createCommand(edit => @_) } +sub printCmd { shift->_createCommand(print => @_) } -=cut +sub _createCommand($$$) +{ my ($self, $method, $type, $file) = @_; + my $entry = $self->getEntry($type, $file); -sub viewCmd { shift->_createCommand('view', @_); } -sub composeCmd { shift->_createCommand('compose', @_); } -sub editCmd { shift->_createCommand('edit', @_); } -sub printCmd { shift->_createCommand('print', @_); } + $entry && exists $entry->{$method} + or return undef; -sub _createCommand -{ - my($self, $method, $type, $file) = @_; - my $entry = $self->getEntry($type, $file); - return undef unless $entry; - if (exists $entry->{$method}) { - return $self->expandPercentMacros($entry->{$method}, $type, $file); - } else { - return undef; - } + $self->expandPercentMacros($entry->{$method}, $type, $file); } -sub _run -{ - my($self, $cmd) = @_; - if (defined $cmd) { - system $cmd; - return 1; - } - 0; -} +sub makeName($$) +{ my ($self, $type, $basename) = @_; + my $template = $self->nametemplate($type) + or return $basename; -sub makeName -{ - my($self, $type, $basename) = @_; - my $template = $self->nametemplate($type); - return $basename unless $template; $template =~ s/%s/$basename/g; $template; } -=head2 field($type, $field) - -Returns the specified field for the type. Returns undef if no -specification exsists. - -=cut +#------------------ -sub field -{ - my($self, $type, $field) = @_; +sub field($$) +{ my($self, $type, $field) = @_; my $entry = $self->getEntry($type); $entry->{$field}; } -=head2 description($type) - -=head2 textualnewlines($type) - -=head2 x11_bitmap($type) - -=head2 nametemplate($type) - -These methods return the corresponding mailcap field for the type. -These methods should be more convenient to use than the field() method -for the same fields. - -=cut sub description { shift->field(shift, 'description'); } sub textualnewlines { shift->field(shift, 'textualnewlines'); } @@ -279,55 +171,50 @@ sub x11_bitmap { shift->field(shift, 'x11-bitmap'); } sub nametemplate { shift->field(shift, 'nametemplate'); } sub getEntry -{ - my($self, $origtype, $file) = @_; +{ my($self, $origtype, $file) = @_; - if ($useCache) { - if (exists $self->{'_cache'}{$origtype}) { - return $self->{'_cache'}{$origtype}; - } - } + return $self->{_cache}{$origtype} + if $useCache && exists $self->{_cache}{$origtype}; - my($fulltype, @params) = split(/\s*;\s*/, $origtype); - my($type, $subtype) = split(/\//, $fulltype, 2); - $subtype = "" unless defined $subtype; + my ($fulltype, @params) = split /\s*;\s*/, $origtype; + my ($type, $subtype) = split m[/], $fulltype, 2; + $subtype ||= ''; my $entry; - for (@{$self->{"$type/$subtype"}}, @{$self->{"$type/*"}}) { - if (exists $_->{'test'}) { - # must run test to see if it applies - my $test = $self->expandPercentMacros($_->{'test'}, - $origtype, $file); - system $test; - next if $?; - } - $entry = { %$_ }; # make copy + foreach (@{$self->{"$type/$subtype"}}, @{$self->{"$type/*"}}) + { if(exists $_->{'test'}) + { # must run test to see if it applies + my $test = $self->expandPercentMacros($_->{'test'}, + $origtype, $file); + system $test; + next if $?; + } + $entry = { %$_ }; # make copy last; } - $self->{'_cache'}{$origtype} = $entry if $useCache; + $self->{_cache}{$origtype} = $entry if $useCache; $entry; } - sub expandPercentMacros -{ - my($self,$text,$type,$file) = @_; - return $text unless defined $type; - $file = "" unless defined $file; - my($fulltype, @params) = split(/\s*;\s*/, $type); - my $subtype; - ($type, $subtype) = split(/\//, $fulltype, 2); +{ my ($self, $text, $type, $file) = @_; + defined $type or return $text; + defined $file or $file = ""; + + my ($fulltype, @params) = split /\s*;\s*/, $type; + ($type, my $subtype) = split m[/], $fulltype, 2; + my %params; - for (@params) { - my($key,$val) = split(/\s*=\s*/, $_, 2); - $params{$key} = $val; + foreach (@params) + { my($key, $val) = split /\s*=\s*/, $_, 2; + $params{$key} = $val; } - $text =~ s/\\%/\0/g; # hide all escaped %'s + $text =~ s/\\%/\0/g; # hide all escaped %'s $text =~ s/%t/$fulltype/g; # expand %t $text =~ s/%s/$file/g; # expand %s - { # expand %{field} - local($^W) = 0; # avoid warnings when expanding %params - $text =~ s/%\{\s*(.*?)\s*\}/$params{$1}/g; + { # expand %{field} + local $^W = 0; # avoid warnings when expanding %params + $text =~ s/%\{\s*(.*?)\s*\}/$params{$1}/g; } $text =~ s/\0/%/g; $text; @@ -336,49 +223,28 @@ sub expandPercentMacros # This following procedures can be useful for debugging purposes sub dumpEntry -{ - my($hash, $prefix) = @_; - $prefix = "" unless defined $prefix; - for (sort keys %$hash) { - print "$prefix$_ = $hash->{$_}\n"; - } +{ my($hash, $prefix) = @_; + defined $prefix or $prefix = ""; + print "$prefix$_ = $hash->{$_}\n" + for sort keys %$hash; } sub dump -{ - my($self) = @_; - for (keys %$self) { - next if /^_/; - print "$_\n"; - for (@{$self->{$_}}) { - dumpEntry($_, "\t"); - print "\n"; - } +{ my $self = shift; + foreach (keys %$self) + { next if /^_/; + print "$_\n"; + foreach (@{$self->{$_}}) + { dumpEntry($_, "\t"); + print "\n"; + } } - if (exists $self->{'_cache'}) { - print "Cached types\n"; - for (keys %{$self->{'_cache'}}) { - print "\t$_\n"; - } + + if(exists $self->{_cache}) + { print "Cached types\n"; + print "\t$_\n" + for keys %{$self->{_cache}}; } } -=head1 COPYRIGHT - -Copyright (c) 1995 Gisle Aas. All rights reserved. - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=head1 AUTHOR - -Gisle Aas <aas@oslonett.no> - -Modified by Graham Barr <gbarr@pobox.com> - -Maintained by Mark Overmeer <mailtools@overmeer.net> - -=cut - - 1; diff --git a/cpan/lib/Mail/Cap.pod b/cpan/lib/Mail/Cap.pod new file mode 100644 index 00000000..96db477b --- /dev/null +++ b/cpan/lib/Mail/Cap.pod @@ -0,0 +1,157 @@ +=encoding utf8 + +=head1 NAME + +Mail::Cap - understand mailcap files + +=head1 SYNOPSIS + + my $mc = Mail::Cap->new; + + my $desc = $mc->description('image/gif'); + print "GIF desc: $desc\n"; + + my $cmd = $mc->viewCmd('text/plain; charset=iso-8859-1', 'file.txt'); + +=head1 DESCRIPTION + +Parse mailcap files as specified in "RFC 1524 --A User Agent +Configuration Mechanism For Multimedia Mail Format Information>. In +the description below C<$type> refers to the MIME type as specified in +the C<Content-Type> header of mail or HTTP messages. Examples of +types are: + + image/gif + text/html + text/plain; charset=iso-8859-1 + +You could also take a look at the File::MimeInfo distribution, which +are accessing tables which are used by many applications on a system, +and therefore have succeeded the mail-cap specifications on modern +(UNIX) systems. + +=head1 METHODS + +=head2 Constructors + +=over 4 + +=item Mail::Cap-E<gt>B<new>(OPTIONS) + +Create and initialize a new Mail::Cap object. If you give it an +argument it will try to parse the specified file. Without any +arguments it will search for the mailcap file using the standard +mailcap path, or the MAILCAPS environment variable if it is defined. + + -Option --Default + filename undef + take 'FIRST' + +=over 2 + +=item filename => FILENAME + +Add the specified file to the list to standard locations. This file +is tried first. + +=item take => 'ALL'|'FIRST' + +Include all mailcap files you can find. By default, only the first +file is parsed, however the RFC tells us to include ALL. To maintain +backwards compatibility, the default only takes the FIRST. + +=back + +example: + + $mcap = new Mail::Cap; + $mcap = new Mail::Cap "/mydir/mailcap"; + $mcap = new Mail::Cap filename => "/mydir/mailcap"; + $mcap = new Mail::Cap take => 'ALL'; + $mcap = Mail::Cap->new(take => 'ALL'); + +=back + +=head2 Run commands + +These methods invoke a suitable program presenting or manipulating the +media object in the specified file. They all return C<1> if a command +was found, and C<0> otherwise. You might test C<$?> for the outcome +of the command. + +=over 4 + +=item $obj-E<gt>B<compose>(TYPE, FILE) + +=item $obj-E<gt>B<edit>(TYPE, FILE) + +=item $obj-E<gt>B<print>(TYPE, FILE) + +=item $obj-E<gt>B<view>(TYPE, FILE) + +=back + +=head2 Command creator + +These methods return a string that is suitable for feeding to system() +in order to invoke a suitable program presenting or manipulating the +media object in the specified file. It will return C<undef> if no +suitable specification exists. + +=over 4 + +=item $obj-E<gt>B<composeCmd>(TYPE, FILE) + +=item $obj-E<gt>B<editCmd>(TYPE, FILE) + +=item $obj-E<gt>B<printCmd>(TYPE, FILE) + +=item $obj-E<gt>B<viewCmd>(TYPE, FILE) + +=back + +=head2 Look-up definitions + +Methods return the corresponding mailcap field for the type. + +=over 4 + +=item $obj-E<gt>B<description>(TYPE) + +=item $obj-E<gt>B<field>(TYPE, FIELD) + +Returns the specified field for the type. Returns undef if no +specification exists. + +=item $obj-E<gt>B<nametemplate>(TYPE) + +=item $obj-E<gt>B<textualnewlines>(TYPE) + +=item $obj-E<gt>B<x11_bitmap>(TYPE) + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + diff --git a/cpan/lib/Mail/Field.pm b/cpan/lib/Mail/Field.pm index 50ba5ad6..6b73823e 100644 --- a/cpan/lib/Mail/Field.pm +++ b/cpan/lib/Mail/Field.pm @@ -1,509 +1,227 @@ -# Mail::Field.pm -# -# 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. - +# 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::Field; +use vars '$VERSION'; +$VERSION = '2.19'; -# $Id$ -use Carp; use strict; -use vars qw($AUTOLOAD $VERSION); - -$VERSION = "1.52"; - -unless(defined &UNIVERSAL::can) { - *UNIVERSAL::can = sub { - my($obj,$meth) = @_; - my $pkg = ref($obj) || $obj; - my @pkg = ($pkg); - my %done; - while(@pkg) { - $pkg = shift @pkg; - next if exists $done{$pkg}; - $done{$pkg} = 1; - - no strict 'refs'; - - unshift @pkg,@{$pkg . "::ISA"} - if(@{$pkg . "::ISA"}); - return \&{$pkg . "::" . $meth} - if defined(&{$pkg . "::" . $meth}); - } - undef; - } -} + +use Carp; +use Mail::Field::Generic; + sub _header_pkg_name -{ - my($header) = lc shift; - - $header =~ s/((\b|_)\w)/\U$1/gio; - - if (length($header) > 8) - { - my @header = split /[-_]+/, $header; - my $chars = int((7 + @header) / @header) || 1; - $header = substr(join('', map { substr($_,0,$chars) } @header),0,8); - } - else - { - $header =~ s/[-_]+//go; - } - - 'Mail::Field::' . $header; -} +{ my $header = lc shift; + $header =~ s/((\b|_)\w)/\U$1/g; -## -## Use the import method to load the sub-classes -## + if(length($header) > 8) + { my @header = split /[-_]+/, $header; + my $chars = int((7 + @header) / @header) || 1; + $header = substr join('', map {substr $_,0,$chars} @header), 0, 8; + } + else + { $header =~ s/[-_]+//g; + } + + 'Mail::Field::' . $header; +} sub _require_dir -{ - my($pkg,$dir,$dir_sep) = @_; - - if(opendir(DIR,$dir)) - { - my @inc = (); - my $f; - - foreach $f (readdir(DIR)) - { - next - unless $f =~ /^([\w\-]+)/; - - my $p = $1; - my $n = $dir . $dir_sep . $p; - - if(-d $n ) - { - _require_dir( $pkg . "::" . $f, $n, $dir_sep); - } - else - { - $p =~ s/-/_/go; - eval "require ${pkg}::$p" - } +{ my($class, $dir, $dir_sep) = @_; + + local *DIR; + opendir DIR, $dir + or return; + + my @inc; + foreach my $f (readdir DIR) + { $f =~ /^([\w\-]+)/ or next; + my $p = $1; + my $n = "$dir$dir_sep$p"; + + if(-d $n ) + { _require_dir("${class}::$f", $n, $dir_sep); + } + else + { $p =~ s/-/_/go; + eval "require ${class}::$p"; + + # added next warning in 2.14, may be ignored for ancient code + warn $@ if $@; + } } - closedir(DIR); - } + closedir DIR; } sub import -{ - my $pkg = shift; - - if(@_) - { - local $_; - map { - eval "require " . _header_pkg_name($_) || die $@; - } @_; - } - else - { - my($f,$dir,$dir_sep); - foreach $f (keys %INC) - { - if($f =~ /^Mail(\W)Field\W/i) - { - $dir_sep = $1; - $dir = ($INC{$f} =~ /(.*Mail\W+Field)/i)[0] . $dir_sep; - last; - } +{ my $class = shift; + + if(@_) + { local $_; + eval "require " . _header_pkg_name($_) || die $@ + for @_; + return; } - _require_dir('Mail::Field', $dir, $dir_sep); - } -} + my ($dir, $dir_sep); + foreach my $f (grep defined $INC{$_}, keys %INC) + { next if $f !~ /^Mail(\W)Field\W/i; + $dir_sep = $1; +# $dir = ($INC{$f} =~ /(.*Mail\W+Field)/i)[0] . $dir_sep; + ($dir = $INC{$f}) =~ s/(Mail\W+Field).*/$1$dir_sep/; + last; + } -## -## register a header class, this creates a new method in Mail::Field -## which will call new on that class -## + _require_dir('Mail::Field', $dir, $dir_sep); +} +# register a header class, this creates a new method in Mail::Field +# which will call new on that class sub register -{ - my $self = shift; - my $method = lc shift; - my $pkg = shift || ref($self) || $self; +{ my $thing = shift; + my $method = lc shift; + my $class = shift || ref($thing) || $thing; - $method =~ tr/-/_/; + $method =~ tr/-/_/; + $class = _header_pkg_name $method + if $class eq "Mail::Field"; - $pkg = _header_pkg_name($method) - if($pkg eq "Mail::Field"); - - croak "Re-register of $method" + croak "Re-register of $method" if Mail::Field->can($method); - no strict 'refs'; - *{$method} = sub { + no strict 'refs'; + *{$method} = sub { shift; - unless ($pkg->can('stringify')) { - eval "require $pkg" || die $@; - } - $pkg->_build(@_); - }; - + $class->can('stringify') or eval "require $class" or die $@; + $class->_build(@_); + }; } -## -## the *real* constructor -## if called with one argument then the `parse' method will be called -## otherwise the `create' method is called -## +# the *real* constructor +# if called with one argument then the `parse' method will be called +# otherwise the `create' method is called sub _build -{ - my $type = shift; - my $self = bless {}, $type; - - @_ == 1 ? $self->parse(@_) - : $self->create(@_); -} - -sub new -{ - my $self = shift; # ignored - my $field = lc shift; - - $field =~ tr/-/_/; - - $self->$field(@_); +{ my $self = bless {}, shift; + @_==1 ? $self->parse(@_) : $self->create(@_); } -## -## A default create method. This allows us to do -## $s = Mail::Field->new('Subject', Text => "joe"); -## $s = Mail::Field->new('Subject', "joe"); -## - -sub create -{ - my $self = shift; - my %arg = @_; - - $self = bless {}, $self - unless ref($self); +#------------- - %$self = (); - - $self->set(\%arg); +sub new +{ my $class = shift; + my $field = lc shift; + $field =~ tr/-/_/; + $class->$field(@_); } -## -## A default create method. This allows us to do -## $s = Mail::Field->new('Subject'); -## -sub parse -{ - my $self = shift; - my $type = ref($self) || $self; +sub combine {confess "Combine not implemented" } - croak "$type: Cannot parse"; -} +our $AUTOLOAD; +sub AUTOLOAD +{ my $method = $AUTOLOAD; + $method =~ s/.*:://; -## -## either get the text, or parse a new one -## + $method =~ /^[^A-Z\x00-\x1f\x80-\xff :]+$/ + or croak "Undefined subroutine &$AUTOLOAD called"; -sub text -{ - my $self = shift; - @_ ? $self->parse(@_) - : $self->stringify; -} + my $class = _header_pkg_name $method; -## -## Return the tag (in the correct case) for this item -## + unless(eval "require $class") + { my $tag = $method; + $tag =~ s/_/-/g; + $tag = join '-', + map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) } + split /\-/, $tag; -sub tag -{ - my $self = shift; - my $tag = ref($self) || $self; + no strict; + @{"${class}::ISA"} = qw(Mail::Field::Generic); + *{"${class}::tag"} = sub { $tag }; + } - $tag =~ s/.*:://o; - $tag =~ s/_/-/og; - $tag =~ s/\b([a-z]+)/\L\u$1/gio; - $tag =~ s/\b([b-df-hj-np-tv-z]+)\b/\U$1/gio; + Mail::Field->can($method) + or $class->register($method); - $tag; + goto &$AUTOLOAD; } -## -## a constructor -## create a new object by extracting from a Mail::Header object -## +# Of course, the functionality should have been in the Mail::Header class sub extract -{ - my $self = shift; - - my $tag = shift; - my $head = shift; - - my $method = lc $tag; - $method =~ tr/-/_/; - - my $text; - - if(@_ == 0 && wantarray) - { - my @ret = (); - - foreach $text ($head->get($tag)) - { - chomp($text); - - push(@ret, $self->$method($text)); +{ my ($class, $tag, $head) = (shift, shift, shift); + + my $method = lc $tag; + $method =~ tr/-/_/; + + if(@_==0 && wantarray) + { my @ret; + my $text; # need real copy! + foreach $text ($head->get($tag)) + { chomp $text; + push @ret, $class->$method($text); + } + return @ret; } - return @ret; - } - - my $idx = shift || 0; - - $text = $head->get($tag,$idx) or - return undef; - - chomp($text); - - $self->$method($text); -} - -## -## Autoload sub-classes, or, if the .pm file cannot be found, create a dummy -## sub-class based on Mail::Field::Generic -## - -sub AUTOLOAD -{ - my $method = $AUTOLOAD; - - $method =~ s/.*:://o; - - croak "Undefined subroutine &$AUTOLOAD called" - unless $method =~ /^[^A-Z\x00-\x1f\x80-\xff :]+$/o; - - my $pkg = _header_pkg_name($method); - - unless(eval "require " . $pkg) - { - my $tag = $method; - - $tag =~ s/_/-/og; - $tag =~ s/\b([a-z]+)/\L\u$1/gio; - $tag =~ s/\b([b-df-hj-np-tv-z]+)\b/\U$1/gio; - - no strict; - - @{$pkg . "::ISA"} = qw(Mail::Field::Generic); - *{$pkg . "::tag"} = sub { $tag }; - } + my $idx = shift || 0; + my $text = $head->get($tag,$idx) + or return undef; - $pkg->register($method) - unless(Mail::Field->can($method)); - - goto &$AUTOLOAD; + chomp $text; + $class->$method($text); } -## -## prevent the calling of AUTOLOAD for DESTROY :-) -## - -sub DESTROY {} - -## -## A generic package for those not defined in thier own package. This is -## fine for fields like Subject, X-Mailer etc. where the field holds only -## a string of no particular importance/format. -## - -package Mail::Field::Generic; - -use Carp; -use vars qw(@ISA); - -@ISA = qw(Mail::Field); +#------------- +# before 2.00, this method could be called as class method, however +# not all extensions supported that. sub create -{ - my $self = shift; - my %arg = @_; - my $text = delete $arg{Text} || ""; - - croak "Unknown options " . join(",", keys %arg) - if %arg; - - $self->{Text} = $text; - - $self; +{ my ($self, %arg) = @_; + %$self = (); + $self->set(\%arg); } -sub parse -{ - my $self = shift; - - $self->{Text} = shift || ""; - $self; -} -sub stringify -{ - my $self = shift; - $self->{Text}; +# before 2.00, this method could be called as class method, however +# not all extensions supported that. +sub parse +{ my $class = ref shift; + confess "parse() not implemented"; } -1; - -__END__ - -=head1 NAME - -Mail::Field - Base class for manipulation of mail header fields - -=head1 SYNOPSIS - - use Mail::Field; - - $field = Mail::Field->new('Subject', 'some subject text'); - print $field->tag,": ",$field->stringify,"\n"; - - $field = Mail::Field->subject('some subject text'); - -=head1 DESCRIPTION - -C<Mail::Field> is a base class for packages that create and manipulate -fields from Email (and MIME) headers. Each different field will have its -own sub-class, defining its own interface. - -This document describes the minimum interface that each sub-class should -provide, and also guidlines on how the field specific interface should be -defined. - -=head1 CONSTRUCTOR - -Mail::Field, and it's sub-classes define several methods which return -new objects. These can all be termed to be constructors. - -=over 4 - -=item new ( TAG [, STRING | OPTIONS ] ) - -The new constructor will create an object in the class which defines -the field specified by the tag argument. - -After creation of the object :- - -If the tag argument is followed by a single string then the C<parse> method -will be called with this string. - -If the tag argument is followed by more than one arguments then the C<create> -method will be called with these arguments. - -=item extract ( TAG, HEAD [, INDEX ] ) - -This constuctor takes as arguments the tag name, a C<Mail::Head> object -and optionally an index. - -If the index argument is given then C<extract> will retrieve the given tag -from the C<Mail::Head> object and create a new C<Mail::Field> based object. -I<undef> will be returned in the field does not exist. - -If the index argument is not given the the result depends on the context -in which C<extract> is called. If called in a scalar context the result -will be as if C<extract> was called with an index value of zero. If called -in an array context then all tags will be retrieved and a list of -C<Mail::Field> objects will be returned. - -=item combine ( FIELD_LIST ) - -This constructor takes as arguments a list of C<Mail::Field> objects, which -should all be of the same sub-class, and creates a new object in that same -class. - -This constructor is nor defined in C<Mail::Field> as there is no generic -way to combine the various field types. Each sub-class should define -its own combine constructor, if combining is possible/allowed. +#------------- -=back +sub stringify { confess "stringify() not implemented" } -=head1 METHODS -=over 4 - -=item parse - -=item set - -=item tag - -=item stringify - -=back - -=head1 SUB-CLASS PACKAGE NAMES - -All sub-classes should be called Mail::Field::I<name> where I<name> is -derived from the tag using these rules. - -=over 4 - -=item * - -Consider a tag as being made up of elements separated by '-' - -=item * - -Convert all characters to lowercase except the first in each element, which -should be uppercase. - -=item * - -I<name> is then created from these elements by using the first -N characters from each element. - -=item * - -N is calculated by using the formula :- - - int((7 + #elements) / #elements) - -=item * - -I<name> is then limited to a maximum of 8 characters, keeping the first 8 -characters - -=back - -For an example of this take a look at the definition of the -C<_header_pkg_name> subroutine in C<Mail::Field> - -=head1 AUTHOR - -Graham Barr. - -Maintained by Mark Overmeer <mailtools@overmeer.net> - -=head1 SEE ALSO +sub tag +{ my $thing = shift; + my $tag = ref($thing) || $thing; + $tag =~ s/.*:://; + $tag =~ s/_/-/g; -L<MIME::*>s + join '-', + map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) } + split /\-/, $tag; +} -=head1 CREDITS -Eryq <eryq@rhine.gsfc.nasa.gov> - for all the help in defining this package -so that C<Mail::*> and C<MIME::*> can be integrated together. +sub set(@) { confess "set() not implemented" } -=head1 COPYRIGHT +# prevent the calling of AUTOLOAD for DESTROY :-) +sub DESTROY {} -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. +#------------- -=cut +sub text +{ my $self = shift; + @_ ? $self->parse(@_) : $self->stringify; +} +#------------- +1; diff --git a/cpan/lib/Mail/Field.pod b/cpan/lib/Mail/Field.pod new file mode 100644 index 00000000..f8374a1b --- /dev/null +++ b/cpan/lib/Mail/Field.pod @@ -0,0 +1,196 @@ +=encoding utf8 + +=head1 NAME + +Mail::Field - base-class for manipulation of mail header fields + +=head1 INHERITANCE + + Mail::Field is extended by + Mail::Field::AddrList + Mail::Field::Date + Mail::Field::Generic + +=head1 SYNOPSIS + + use Mail::Field; + + my $field = Mail::Field->new('Subject', 'some subject text'); + my $field = Mail::Field->new(Subject => 'some subject text'); + print $field->tag,": ",$field->stringify,"\n"; + + my $field = Mail::Field->subject('some subject text'); + +=head1 DESCRIPTION + +C<Mail::Field> creates and manipulates fields in MIME headers, collected +within a L<Mail::Header|Mail::Header> object. Different field types have their +own sub-class (extension), defining additional useful accessors to the +field content. + +People are invited to merge their implementation to special fields into +MailTools, to maintain a consistent set of packages and documentation. + +=head1 METHODS + +=head2 Constructors + +Mail::Field (and it's sub-classes) define several methods which return +new objects. These can all be categorized as constructor. + +=over 4 + +=item Mail::Field-E<gt>B<combine>(FIELDS) + +Take a LIST of C<Mail::Field> objects (which should all be of the same +sub-class) and create a new object in that same class. + +=item Mail::Field-E<gt>B<extract>( TAG, HEAD [, INDEX ] ) + +Takes as arguments the tag name, a C<Mail::Head> object +and optionally an index. + +If the index argument is given then C<extract> will retrieve the given tag +from the C<Mail::Head> object and create a new C<Mail::Field> based object. +I<undef> will be returned in the field does not exist. + +If the index argument is not given the result depends on the context +in which C<extract> is called. If called in a scalar context the result +will be as if C<extract> was called with an index value of zero. If called +in an array context then all tags will be retrieved and a list of +C<Mail::Field> objects will be returned. + +=item Mail::Field-E<gt>B<new>( TAG [, STRING | OPTIONS] ) + +Create an object in the class which defines the field specified by +the TAG argument. + +=back + +=head2 "Fake" constructors + +=over 4 + +=item $obj-E<gt>B<create>(OPTIONS) + +This constructor is used internally with preprocessed field information. +When called on an existing object, its original content will get +replaced. + +=item $obj-E<gt>B<parse>() + +Parse a field line. + +=back + +=head2 Accessors + +=over 4 + +=item $obj-E<gt>B<set>(OPTIONS) + +Change the settings (the content, but then smart) of this field. + +=item $obj-E<gt>B<stringify>() + +Returns the field as a string. + +=item $obj-E<gt>B<tag>() + +=item Mail::Field-E<gt>B<tag>() + +Return the tag (in the correct case) for this item. Well, actually any +casing is OK, because the field tags are treated case-insensitive; however +people have some preferences. + +=back + +=head2 Smart accessors + +=over 4 + +=item $obj-E<gt>B<text>( [STRING] ) + +Without arguments, the field is returned as L<stringify()|Mail::Field/"Accessors"> does. Otherwise, +the STRING is parsed with L<parse()|Mail::Field/""Fake" constructors"> to replace the object's content. + +It is more clear to call either L<stringify()|Mail::Field/"Accessors"> or L<parse()|Mail::Field/""Fake" constructors"> directly, because +this method does not add additional processing. + +=back + +=head1 DETAILS + +=head2 SUB-CLASS PACKAGE NAMES + +All sub-classes should be called Mail::Field::I<name> where I<name> is +derived from the tag using these rules. + +=over 4 + +=item * + +Consider a tag as being made up of elements separated by '-' + +=item * + +Convert all characters to lowercase except the first in each element, which +should be uppercase. + +=item * + +I<name> is then created from these elements by using the first +N characters from each element. + +=item * + +N is calculated by using the formula :- + + int((7 + #elements) / #elements) + +=item * + +I<name> is then limited to a maximum of 8 characters, keeping the first 8 +characters. + +=back + +For an example of this take a look at the definition of the +C<_header_pkg_name()> subroutine in C<Mail::Field> + +=head1 DIAGNOSTICS + +=over 4 + +=item Error: Undefined subroutine <method> called + +Mail::Field objects use autoloading to compile new functionality. +Apparently, the method called is not implemented for the specific +class of the field object. + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + diff --git a/cpan/lib/Mail/Field/AddrList.pm b/cpan/lib/Mail/Field/AddrList.pm index 950385c4..3887b87e 100644 --- a/cpan/lib/Mail/Field/AddrList.pm +++ b/cpan/lib/Mail/Field/AddrList.pm @@ -1,106 +1,66 @@ -package Mail::Field::AddrList; - -=head1 NAME - -Mail::Field::AddrList - object representation of e-mail address lists - -=head1 DESCRIPTION - -I<Don't use this class directly!> Instead ask Mail::Field for new -instances based on the field name! - -=head1 SYNOPSIS - - use Mail::Field::AddrList; - - $to = Mail::Field->new('To'); - $from = Mail::Field->new('From', 'poe@daimi.aau.dk (Peter Orbaek)'); - - $from->create('foo@bar.com' => 'Mr. Foo', poe => 'Peter'); - $from->parse('foo@bar.com (Mr Foo), Peter Orbaek <poe>'); - - # make a RFC822 header string - print $from->stringify(),"\n"; - - # extract e-mail addresses and names - @addresses = $from->addresses(); - @names = $from->names(); - - # adjoin a new address to the list - $from->set_address('foo@bar.com', 'Mr. Foo'); - -=head1 NOTES - -Defines parsing and formatting according to RFC822, of the following fields: -To, From, Cc, Reply-To and Sender. - -=head1 AUTHOR +# 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. +use strict; -Peter Orbaek <poe@cit.dk> 26-Feb-97 -Modified by Graham Barr <gbarr@pobox.com> -Maintained by Mark Overmeer <mailtools@overmeer.net> +package Mail::Field::AddrList; +use vars '$VERSION'; +$VERSION = '2.19'; -=cut +use base 'Mail::Field'; -use strict; -use vars qw(@ISA $VERSION); -use Mail::Field (); use Carp; use Mail::Address; -@ISA = qw(Mail::Field); -$VERSION = '1.52'; -# install header interpretation, see Mail::Field -INIT: { - my $x = bless([]); - - $x->register('To'); - $x->register('From'); - $x->register('Cc'); - $x->register('Reply-To'); - $x->register('Sender'); -} +my $x = bless []; +$x->register('To'); +$x->register('From'); +$x->register('Cc'); +$x->register('Reply-To'); +$x->register('Sender'); -sub create { - my ($self, %arg) = @_; # (email => name, email => realname,...) - my($e,$n); +sub create(@) +{ my ($self, %arg) = @_; $self->{AddrList} = {}; - $self->{AddrList}{$e} = Mail::Address->new($n,$e) - while(($e,$n) = each %arg); + while(my ($e, $n) = each %arg) + { $self->{AddrList}{$e} = Mail::Address->new($n, $e); + } $self; } -sub parse { - my ($self, $string) = @_; - my ($a,$email,$name); - - foreach $a (Mail::Address->parse($string)) { - my $e = $a->address; +sub parse($) +{ my ($self, $string) = @_; + foreach my $a (Mail::Address->parse($string)) + { my $e = $a->address; $self->{AddrList}{$e} = $a; } $self; } -sub stringify { - my $self = shift; - my ($x, $email, $name); - +sub stringify() +{ my $self = shift; join(", ", map { $_->format } values %{$self->{AddrList}}); } -sub addresses { - keys %{shift->{AddrList}}; -} -sub names { - map { $_->name } values %{shift->{AddrList}}; -} +sub addresses { keys %{shift->{AddrList}} } + + +# someone forgot to implement a method to return the Mail::Address +# objects. Added in 2.00; a pity that the name addresses() is already +# given :( That one should have been named emails() +sub addr_list { values %{shift->{AddrList}} } + + +sub names { map { $_->name } values %{shift->{AddrList}} } + -sub set_address { - my ($self, $email, $name) = @_; +sub set_address($$) +{ my ($self, $email, $name) = @_; $self->{AddrList}{$email} = Mail::Address->new($name, $email); $self; } diff --git a/cpan/lib/Mail/Field/AddrList.pod b/cpan/lib/Mail/Field/AddrList.pod new file mode 100644 index 00000000..a42091fd --- /dev/null +++ b/cpan/lib/Mail/Field/AddrList.pod @@ -0,0 +1,175 @@ +=encoding utf8 + +=head1 NAME + +Mail::Field::AddrList - object representation of e-mail address lists + +=head1 INHERITANCE + + Mail::Field::AddrList + is a Mail::Field + +=head1 SYNOPSIS + + use Mail::Field::AddrList; + + $to = Mail::Field->new('To'); + $from = Mail::Field->new('From', 'poe@daimi.aau.dk (Peter Orbaek)'); + + $from->create('foo@bar.com' => 'Mr. Foo', poe => 'Peter'); + $from->parse('foo@bar.com (Mr Foo), Peter Orbaek <poe>'); + + # make a RFC822 header string + print $from->stringify(),"\n"; + + # extract e-mail addresses and names + @addresses = $from->addresses(); # strings + @names = $from->names(); # strings + @addr = $from->addr_list(); # Mail::Address objects (v2.00) + + # adjoin a new address to the list + $from->set_address('foo@bar.com', 'Mr. Foo'); + +=head1 DESCRIPTION + +Defines parsing and formatting of address field, for the following +fields: C<To>, C<From>, C<Cc>, C<Reply-To>, and C<Sender>. + +All the normally used features of the address field specification of +RFC2822 are implemented, but some complex (and therefore hardly ever used) +constructs will not be understood. Use Mail::Message::Field::Full +in MailBox if you need full RFC compliance. + +Extends L<"DESCRIPTION" in Mail::Field|Mail::Field/"DESCRIPTION">. + +=head1 METHODS + +Extends L<"METHODS" in Mail::Field|Mail::Field/"METHODS">. + +=head2 Constructors + +Extends L<"Constructors" in Mail::Field|Mail::Field/"Constructors">. + +=over 4 + +=item Mail::Field::AddrList-E<gt>B<combine>(FIELDS) + +Inherited, see L<Mail::Field/"Constructors"> + +=item Mail::Field::AddrList-E<gt>B<extract>( TAG, HEAD [, INDEX ] ) + +Inherited, see L<Mail::Field/"Constructors"> + +=item Mail::Field::AddrList-E<gt>B<new>( TAG [, STRING | OPTIONS] ) + +Inherited, see L<Mail::Field/"Constructors"> + +=back + +=head2 "Fake" constructors + +Extends L<""Fake" constructors" in Mail::Field|Mail::Field/""Fake" constructors">. + +=over 4 + +=item $obj-E<gt>B<create>(OPTIONS) + +Inherited, see L<Mail::Field/""Fake" constructors"> + +=item $obj-E<gt>B<parse>() + +Inherited, see L<Mail::Field/""Fake" constructors"> + +=back + +=head2 Accessors + +Extends L<"Accessors" in Mail::Field|Mail::Field/"Accessors">. + +=over 4 + +=item $obj-E<gt>B<set>(OPTIONS) + +Inherited, see L<Mail::Field/"Accessors"> + +=item $obj-E<gt>B<stringify>() + +Inherited, see L<Mail::Field/"Accessors"> + +=item $obj-E<gt>B<tag>() + +=item Mail::Field::AddrList-E<gt>B<tag>() + +Inherited, see L<Mail::Field/"Accessors"> + +=back + +=head2 Smart accessors + +Extends L<"Smart accessors" in Mail::Field|Mail::Field/"Smart accessors">. + +=over 4 + +=item $obj-E<gt>B<addr_list>() + +Returns the collected L<Mail::Address|Mail::Address> objects. + +=item $obj-E<gt>B<addresses>() + +Returns a list if email addresses, found in the field content. + +=item $obj-E<gt>B<names>() + +Returns a list of nicely formatted named, for each of the addresses +found in the content. + +=item $obj-E<gt>B<set_address>(EMAIL, NAME) + +Add/replace an EMAIL address to the field. + +=item $obj-E<gt>B<text>( [STRING] ) + +Inherited, see L<Mail::Field/"Smart accessors"> + +=back + +=head1 DETAILS + +Extends L<"DETAILS" in Mail::Field|Mail::Field/"DETAILS">. + +=head1 DIAGNOSTICS + +=over 4 + +=item Error: Undefined subroutine <method> called + +Mail::Field objects use autoloading to compile new functionality. +Apparently, the method called is not implemented for the specific +class of the field object. + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + diff --git a/cpan/lib/Mail/Field/Date.pm b/cpan/lib/Mail/Field/Date.pm index 49db8a17..303d0ecc 100644 --- a/cpan/lib/Mail/Field/Date.pm +++ b/cpan/lib/Mail/Field/Date.pm @@ -1,80 +1,62 @@ -# Mail::Field::Date -# -# Copyright (c) 1997 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. -# -# An example of a Mail::Field::* class +# 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. +use strict; package Mail::Field::Date; +use vars '$VERSION'; +$VERSION = '2.19'; + +use base 'Mail::Field'; -use strict; -use Mail::Field (); -use vars qw(@ISA $VERSION); use Date::Format qw(time2str); -use Date::Parse qw(str2time); +use Date::Parse qw(str2time); -@ISA = qw(Mail::Field); -$VERSION = '1.52'; +(bless [])->register('Date'); -bless([])->register('Date'); -sub set -{ - my $self = shift; - my $arg = @_ == 1 ? shift : { @_ }; - my $s; +sub set() +{ my $self = shift; + my $arg = @_ == 1 ? shift : { @_ }; - foreach $s (qw(Time TimeStr)) - { - if(exists $arg->{$s}) { $self->{$s} = $arg->{$s} } - else { delete $self->{$s} } - } + foreach my $s (qw(Time TimeStr)) + { if(exists $arg->{$s}) + { $self->{$s} = $arg->{$s} } + else { delete $self->{$s} } + } - $self; + $self; } -sub parse -{ - my $self = shift; - - delete $self->{Time}; - $self->{TimeStr} = shift; - $self; +sub parse($) +{ my $self = shift; + delete $self->{Time}; + $self->{TimeStr} = shift; + $self; } -sub time -{ - my $self = shift; - if(@_) - { - delete $self->{TimeStr}; - return $self->{Time} = shift; - } +sub time(;$) +{ my $self = shift; - return $self->{Time} - if exists $self->{Time}; + if(@_) + { delete $self->{TimeStr}; + return $self->{Time} = shift; + } - $self->{Time} = str2time($self->{TimeStr}); + $self->{Time} ||= str2time $self->{TimeStr}; } sub stringify -{ - my $self = shift; - - return $self->{TimeStr} - if exists $self->{TimeStr}; - - time2str("%a, %e %b %T %Y %z", $self->time); +{ my $self = shift; + $self->{TimeStr} ||= time2str("%a, %e %b %Y %T %z", $self->time); } sub reformat -{ - my $self = shift; - $self->time($self->time); - $self->stringify; +{ my $self = shift; + $self->time($self->time); + $self->stringify; } 1; - diff --git a/cpan/lib/Mail/Field/Date.pod b/cpan/lib/Mail/Field/Date.pod new file mode 100644 index 00000000..2a41e19f --- /dev/null +++ b/cpan/lib/Mail/Field/Date.pod @@ -0,0 +1,152 @@ +=encoding utf8 + +=head1 NAME + +Mail::Field::Date - a date header field + +=head1 INHERITANCE + + Mail::Field::Date + is a Mail::Field + +=head1 SYNOPSIS + + use HTTP::Date 'time2iso'; + my $field = Mail::Field->new(Date => time2iso()); + +=head1 DESCRIPTION + +Represents one "Date" header field. + +Extends L<"DESCRIPTION" in Mail::Field|Mail::Field/"DESCRIPTION">. + +=head1 METHODS + +Extends L<"METHODS" in Mail::Field|Mail::Field/"METHODS">. + +=head2 Constructors + +Extends L<"Constructors" in Mail::Field|Mail::Field/"Constructors">. + +=over 4 + +=item Mail::Field::Date-E<gt>B<combine>(FIELDS) + +Inherited, see L<Mail::Field/"Constructors"> + +=item Mail::Field::Date-E<gt>B<extract>( TAG, HEAD [, INDEX ] ) + +Inherited, see L<Mail::Field/"Constructors"> + +=item Mail::Field::Date-E<gt>B<new>( TAG [, STRING | OPTIONS] ) + +Inherited, see L<Mail::Field/"Constructors"> + +=back + +=head2 "Fake" constructors + +Extends L<""Fake" constructors" in Mail::Field|Mail::Field/""Fake" constructors">. + +=over 4 + +=item $obj-E<gt>B<create>(OPTIONS) + +Inherited, see L<Mail::Field/""Fake" constructors"> + +=item $obj-E<gt>B<parse>() + +Inherited, see L<Mail::Field/""Fake" constructors"> + +=back + +=head2 Accessors + +Extends L<"Accessors" in Mail::Field|Mail::Field/"Accessors">. + +=over 4 + +=item $obj-E<gt>B<set>(OPTIONS) + + -Option --Default + Time undef + TimeStr undef + +=over 2 + +=item Time => SECONDS + +=item TimeStr => STRING + +A string acceptable to Date::Parse. + +=back + +=item $obj-E<gt>B<stringify>() + +Inherited, see L<Mail::Field/"Accessors"> + +=item $obj-E<gt>B<tag>() + +=item Mail::Field::Date-E<gt>B<tag>() + +Inherited, see L<Mail::Field/"Accessors"> + +=back + +=head2 Smart accessors + +Extends L<"Smart accessors" in Mail::Field|Mail::Field/"Smart accessors">. + +=over 4 + +=item $obj-E<gt>B<text>( [STRING] ) + +Inherited, see L<Mail::Field/"Smart accessors"> + +=item $obj-E<gt>B<time>( [TIME] ) + +Query (or change) the TIME (as stored in the field) in seconds. + +=back + +=head1 DETAILS + +Extends L<"DETAILS" in Mail::Field|Mail::Field/"DETAILS">. + +=head1 DIAGNOSTICS + +=over 4 + +=item Error: Undefined subroutine <method> called + +Mail::Field objects use autoloading to compile new functionality. +Apparently, the method called is not implemented for the specific +class of the field object. + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + diff --git a/cpan/lib/Mail/Field/Generic.pm b/cpan/lib/Mail/Field/Generic.pm new file mode 100644 index 00000000..2a9d193c --- /dev/null +++ b/cpan/lib/Mail/Field/Generic.pm @@ -0,0 +1,33 @@ +# 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::Field::Generic; +use vars '$VERSION'; +$VERSION = '2.19'; + + +use Carp; +use base 'Mail::Field'; + + +sub create +{ my ($self, %arg) = @_; + $self->{Text} = delete $arg{Text}; + + croak "Unknown options " . join(",", keys %arg) + if %arg; + + $self; +} + + +sub parse +{ my $self = shift; + $self->{Text} = shift || ""; + $self; +} + +sub stringify { shift->{Text} } + +1; diff --git a/cpan/lib/Mail/Field/Generic.pod b/cpan/lib/Mail/Field/Generic.pod new file mode 100644 index 00000000..cdb90560 --- /dev/null +++ b/cpan/lib/Mail/Field/Generic.pod @@ -0,0 +1,147 @@ +=encoding utf8 + +=head1 NAME + +Mail::Field::Generic - implementation for inspecific fields + +=head1 INHERITANCE + + Mail::Field::Generic + is a Mail::Field + +=head1 SYNOPSIS + + use Mail::Field; + my $field = Mail::Field->new('Subject', 'some subject text'); + my $field = Mail::Field->new(subject => 'some subject text'); + +=head1 DESCRIPTION + +A generic implementation for header fields without own +implementation. This is fine for fields like C<Subject>, C<X-Mailer>, +etc., where the field holds only a string of no particular +importance/format. + +Extends L<"DESCRIPTION" in Mail::Field|Mail::Field/"DESCRIPTION">. + +=head1 METHODS + +Extends L<"METHODS" in Mail::Field|Mail::Field/"METHODS">. + +=head2 Constructors + +Extends L<"Constructors" in Mail::Field|Mail::Field/"Constructors">. + +=over 4 + +=item Mail::Field::Generic-E<gt>B<combine>(FIELDS) + +Inherited, see L<Mail::Field/"Constructors"> + +=item Mail::Field::Generic-E<gt>B<extract>( TAG, HEAD [, INDEX ] ) + +Inherited, see L<Mail::Field/"Constructors"> + +=item Mail::Field::Generic-E<gt>B<new>( TAG [, STRING | OPTIONS] ) + +Inherited, see L<Mail::Field/"Constructors"> + +=back + +=head2 "Fake" constructors + +Extends L<""Fake" constructors" in Mail::Field|Mail::Field/""Fake" constructors">. + +=over 4 + +=item $obj-E<gt>B<create>(OPTIONS) + + -Option--Default + Text '' + +=over 2 + +=item Text => STRING + +=back + +=item $obj-E<gt>B<parse>( [STRING] ) + +Set the new text, which is empty when no STRING is provided. + +=back + +=head2 Accessors + +Extends L<"Accessors" in Mail::Field|Mail::Field/"Accessors">. + +=over 4 + +=item $obj-E<gt>B<set>(OPTIONS) + +Inherited, see L<Mail::Field/"Accessors"> + +=item $obj-E<gt>B<stringify>() + +Inherited, see L<Mail::Field/"Accessors"> + +=item $obj-E<gt>B<tag>() + +=item Mail::Field::Generic-E<gt>B<tag>() + +Inherited, see L<Mail::Field/"Accessors"> + +=back + +=head2 Smart accessors + +Extends L<"Smart accessors" in Mail::Field|Mail::Field/"Smart accessors">. + +=over 4 + +=item $obj-E<gt>B<text>( [STRING] ) + +Inherited, see L<Mail::Field/"Smart accessors"> + +=back + +=head1 DETAILS + +Extends L<"DETAILS" in Mail::Field|Mail::Field/"DETAILS">. + +=head1 DIAGNOSTICS + +=over 4 + +=item Error: Undefined subroutine <method> called + +Mail::Field objects use autoloading to compile new functionality. +Apparently, the method called is not implemented for the specific +class of the field object. + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + diff --git a/cpan/lib/Mail/Filter.pm b/cpan/lib/Mail/Filter.pm index b0f3aba5..05320f9d 100644 --- a/cpan/lib/Mail/Filter.pm +++ b/cpan/lib/Mail/Filter.pm @@ -1,184 +1,70 @@ -# Mail::Filter.pm -# -# Copyright (c) 1997-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. - +# 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::Filter; +use vars '$VERSION'; +$VERSION = '2.19'; + -use Carp; use strict; -use vars qw($VERSION); +use Carp; -$VERSION = "1.52"; -sub new { - my $self = shift; - - bless { - filters => [ @_ ] - }, $self; +sub new(@) +{ my $class = shift; + bless { filters => [ @_ ] }, $class; } -sub add { - my $self = shift; - push(@{$self->{'filters'}}, @_); +#------------ + +sub add(@) +{ my $self = shift; + push @{$self->{filters}}, @_; } -sub _filter { - my $self = shift; - my $mail = shift; - my $sub; +#------------ - foreach $sub (@{$self->{'filters'}}) { - if(ref($sub) eq "CODE") { - $mail = $sub->($self,$mail); - } - elsif(!ref($sub)) { - $mail = $self->$sub($mail); - } - else { - carp "Cannot call filter '$sub', ignored"; - } - last unless ref($mail); +sub _filter($) +{ my ($self, $mail) = @_; + + foreach my $sub ( @{$self->{filters}} ) + { my $mail + = ref $sub eq 'CODE' ? $sub->($self,$mail) + : !ref $sub ? $self->$sub($mail) + : carp "Cannot call filter '$sub', ignored"; + + ref $mail or last; } - # the specification indicates that the result of operations on $mail - # should be returned by this function - return $mail; + + $mail; } -sub filter { - my $self = shift; - my $obj = shift; - - if($obj->isa('Mail::Folder')) { - $self->{'folder'} = $obj; - my $m; - foreach $m ($obj->message_list) { - my $mail = $obj->get_message($m) || next; - $self->{'msgnum'} = $m; - _filter($self,$mail); +sub filter +{ my ($self, $obj) = @_; + if($obj->isa('Mail::Folder')) + { $self->{folder} = $obj; + foreach my $m ($obj->message_list) + { my $mail = $obj->get_message($m) or next; + $self->{msgnum} = $m; + $self->_filter($mail); } - delete $self->{'folder'}; - delete $self->{'msgnum'}; + delete $self->{folder}; + delete $self->{msgnum}; } - elsif($obj->isa('Mail::Internet')) { - return _filter($self,$obj); + elsif($obj->isa('Mail::Internet')) + { return $self->filter($obj); } - else { - carp "Cannot process '$obj'"; + else + { carp "Cannot process '$obj'"; return undef; } } -sub folder { - my $self = shift; - exists $self->{'folder'} - ? $self->{'folder'} - : undef; -} - -sub msgnum { - my $self = shift; - exists $self->{'msgnum'} - ? $self->{'msgnum'} - : undef; -} - - -1; - -__END__ - -=head1 NAME - -Mail::Filter - Filter mail through multiple subroutines - -=head1 SYNOPSIS - - use Mail::Filter; - - $filter = new Mail::Filter( \&filter1, \&filter2 ); - - $mail = new Mail::Internet( [<>] ); - $mail = $filter->filter($mail); - - $folder = new Mail::Folder( .... ); - $filter->filter($folder); - -=head1 DESCRIPTION - -C<Mail::Filter> provides an interface to filtering Email through multiple -subroutines. - -C<Mail::Filter> filters mail by calling each filter subroutine in turn. Each -filter subroutine is called with two arguments, the first is the filter -object and the second is the mail or folder object being filtered. -The result from each filter sub is passed to the next filter as the mail -object. If a filter subroutine returns undef, then C<Mail::Filter> will abort -and return immediately. +sub folder() {shift->{folder}} -The function returns the result from the last subroutine to operate on the -mail object. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ FILTER [, ... ]]) - -Create a new C<Mail::Filter> object with the given filter subroutines. Each -filter may be either a code reference or the name of a method to call -on the <Mail::Filter> object. - -=back - -=head1 METHODS - -=over 4 - -=item add ( FILTER [, FILTER ...] ) - -Add the given filters to the end of the fliter list. - -=item filter ( MAIL-OBJECT | MAIL-FOLDER ) - -If the first argument is a C<Mail::Internet> object, then this object will -be passed through the filter list. If the first argument is a C<Mail::Folder> -object, then each message in turn will be passed through the filter list. - -=item folder - -If the C<filter> method is called with a C<Mail::Folder> object, then the -filter subroutines may call this method to obtain the folder object that is -being processed. - -=item msgnum - -If the C<filter> method is called with a C<Mail::Folder> object, then the -filter subroutines may call this method to obtain the message number -of the message that is being processed. - -=back - -=head1 SEE ALSO - -L<Mail::Internet> -L<Mail::Folder> - -=head1 AUTHOR - -Graham Barr. - -Maintained by Mark Overmeer <mailtools@overmeer.net> - -=head1 COPYRIGHT - -Copyright (c) 1997-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. - -=cut +sub msgnum() {shift->{msgnum}} +1; diff --git a/cpan/lib/Mail/Filter.pod b/cpan/lib/Mail/Filter.pod new file mode 100644 index 00000000..e4397c72 --- /dev/null +++ b/cpan/lib/Mail/Filter.pod @@ -0,0 +1,106 @@ +=encoding utf8 + +=head1 NAME + +Mail::Filter - filter mail through multiple subroutines + +=head1 SYNOPSIS + + use Mail::Filter; + + my $filter = Mail::Filter->new( \&filter1, \&filter2 ); + + my $mail = Mail::Internet->new( [<>] ); + my $mail = $filter->filter($mail); + + my $folder = Mail::Folder->new( .... ); + my $filter->filter($folder); + +=head1 DESCRIPTION + +C<Mail::Filter> provides an interface to filtering Email through multiple +subroutines. + +C<Mail::Filter> filters mail by calling each filter subroutine in turn. Each +filter subroutine is called with two arguments, the first is the filter +object and the second is the mail or folder object being filtered. + +The result from each filter sub is passed to the next filter as the mail +object. If a filter subroutine returns undef, then C<Mail::Filter> will abort +and return immediately. + +The function returns the result from the last subroutine to operate on the +mail object. + +=head1 METHODS + +=head2 Constructors + +=over 4 + +=item Mail::Filter-E<gt>B<new>( [FILTER [, ... ]] ) + +Create a new C<Mail::Filter> object with the given filter subroutines. Each +filter may be either a code reference or the name of a method to call +on the <Mail::Filter> object. + +=back + +=head2 Accessors + +=over 4 + +=item $obj-E<gt>B<add>( FILTER [, FILTER ...] ) + +Add the given filters to the end of the filter list. + +=back + +=head2 Processing + +=over 4 + +=item $obj-E<gt>B<filter>(MAIL-OBJECT | MAIL-FOLDER) + +If the first argument is a C<Mail::Internet> object, then this object will +be passed through the filter list. If the first argument is a C<Mail::Folder> +object, then each message in turn will be passed through the filter list. + +=item $obj-E<gt>B<folder>() + +While the C<filter> method is called with a C<Mail::Folder> object, these +filter subroutines can call this method to obtain the folder object that is +being processed. + +=item $obj-E<gt>B<msgnum>() + +If the C<filter> method is called with a C<Mail::Folder> object, then the +filter subroutines may call this method to obtain the message number +of the message that is being processed. + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + 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; diff --git a/cpan/lib/Mail/Header.pod b/cpan/lib/Mail/Header.pod new file mode 100644 index 00000000..9f90f4f8 --- /dev/null +++ b/cpan/lib/Mail/Header.pod @@ -0,0 +1,255 @@ +=encoding utf8 + +=head1 NAME + +Mail::Header - manipulate MIME headers + +=head1 SYNOPSIS + + use Mail::Header; + + my $head = Mail::Header->new; + my $head = Mail::Header->new( \*STDIN ); + my $head = Mail::Header->new( [<>], Modify => 0); + +=head1 DESCRIPTION + +Read, write, create, and manipulate MIME headers, the leading part +of each modern e-mail message, but also used in other protocols +like HTTP. The fields are kept in L<Mail::Field|Mail::Field> objects. + +Be aware that the header fields each have a name part, which shall +be treated case-insensitive, and a content part, which may be folded +over multiple lines. + +Mail::Header does not always follow the RFCs strict enough, does not +help you with character encodings. It does not use weak references +where it could (because those did not exist when the module was written) +which costs some performance and make the implementation a little more +complicated. The Mail::Message::Head implementation is much newer +and therefore better. + +=head1 METHODS + +=head2 Constructors + +=over 4 + +=item $obj-E<gt>B<dup>() + +Create a duplicate of the current object. + +=item $obj-E<gt>B<new>( [ARG], [OPTIONS] ) + +=item Mail::Header-E<gt>B<new>( [ARG], [OPTIONS] ) + +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. + +OPTIONS is a list of options given in the form of key-value +pairs, just like a hash table. Valid options are + + -Option --Default + FoldLength 79 + MailFrom 'KEEP' + Modify false + +=over 2 + +=item FoldLength => INTEGER + +The default length of line to be used when folding header lines. +See L<fold_length()|Mail::Header/"Accessors">. + +=item MailFrom => 'IGNORE'|'COERCE'|'KEEP'|'ERROR' + +See method L<mail_from()|Mail::Header/"Accessors">. + +=item Modify => BOOLEAN + +If this value is I<true> then the headers will be re-formatted, +otherwise the format of the header lines will remain unchanged. + +=back + +=back + +=head2 "Fake" constructors + +Be warned that the next constructors all require an already created +header object, of which the original content will be destroyed. + +=over 4 + +=item $obj-E<gt>B<empty>() + +Empty an existing C<Mail::Header> object of all lines. + +=item $obj-E<gt>B<extract>(ARRAY) + +Extract a header from the given array into an existing Mail::Header +object. C<extract> B<will modify> this array. +Returns the object that the method was called on. + +=item $obj-E<gt>B<header>( [ARRAY] ) + +C<header> does multiple operations. First it will extract a header from +the ARRAY, if given. It will then reformat the header (if reformatting +is permitted), and finally return a reference to an array which +contains the header in a printable form. + +=item $obj-E<gt>B<header_hashref>( [HASH] ) + +As L<header()|Mail::Header/""Fake" constructors">, but it will eventually set headers from a hash +reference, and it will return the headers as a hash reference. + +example: + + $fields->{From} = 'Tobias Brox <tobix@cpan.org>'; + $fields->{To} = ['you@somewhere', 'me@localhost']; + $head->header_hashref($fields); + +=item $obj-E<gt>B<read>(FILEHANDLE) + +Read a header from the given file descriptor into an existing Mail::Header +object. + +=back + +=head2 Accessors + +=over 4 + +=item $obj-E<gt>B<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. + +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. + +=item $obj-E<gt>B<mail_from>('IGNORE'|'COERCE'|'KEEP'|'ERROR') + +This 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 $obj-E<gt>B<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. + +=back + +=head2 Processing + +=over 4 + +=item $obj-E<gt>B<add>( TAG, LINE [, INDEX] ) + +Add a new line to the header. If TAG is C<undef> the tag will be +extracted from the beginning of the given line. If 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. + +=item $obj-E<gt>B<as_string>() + +Returns the header as a single string. + +=item $obj-E<gt>B<cleanup>() + +Remove any header line that, other than the tag, only contains whitespace + +=item $obj-E<gt>B<combine>( TAG [, WITH] ) + +Combine all instances of TAG into one. The lines will be +joined together 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 $obj-E<gt>B<count>(TAG) + +Returns the number of times the given atg appears in the header + +=item $obj-E<gt>B<delete>( TAG [, INDEX ] ) + +Delete a tag from the header. If an INDEX id is given, then the Nth instance +of the tag will be removed. If no INDEX is given, then all instances +of tag will be removed. + +=item $obj-E<gt>B<fold>( [LENGTH] ) + +Fold the header. If LENGTH is not given, then C<Mail::Header> uses the +following rules to determine what length to fold a line. + +=item $obj-E<gt>B<get>( TAG [, INDEX] ) + +Get the text from a line. If an 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 the TAG will be returned. In a scalar context +the text for the first instance will be returned. + +The lines are unfolded, but still terminated with a new-line (see C<chomp>) + +=item $obj-E<gt>B<print>( [FILEHANDLE] ) + +Print the header to the given file descriptor, or C<STDOUT> if no +file descriptor is given. + +=item $obj-E<gt>B<replace>( TAG, LINE [, INDEX ] ) + +Replace a line in the header. If TAG is C<undef> the tag will be +extracted from the beginning of the given line. If 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. + +=item $obj-E<gt>B<tags>() + +Returns 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 $obj-E<gt>B<unfold>( [TAG] ) + +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. + +The unfolding process is wrong but (for compatibility reasons) will +not be repaired: only one blank at the start of the line should be +removed, not all of them. + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + diff --git a/cpan/lib/Mail/Internet.pm b/cpan/lib/Mail/Internet.pm index 6b1157ba..bace44be 100644 --- a/cpan/lib/Mail/Internet.pm +++ b/cpan/lib/Mail/Internet.pm @@ -1,963 +1,554 @@ -# Mail::Internet.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. -# - +# 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::Internet; -use strict; +use vars '$VERSION'; +$VERSION = '2.19'; -require 5.002; +use strict; +# use warnings? probably breaking too much code use Carp; -use AutoLoader; use Mail::Header; -use vars qw($VERSION); - -BEGIN { - $VERSION = "1.52"; - *AUTOLOAD = \&AutoLoader::AUTOLOAD; - - unless(defined &UNIVERSAL::isa) { - *UNIVERSAL::isa = sub { - my($obj,$type) = @_; - my $pkg = ref($obj) || $obj; - my @pkg = ($pkg); - my %done; - while(@pkg) { - $pkg = shift @pkg; - return 1 if $pkg eq $type; - next if exists $done{$pkg}; - $done{$pkg} = 1; - - no strict 'refs'; - - unshift @pkg,@{$pkg . "::ISA"} - if(@{$pkg . "::ISA"}); - } - undef; - } - } -} +use Mail::Util qw/mailaddress/; +use Mail::Address; -sub new -{ - my $self = shift; - my $type = ref($self) || $self; - my $arg = @_ % 2 ? shift : undef; - my %arg = @_; +sub new(@) +{ my $call = shift; + my $arg = @_ % 2 ? shift : undef; + my %opt = @_; - my $me = bless {}, $type; + my $class = ref($call) || $call; + my $self = bless {}, $class; - $me->{'mail_inet_head'} = $arg{Header} if exists $arg{Header}; - $me->{'mail_inet_body'} = $arg{Body} if exists $arg{Body}; + $self->{mail_inet_head} = $opt{Header} if exists $opt{Header}; + $self->{mail_inet_body} = $opt{Body} if exists $opt{Body}; - $me->head->fold_length(delete $arg{FoldLength} || 79); # Default fold length - $me->head->mail_from($arg{MailFrom}) if exists $arg{MailFrom}; - $me->head->modify(exists $arg{Modify} ? $arg{Modify} : 1); + my $head = $self->head; + $head->fold_length(delete $opt{FoldLength} || 79); + $head->mail_from($opt{MailFrom}) if exists $opt{MailFrom}; + $head->modify(exists $opt{Modify} ? $opt{Modify} : 1); - if(defined $arg) - { - if(ref($arg) eq 'ARRAY') - { - $me->header($arg) unless exists $arg{Header}; - $me->body($arg) unless exists $arg{Body}; + if(!defined $arg) { } + elsif(ref($arg) eq 'ARRAY') + { $self->header($arg) unless exists $opt{Header}; + $self->body($arg) unless exists $opt{Body}; } - elsif(defined fileno($arg)) - { - $me->read_header($arg) unless exists $arg{Header}; - $me->read_body($arg) unless exists $arg{Body}; + elsif(defined fileno($arg)) + { $self->read_header($arg) unless exists $opt{Header}; + $self->read_body($arg) unless exists $opt{Body}; + } + else + { croak "couldn't understand $arg to Mail::Internet constructor"; } - } - - return $me; -} - -sub read -{ - my $me = shift; - - $me->read_header(@_); - $me->read_body(@_); -} - -sub read_body -{ - my($me,$fd) = @_; - $me->body( [ <$fd> ] ); + $self; } -sub extract -{ - my $me = shift; - my $arg = shift; - - $me->head->extract($arg); - $me->body($arg); +sub read(@) +{ my $self = shift; + $self->read_header(@_); + $self->read_body(@_); } - -sub body -{ - my $me = shift; - my $body = $me->{'mail_inet_body'} ||= []; - - if(@_) - { - my $new = shift; - $me->{'mail_inet_body'} = ref($new) eq 'ARRAY' ? $new : [ $new, @_ ]; - } - - return $body; +sub read_body($) +{ my ($self, $fd) = @_; + $self->body( [ <$fd> ] ); } -sub header { shift->head->header(@_) } -sub fold { shift->head->fold(@_) } -sub fold_length { shift->head->fold_length(@_) } -sub combine { shift->head->combine(@_) } -sub print_header { shift->{'mail_inet_head'}->print(@_) } -sub head { shift->{'mail_inet_head'} ||= new Mail::Header } - -sub read_header -{ - my $me = shift; - my $head = $me->head; - $head->read(@_); - $head->header(); +sub read_header(@) +{ my $head = shift->head; + $head->read(@_); + $head->header; } -sub clean_header -{ - carp "clean_header depreciated, use ->header" if $^W; - shift->header(); -} -sub tidy_headers -{ - carp "tidy_headers no longer required" if $^W; +sub extract($) +{ my ($self, $lines) = @_; + $self->head->extract($lines); + $self->body($lines); } -sub add -{ - my $me = shift; - my $head = $me->head; - my $ret; - while(@_) - { - my ($tag,$line) = splice(@_,0,2); +sub dup() +{ my $self = shift; + my $dup = ref($self)->new; - $ret = $head->add($tag,$line,-1) or - return undef; - } + my $body = $self->{mail_inet_body} || []; + my $head = $self->{mail_inet_head};; - $ret; + $dup->{mail_inet_body} = [ @$body ]; + $dup->{mail_inet_head} = $head->dup if $head; + $dup; } -sub replace -{ - my $me = shift; - my $head = $me->head; - my $ret; +#--------------- - while(@_) - { - my ($tag,$line) = splice(@_,0,2); +sub body(;$@) +{ my $self = shift; - $ret = $head->replace($tag,$line,0) or - return undef; - } + return $self->{mail_inet_body} ||= [] + unless @_; - $ret; + $self->{mail_inet_body} = ref $_[0] eq 'ARRAY' ? $_[0] : [ @_ ]; } -sub get -{ - my $me = shift; - my $head = $me->head; - my @ret = (); - my $tag; - - foreach $tag (@_) - { - last - if push(@ret, $head->get($tag)) && !wantarray; - } - wantarray ? @ret : shift @ret; -} +sub head { shift->{mail_inet_head} ||= Mail::Header->new } -sub delete -{ - my $me = shift; - my $head = $me->head; - my @ret = (); - my $tag; +#--------------- - foreach $tag (@_) - { - push(@ret, $head->delete($tag)); - } +sub print($) +{ my $self = shift; + my $fd = shift || \*STDOUT; - @ret; + $self->print_header($fd) + and print $fd "\n" + and $self->print_body($fd); } -sub dup -{ - my $me = shift; - my $type = ref($me); - my $dup = $type->new; - $dup->{'mail_inet_body'} = [@{$me->body}] - if exists $me->{'mail_inet_body'}; - - $dup->{'mail_inet_head'} = $me->{'mail_inet_head'}->dup - if exists $me->{'mail_inet_head'}; - - $dup; -} +sub print_header($) { shift->head->print(@_) } -sub empty -{ - my $me = shift; +sub print_body($) +{ my $self = shift; + my $fd = shift || \*STDOUT; - %{*$me} = (); - - 1; -} - -sub print_body -{ - my $me = shift; - my $fd = shift || \*STDOUT; - my $ln; - - foreach $ln (@{$me->body}) - { - print $fd $ln or - return 0; - } + foreach my $ln (@{$self->body}) + { print $fd $ln or return 0; + } - 1; + 1; } -sub print -{ - my $me = shift; - my $fd = shift || \*STDOUT; - $me->print_header($fd) - and print $fd "\n" - and $me->print_body($fd); +sub as_string() +{ my $self = shift; + $self->head->as_string . "\n" . join '', @{$self->body}; } -sub as_string -{ - my $me = shift; - - $me->head->as_string . "\n" . join '', @{ $me->body }; -} -sub as_mbox_string -{ - my $me = shift->dup; - my $escaped = shift; +sub as_mbox_string($) +{ my $self = shift->dup; + my $escaped = shift; - $me->head->delete('Content-Length'); - $me->escape_from unless $escaped; - $me->as_string . "\n"; + $self->head->delete('Content-Length'); + $self->escape_from unless $escaped; + $self->as_string . "\n"; } -sub remove_sig -{ - my $me = shift; - my $nlines = shift || 10; +#--------------- - my $body = $me->body; - my($line,$i); +sub header { shift->head->header(@_) } +sub fold { shift->head->fold(@_) } +sub fold_length { shift->head->fold_length(@_) } +sub combine { shift->head->combine(@_) } - $line = scalar(@{$body}); - return unless($line); - while($i++ < $nlines && $line--) - { - if($body->[$line] =~ /\A--\040?[\r\n]+/) - { - splice(@{$body},$line,$i); - last; +sub add(@) +{ my $head = shift->head; + my $ret; + while(@_) + { my ($tag, $line) = splice @_, 0, 2; + $ret = $head->add($tag, $line, -1) + or return undef; } - } + + $ret; } -sub tidy_body -{ - my $me = shift; - my $body = $me->body; - my $line; +sub replace(@) +{ my $head = shift->head; + my $ret; - if(scalar(@{$body})) - { - shift @$body - while(scalar(@{$body}) && $body->[0] =~ /\A\s*\Z/); - pop @$body - while(scalar(@{$body}) && $body->[-1] =~ /\A\s*\Z/); - } + while(@_) + { my ($tag, $line) = splice @_, 0, 2; + $ret = $head->replace($tag, $line, 0) + or return undef; + } - return $body; + $ret; } -sub DESTROY {} -# Auto loaded methods go after __END__ -__END__ +sub get(@) +{ my $head = shift->head; -sub reply; + return map { $head->get($_) } @_ + if wantarray; + foreach my $tag (@_) + { my $r = $head->get($tag); + return $r if defined $r; + } -use Mail::Address; - - sub reply -{ - my $me = shift; - my %arg = @_; - my $pkg = ref $me; - my @reply = (); + undef; +} - local *MAILHDR; - if(open(MAILHDR,"$ENV{HOME}/.mailhdr")) - { - # User has defined a mail header template - @reply = <MAILHDR>; - close(MAILHDR); - } - my $reply = $pkg->new(\@reply); +sub delete(@) +{ my $head = shift->head; + map { $head->delete($_) } @_; +} - my($to,$cc,$name,$body,$id); +# Undocumented; unused??? +sub empty() +{ my $self = shift; + %$self = (); + 1; +} - # The Subject line +#--------------- - my $subject = $me->get('Subject') || ""; +sub remove_sig($) +{ my $body = shift->body; + my $nlines = shift || 10; + my $start = @$body; - $subject = "Re: " . $subject if($subject =~ /\S+/ && $subject !~ /Re:/i); + my $i = 0; + while($i++ < $nlines && $start--) + { next if $body->[$start] !~ /^--[ ]?[\r\n]/; - $reply->replace('Subject',$subject); + splice @$body, $start, $i; + last; + } +} - # Locate who we are sending to - $to = $me->get('Reply-To') - || $me->get('From') - || $me->get('Return-Path') - || ""; - # Mail::Address->parse returns a list of refs to a 2 element array - my $sender = (Mail::Address->parse($to))[0]; +sub sign(@) +{ my ($self, %arg) = @_; + my ($sig, @sig); - $name = $sender->name; - $id = $sender->address; + if($sig = delete $arg{File}) + { local *SIG; - unless(defined $name) - { - my $fr = $me->get('From'); + if(open(SIG, $sig)) + { local $_; + while(<SIG>) { last unless /^(--)?\s*$/ } + @sig = ($_, <SIG>, "\n"); + close SIG; + } + } + elsif($sig = delete $arg{Signature}) + { @sig = ref($sig) ? @$sig : split(/\n/, $sig); + } - $fr = (Mail::Address->parse($fr))[0] if(defined $fr); - $name = $fr->name if(defined $fr); - } + if(@sig) + { $self->remove_sig; + s/[\r\n]*$/\n/ for @sig; + push @{$self->body}, "-- \n", @sig; + } - my $indent = $arg{Indent} || ">"; + $self; +} - if($indent =~ /%/) - { - my %hash = ( '%' => '%'); - my @name = grep(do { length > 0 }, split(/[\n\s]+/,$name || "")); - my @tmp; - @name = "" unless(@name); +sub tidy_body() +{ my $body = shift->body; - $hash{f} = $name[0]; - $hash{F} = $#name ? substr($hash{f},0,1) : $hash{f}; + shift @$body while @$body && $body->[0] =~ /^\s*$/; + pop @$body while @$body && $body->[-1] =~ /^\s*$/; + $body; +} - $hash{l} = $#name ? $name[$#name] : ""; - $hash{L} = substr($hash{l},0,1) || ""; +#--------------- - $hash{n} = $name || ""; - $hash{I} = join("",grep($_ = substr($_,0,1), @tmp = @name)); +sub reply(@) +{ my ($self, %arg) = @_; + my $class = ref $self; + my @reply; - $indent =~ s/%(.)/defined $hash{$1} ? $hash{$1} : $1/eg; - } + local *MAILHDR; + if(open(MAILHDR, "$ENV{HOME}/.mailhdr")) + { # User has defined a mail header template + @reply = <MAILHDR>; + close MAILHDR; + } - $reply->replace('To', $id); + my $reply = $class->new(\@reply); - # Find addresses not to include - my %nocc = (); - my $mailaddresses = $ENV{MAILADDRESSES} || ""; - my $addr; + # The Subject line + my $subject = $self->get('Subject') || ""; + $subject = "Re: " . $subject + if $subject =~ /\S+/ && $subject !~ /Re:/i; - $nocc{lc $id} = 1; + $reply->replace(Subject => $subject); - foreach $addr (Mail::Address->parse($reply->get('Bcc'),$mailaddresses)) - { - my $lc = lc $addr->address; - $nocc{$lc} = 1; - } + # Locate who we are sending to + my $to = $self->get('Reply-To') + || $self->get('From') + || $self->get('Return-Path') + || ""; - if($arg{ReplyAll} || 0) - { - # Who shall we copy this to - my %cc = (); + my $sender = (Mail::Address->parse($to))[0]; - foreach $addr (Mail::Address->parse($me->get('To'),$me->get('Cc'))) - { - my $lc = lc $addr->address; - $cc{$lc} = $addr->format unless(defined $nocc{$lc}); + my $name = $sender->name; + unless(defined $name) + { my $fr = $self->get('From'); + $fr = (Mail::Address->parse($fr))[0] if defined $fr; + $name = $fr->name if defined $fr; } - $cc = join(', ',values %cc); - - $reply->replace('Cc', $cc); - } - - # References - my $refs = $me->get('References') || ""; - my $mid = $me->get('Message-Id'); - - $refs .= " " . $mid if(defined $mid); - $reply->replace('References',$refs); - - # In-Reply-To - my $date = $me->get('Date'); - my $inreply = ""; - - if(defined $mid) - { - $inreply = $mid; - $inreply .= " from " . $name if(defined $name); - $inreply .= " on " . $date if(defined $date); - } - elsif(defined $name) - { - $inreply = $name . "'s message"; - $inreply .= "of " . $date if(defined $date); - } - - $reply->replace('In-Reply-To', $inreply); - - # Quote the body - $body = $reply->body; - - @$body = @{$me->body}; # copy body - $reply->remove_sig; # remove signature, if any - $reply->tidy_body; # tidy up - map { s/\A/$indent/ } @$body; # indent - - # Add references - unshift @{$body}, (defined $name ? $name . " " : "") . "<$id> writes:\n"; - - if(defined $arg{Keep} && 'ARRAY' eq ref($arg{Keep})) - { - # Copy lines from the original - my $keep; - - foreach $keep (@{$arg{Keep}}) - { - my $ln = $me->get($keep); - $reply->replace($keep,$ln) if(defined $ln); - } - } - - if(defined $arg{Exclude} && 'ARRAY' eq ref($arg{Exclude})) - { - # Exclude lines - $reply->delete(@{$arg{Exclude}}); - } - - # remove empty header lins - $reply->head->cleanup; - - $reply; -} - -sub add_signature -{ - my $me = shift; - carp "add_signature depriciated, use ->sign" if $^W; - $me->sign(File => shift || "$ENV{HOME}/.signature"); -} -sub sign -{ - my $me = shift; - my %arg = @_; - my $sig; - my @sig; + my $indent = $arg{Indent} || ">"; + if($indent =~ /\%/) + { my %hash = ( '%' => '%'); + my @name = $name ? grep( {length $_} split /[\n\s]+/, $name) : ''; - if($sig = delete $arg{File}) - { - local *SIG; + $hash{f} = $name[0]; + $hash{F} = $#name ? substr($hash{f},0,1) : $hash{f}; - if(open(SIG,$sig)) - { - local $_; - while(<SIG>) { last unless /\A(--)?\s*\Z/; } + $hash{l} = $#name ? $name[$#name] : ""; + $hash{L} = substr($hash{l},0,1) || ""; - @sig = ($_,<SIG>,"\n"); + $hash{n} = $name || ""; + $hash{I} = join "", map {substr($_,0,1)} @name; - close(SIG); + $indent =~ s/\%(.)/defined $hash{$1} ? $hash{$1} : $1/eg; } - } - elsif($sig = delete $arg{Signature}) - { - @sig = ref($sig) ? @$sig : split(/\n/, $sig); - } - - if(@sig) - { - $me->remove_sig; - map(s/\n?\Z/\n/,@sig); - push(@{$me->body}, "-- \n",@sig); - } -} - -sub _prephdr { - - use Mail::Util; - - my $hdr = shift; - - $hdr->delete('From '); # Just in case :-) - # An original message should not have any Received lines + my $id = $sender->address; + $reply->replace(To => $id); + + # Find addresses not to include + my $mailaddresses = $ENV{MAILADDRESSES} || ""; + + my %nocc = (lc($id) => 1); + $nocc{lc $_->address} = 1 + for Mail::Address->parse($reply->get('Bcc'), $mailaddresses); + + if($arg{ReplyAll}) # Who shall we copy this to + { my %cc; + foreach my $addr (Mail::Address->parse($self->get('To'), $self->get('Cc'))) + { my $lc = lc $addr->address; + $cc{$lc} = $addr->format + unless $nocc{$lc}; + } + my $cc = join ', ', values %cc; + $reply->replace(Cc => $cc); + } - $hdr->delete('Received'); + # References + my $refs = $self->get('References') || ""; + my $mid = $self->get('Message-Id'); - $hdr->replace('X-Mailer', "Perl5 Mail::Internet v".$Mail::Internet::VERSION) - unless $hdr->count('X-Mailer'); + $refs .= " " . $mid if defined $mid; + $reply->replace(References => $refs); - my $name = eval {local $SIG{__DIE__}; (getpwuid($>))[6]} || $ENV{NAME} ||""; + # In-Reply-To + my $date = $self->get('Date'); + my $inreply = ""; - while($name =~ s/\([^\(\)]*\)//) { 1; } + if(defined $mid) + { $inreply = $mid; + my @comment; + push @comment, "from $name" if defined $name; + push @comment, "on $date" if defined $date; + local $" = ' '; + $inreply .= " (@comment)" if @comment; + } + elsif(defined $name) + { $inreply = $name . "'s message"; + $inreply .= "of " . $date if defined $date; + } + $reply->replace('In-Reply-To' => $inreply); + + # Quote the body + my $body = $reply->body; + @$body = @{$self->body}; # copy body + $reply->remove_sig; + $reply->tidy_body; + s/\A/$indent/ for @$body; + + # Add references + unshift @{$body}, (defined $name ? $name . " " : "") . "<$id> writes:\n"; + + if(defined $arg{Keep} && ref $arg{Keep} eq 'ARRAY') # Include lines + { foreach my $keep (@{$arg{Keep}}) + { my $ln = $self->get($keep); + $reply->replace($keep => $ln) if defined $ln; + } + } - if($name =~ /[^\w\s]/) { - $name =~ s/"/\"/g; - $name = '"' . $name . '"'; + if(defined $arg{Exclude} && ref $arg{Exclude} eq 'ARRAY') # Exclude lines + { $reply->delete(@{$arg{Exclude}}); } - my $from = sprintf "%s <%s>", $name, Mail::Util::mailaddress(); - $from =~ s/\s{2,}/ /g; + $reply->head->cleanup; # remove empty header lines + $reply; +} - my $tag; - foreach $tag (qw(From Sender)) { # Sender is deprecated - $hdr->add($tag,$from) - unless($hdr->get($tag)); - } -} +sub smtpsend($@) +{ my ($self, %opt) = @_; -sub smtpsend; + require Net::SMTP; + require Net::Domain; -use Carp; -use Mail::Util qw(mailaddress); -use Mail::Address; -use Net::Domain qw(hostname); -use Net::SMTP; -use strict; + my $host = $opt{Host}; + my $envelope = $opt{MailFrom} || mailaddress(); + my $quit = 1; + + my ($smtp, @hello); - sub smtpsend -{ - my $src = shift; - my %opt = @_; - my $host = $opt{Host}; - my $noquit = 0; - my $smtp; - my @hello = defined $opt{Hello} ? (Hello => $opt{Hello}) : (); + push @hello, Hello => $opt{Hello} + if defined $opt{Hello}; - push(@hello, 'Port', $opt{'Port'}) - if exists $opt{'Port'}; + push @hello, Port => $opt{Port} + if exists $opt{Port}; - push(@hello, 'Debug', $opt{'Debug'}) - if exists $opt{'Debug'}; + push @hello, Debug => $opt{Debug} + if exists $opt{Debug}; - unless(defined($host)) { - local $SIG{__DIE__}; + if(!defined $host) + { local $SIG{__DIE__}; my @hosts = qw(mailhost localhost); - unshift(@hosts, split(/:/, $ENV{SMTPHOSTS})) if(defined $ENV{SMTPHOSTS}); + unshift @hosts, split /\:/, $ENV{SMTPHOSTS} + if defined $ENV{SMTPHOSTS}; - foreach $host (@hosts) { - $smtp = eval { Net::SMTP->new($host, @hello) }; - last if(defined $smtp); + foreach $host (@hosts) + { $smtp = eval { Net::SMTP->new($host, @hello) }; + last if defined $smtp; } } - elsif(ref($host) && UNIVERSAL::isa($host,'Net::SMTP')) { - $smtp = $host; - $noquit = 1; + elsif(UNIVERSAL::isa($host,'Net::SMTP') + || UNIVERSAL::isa($host,'Net::SMTP::SSL')) + { $smtp = $host; + $quit = 0; } - else { - local $SIG{__DIE__}; + else + { local $SIG{__DIE__}; $smtp = eval { Net::SMTP->new($host, @hello) }; } - return () - unless(defined $smtp); - - my $hdr = $src->head->dup; + defined $smtp or return (); - _prephdr($hdr); + my $head = $self->cleaned_header_dup; # Who is it to - my @rcpt = map { ref($_) ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'}; - @rcpt = map { $hdr->get($_) } qw(To Cc Bcc) + my @rcpt = map { ref $_ ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'}; + @rcpt = map { $head->get($_) } qw(To Cc Bcc) unless @rcpt; - my @addr = map($_->address, Mail::Address->parse(@rcpt)); - return () - unless(@addr); + my @addr = map {$_->address} Mail::Address->parse(@rcpt); + @addr or return (); - $hdr->delete('Bcc'); # Remove blind Cc's + $head->delete('Bcc'); # Send it - my $ok = $smtp->mail( mailaddress() ) && - $smtp->to(@addr) && - $smtp->data(join("", @{$hdr->header},"\n",@{$src->body})); - - $smtp->quit - unless $noquit; + my $ok = $smtp->mail($envelope) + && $smtp->to(@addr) + && $smtp->data(join("", @{$head->header}, "\n", @{$self->body})); + $quit && $smtp->quit; $ok ? @addr : (); } -sub send; - -use Mail::Mailer; -use strict; - - sub send -{ - my ($src, $type, @args) = @_; - - my $hdr = $src->head->dup; - _prephdr($hdr); +sub send($@) +{ my ($self, $type, @args) = @_; - my $headers = $hdr->header_hashref; + require Mail::Mailer; - # Actually send it + my $head = $self->cleaned_header_dup; my $mailer = Mail::Mailer->new($type, @args); - $mailer->open($headers); - $src->print_body($mailer); - $mailer->close(); -} -sub nntppost; - -use Mail::Util qw(mailaddress); -use Net::NNTP; -use strict; + $mailer->open($head->header_hashref); + $self->print_body($mailer); + $mailer->close; +} - sub nntppost -{ - my $mail = shift; - my %opt = @_; - my $groups = $mail->get('Newsgroups') || ""; - my @groups = split(/[\s,]+/,$groups); +sub nntppost +{ my ($self, %opt) = @_; - return () - unless @groups; + require Net::NNTP; - my $hdr = $mail->head->dup; + my $groups = $self->get('Newsgroups') || ""; + my @groups = split /[\s,]+/, $groups; + @groups or return (); - _prephdr($hdr); + my $head = $self->cleaned_header_dup; # Remove these incase the NNTP host decides to mail as well as me - $hdr->delete(qw(To Cc Bcc)); + $head->delete(qw(To Cc Bcc)); my $news; - my $noquit = 0; - my $host = $opt{Host}; + my $quit = 1; - if(ref($host) && UNIVERSAL::isa($host,'Net::NNTP')) { - $news = $host; - $noquit = 1; + my $host = $opt{Host}; + if(ref($host) && UNIVERSAL::isa($host,'Net::NNTP')) + { $news = $host; + $quit = 0; } - else { - my @opt = (); + else + { my @opt = $opt{Host}; - push(@opt, $opt{'Host'}); + push @opt, Port => $opt{Port} + if exists $opt{Port}; - push(@opt, 'Port', $opt{'Port'}) - if exists $opt{'Port'}; + push @opt, Debug => $opt{Debug} + if exists $opt{Debug}; - push(@opt, 'Debug', $opt{'Debug'}) - if exists $opt{'Debug'}; - - $news = new Net::NNTP(@opt) + $news = Net::NNTP->new(@opt) or return (); } - $news->post(@{$hdr->header},"\n",@{$mail->body}); - - my $code = $news->code; + $news->post(@{$head->header}, "\n", @{$self->body}); + my $rc = $news->code; - $news->quit - unless $noquit; + $news->quit if $quit; - return 240 == $code ? @groups : (); + $rc == 240 ? @groups : (); } -sub escape_from -{ - my $me = shift; - my $body = $me->body; - local $_; - - scalar grep { s/\A(>*From) />$1 /o } @$body; +sub escape_from +{ my $body = shift->body; + scalar grep { s/\A(>*From) />$1 /o } @$body; } -sub unescape_from -{ - my $me = shift; - my $body = $me->body; - local $_; - scalar grep { s/\A>(>*From) /$1 /o } @$body; +sub unescape_from +{ my $body = shift->body; + scalar grep { s/\A>(>*From) /$1 /o } @$body; } -1; # keep require happy - +# Don't tell people it exists +sub cleaned_header_dup() +{ my $head = shift->head->dup; + $head->delete('From '); # Just in case :-) -=head1 NAME - -Mail::Internet - manipulate Internet format (RFC 822) mail messages - -=head1 SYNOPSIS - - use Mail::Internet; - -=head1 DESCRIPTION - -This package provides a class object which can be used for reading, creating, -manipulating and writing a message with RFC822 compliant headers. - -If you start writing a new application, you may want to use the -L<Mail::Box> set of packages (requires perl 5.6.1), which has more -features. See http://perl.overmeer.net/mailbox. - -=head1 CONSTRUCTOR - -=over 4 - -=item new ( [ ARG ], [ OPTIONS ] ) - -C<ARG> is optiona and 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 and body 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<Header> - -The value of this option should be a C<Mail::Header> object. If given then -C<Mail::Internet> will not attempt to read a mail header from C<ARG>, if -it was specified. - -=item B<Body> - -The value of this option should be a reference to an array which contains -the lines for the body of the message. Each line should be terminated with -C<\n> (LF). If Body is given then C<Mail::Internet> will not attempt to -read the body from C<ARG> (even if it is specified). - -=back - -The Mail::Header options C<Modify>, C<MailFrom> and C<FoldLength> may -also be given. - -=back - -=head1 METHODS - -=over 4 - -=item body ( [ BODY ] ) - -Returns the body of the message. This is a reference to an array. -Each entry in the array represents a single line in the message. - -If I<BODY> is given, it can be a referenc to an aray or an array, then -the body will be replaced. If a reference is passed, it is used directly -and not copied, so any sunsequent changes to the array will change the -contents of the body. - -=item print_header ( [ FILEHANDLE ] ) - -=item print_body ( [ FILEHANDLE ] ) - -=item print ( [ FILEHANDLE ] ) - -Print the header, body or whole message to file descriptor I<FILEHANDLE>. -I<$fd> should be a reference to a GLOB. If I<FILEHANDLE> is not given the -output will be sent to STDOUT. - - $mail->print( \*STDOUT ); # Print message to STDOUT - -=item as_string () - -Returns the message as a single string. - -=item as_mbox_string ( [ ALREADY_ESCAPED ] ) - -Returns the message as a string in mbox format. C<ALREADY_ESCAPED>, if -given and true, indicates that ->escape_from has already been called on -this object. - -=item head () - -Returns the C<Mail::Header> object which holds the headers for the current -message - -=back - -=head1 UTILITY METHODS - -The following methods are more a utility type than a manipulation -type of method. - -=over 4 - -=item remove_sig ( [ NLINES ] ) - -Attempts to remove a users signature from the body of a message. It does this -by looking for a line equal to C<'-- '> within the last C<NLINES> of the -message. If found then that line and all lines after it will be removed. If -C<NLINES> is not given a default value of 10 will be used. This would be of -most use in auto-reply scripts. - -=item tidy_body () - -Removes all leading and trailing lines from the body that only contain -white spaces. - -=item reply () - -Create a new object with header initialised for a reply to the current -object. And the body will be a copy of the current message indented. - -=item add_signature ( [ FILE ] ) - -Append a signature to the message. C<FILE> is a file which contains -the signature, if not given then the file "$ENV{HOME}/.signature" -will be checked for. - -=item send ( [ type [ args.. ]] ) - -Send a Mail::Internet message using Mail::Mailer. Type and args are -passed on to C<Mail::Mailer> - -=item smtpsend ( [ OPTIONS ] ) - -Send a Mail::Internet message via SMTP, requires Net::SMTP - -The return value will be a list of email addresses that the message was sent -to. If the message was not sent the list will be empty. - -Options are passed as key-value pairs. Current options are - -=over 4 - -=item Host - -Name of the SMTP server to connect to, or a Net::SMTP object to use - -If C<Host> is not given then the SMTP host is found by attempting -connections first to hosts specified in C<$ENV{SMTPHOSTS}>, a colon -separated list, then C<mailhost> and C<localhost>. - -=item To - -=item Cc - -=item Bcc - -Send the email to the given addresses, each can be either a string or -a reference to a list of email addresses. If none of C<To>, <Cc> or C<Bcc> -are given then the addresses are extracted from the message being sent. - -=item Hello - -Send a HELO (or EHLO) command to the server with the given name. - -=item Port - -Port number to connect to on remote host - -=item Debug - -Debug value to pass to Net::SMPT, see <Net::SMTP> - -=back - -=item nntppost ( [ OPTIONS ] ) - -Post an article via NNTP, requires Net::NNTP. - -Options are passed as key-value pairs. Current options are - -=over 4 - -=item Host - -Name of NNTP server to connect to, or a Net::NNTP object to use. - -=item Port - -Port number to connect to on remote host - -=item Debug - -Debug value to pass to Net::NNTP, see <Net::NNTP> - -=back - -=item escape_from () - -It can cause problems with some applications if a message contains a line -starting with C<`From '>, in particular when attempting to split a folder. -This method inserts a leading C<`>'> on anyline that matches the regular -expression C</^>*From/> - -=item unescape_from () - -This method will remove the escaping added by escape_from - -=back - -=head1 SEE ALSO + # An original message should not have any Received lines + $head->delete('Received'); -L<Mail::Header> -L<Mail::Address> + $head->replace('X-Mailer', "Perl5 Mail::Internet v".$Mail::Internet::VERSION) + unless $head->count('X-Mailer'); -=head1 AUTHOR + my $name = eval {local $SIG{__DIE__}; (getpwuid($>))[6]} || $ENV{NAME} ||""; -Graham Barr. Maintained by Mark Overmeer <mailtools@overmeer.net> + while($name =~ s/\([^\(\)]*\)//) { 1; } -=head1 COPYRIGHT + if($name =~ /[^\w\s]/) + { $name =~ s/"/\"/g; + $name = '"' . $name . '"'; + } -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. + my $from = sprintf "%s <%s>", $name, mailaddress(); + $from =~ s/\s{2,}/ /g; -=cut + foreach my $tag (qw(From Sender)) + { $head->get($tag) or $head->add($tag, $from); + } + $head; +} +1; diff --git a/cpan/lib/Mail/Internet.pod b/cpan/lib/Mail/Internet.pod new file mode 100644 index 00000000..a6c42b7f --- /dev/null +++ b/cpan/lib/Mail/Internet.pod @@ -0,0 +1,387 @@ +=encoding utf8 + +=head1 NAME + +Mail::Internet - manipulate email messages + +=head1 SYNOPSIS + + use Mail::Internet; + my $msg = Mail::Internet->new(\*STDIN); + +=head1 DESCRIPTION + +This package implements reading, creating, manipulating, and writing email +messages. Sometimes, the implementation tries to be too smart, but in +the general case it works as expected. + +If you start writing a B<new application>, you should use the L<Mail::Box> +distribution, which has more features and handles messages much better +according to the RFCs. See L<http://perl.overmeer.net/mailbox/>. +You may also chose L<MIME::Entity>, to get at least some multipart +support in your application. + +=head1 METHODS + +=head2 Constructors + +=over 4 + +=item $obj-E<gt>B<dup>() + +Duplicate the message as a whole. Both header and body will be +deep-copied: a new L<Mail::Internet|Mail::Internet> object is returned. + +=item $obj-E<gt>B<extract>(ARRAY-of-LINES) + +Extract header and body from an ARRAY of message lines. Requires an +object already created with L<new()|Mail::Internet/"Constructors">, which contents will get overwritten. + +=item $obj-E<gt>B<new>( [ARG], [OPTIONS] ) + +=item Mail::Internet-E<gt>B<new>( [ARG], [OPTIONS] ) + +ARG is optional and 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 and body either from the array of read from +the file descriptor. + +The L<Mail::Header::new()|Mail::Header/"Constructors"> OPTIONS C<Modify>, C<MailFrom> and C<FoldLength> +may also be given. + + -Option--Default + Body [] + Header undef + +=over 2 + +=item Body => ARRAY-of-LINES + +The value of this option should be a reference to an array which contains +the lines for the body of the message. Each line should be terminated with +C<\n> (LF). If Body is given then C<Mail::Internet> will not attempt to +read the body from C<ARG> (even if it is specified). + +=item Header => Mail::Header + +The value of this option should be a L<Mail::Header|Mail::Header> object. If given then +C<Mail::Internet> will not attempt to read a mail header from C<ARG>, if +it was specified. + +=back + +=item $obj-E<gt>B<read>(FILEHANDLE) + +Read a message from the FILEHANDLE into an already existing message +object. Better use L<new()|Mail::Internet/"Constructors"> with the FILEHANDLE as first argument. + +=back + +=head2 Accessors + +=over 4 + +=item $obj-E<gt>B<body>( [BODY] ) + +Returns the body of the message. This is a reference to an array. +Each entry in the array represents a single line in the message. + +If I<BODY> is given, it can be a reference to an array or an array, then +the body will be replaced. If a reference is passed, it is used directly +and not copied, so any subsequent changes to the array will change the +contents of the body. + +=item $obj-E<gt>B<head>() + +Returns the C<Mail::Header> object which holds the headers for the current +message + +=back + +=head2 Processing the message as a whole + +=over 4 + +=item $obj-E<gt>B<as_mbox_string>( [ALREADY_ESCAPED] ) + +Returns the message as a string in mbox format. C<ALREADY_ESCAPED>, if +given and true, indicates that L<escape_from()|Mail::Internet/"High-level functionality"> has already been called on +this object. + +=item $obj-E<gt>B<as_string>() + +Returns the message as a single string. + +=item $obj-E<gt>B<print>( [FILEHANDLE] ) + +Print the header, body or whole message to file descriptor I<FILEHANDLE>. +I<$fd> should be a reference to a GLOB. If I<FILEHANDLE> is not given the +output will be sent to STDOUT. + +example: + + $mail->print( \*STDOUT ); # Print message to STDOUT + +=item $obj-E<gt>B<print_body>( [FILEHANDLE] ) + +Print only the body to the FILEHANDLE (default STDOUT). + +=item $obj-E<gt>B<print_header>( [FILEHANDLE] ) + +Print only the header to the FILEHANDLE (default STDOUT). + +=back + +=head2 Processing the header + +Most of these methods are simply wrappers around methods provided +by L<Mail::Header|Mail::Header>. + +=over 4 + +=item $obj-E<gt>B<add>(PAIRS-of-FIELD) + +The PAIRS are field-name and field-content. For each PAIR, +L<Mail::Header::add()|Mail::Header/"Processing"> is called. All fields are added after +existing fields. The last addition is returned. + +=item $obj-E<gt>B<combine>( TAG, [WITH] ) + +See L<Mail::Header::combine()|Mail::Header/"Processing">. + +=item $obj-E<gt>B<delete>( TAG, [TAGs] ) + +Delete all fields with the name TAG. L<Mail::Header::delete()|Mail::Header/"Processing"> is doing the +work. + +=item $obj-E<gt>B<fold>( [LENGTH] ) + +See L<Mail::Header::fold()|Mail::Header/"Processing">. + +=item $obj-E<gt>B<fold_length>( [TAG], [LENGTH] ) + +See L<Mail::Header::fold_length()|Mail::Header/"Accessors">. + +=item $obj-E<gt>B<get>( TAG, [TAGs] ) + +In LIST context, all fields with the name TAG are returned. In SCALAR +context, only the first field which matches the earliest TAG is returned. +L<Mail::Header::get()|Mail::Header/"Processing"> is called to collect the data. + +=item $obj-E<gt>B<header>( [ARRAY-of-LINES] ) + +See L<Mail::Header::header()|Mail::Header/""Fake" constructors">. + +=item $obj-E<gt>B<replace>(PAIRS-of-FIELD) + +The PAIRS are field-name and field-content. For each PAIR, +L<Mail::Header::replace()|Mail::Header/"Processing"> is called with INDEX 0. If a FIELD is already +in the header, it will be removed first. Do not specified the same +field-name twice. + +=back + +=head2 Processing the body + +=over 4 + +=item $obj-E<gt>B<remove_sig>( [NLINES] ) + +Attempts to remove a users signature from the body of a message. It does this +by looking for a line equal to C<'-- '> within the last C<NLINES> of the +message. If found then that line and all lines after it will be removed. If +C<NLINES> is not given a default value of 10 will be used. This would be of +most use in auto-reply scripts. + +=item $obj-E<gt>B<sign>(OPTIONS) + +Add your signature to the body. L<remove_sig()|Mail::Internet/"Processing the body"> will strip existing +signatures first. + + -Option --Default + File undef + Signature [] + +=over 2 + +=item File => FILEHANDLE + +Take from the FILEHANDLE all lines starting from the first C<< -- >>. + +=item Signature => STRING|ARRAY-of-LINES + +=back + +=item $obj-E<gt>B<tidy_body>() + +Removes all leading and trailing lines from the body that only contain +white spaces. + +=back + +=head2 High-level functionality + +=over 4 + +=item $obj-E<gt>B<escape_from>() + +It can cause problems with some applications if a message contains a line +starting with C<`From '>, in particular when attempting to split a folder. +This method inserts a leading C<`>'> on any line that matches the regular +expression C</^>*From/> + +=item $obj-E<gt>B<nntppost>( [OPTIONS] ) + +Post an article via NNTP. Requires Net::NNTP to be installed. + + -Option--Default + Debug <false> + Host <required> + Port 119 + +=over 2 + +=item Debug => BOOLEAN + +Debug value to pass to Net::NNTP, see L<Net::NNTP> + +=item Host => HOSTNAME|Net::NNTP object + +Name of NNTP server to connect to, or a Net::NNTP object to use. + +=item Port => INTEGER + +Port number to connect to on remote host + +=back + +=item $obj-E<gt>B<reply>(OPTIONS) + +Create a new object with header initialised for a reply to the current +object. And the body will be a copy of the current message indented. + +The C<.mailhdr> file in your home directory (if exists) will be read +first, to provide defaults. + + -Option --Default + Exclude [] + Indent '>' + Keep [] + ReplyAll false + +=over 2 + +=item Exclude => ARRAY-of-FIELDS + +Remove the listed FIELDS from the produced message. + +=item Indent => STRING + +Use as indentation string. The string may contain C<%%> to get a single C<%>, +C<%f> to get the first from name, C<%F> is the first character of C<%f>, +C<%l> is the last name, C<%L> its first character, C<%n> the whole from +string, and C<%I> the first character of each of the names in the from string. + +=item Keep => ARRAY-of-FIELDS + +Copy the listed FIELDS from the original message. + +=item ReplyAll => BOOLEAN + +Automatically include all To and Cc addresses of the original mail, +excluding those mentioned in the Bcc list. + +=back + +=item $obj-E<gt>B<send>( [TYPE, [ARGS...]] ) + +Send a Mail::Internet message using L<Mail::Mailer|Mail::Mailer>. TYPE and ARGS are +passed on to L<Mail::Mailer::new()|Mail::Mailer/"Constructors">. + +=item $obj-E<gt>B<smtpsend>( [OPTIONS] ) + +Send a Mail::Internet message using direct SMTP. to the given +ADDRESSES, each can be either a string or a reference to a list of email +addresses. If none of C<To>, <Cc> or C<Bcc> are given then the addresses +are extracted from the message being sent. + +The return value will be a list of email addresses that the message was sent +to. If the message was not sent the list will be empty. + +Requires Net::SMTP and Net::Domain to be installed. + + -Option --Default + Bcc undef + Cc undef + Debug <false> + Hello localhost.localdomain + Host $ENV{SMTPHOSTS} + MailFrom Mail::Util::mailaddress() + Port 25 + To undef + +=over 2 + +=item Bcc => ADDRESSES + +=item Cc => ADDRESSES + +=item Debug => BOOLEAN + +Debug value to pass to Net::SMPT, see <Net::SMTP> + +=item Hello => STRING + +Send a HELO (or EHLO) command to the server with the given name. + +=item Host => HOSTNAME + +Name of the SMTP server to connect to, or a Net::SMTP object to use + +If C<Host> is not given then the SMTP host is found by attempting +connections first to hosts specified in C<$ENV{SMTPHOSTS}>, a colon +separated list, then C<mailhost> and C<localhost>. + +=item MailFrom => ADDRESS + +The e-mail address which is used as sender. By default, +L<Mail::Util::mailaddress()|Mail::Util/"FUNCTIONS"> provides the address of the sender. + +=item Port => INTEGER + +Port number to connect to on remote host + +=item To => ADDRESSES + +=back + +=item $obj-E<gt>B<unescape_from>(()) + +Remove the escaping added by L<escape_from()|Mail::Internet/"High-level functionality">. + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + diff --git a/cpan/lib/Mail/Mailer.pm b/cpan/lib/Mail/Mailer.pm index bda244e2..7fc90d45 100644 --- a/cpan/lib/Mail/Mailer.pm +++ b/cpan/lib/Mail/Mailer.pm @@ -1,329 +1,217 @@ -# - +# 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::Mailer; +use vars '$VERSION'; +$VERSION = '2.19'; -=head1 NAME - -Mail::Mailer - Simple interface to electronic mailing mechanisms - -=head1 SYNOPSIS - - use Mail::Mailer; - use Mail::Mailer qw(mail); - - $mailer = new Mail::Mailer; - - $mailer = new Mail::Mailer $type, @args; - - $mailer->open(\%headers); - - print $mailer $body; - - $mailer->close; - - -=head1 DESCRIPTION - -Sends mail using any of the built-in methods. You can alter the -behaviour of a method by passing C<$command> to the C<new> method. - -=over 4 - -=item C<sendmail> - -Use the C<sendmail> program to deliver the mail. C<$command> is the -path to C<sendmail>. - -=item C<smtp> - -Use the C<smtp> protocol via Net::SMTP to deliver the mail. The server -to use can be specified in C<@args> with - - $mailer = new Mail::Mailer 'smtp', Server => $server; - -The smtp mailer does not handle C<Cc> and C<Bcc> lines, neither their -C<Resent-*> fellows. The C<Debug> options enables debugging output -from C<Net::SMTP>. - -=item C<qmail> - -Use qmail's qmail-inject program to deliver the mail. - -=item C<test> - -Used for debugging, this displays the data on STDOUT. No mail is ever -sent. C<$command> is ignored. - -=back - -C<Mail::Mailer> will search for executables in the above order. The -default mailer will be the first one found. - -=head2 ARGUMENTS - -C<new> can optionally be given a C<$command> and C<$type>. C<$type> -is one C<sendmail>, C<mail>, ... given above. The meaning of -C<$command> depends on C<$type>. - -C<open> is given a reference to a hash. The hash consists of key and -value pairs, the key being the name of the header field (eg, C<To>), -and the value being the corresponding contents of the header field. -The value can either be a scalar (eg, C<gnat@frii.com>) or a reference -to an array of scalars (C<eg, ['gnat@frii.com', 'Tim.Bunce@ig.co.uk']>). - -=head1 TO DO - -Assist formatting of fields in ...::rfc822:send_headers to ensure -valid in the face of newlines and longlines etc. - -Secure all forms of send_headers() against hacker attack and invalid -contents. Especially "\n~..." in ...::mail::send_headers. - -=head1 ENVIRONMENT VARIABLES - -=over 4 - -=item PERL_MAILERS - -Augments/override the build in choice for binary used to send out -our mail messages. - -Format: - - "type1:mailbinary1;mailbinary2;...:type2:mailbinaryX;...:..." +use base 'IO::Handle'; -Example: assume you want you use private sendmail binary instead -of mailx, one could set C<PERL_MAILERS> to: - - "mail:/does/not/exists:sendmail:$HOME/test/bin/sendmail" - -On systems which may include C<:> in file names, use C<|> as separator -between type-groups. - - "mail:c:/does/not/exists|sendmail:$HOME/test/bin/sendmail" - - -=back - -=head1 SEE ALSO - -Mail::Send - -=head1 AUTHORS - -Maintained by Mark Overmeer <mailtools@overmeer.net> - -Original code written by Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>, -with a kick start from Graham Barr E<lt>F<gbarr@pobox.com>E<gt>. With -contributions by Gerard Hickey E<lt>F<hickey@ctron.com>E<gt> Small fix -and documentation by Nathan Torkington E<lt>F<gnat@frii.com>E<gt>. - -=cut +use strict; +use POSIX qw/_exit/; use Carp; -use IO::Handle; -use vars qw(@ISA $VERSION $MailerBinary $MailerType %Mailers @Mailers); use Config; -use strict; -$VERSION = "1.52"; +#-------------- -sub Version { $VERSION } -@ISA = qw(IO::Handle); +sub is_exe($); -# Suggested binaries for types? Should this be handled in the object class? -@Mailers = ( +sub Version { our $VERSION } - # Headers-blank-Body all on stdin - 'sendmail' => '/usr/lib/sendmail;/usr/sbin/sendmail;/usr/ucblib/sendmail', +our @Mailers = + ( sendmail => '/usr/lib/sendmail;/usr/sbin/sendmail;/usr/ucblib/sendmail' + , smtp => undef + , smtps => undef + , qmail => '/usr/sbin/qmail-inject;/var/qmail/bin/qmail-inject' + , testfile => undef + ); - 'smtp' => undef, - 'qmail' => '/usr/sbin/qmail-inject;/var/qmail/bin/qmail-inject', - 'test' => undef -); +push @Mailers, map { split /\:/, $_, 2 } + split /$Config{path_sep}/, $ENV{PERL_MAILERS} + if $ENV{PERL_MAILERS}; -if($ENV{PERL_MAILERS}) -{ push @Mailers - , map { split /\:/, $_, 2} - split /$Config{path_sep}/, $ENV{PERL_MAILERS}; -} +our %Mailers = @Mailers; +our $MailerType; +our $MailerBinary; -%Mailers = @Mailers; +# does this really need to be done? or should a default mailer be specified? -$MailerBinary = undef; +$Mailers{sendmail} = 'sendmail' + if $^O eq 'os2' && ! is_exe $Mailers{sendmail}; -# does this really need to be done? or should a default mailer be specfied? - -if($^O eq 'os2') { - $Mailers{sendmail} = 'sendmail' unless is_exe($Mailers{sendmail}); -} - -if($^O eq 'MacOS' || $^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'os2') { - $MailerType = 'smtp'; +if($^O =~ m/MacOS|VMS|MSWin|os2|NetWare/i ) +{ $MailerType = 'smtp'; $MailerBinary = $Mailers{$MailerType}; } -else { - my $i; - for($i = 0 ; $i < @Mailers ; $i += 2) { - $MailerType = $Mailers[$i]; - my $binary; - if($binary = is_exe($Mailers{$MailerType})) { - $MailerBinary = $binary; - last; - } +else +{ for(my $i = 0 ; $i < @Mailers ; $i += 2) + { $MailerType = $Mailers[$i]; + if(my $binary = is_exe $Mailers{$MailerType}) + { $MailerBinary = $binary; + last; + } } } -sub import { - shift; +sub import +{ shift; # class + @_ or return; - if(@_) { - my $type = shift; - my $exe = shift || $Mailers{$type}; + my $type = shift; + my $exe = shift || $Mailers{$type}; - carp "Cannot locate '$exe'" - unless is_exe($exe); + is_exe $exe + or carp "Cannot locate '$exe'"; - $MailerType = $type; - $Mailers{$MailerType} = $exe; - } + $MailerType = $type; + $Mailers{$MailerType} = $exe; } -sub to_array { - my($self, $thing) = @_; - if (ref($thing)) { - return @$thing; - } else { - return ($thing); - } +sub to_array($) +{ my ($self, $thing) = @_; + ref $thing ? @$thing : $thing; } -sub is_exe { - my $exe = shift || ''; - my $cmd; +sub is_exe($) +{ my $exe = shift || ''; - foreach $cmd (split /\;/, $exe) { - $cmd =~ s/^\s+//; + foreach my $cmd (split /\;/, $exe) + { $cmd =~ s/^\s+//; - # remove any options - my $name = ($cmd =~ /^(\S+)/)[0]; + # remove any options + my $name = ($cmd =~ /^(\S+)/)[0]; - # check for absolute or relative path - return ($cmd) - if (-x $name and ! -d $name and $name =~ m:[\\/]:); + # check for absolute or relative path + return $cmd + if -x $name && ! -d $name && $name =~ m![\\/]!; - if (defined $ENV{PATH}) { - my $dir; - foreach $dir (split(/$Config{path_sep}/, $ENV{PATH})) { - return "$dir/$cmd" - if (-x "$dir/$name" && ! -d "$dir/$name"); - } - } + if(defined $ENV{PATH}) + { foreach my $dir (split /$Config{path_sep}/, $ENV{PATH}) + { return "$dir/$cmd" + if -x "$dir/$name" && ! -d "$dir/$name"; + } + } } 0; } -sub new { - my($class, $type, @args) = @_; - $type = $MailerType unless $type; - croak "Mailer '$type' not known, please specify correct type" - unless $type; +sub new($@) +{ my ($class, $type, @args) = @_; + + unless($type) + { $MailerType or croak "No MailerType specified"; + + warn "No real MTA found, using '$MailerType'" + if $MailerType eq 'testfile'; + + $type = $MailerType; + } my $exe = $Mailers{$type}; - if(defined($exe)) { - $exe = is_exe ($exe) if defined $type; + if(defined $exe) + { $exe = is_exe $exe + if defined $type; - $exe = $MailerBinary unless $exe; - croak "No mailer type specified (and no default available), thus can not find executable program." - unless $exe; + $exe ||= $MailerBinary + or croak "No mailer type specified (and no default available), thus can not find executable program."; } $class = "Mail::Mailer::$type"; eval "require $class" or die $@; - my $glob = $class->SUPER::new; # local($glob) = gensym; # Make glob for FileHandle and attributes - %{*$glob} = (Exe => $exe, - Args => [ @args ] - ); - - $glob; # bless $glob, $class; + my $glob = $class->SUPER::new; # object is a GLOB! + %{*$glob} = (Exe => $exe, Args => [ @args ]); + $glob; } -sub open { - my($self, $hdrs) = @_; - my $exe = *$self->{Exe}; # || Carp::croak "$self->open: bad exe"; - my $args = *$self->{Args}; - _cleanup_hdrs($hdrs); - my @to = $self->who_to($hdrs); +sub open($) +{ my ($self, $hdrs) = @_; + my $exe = *$self->{Exe}; # no exe, then direct smtp + my $args = *$self->{Args}; + + my @to = $self->who_to($hdrs); + my $sender = $self->who_sender($hdrs); $self->close; # just in case; - # Fork and start a mailer - (defined($exe) && open($self,"|-")) - || $self->exec($exe, $args, \@to) - || die $!; + if(defined $exe) + { # Fork and start a mailer + my $child = open $self, '|-'; + defined $child or die "Failed to send: $!"; + + if($child==0) + { # Child process will handle sending, but this is not real exec() + # this is a setup!!! + unless($self->exec($exe, $args, \@to, $sender)) + { warn $!; # setup failed + _exit(1); # no DESTROY(), keep it for parent + } + } + } + else + { # Sending is handled by a subclass + $self->exec(undef, $args, \@to) + or die $!; + } - # Set the headers $self->set_headers($hdrs); - - # return self (a FileHandle) ready to accept the body $self; } - -sub _cleanup_hdrs { - my $hdrs = shift; - my $h; - foreach $h (values %$hdrs) { - foreach (ref($h) ? @{$h} : $h) { - s/\n\s*/ /g; - s/\s+$//; +sub _cleanup_hdrs($) +{ foreach my $h (values %{(shift)}) + { foreach (ref $h ? @$h : $h) + { s/\n\s*/ /g; + s/\s+$//; + } } - } } +sub exec($$$$) +{ my($self, $exe, $args, $to, $sender) = @_; -sub exec { - my($self, $exe, $args, $to) = @_; # Fork and exec the mailer (no shell involved to avoid risks) - my @exe = split(/\s+/,$exe); - - exec(@exe, @$args, @$to); + my @exe = split /\s+/, $exe; + exec @exe, @$args, @$to; } sub can_cc { 1 } # overridden in subclass for mailer that can't -sub who_to { - my($self, $hdrs) = @_; +sub who_to($) +{ my($self, $hdrs) = @_; my @to = $self->to_array($hdrs->{To}); - if (!$self->can_cc) { # Can't cc/bcc so add them to @to - push(@to, $self->to_array($hdrs->{Cc})) if $hdrs->{Cc}; - push(@to, $self->to_array($hdrs->{Bcc})) if $hdrs->{Bcc}; + unless($self->can_cc) # Can't cc/bcc so add them to @to + { push @to, $self->to_array($hdrs->{Cc} ) if $hdrs->{Cc}; + push @to, $self->to_array($hdrs->{Bcc}) if $hdrs->{Bcc}; } @to; } +sub who_sender($) +{ my ($self, $hdrs) = @_; + ($self->to_array($hdrs->{Sender} || $hdrs->{From}))[0]; +} + sub epilogue { # This could send a .signature, also see ::smtp subclass } -sub close { - my($self, @to) = @_; - if (fileno($self)) { - $self->epilogue; - close($self) - } +sub close(@) +{ my $self = shift; + fileno $self or return; + + $self->epilogue; + CORE::close $self; } +sub DESTROY { shift->close } -sub DESTROY { - my $self = shift; - $self->close; -} +#-------------- 1; - diff --git a/cpan/lib/Mail/Mailer.pod b/cpan/lib/Mail/Mailer.pod new file mode 100644 index 00000000..7b9c63f9 --- /dev/null +++ b/cpan/lib/Mail/Mailer.pod @@ -0,0 +1,152 @@ +=encoding utf8 + +=head1 NAME + +Mail::Mailer - send simple emails + +=head1 INHERITANCE + + Mail::Mailer + is a IO::Handle + +=head1 SYNOPSIS + + use Mail::Mailer; + use Mail::Mailer qw(mail); # specifies default mailer + + $mailer = Mail::Mailer->new; + $mailer = Mail::Mailer->new($type, @args); + + $mailer->open(\%headers); + print $mailer $body; + $mailer->close + or die "couldn't send whole message: $!\n"; + +=head1 DESCRIPTION + +Sends mail using any of the built-in methods. As TYPE argument +to L<new()|Mail::Mailer/"Constructors">, you can specify any of + +=over 4 + +=item C<sendmail> + +Use the C<sendmail> program to deliver the mail. + +=item C<smtp> + +Use the C<smtp> protocol via Net::SMTP to deliver the mail. The server +to use can be specified in C<@args> with + + $mailer = Mail::Mailer->new('smtp', Server => $server); + +The smtp mailer does not handle C<Cc> and C<Bcc> lines, neither their +C<Resent-*> fellows. The C<Debug> options enables debugging output +from C<Net::SMTP>. + +You may also use the C<< Auth => [ $user, $password ] >> option for SASL +authentication. To make this work, you have to install the L<Authen::SASL> +distribution yourself: it is not automatically installed. + +=item C<smtps> + +Use the smtp over ssl protocol via L<Net::SMTP::SSL> to deliver the mail. +Usage is identical to C<smtp>. You have to install Authen::SASL as +well. + + $mailer = Mail::Mailer->new('smtps', Server => $server); + +=item C<qmail> + +Use qmail's qmail-inject program to deliver the mail. + +=item C<testfile> + +Used for debugging, this displays the data to the file named in +C<$Mail::Mailer::testfile::config{outfile}> which defaults to a file +named C<mailer.testfile>. No mail is ever sent. + +=back + +C<Mail::Mailer> will search for executables in the above order. The +default mailer will be the first one found. + +=head1 METHODS + +=head2 Constructors + +=over 4 + +=item Mail::Mailer-E<gt>B<new>(TYPE, ARGS) + +The TYPE is one of the back-end sender implementations, as described in +the DESCRIPTION chapter of this manual page. The ARGS are passed to +that back-end. + +=item $obj-E<gt>B<open>(HASH) + +The HASH consists of key and value pairs, the key being the name of +the header field (eg, C<To>), and the value being the corresponding +contents of the header field. The value can either be a scalar +(eg, C<gnat@frii.com>) or a reference to an array of scalars +(C<< eg, ['gnat@frii.com', 'Tim.Bunce@ig.co.uk'] >>). + +=back + +=head1 DETAILS + +=head2 ENVIRONMENT VARIABLES + +=over 4 + +=item PERL_MAILERS + +Augments/override the build in choice for binary used to send out +our mail messages. + +Format: + + "type1:mailbinary1;mailbinary2;...:type2:mailbinaryX;...:..." + +Example: assume you want you use private sendmail binary instead +of mailx, one could set C<PERL_MAILERS> to: + + "mail:/does/not/exists:sendmail:$HOME/test/bin/sendmail" + +On systems which may include C<:> in file names, use C<|> as separator +between type-groups. + + "mail:c:/does/not/exists|sendmail:$HOME/test/bin/sendmail" + +=back + +=head2 BUGS + +Mail::Mailer does not help with folding, and does not protect +against various web-script hacker attacks, for instance where +a new-line is inserted in the content of the field. + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + diff --git a/cpan/lib/Mail/Mailer/qmail.pm b/cpan/lib/Mail/Mailer/qmail.pm index ea312606..19660675 100644 --- a/cpan/lib/Mail/Mailer/qmail.pm +++ b/cpan/lib/Mail/Mailer/qmail.pm @@ -1,9 +1,22 @@ +# 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. + +use strict; + package Mail::Mailer::qmail; -use vars qw(@ISA); -require Mail::Mailer::rfc822; -@ISA = qw(Mail::Mailer::rfc822); +use vars '$VERSION'; +$VERSION = '2.19'; + +use base 'Mail::Mailer::rfc822'; -sub exec { - my($self, $exe, $args, $to) = @_; - exec(( $exe )); +sub exec($$$$) +{ my($self, $exe, $args, $to, $sender) = @_; + my $address = defined $sender && $sender =~ m/\<(.*?)\>/ ? $1 : $sender; + + exec($exe, (defined $address ? "-f$address" : ())); + die "ERROR: cannot run $exe: $!"; } + +1; diff --git a/cpan/lib/Mail/Mailer/rfc822.pm b/cpan/lib/Mail/Mailer/rfc822.pm index fa59d0fe..c87e76f5 100644 --- a/cpan/lib/Mail/Mailer/rfc822.pm +++ b/cpan/lib/Mail/Mailer/rfc822.pm @@ -1,20 +1,29 @@ +# 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. +use strict; + package Mail::Mailer::rfc822; -use vars qw(@ISA); -@ISA = qw(Mail::Mailer); - -sub set_headers { - my $self = shift; - my $hdrs = shift; - local($\)=""; - foreach(keys %$hdrs) { - next unless m/^[A-Z]/; - - my ($h); - foreach $h ($self->to_array($hdrs->{$_})) +use vars '$VERSION'; +$VERSION = '2.19'; + +use base 'Mail::Mailer'; + +sub set_headers +{ my ($self, $hdrs) = @_; + + local $\ = ""; + + foreach (keys %$hdrs) + { next unless m/^[A-Z]/; + + foreach my $h ($self->to_array($hdrs->{$_})) { $h =~ s/\n+\Z//; - print $self "$_: ", $h, "\n"; + print $self "$_: $h\n"; } } + print $self "\n"; # terminate headers } diff --git a/cpan/lib/Mail/Mailer/sendmail.pm b/cpan/lib/Mail/Mailer/sendmail.pm index ea67d7e0..343b6cc1 100644 --- a/cpan/lib/Mail/Mailer/sendmail.pm +++ b/cpan/lib/Mail/Mailer/sendmail.pm @@ -1,17 +1,26 @@ +# 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. +use strict; + package Mail::Mailer::sendmail; -use vars qw(@ISA); -require Mail::Mailer::rfc822; -@ISA = qw(Mail::Mailer::rfc822); +use vars '$VERSION'; +$VERSION = '2.19'; +use base 'Mail::Mailer::rfc822'; -sub exec { - my($self, $exe, $args, $to) = @_; +sub exec($$$$) +{ my($self, $exe, $args, $to, $sender) = @_; # Fork and exec the mailer (no shell involved to avoid risks) # We should always use a -t on sendmail so that Cc: and Bcc: work # Rumor: some sendmails may ignore or break with -t (AIX?) # Chopped out the @$to arguments, because -t means # they are sent in the body, and postfix complains if they - # are also given on comand line. + # are also given on command line. + exec( $exe, '-t', @$args ); } + +1; diff --git a/cpan/lib/Mail/Mailer/smtp.pm b/cpan/lib/Mail/Mailer/smtp.pm index 42eac5e4..aa5e4a87 100644 --- a/cpan/lib/Mail/Mailer/smtp.pm +++ b/cpan/lib/Mail/Mailer/smtp.pm @@ -1,84 +1,103 @@ +# 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. +use strict; + package Mail::Mailer::smtp; -use vars qw(@ISA); +use vars '$VERSION'; +$VERSION = '2.19'; + +use base 'Mail::Mailer::rfc822'; + use Net::SMTP; use Mail::Util qw(mailaddress); use Carp; -require Mail::Mailer::rfc822; -@ISA = qw(Mail::Mailer::rfc822); - sub can_cc { 0 } sub exec { - my($self, $exe, $args, $to) = @_; + my ($self, $exe, $args, $to) = @_; my %opt = @$args; my $host = $opt{Server} || undef; $opt{Debug} ||= 0; - # for Net::SMTP we do not really exec my $smtp = Net::SMTP->new($host, %opt) or return undef; - ${*$self}{'sock'} = $smtp; - - $smtp->mail(mailaddress()); - my $u; - foreach $u (@$to) { - $smtp->to($u); + if($opt{Auth}) + { $smtp->auth(@{$opt{Auth}}) + or return undef; } + + ${*$self}{sock} = $smtp; + + $smtp->mail($opt{From} || mailaddress()); + $smtp->to($_) for @$to; $smtp->data; - untie(*$self) if tied *$self; - tie *$self, 'Mail::Mailer::smtp::pipe',$self; + + untie *$self if tied *$self; + tie *$self, 'Mail::Mailer::smtp::pipe', $self; $self; } -sub set_headers { - my($self,$hdrs) = @_; - $self->SUPER::set_headers({ - From => "<" . mailaddress() . ">", - %$hdrs, - 'X-Mailer' => "Mail::Mailer[v$Mail::Mailer::VERSION] Net::SMTP[v$Net::SMTP::VERSION]" - }) +sub set_headers($) +{ my ($self, $hdrs) = @_; + $self->SUPER::set_headers + ( { From => "<" . mailaddress() . ">" + , %$hdrs + , 'X-Mailer' => "Mail::Mailer[v$Mail::Mailer::VERSION] Net::SMTP[v$Net::SMTP::VERSION]" + } + ); } -sub epilogue { - my $self = shift; - my $sock = ${*$self}{'sock'}; - $sock->dataend; +sub epilogue() +{ my $self = shift; + my $sock = ${*$self}{sock}; + + my $ok = $sock->dataend; $sock->quit; - delete ${*$self}{'sock'}; - untie(*$self); + + delete ${*$self}{sock}; + untie *$self; + $ok; } -sub close { - my($self, @to) = @_; - my $sock = ${*$self}{'sock'}; - if ($sock && fileno($sock)) { - $self->epilogue; - # Epilogue should destroy the SMTP filehandle, - # but just to be on the safe side. - if ($sock && fileno($sock)) { - close $sock - or croak 'Cannot destroy socket filehandle'; - } - } - 1; +sub close(@) +{ my ($self, @to) = @_; + my $sock = ${*$self}{sock}; + + $sock && fileno $sock + or return 1; + + my $ok = $self->epilogue; + + # Epilogue should destroy the SMTP filehandle, + # but just to be on the safe side. + $sock && fileno $sock + or return $ok; + + close $sock + or croak 'Cannot destroy socket filehandle'; + + $ok; } package Mail::Mailer::smtp::pipe; +use vars '$VERSION'; +$VERSION = '2.19'; -sub TIEHANDLE { - my $pkg = shift; - my $self = shift; - my $sock = ${*$self}{'sock'}; - return bless \$sock; + +sub TIEHANDLE +{ my ($class, $self) = @_; + my $sock = ${*$self}{sock}; + bless \$sock, $class; } -sub PRINT { - my $self = shift; +sub PRINT +{ my $self = shift; my $sock = $$self; $sock->datasend( @_ ); } - 1; diff --git a/cpan/lib/Mail/Mailer/smtps.pm b/cpan/lib/Mail/Mailer/smtps.pm new file mode 100644 index 00000000..90d10efc --- /dev/null +++ b/cpan/lib/Mail/Mailer/smtps.pm @@ -0,0 +1,108 @@ +# 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. +# Based on smtp.pm, adapted by Maciej Żenczykowski + +use strict; + +package Mail::Mailer::smtps; +use vars '$VERSION'; +$VERSION = '2.19'; + +use base 'Mail::Mailer::rfc822'; + +use Net::SMTP::SSL; +use Mail::Util qw(mailaddress); +use Carp; + +sub can_cc { 0 } + +sub exec { + my ($self, $exe, $args, $to) = @_; + my %opt = @$args; + my $host = $opt{Server} || undef; + $opt{Debug} ||= 0; + $opt{Port} ||= 465; + + my $smtp = Net::SMTP::SSL->new($host, %opt) + or return undef; + + if($opt{Auth}) + { $smtp->auth(@{$opt{Auth}}) + or return undef; + } + + ${*$self}{sock} = $smtp; + + $smtp->mail($opt{From} || mailaddress); + $smtp->to($_) for @$to; + $smtp->data; + + untie *$self if tied *$self; + tie *$self, 'Mail::Mailer::smtps::pipe', $self; + $self; +} + +sub set_headers($) +{ my ($self, $hdrs) = @_; + $self->SUPER::set_headers + ( { From => "<" . mailaddress() . ">" + , %$hdrs + , 'X-Mailer' => "Mail::Mailer[v$Mail::Mailer::VERSION] " + . " Net::SMTP[v$Net::SMTP::VERSION]" + . " Net::SMTP::SSL[v$Net::SMTP::SSL::VERSION]" + } + ); +} + +sub epilogue() +{ my $self = shift; + my $sock = ${*$self}{sock}; + + my $ok = $sock->dataend; + $sock->quit; + + delete ${*$self}{sock}; + untie *$self; + $ok; +} + +sub close(@) +{ my ($self, @to) = @_; + my $sock = ${*$self}{sock}; + + $sock && fileno $sock + or return 1; + + my $ok = $self->epilogue; + + # Epilogue should destroy the SMTP filehandle, + # but just to be on the safe side. + $sock && fileno $sock + or return $ok; + + close $sock + or croak 'Cannot destroy socket filehandle'; + + $ok; +} + +package Mail::Mailer::smtps::pipe; +use vars '$VERSION'; +$VERSION = '2.19'; + + +sub TIEHANDLE +{ my ($class, $self) = @_; + my $sock = ${*$self}{sock}; + bless \$sock, $class; +} + +sub PRINT +{ my $self = shift; + my $sock = $$self; + $sock->datasend( @_ ); +} + +1; diff --git a/cpan/lib/Mail/Mailer/testfile.pm b/cpan/lib/Mail/Mailer/testfile.pm new file mode 100644 index 00000000..94dcad40 --- /dev/null +++ b/cpan/lib/Mail/Mailer/testfile.pm @@ -0,0 +1,54 @@ +# 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. +use strict; + +package Mail::Mailer::testfile; +use vars '$VERSION'; +$VERSION = '2.19'; + +use base 'Mail::Mailer::rfc822'; + +use Mail::Util qw/mailaddress/; + +my $num = 0; +sub can_cc() { 0 } + +sub exec($$$) +{ my ($self, $exe, $args, $to) = @_; + + my $outfn = $Mail::Mailer::testfile::config{outfile} || 'mailer.testfile'; + open F, '>>', $outfn + or die "Cannot append message to testfile $outfn: $!"; + + print F "\n===\ntest ", ++$num, " ", (scalar localtime), + "\nfrom: " . mailaddress(), + "\nto: " . join(' ',@{$to}), "\n\n"; + close F; + + untie *$self if tied *$self; + tie *$self, 'Mail::Mailer::testfile::pipe', $self; + $self; +} + +sub close { 1 } + +package Mail::Mailer::testfile::pipe; +use vars '$VERSION'; +$VERSION = '2.19'; + + +sub TIEHANDLE +{ my ($class, $self) = @_; + bless \$self, $class; +} + +sub PRINT +{ my $self = shift; + open F, '>>', $Mail::Mailer::testfile::config{outfile} || 'mailer.testfile'; + print F @_; + close F; +} + +1; diff --git a/cpan/lib/Mail/Send.pm b/cpan/lib/Mail/Send.pm index 7af92296..01add435 100644 --- a/cpan/lib/Mail/Send.pm +++ b/cpan/lib/Mail/Send.pm @@ -1,110 +1,63 @@ - +# 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::Send; +use vars '$VERSION'; +$VERSION = '2.19'; -# $Id$ use strict; -use Carp; -use vars qw($VERSION); -require Mail::Mailer; - -$VERSION = "1.52"; - -sub Version { $VERSION } - -sub new { - my $pkg = shift; - my %attr = @_; - my($key, $value); - my $me = bless {}, $pkg; - while( ($key, $value) = each %attr ) { - $key = lc($key); - $me->$key($value); - } - $me; -} -sub set { - my($me, $hdr, @values) = @_; - $me->{$hdr} = [ @values ] if @values; - @{$me->{$hdr} || []}; # return new (or original) values -} +use Mail::Mailer (); -sub add { - my($me, $hdr, @values) = @_; - $me->{$hdr} = [] unless $me->{$hdr}; - push(@{$me->{$hdr}}, @values); -} +sub Version { our $VERSION } -sub delete { - my($me, $hdr) = @_; - delete $me->{$hdr}; -} +#------------------ -sub to { my $me=shift; $me->set('To', @_); } -sub cc { my $me=shift; $me->set('Cc', @_); } -sub bcc { my $me=shift; $me->set('Bcc', @_); } -sub subject { my $me=shift; $me->set('Subject', join (' ', @_)); } +sub new(@) +{ my ($class, %attr) = @_; + my $self = bless {}, $class; + while(my($key, $value) = each %attr) + { $key = lc $key; + $self->$key($value); + } -sub open { - my $me = shift; - Mail::Mailer->new(@_)->open($me); + $self; } -1; - -__END__ - -=head1 NAME - -Mail::Send - Simple electronic mail interface - -=head1 SYNOPSIS - - require Mail::Send; +#--------------- - $msg = new Mail::Send; - - $msg = new Mail::Send Subject=>'example subject', To=>'timbo'; - - $msg->to('user@host'); - $msg->subject('example subject'); - $msg->cc('user@host'); - $msg->bcc('someone@else'); - - $msg->set($header, @values); - $msg->add($header, @values); - $msg->delete($header); - - # Launch mailer and set headers. The filehandle returned - # by open() is an instance of the Mail::Mailer class. - # Arguments to the open() method are passed to the Mail::Mailer - # constructor. - - $fh = $msg->open; # some default mailer - # $fh = $msg->open('sendmail'); # explicit - - print $fh "Body of message"; - - $fh->close; # complete the message and send it - - $fh->cancel; # not yet implemented +sub set($@) +{ my ($self, $hdr, @values) = @_; + $self->{$hdr} = [ @values ] if @values; + @{$self->{$hdr} || []}; # return new (or original) values +} -=head1 DESCRIPTION -=head1 SEE ALSO +sub add($@) +{ my ($self, $hdr, @values) = @_; + push @{$self->{$hdr}}, @values; +} -Mail::Mailer -=head1 AUTHORS +sub delete($) +{ my($self, $hdr) = @_; + delete $self->{$hdr}; +} -Maintained by Mark Overmeer <mailtools@overmeer.net> -Original code written by Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>, -with a kick start from Graham Barr E<lt>F<gbarr@pobox.com>E<gt>. With -contributions by Gerard Hickey E<lt>F<hickey@ctron.com>E<gt> +sub to { my $self=shift; $self->set('To', @_); } +sub cc { my $self=shift; $self->set('Cc', @_); } +sub bcc { my $self=shift; $self->set('Bcc', @_); } +sub subject { my $self=shift; $self->set('Subject', join (' ', @_)); } -=cut +#--------------- +sub open(@) +{ my $self = shift; + Mail::Mailer->new(@_)->open($self); +} +1; diff --git a/cpan/lib/Mail/Send.pod b/cpan/lib/Mail/Send.pod new file mode 100644 index 00000000..bda52154 --- /dev/null +++ b/cpan/lib/Mail/Send.pod @@ -0,0 +1,116 @@ +=encoding utf8 + +=head1 NAME + +Mail::Send - Simple electronic mail interface + +=head1 SYNOPSIS + + require Mail::Send; + + $msg = Mail::Send->new; + $msg = Mail::Send->new(Subject => 'example', To => 'timbo'); + + $msg->to('user@host'); + $msg->to('user@host', 'user2@example.com'); + $msg->subject('example subject'); + $msg->cc('user@host'); + $msg->bcc('someone@else'); + + $msg->set($header, @values); + $msg->add($header, @values); + $msg->delete($header); + + # Launch mailer and set headers. The filehandle returned + # by open() is an instance of the Mail::Mailer class. + # Arguments to the open() method are passed to the Mail::Mailer + # constructor. + + $fh = $msg->open; # some default mailer + $fh = $msg->open('sendmail'); # explicit + print $fh "Body of message"; + $fh->close # complete the message and send it + or die "couldn't send whole message: $!\n"; + +=head1 DESCRIPTION + +L<Mail::Send|Mail::Send> creates e-mail messages without using the L<Mail::Header|Mail::Header> +knowledge, which means that all escaping and folding must be done by +you! Simplicity has its price. + +When you have time, take a look at Mail::Transport + +=head1 METHODS + +=head2 Constructors + +=over 4 + +=item Mail::Send-E<gt>B<new>(PAIRS) + +A list of header fields (provided as key-value PAIRS) can be +used to initialize the object. + +=back + +=head2 Header fields + +=over 4 + +=item $obj-E<gt>B<add>(FIELDNAME, VALUES) + +Add values to the list of defined values for the FIELDNAME. + +=item $obj-E<gt>B<bcc>(VALUES) + +=item $obj-E<gt>B<cc>(VALUES) + +=item $obj-E<gt>B<delete>(FIELDNAME) + +=item $obj-E<gt>B<set>(FIELDNAME, VALUES) + +VALUES will replace the old values for the FIELDNAME. Returned is +the LIST of values after modification. + +=item $obj-E<gt>B<subject>(VALUES) + +=item $obj-E<gt>B<to>(VALUES) + +=back + +=head2 Sending + +=over 4 + +=item $obj-E<gt>B<open>(OPTIONS) + +The OPTIONS are used to initiate a mailer object via +L<Mail::Mailer::new()|Mail::Mailer/"Constructors">. Then L<Mail::Mailer::open()|Mail::Mailer/"Constructors"> is called +with the knowledge collected in this Mail::Send object. + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + diff --git a/cpan/lib/Mail/Util.pm b/cpan/lib/Mail/Util.pm index a1d5be98..af7894a7 100644 --- a/cpan/lib/Mail/Util.pm +++ b/cpan/lib/Mail/Util.pm @@ -1,263 +1,151 @@ -# Mail::Util.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. - +# 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::Util; +use vars '$VERSION'; +$VERSION = '2.19'; -use strict; -use vars qw($VERSION @ISA @EXPORT_OK); -use AutoLoader (); -use Exporter (); - -BEGIN { - require 5.000; - - $VERSION = "1.52"; - - *AUTOLOAD = \&AutoLoader::AUTOLOAD; - @ISA = qw(Exporter); - - @EXPORT_OK = qw(read_mbox maildomain mailaddress); -} - -1; - -sub Version { $VERSION } - -=head1 NAME - -Mail::Util - mail utility functions - -=head1 SYNOPSIS - -use Mail::Util qw( ... ); - -=head1 DESCRIPTION - -This package provides several mail related utility functions. Any function -required must by explicitly listed on the use line to be exported into -the calling package. - -=head2 read_mbox( $file ) - -Read C<$file>, a binmail mailbox file, and return a list of references. -Each reference is a reference to an array containg one message. - -=head2 maildomain() - -Attempt to determine the current uers mail domain string via the following -methods - -=over 4 - -=item * Look for the MAILDOMAIN enviroment variable, which can be set from outside the program. - -=item * Look for a sendmail.cf file and extract DH parameter - -=item * Look for a smail config file and usr the first host defined in hostname(s) - -=item * Try an SMTP connect (if Net::SMTP exists) first to mailhost then localhost - -=item * Use value from Net::Domain::domainname (if Net::Domain exists) +use base 'Exporter'; -=back - -=head2 mailaddress() - -Return a guess at the current users mail address. The user can force -the return value by setting the MAILADDRESS environment variable. - -=head1 AUTHOR +use strict; +use Carp; -Graham Barr. +our @EXPORT_OK = qw(read_mbox maildomain mailaddress); -Maintained by Mark Overmeer <mailtools@overmeer.net> +sub Version { our $VERSION } -=head1 COPYRIGHT +my ($domain, $mailaddress); +my @sendmailcf = qw(/etc /etc/sendmail /etc/ucblib + /etc/mail /usr/lib /var/adm/sendmail); -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. -=cut +sub read_mbox($) +{ my $file = shift; -__END__ + local *FH; + open FH,'<', $file + or croak "cannot open '$file': $!\n"; -sub read_mbox { - my $file = shift; - my @mail = (); + local $_; + my @mbox; my $mail = []; my $blank = 1; - local *FH; - local $_; - open(FH,"< $file") or - do { - require Carp; - Carp::croak("cannot open '$file': $!\n"); - }; - - while(<FH>) { - if($blank && /\AFrom .*\d{4}/) { - push(@mail, $mail) if scalar(@{$mail}); - $mail = [ $_ ]; - $blank = 0; - } - else { - $blank = m#\A\Z#o ? 1 : 0; - push(@{$mail}, $_); - } + while(<FH>) + { if($blank && /^From .*\d{4}/) + { push @mbox, $mail if @$mail; + $mail = [ $_ ]; + $blank = 0; + } + else + { $blank = m/^$/ ? 1 : 0; + push @$mail, $_; + } } - push(@mail, $mail) if scalar(@{$mail}); + push @mbox, $mail if @$mail; + close FH; - close(FH); - - return wantarray ? @mail : \@mail; + wantarray ? @mbox : \@mbox; } -sub maildomain { - - ## - ## return imediately if already found - ## - - return $domain - if(defined $domain); +sub maildomain() +{ return $domain + if defined $domain; - ## - ## Get mail domain from environment - ## + $domain = $ENV{MAILDOMAIN} + and return $domain; - $domain = $ENV{MAILDOMAIN}; + # Try sendmail configuration file - return $domain - if(defined $domain); - - ## - ## Try sendmail config file if exists - ## + my $config = (grep -r, map {"$_/sendmail.cf"} @sendmailcf)[0]; local *CF; local $_; - my @sendmailcf = qw(/etc - /etc/sendmail - /etc/ucblib - /etc/mail - /usr/lib - /var/adm/sendmail); - - my $config = (grep(-r, map("$_/sendmail.cf", @sendmailcf)))[0]; - - if(defined $config && open(CF,$config)) { - my %var; - while(<CF>) { - if(my ($v, $arg) = /^D([a-zA-Z])([\w.\$\-]+)/) { - $arg =~ s/\$([a-zA-Z])/exists $var{$1} ? $var{$1} : '$'.$1/eg; + if(defined $config && open CF, '<', $config) + { my %var; + while(<CF>) + { if(my ($v, $arg) = /^D([a-zA-Z])([\w.\$\-]+)/) + { $arg =~ s/\$([a-zA-Z])/exists $var{$1} ? $var{$1} : '$'.$1/eg; $var{$v} = $arg; } } - close(CF); + close CF; $domain = $var{j} if defined $var{j}; $domain = $var{M} if defined $var{M}; $domain = $1 - if($domain && $domain =~ m/([A-Za-z0-9](?:[\.\-A-Za-z0-9]+))/ ); + if $domain && $domain =~ m/([A-Za-z0-9](?:[\.\-A-Za-z0-9]+))/; return $domain - if(defined $domain); + if defined $domain && $domain !~ /\$/; } - ## - ## Try smail config file if exists - ## + # Try smail config file if exists - if(open(CF,"/usr/lib/smail/config")) { - while(<CF>) { - if(/\A\s*hostnames?\s*=\s*(\S+)/) { - $domain = (split(/:/,$1))[0]; + if(open CF, '<', "/usr/lib/smail/config") + { while(<CF>) + { if( /\A\s*hostnames?\s*=\s*(\S+)/ ) + { $domain = (split /\:/,$1)[0]; last; } } - close(CF); + close CF; return $domain - if(defined $domain); + if defined $domain; } - ## - ## Try a SMTP connection to 'mailhost' - ## - - if(eval { require Net::SMTP }) { - my $host; + # Try a SMTP connection to 'mailhost' - foreach $host (qw(mailhost localhost)) { - my $smtp = eval { Net::SMTP->new($host) }; - - if(defined $smtp) { - $domain = $smtp->domain; + if(eval {require Net::SMTP}) + { foreach my $host (qw(mailhost localhost)) + { # hosts are local, so short timeout + my $smtp = eval { Net::SMTP->new($host, Timeout => 5) }; + if(defined $smtp) + { $domain = $smtp->domain; $smtp->quit; last; } } } - ## - ## Use internet(DNS) domain name, if it can be found - ## - - unless(defined $domain) { - if(eval { require Net::Domain } ) { - $domain = Net::Domain::domainname(); - } - } - - $domain = "localhost" - unless(defined $domain); + # Use internet(DNS) domain name, if it can be found + $domain = Net::Domain::domainname() + if !defined $domain && eval {require Net::Domain}; - return $domain; + $domain ||= "localhost"; } -sub mailaddress { - - ## - ## Return imediately if already found - ## +sub mailaddress(;$) +{ $mailaddress = shift if @_; return $mailaddress - if(defined $mailaddress); - - ## - ## Get user name from environment - ## + if defined $mailaddress; + # Get user name from environment $mailaddress = $ENV{MAILADDRESS}; - unless ($mailaddress || $^O ne 'MacOS') { - require Mac::InternetConfig; - Mac::InternetConfig->import(); + unless($mailaddress || $^O ne 'MacOS') + { require Mac::InternetConfig; + no strict; + Mac::InternetConfig->import; $mailaddress = $InternetConfig{kICEmail()}; } - $mailaddress ||= $ENV{USER} || - $ENV{LOGNAME} || - eval {getpwuid($>)} || - "postmaster"; - - ## - ## Add domain if it does not exist - ## + $mailaddress ||= $ENV{USER} || $ENV{LOGNAME} || eval {getpwuid $>} + || "postmaster"; - $mailaddress .= '@' . maildomain() - unless($mailaddress =~ /\@/); + # Add domain if it does not exist + $mailaddress .= '@' . maildomain + if $mailaddress !~ /\@/; $mailaddress =~ s/(^.*<|>.*$)//g; - $mailaddress; } + +1; diff --git a/cpan/lib/Mail/Util.pod b/cpan/lib/Mail/Util.pod new file mode 100644 index 00000000..8eb71268 --- /dev/null +++ b/cpan/lib/Mail/Util.pod @@ -0,0 +1,119 @@ +=encoding utf8 + +=head1 NAME + +Mail::Util - mail utility functions + +=head1 INHERITANCE + + Mail::Util + is a Exporter + +=head1 SYNOPSIS + + use Mail::Util qw( ... ); + +=head1 DESCRIPTION + +This package provides several mail related utility functions. Any function +required must by explicitly listed on the use line to be exported into +the calling package. + +=head1 FUNCTIONS + +=over 4 + +=item B<mailaddress>( [ADDRESS] ) + +Return a guess at the current users mail address. The user can force +the return value by setting the MAILADDRESS environment variable. +[2.10] You may set the ADDRESS via the parameter. + +WARNING: +When not supplied via the environment variable, <mailaddress> looks at +various configuration files and other environmental data. Although this +seems to be smart behavior, this is not predictable enough (IMHO) to +be used. Please set the MAILADDRESS explicitly, and do not trust on +the "automatic detection", even when that produces a correct address +(on the moment) + +example: + + # in your main script + $ENV{MAILADDRESS} = 'me@example.com'; + + # everywhere else + use Mail::Util 'mailaddress'; + print mailaddress; + + # since v2.10 + mailaddress "me@example.com"; + +=item B<maildomain>() + +Attempt to determine the current user mail domain string via the following +methods + +=over 4 + +=item * Look for the MAILDOMAIN environment variable, which can be set from outside the program. This is by far the best way to configure the domain. + +=item * Look for a sendmail.cf file and extract DH parameter + +=item * Look for a smail config file and usr the first host defined in hostname(s) + +=item * Try an SMTP connect (if Net::SMTP exists) first to mailhost then localhost + +=item * Use value from Net::Domain::domainname (if Net::Domain exists) + +=back + +WARNING: +On modern machines, there is only one good way to provide information to +this method: the first; always explicitly configure the MAILDOMAIN. + +example: + + # in your main script + $ENV{MAILDOMAIN} = 'example.com'; + + # everywhere else + use Mail::Util 'maildomain'; + print maildomain; + +=item B<read_mbox>(FILE) + +Read FILE, a binmail mailbox file, and return a list of references. +Each reference is a reference to an array containing one message. + +WARNING: +This method does not quote lines which accidentally also start with the +message separator C<From>, so this implementation can be considered +broken. See Mail::Box::Mbox + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + diff --git a/cpan/lib/MailTools.pm b/cpan/lib/MailTools.pm new file mode 100644 index 00000000..77accb7d --- /dev/null +++ b/cpan/lib/MailTools.pm @@ -0,0 +1,11 @@ +# 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 MailTools; +use vars '$VERSION'; +$VERSION = '2.19'; + + + +1; diff --git a/cpan/lib/MailTools.pod b/cpan/lib/MailTools.pod new file mode 100644 index 00000000..17d25a5f --- /dev/null +++ b/cpan/lib/MailTools.pod @@ -0,0 +1,92 @@ +=encoding utf8 + +=head1 NAME + +MailTools - bundle of ancient email modules + +=head1 SYNOPSIS + + # This is a place-holder for the distribution + +=head1 DESCRIPTION + +MailTools is a bundle: an ancient form of combining packages into one +distribution. Gladly, it can be distributed as if it is a normal +distribution as well. + +B<Be warned:> The code you find here is very old. It works for simple +emails, but when you start with new code then please use more +sofisticated libraries. The main reason that you still find this code +on CPAN, is because many books use it as example. + +=head2 Component + +In this distribution, you find + +=over 4 + +=item Mail::Address + +Parse email address from a header line. + +=item Mail::Cap + +Interpret mailcap files: mappings of file-types to applications as used +by many command-line email programs. + +=item Mail::Field + +Simplifies access to (some) email header fields. Used by L<Mail::Header|Mail::Header>. + +=item Mail::Filter + +Process L<Mail::Internet|Mail::Internet> messages. + +=item Mail::Header + +Collection of L<Mail::Field|Mail::Field> objects, representing the header of a +L<Mail::Internet|Mail::Internet> object. + +=item Mail::Internet + +Represents a single email message, with header and body. + +=item Mail::Mailer + +Send L<Mail::Internet|Mail::Internet> emails via direct smtp or local MTA's. + +=item Mail::Send + +Build a L<Mail::Internet|Mail::Internet> object, and then send it out using +L<Mail::Mailer|Mail::Mailer>. + +=item Mail::Util + +"Smart functions" you should not depend on. + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F<http://perl.overmeer.net/mailtools/>. + +=head1 AUTHORS + +The MailTools bundle was developed by Graham Barr. Later, Mark +Overmeer took over maintenance without commitment to further development. + +Mail::Cap by Gisle Aas E<lt>aas@oslonett.noE<gt>. +Mail::Field::AddrList by Peter Orbaek E<lt>poe@cit.dkE<gt>. +Mail::Mailer and Mail::Send by Tim Bunce E<lt>Tim.Bunce@ig.co.ukE<gt>. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr E<lt>gbarr@pobox.comE<gt> and +2001-2017 Mark Overmeer E<lt>perl@overmeer.netE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F<http://www.perl.com/perl/misc/Artistic.html> + |