From 3c4d0bcf412dde7975d734ddf893b554d560bb40 Mon Sep 17 00:00:00 2001 From: fukachan Date: Mon, 1 Jan 2018 03:24:59 +0000 Subject: Initial revision --- cpan/dist/MailTools/META.json | 46 ++ cpan/dist/MailTools/META.yml | 27 + cpan/dist/MailTools/examples/mail-mailer.pl | 113 +++++ cpan/dist/MailTools/lib/Mail/Address.pm | 276 +++++++++++ cpan/dist/MailTools/lib/Mail/Address.pod | 164 ++++++ cpan/dist/MailTools/lib/Mail/Cap.pm | 250 ++++++++++ cpan/dist/MailTools/lib/Mail/Cap.pod | 157 ++++++ cpan/dist/MailTools/lib/Mail/Field.pm | 227 +++++++++ cpan/dist/MailTools/lib/Mail/Field.pod | 196 ++++++++ cpan/dist/MailTools/lib/Mail/Field/AddrList.pm | 68 +++ cpan/dist/MailTools/lib/Mail/Field/AddrList.pod | 175 +++++++ cpan/dist/MailTools/lib/Mail/Field/Date.pm | 62 +++ cpan/dist/MailTools/lib/Mail/Field/Date.pod | 152 ++++++ cpan/dist/MailTools/lib/Mail/Field/Generic.pm | 33 ++ cpan/dist/MailTools/lib/Mail/Field/Generic.pod | 147 ++++++ cpan/dist/MailTools/lib/Mail/Filter.pm | 70 +++ cpan/dist/MailTools/lib/Mail/Filter.pod | 106 ++++ cpan/dist/MailTools/lib/Mail/Header.pm | 632 ++++++++++++++++++++++++ cpan/dist/MailTools/lib/Mail/Header.pod | 255 ++++++++++ cpan/dist/MailTools/lib/Mail/Internet.pm | 554 +++++++++++++++++++++ cpan/dist/MailTools/lib/Mail/Internet.pod | 387 +++++++++++++++ cpan/dist/MailTools/lib/Mail/Mailer.pm | 217 ++++++++ cpan/dist/MailTools/lib/Mail/Mailer.pod | 152 ++++++ cpan/dist/MailTools/lib/Mail/Mailer/qmail.pm | 22 + cpan/dist/MailTools/lib/Mail/Mailer/rfc822.pm | 30 ++ cpan/dist/MailTools/lib/Mail/Mailer/sendmail.pm | 26 + cpan/dist/MailTools/lib/Mail/Mailer/smtp.pm | 103 ++++ cpan/dist/MailTools/lib/Mail/Mailer/smtps.pm | 108 ++++ cpan/dist/MailTools/lib/Mail/Mailer/testfile.pm | 54 ++ cpan/dist/MailTools/lib/Mail/Send.pm | 63 +++ cpan/dist/MailTools/lib/Mail/Send.pod | 116 +++++ cpan/dist/MailTools/lib/Mail/Util.pm | 151 ++++++ cpan/dist/MailTools/lib/Mail/Util.pod | 119 +++++ cpan/dist/MailTools/lib/MailTools.pm | 11 + cpan/dist/MailTools/lib/MailTools.pod | 92 ++++ cpan/dist/MailTools/xt/99pod.t | 7 + 36 files changed, 5368 insertions(+) create mode 100644 cpan/dist/MailTools/META.json create mode 100644 cpan/dist/MailTools/META.yml create mode 100644 cpan/dist/MailTools/examples/mail-mailer.pl create mode 100644 cpan/dist/MailTools/lib/Mail/Address.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Address.pod create mode 100644 cpan/dist/MailTools/lib/Mail/Cap.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Cap.pod create mode 100644 cpan/dist/MailTools/lib/Mail/Field.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Field.pod create mode 100644 cpan/dist/MailTools/lib/Mail/Field/AddrList.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Field/AddrList.pod create mode 100644 cpan/dist/MailTools/lib/Mail/Field/Date.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Field/Date.pod create mode 100644 cpan/dist/MailTools/lib/Mail/Field/Generic.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Field/Generic.pod create mode 100644 cpan/dist/MailTools/lib/Mail/Filter.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Filter.pod create mode 100644 cpan/dist/MailTools/lib/Mail/Header.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Header.pod create mode 100644 cpan/dist/MailTools/lib/Mail/Internet.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Internet.pod create mode 100644 cpan/dist/MailTools/lib/Mail/Mailer.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Mailer.pod create mode 100644 cpan/dist/MailTools/lib/Mail/Mailer/qmail.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Mailer/rfc822.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Mailer/sendmail.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Mailer/smtp.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Mailer/smtps.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Mailer/testfile.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Send.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Send.pod create mode 100644 cpan/dist/MailTools/lib/Mail/Util.pm create mode 100644 cpan/dist/MailTools/lib/Mail/Util.pod create mode 100644 cpan/dist/MailTools/lib/MailTools.pm create mode 100644 cpan/dist/MailTools/lib/MailTools.pod create mode 100644 cpan/dist/MailTools/xt/99pod.t diff --git a/cpan/dist/MailTools/META.json b/cpan/dist/MailTools/META.json new file mode 100644 index 00000000..d07aa320 --- /dev/null +++ b/cpan/dist/MailTools/META.json @@ -0,0 +1,46 @@ +{ + "abstract" : "Various ancient e-mail related modules", + "author" : [ + "Mark Overmeer " + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120630", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "MailTools", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : { + "Date::Format" : "0", + "Date::Parse" : "0", + "IO::Handle" : "0", + "Net::Domain" : "1.05", + "Net::SMTP" : "1.03", + "Test::More" : "0" + } + } + }, + "release_status" : "stable", + "version" : "2.19" +} diff --git a/cpan/dist/MailTools/META.yml b/cpan/dist/MailTools/META.yml new file mode 100644 index 00000000..a3667ede --- /dev/null +++ b/cpan/dist/MailTools/META.yml @@ -0,0 +1,27 @@ +--- +abstract: 'Various ancient e-mail related modules' +author: + - 'Mark Overmeer ' +build_requires: + ExtUtils::MakeMaker: 0 +configure_requires: + ExtUtils::MakeMaker: 0 +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120630' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 +name: MailTools +no_index: + directory: + - t + - inc +requires: + Date::Format: 0 + Date::Parse: 0 + IO::Handle: 0 + Net::Domain: 1.05 + Net::SMTP: 1.03 + Test::More: 0 +version: 2.19 diff --git a/cpan/dist/MailTools/examples/mail-mailer.pl b/cpan/dist/MailTools/examples/mail-mailer.pl new file mode 100644 index 00000000..6f08cca0 --- /dev/null +++ b/cpan/dist/MailTools/examples/mail-mailer.pl @@ -0,0 +1,113 @@ +#!/usr/bin/perl -w + +# Note by Mark Overmeer: +# This script does work, but Mail::Send may provide a nicer interface + +# NAME +# mail-mailer.pl - Smtp client written in Perl +# +# SYNOPSIS +# mail-mailer.pl -s "Test" --smtp=my-smtp-server.com admin@net1.net +# +# INTRODUCTION +# This script can be an alternative to the 'mail' Unix command when +# sending e-mails. +# It reads the mail body from the standard input. +# If your system is Windows, use the '--smtp' option to send your +# e-mails. +# This script works in Linux, Unix and Windows environments. +# +# OPTIONS +# -f From +# -s Subject +# -c Cc-address +# -b bcc-address +# --sendmail Use sendmail to send the e-mail +# --qmail Use qmail-inject to send the e-mail +# --smtp=HOSTNAME Use HOSTNAME as the SMTP server. +# --help Prints the help info and exits +# +# EXAMPLES +# cat mailbody.txt | mail-mailer.pl -f me@mydom.com -s "Hy dude" --sendmail friend@dom.com +# +# AUTHOR +# Bruno Negrao G Zica +# +# COPYRIGHT +# Copyright (c) 2004 Bruno Negrao G Zica. All rights reserved. +# This program is free software; you can redistribute it and/or modify +# it under the same terms as Perl itself. +# +# LAST MODIFIED +# 01/12/2004 +################################################################## +use Mail::Mailer; +use Getopt::Long; +use strict; + +# hash that'll receive the arguments and options +my %opt; +GetOptions ( \%opt, 'help', 'f=s', 's=s', 'c=s', 'b=s', 'sendmail', + 'qmail', 'smtp=s' ); + +if ($opt{help}) { help(); exit 0; } + +$opt{to} = $ARGV[$#ARGV]; # the "To" address is the last argument +die "Error: You didn't specify a destination e-mail address.\n" + unless ( $opt{to} || $opt{c} || $opt{b} ); + +# Defining the method to send the message +my $mailer; # Mail::Mailer object +if ($opt{sendmail}) { + $mailer = new Mail::Mailer 'sendmail'; +} elsif ($opt{qmail}) { + $mailer = new Mail::Mailer 'qmail'; +} elsif ($opt{smtp}) { + $mailer = new Mail::Mailer 'smtp', Server => $opt{smtp}; +} else { + die "Error: you didn't specify the delivery method. ". + "Possible methods are:\n'--qmail', '--sendmail', and ". + "--smtp=HOSTNAME\n"; +} +# Setting the headers +my %headers; # hash with the e-mail headers +$headers{To} = $opt{to}; +$headers{From} = $opt{f} if defined $opt{f}; +$headers{Cc} = $opt{c} if defined $opt{c}; +$headers{Bcc} = $opt{b} if defined $opt{b}; +$headers{Subject} = $opt{s} if defined $opt{s}; +$mailer->open(\%headers); + +# Reading and feeding the e-mail body +while () { + last if ( $_ =~ /^\.$/ ); + print $mailer $_; +} + +# Finishing +$mailer->close(); + +# Subroutines +sub help { + print ' +Example 1: Entering the e-mail body by hand: +mail-mailer.pl -s "Hy buddy" --qmail friend@domain.com +[ ENTER YOU MESSAGE BODY ] +[ A SINGLE . (dot sign) ALONE IN ONE LINE TO SAY ] +[ YOU FINISHED YOUR E-MAIL ] +. + +Example 2: Using the output of another program as the body: +dir c:\ | perl mail-mailer.pl -f me@mydom.com -s "My c:\" admin@mydom.com --smtp=server1.mydom.com + +OPTIONS +-f addr From address. +-s TEXT Subject. +-c addr Cc-address. +-b addr bcc-address. +--sendmail Use sendmail to send the e-mail. +--qmail Use qmail-inject to send the e-mail. +--smtp HOSTNAME Use HOSTNAME as the SMTP server. +--help Prints this help text. +'; +} diff --git a/cpan/dist/MailTools/lib/Mail/Address.pm b/cpan/dist/MailTools/lib/Mail/Address.pm new file mode 100644 index 00000000..13b2ff7d --- /dev/null +++ b/cpan/dist/MailTools/lib/Mail/Address.pm @@ -0,0 +1,276 @@ +# Copyrights 1995-2017 by [Mark Overmeer ]. +# For other contributors see ChangeLog. +# See the manual pages for details on the licensing terms. +# Pod stripped from pm file by OODoc 2.02. +package Mail::Address; +use vars '$VERSION'; +$VERSION = '2.19'; + +use strict; + +use Carp; + +# use locale; removed in version 1.78, because it causes taint problems + +sub Version { our $VERSION } + + + +# given a comment, attempt to extract a person's name +sub _extract_name +{ # 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+$//; + s/\s+/ /; + + # Disregard numeric names (e.g. 123456.1234@compuserve.com) + return "" if /^[\d ]+$/; + + 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/,.*//; + + # 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; + + $_; +} + +sub _tokenise +{ local $_ = join ',', @_; + my (@words,$snippet,$field); + + 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/^(([^\\]|\\.)+)//; + } + } + + carp "Unmatched () '$field' '$_'" + if $depth; + + $field =~ s/\s+\Z//; + push @words, $field; + + next; + } + + if( s/^("(?:[^"\\]+|\\.)*")\s*// # "..." + || s/^(\[(?:[^\]\\]+|\\.)*\])\s*// # [...] + || s/^([^\s()<>\@,;:\\".[\]]+)\s*// + || s/^([()<>\@,;:\\".[\]])\s*// + ) + { push @words, $1; + next; + } + + croak "Unrecognised line: $_"; + } + + push @words, ","; + \@words; +} + +sub _find_next +{ my ($idx, $tokens, $len) = @_; + + while($idx < $len) + { my $c = $tokens->[$idx]; + return $c if $c eq ',' || $c eq ';' || $c eq '<'; + $idx++; + } + + ""; +} + +sub _complete +{ my ($class, $phrase, $address, $comment) = @_; + + @$phrase || @$comment || @$address + or return undef; + + my $o = $class->new(join(" ",@$phrase), join("",@$address), join(" ",@$comment)); + @$phrase = @$address = @$comment = (); + $o; +} + +#------------ + +sub new(@) +{ my $class = shift; + bless [@_], $class; +} + + +sub parse(@) +{ my $class = shift; + my @line = grep {defined} @_; + my $line = join '', @line; + + my (@phrase, @comment, @address, @objs); + my ($depth, $idx) = (0, 0); + + my $tokens = _tokenise @line; + my $len = @$tokens; + my $next = _find_next $idx, $tokens, $len; + + local $_; + for(my $idx = 0; $idx < $len; $idx++) + { $_ = $tokens->[$idx]; + + 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 phrase { shift->set_or_get(0, @_) } +sub address { shift->set_or_get(1, @_) } +sub comment { shift->set_or_get(2, @_) } + +sub set_or_get($) +{ my ($self, $i) = (shift, shift); + @_ or return $self->[$i]; + + my $val = $self->[$i]; + $self->[$i] = shift if @_; + $val; +} + + +my $atext = '[\-\w !#$%&\'*+/=?^`{|}~]'; +sub format +{ my @addrs; + + foreach (@_) + { my ($phrase, $email, $comment) = @$_; + my @addr; + + if(defined $phrase && length $phrase) + { push @addr + , $phrase =~ /^(?:\s*$atext\s*)+$/o ? $phrase + : $phrase =~ /(?" + if defined $email && length $email; + } + elsif(defined $email && length $email) + { push @addr, $email; + } + + if(defined $comment && $comment =~ /\S/) + { $comment =~ s/^\s*$?/(/; + $comment =~ s/$?\s*$/)/; + } + + push @addr, $comment + if defined $comment && length $comment; + + push @addrs, join(" ", @addr) + if @addr; + } + + join ", ", @addrs; +} + +#------------ + +sub name +{ my $self = shift; + my $phrase = $self->phrase; + my $addr = $self->address; + + $phrase = $self->comment + unless defined $phrase && length $phrase; + + my $name = $self->_extract_name($phrase); + + # first.last@domain address + if($name eq '' && $addr =~ /([^\%\.\@_]+([\._][^\%\.\@_]+)+)[\@\%]/) + { ($name = $1) =~ s/[\._]+/ /g; + $name = _extract_name $name; + } + + 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"; + } + + length $name ? $name : undef; +} + + +sub host +{ my $addr = shift->address || ''; + my $i = rindex $addr, '@'; + $i >= 0 ? substr($addr, $i+1) : undef; +} + + +sub user +{ my $addr = shift->address || ''; + my $i = rindex $addr, '@'; + $i >= 0 ? substr($addr,0,$i) : $addr; +} + +1; diff --git a/cpan/dist/MailTools/lib/Mail/Address.pod b/cpan/dist/MailTools/lib/Mail/Address.pod new file mode 100644 index 00000000..e3eeb066 --- /dev/null +++ b/cpan/dist/MailTools/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 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 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 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, +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-EB( PHRASE, ADDRESS, [ COMMENT ] ) + +Create a new C object which represents an address with the +elements given. In a message these 3 elements would be seen like: + + PHRASE

(COMMENT) + ADDRESS (COMMENT) + +example: + + Mail::Address->new("Perl5 Porters", "perl5-porters@africa.nicoh.com"); + +=item $obj-EB(LINE) + +Parse the given line a return a list of extracted C 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-EB

() + +Return the address part of the object. + +=item $obj-EB() + +Return the comment part of the object + +=item $obj-EB( [ADDRESSes] ) + +Return a string representing the address in a suitable form to be placed +on a C, C, or C 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-EB() + +Return the phrase part of the object. + +=back + +=head2 Smart accessors + +=over 4 + +=item $obj-EB() + +Return the address excluding the user id and '@' + +=item $obj-EB() + +Using the information contained within the object attempt to identify what +the person or groups name is. + +B This function tries to be smart with the "phrase" of the +email address, which is probably a very bad idea. Consider to use +L itself. + +=item $obj-EB() + +Return the address excluding the '@' and the mail domain + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F. + +=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 Eaas@oslonett.noE. +Mail::Field::AddrList by Peter Orbaek Epoe@cit.dkE. +Mail::Mailer and Mail::Send by Tim Bunce ETim.Bunce@ig.co.ukE. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr Egbarr@pobox.comE and +2001-2017 Mark Overmeer Eperl@overmeer.netE. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F + diff --git a/cpan/dist/MailTools/lib/Mail/Cap.pm b/cpan/dist/MailTools/lib/Mail/Cap.pm new file mode 100644 index 00000000..12dbbb4f --- /dev/null +++ b/cpan/dist/MailTools/lib/Mail/Cap.pm @@ -0,0 +1,250 @@ +# Copyrights 1995-2017 by [Mark Overmeer ]. +# For other contributors see ChangeLog. +# See the manual pages for details on the licensing terms. +# Pod stripped from pm file by OODoc 2.02. +package Mail::Cap; +use vars '$VERSION'; +$VERSION = '2.19'; + +use strict; + +sub Version { our $VERSION } + + +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} || (defined $ENV{HOME} ? "$ENV{HOME}/.mailcap:" : '') + . '/etc/mailcap:/usr/etc/mailcap:/usr/local/etc/mailcap' + ); # this path is specified under RFC1524 appendix A +} + +#-------- + +sub new +{ my $class = shift; + + unshift @_, 'filename' if @_ % 2; + my %args = @_; + + my $take_all = $args{take} && uc $args{take} eq 'ALL'; + + my $self = bless {_count => 0}, $class; + + $self->_process_file($args{filename}) + if defined $args{filename} && -r $args{filename}; + + 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"}]; + } + + $self; +} + +sub _process_file +{ my $self = shift; + my $file = shift or return; + + local *MAILCAP; + open MAILCAP, $file + or return; + + $self->{_file} = $file; + + local $_; + while() + { next if /^\s*#/; # comment + next if /^\s*$/; # blank line + $_ .= # 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; + } + + 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(@_)) } + +sub _run($) +{ my ($self, $cmd) = @_; + defined $cmd or return 0; + + system $cmd; + 1; +} + +#------------------ + +sub viewCmd { shift->_createCommand(view => @_) } +sub composeCmd { shift->_createCommand(compose => @_) } +sub editCmd { shift->_createCommand(edit => @_) } +sub printCmd { shift->_createCommand(print => @_) } + +sub _createCommand($$$) +{ my ($self, $method, $type, $file) = @_; + my $entry = $self->getEntry($type, $file); + + $entry && exists $entry->{$method} + or return undef; + + $self->expandPercentMacros($entry->{$method}, $type, $file); +} + +sub makeName($$) +{ my ($self, $type, $basename) = @_; + my $template = $self->nametemplate($type) + or return $basename; + + $template =~ s/%s/$basename/g; + $template; +} + +#------------------ + +sub field($$) +{ my($self, $type, $field) = @_; + my $entry = $self->getEntry($type); + $entry->{$field}; +} + + +sub description { shift->field(shift, 'description'); } +sub textualnewlines { shift->field(shift, 'textualnewlines'); } +sub x11_bitmap { shift->field(shift, 'x11-bitmap'); } +sub nametemplate { shift->field(shift, 'nametemplate'); } + +sub getEntry +{ my($self, $origtype, $file) = @_; + + return $self->{_cache}{$origtype} + if $useCache && exists $self->{_cache}{$origtype}; + + my ($fulltype, @params) = split /\s*;\s*/, $origtype; + my ($type, $subtype) = split m[/], $fulltype, 2; + $subtype ||= ''; + + my $entry; + 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; + $entry; +} + +sub expandPercentMacros +{ 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; + foreach (@params) + { my($key, $val) = split /\s*=\s*/, $_, 2; + $params{$key} = $val; + } + $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; + } + $text =~ s/\0/%/g; + $text; +} + +# This following procedures can be useful for debugging purposes + +sub dumpEntry +{ my($hash, $prefix) = @_; + defined $prefix or $prefix = ""; + print "$prefix$_ = $hash->{$_}\n" + for sort keys %$hash; +} + +sub dump +{ my $self = shift; + foreach (keys %$self) + { next if /^_/; + print "$_\n"; + foreach (@{$self->{$_}}) + { dumpEntry($_, "\t"); + print "\n"; + } + } + + if(exists $self->{_cache}) + { print "Cached types\n"; + print "\t$_\n" + for keys %{$self->{_cache}}; + } +} + +1; diff --git a/cpan/dist/MailTools/lib/Mail/Cap.pod b/cpan/dist/MailTools/lib/Mail/Cap.pod new file mode 100644 index 00000000..96db477b --- /dev/null +++ b/cpan/dist/MailTools/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 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-EB(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-EB(TYPE, FILE) + +=item $obj-EB(TYPE, FILE) + +=item $obj-EB(TYPE, FILE) + +=item $obj-EB(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 if no +suitable specification exists. + +=over 4 + +=item $obj-EB(TYPE, FILE) + +=item $obj-EB(TYPE, FILE) + +=item $obj-EB(TYPE, FILE) + +=item $obj-EB(TYPE, FILE) + +=back + +=head2 Look-up definitions + +Methods return the corresponding mailcap field for the type. + +=over 4 + +=item $obj-EB(TYPE) + +=item $obj-EB(TYPE, FIELD) + +Returns the specified field for the type. Returns undef if no +specification exists. + +=item $obj-EB(TYPE) + +=item $obj-EB(TYPE) + +=item $obj-EB(TYPE) + +=back + +=head1 SEE ALSO + +This module is part of the MailTools distribution, +F. + +=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 Eaas@oslonett.noE. +Mail::Field::AddrList by Peter Orbaek Epoe@cit.dkE. +Mail::Mailer and Mail::Send by Tim Bunce ETim.Bunce@ig.co.ukE. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr Egbarr@pobox.comE and +2001-2017 Mark Overmeer Eperl@overmeer.netE. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F + diff --git a/cpan/dist/MailTools/lib/Mail/Field.pm b/cpan/dist/MailTools/lib/Mail/Field.pm new file mode 100644 index 00000000..6b73823e --- /dev/null +++ b/cpan/dist/MailTools/lib/Mail/Field.pm @@ -0,0 +1,227 @@ +# Copyrights 1995-2017 by [Mark Overmeer ]. +# For other contributors see ChangeLog. +# See the manual pages for details on the licensing terms. +# Pod stripped from pm file by OODoc 2.02. +package Mail::Field; +use vars '$VERSION'; +$VERSION = '2.19'; + + +use strict; + +use Carp; +use Mail::Field::Generic; + + +sub _header_pkg_name +{ my $header = lc shift; + $header =~ s/((\b|_)\w)/\U$1/g; + + 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($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; +} + +sub import +{ my $class = shift; + + if(@_) + { local $_; + eval "require " . _header_pkg_name($_) || die $@ + for @_; + return; + } + + 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; + } + + _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 $thing = shift; + my $method = lc shift; + my $class = shift || ref($thing) || $thing; + + $method =~ tr/-/_/; + $class = _header_pkg_name $method + if $class eq "Mail::Field"; + + croak "Re-register of $method" + if Mail::Field->can($method); + + no strict 'refs'; + *{$method} = sub { + shift; + $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 + +sub _build +{ my $self = bless {}, shift; + @_==1 ? $self->parse(@_) : $self->create(@_); +} + +#------------- + +sub new +{ my $class = shift; + my $field = lc shift; + $field =~ tr/-/_/; + $class->$field(@_); +} + + +sub combine {confess "Combine not implemented" } + +our $AUTOLOAD; +sub AUTOLOAD +{ my $method = $AUTOLOAD; + $method =~ s/.*:://; + + $method =~ /^[^A-Z\x00-\x1f\x80-\xff :]+$/ + or croak "Undefined subroutine &$AUTOLOAD called"; + + my $class = _header_pkg_name $method; + + 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; + + no strict; + @{"${class}::ISA"} = qw(Mail::Field::Generic); + *{"${class}::tag"} = sub { $tag }; + } + + Mail::Field->can($method) + or $class->register($method); + + goto &$AUTOLOAD; +} + + +# Of course, the functionality should have been in the Mail::Header class +sub extract +{ 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; + } + + my $idx = shift || 0; + my $text = $head->get($tag,$idx) + or return undef; + + chomp $text; + $class->$method($text); +} + +#------------- + +# before 2.00, this method could be called as class method, however +# not all extensions supported that. +sub create +{ my ($self, %arg) = @_; + %$self = (); + $self->set(\%arg); +} + + +# 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"; +} + +#------------- + +sub stringify { confess "stringify() not implemented" } + + +sub tag +{ my $thing = shift; + my $tag = ref($thing) || $thing; + $tag =~ s/.*:://; + $tag =~ s/_/-/g; + + join '-', + map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) } + split /\-/, $tag; +} + + +sub set(@) { confess "set() not implemented" } + +# prevent the calling of AUTOLOAD for DESTROY :-) +sub DESTROY {} + +#------------- + +sub text +{ my $self = shift; + @_ ? $self->parse(@_) : $self->stringify; +} + +#------------- + +1; diff --git a/cpan/dist/MailTools/lib/Mail/Field.pod b/cpan/dist/MailTools/lib/Mail/Field.pod new file mode 100644 index 00000000..f8374a1b --- /dev/null +++ b/cpan/dist/MailTools/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 creates and manipulates fields in MIME headers, collected +within a L 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-EB(FIELDS) + +Take a LIST of C objects (which should all be of the same +sub-class) and create a new object in that same class. + +=item Mail::Field-EB( TAG, HEAD [, INDEX ] ) + +Takes as arguments the tag name, a C object +and optionally an index. + +If the index argument is given then C will retrieve the given tag +from the C object and create a new C based object. +I 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 is called. If called in a scalar context the result +will be as if C 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 objects will be returned. + +=item Mail::Field-EB( 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-EB(OPTIONS) + +This constructor is used internally with preprocessed field information. +When called on an existing object, its original content will get +replaced. + +=item $obj-EB() + +Parse a field line. + +=back + +=head2 Accessors + +=over 4 + +=item $obj-EB(OPTIONS) + +Change the settings (the content, but then smart) of this field. + +=item $obj-EB() + +Returns the field as a string. + +=item $obj-EB() + +=item Mail::Field-EB() + +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-EB( [STRING] ) + +Without arguments, the field is returned as L does. Otherwise, +the STRING is parsed with L to replace the object's content. + +It is more clear to call either L or L 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 where I 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 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 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 + +=head1 DIAGNOSTICS + +=over 4 + +=item Error: Undefined subroutine 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. + +=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 Eaas@oslonett.noE. +Mail::Field::AddrList by Peter Orbaek Epoe@cit.dkE. +Mail::Mailer and Mail::Send by Tim Bunce ETim.Bunce@ig.co.ukE. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr Egbarr@pobox.comE and +2001-2017 Mark Overmeer Eperl@overmeer.netE. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F + diff --git a/cpan/dist/MailTools/lib/Mail/Field/AddrList.pm b/cpan/dist/MailTools/lib/Mail/Field/AddrList.pm new file mode 100644 index 00000000..3887b87e --- /dev/null +++ b/cpan/dist/MailTools/lib/Mail/Field/AddrList.pm @@ -0,0 +1,68 @@ +# Copyrights 1995-2017 by [Mark Overmeer ]. +# For other contributors see ChangeLog. +# See the manual pages for details on the licensing terms. +# Pod stripped from pm file by OODoc 2.02. +use strict; + +package Mail::Field::AddrList; +use vars '$VERSION'; +$VERSION = '2.19'; + +use base 'Mail::Field'; + +use Carp; +use Mail::Address; + + +my $x = bless []; +$x->register('To'); +$x->register('From'); +$x->register('Cc'); +$x->register('Reply-To'); +$x->register('Sender'); + +sub create(@) +{ my ($self, %arg) = @_; + $self->{AddrList} = {}; + + while(my ($e, $n) = each %arg) + { $self->{AddrList}{$e} = Mail::Address->new($n, $e); + } + + $self; +} + +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; + join(", ", map { $_->format } values %{$self->{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) = @_; + $self->{AddrList}{$email} = Mail::Address->new($name, $email); + $self; +} + +1; diff --git a/cpan/dist/MailTools/lib/Mail/Field/AddrList.pod b/cpan/dist/MailTools/lib/Mail/Field/AddrList.pod new file mode 100644 index 00000000..a42091fd --- /dev/null +++ b/cpan/dist/MailTools/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 '); + + # 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, C, C, C, and C. + +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-EB(FIELDS) + +Inherited, see L + +=item Mail::Field::AddrList-EB( TAG, HEAD [, INDEX ] ) + +Inherited, see L + +=item Mail::Field::AddrList-EB( TAG [, STRING | OPTIONS] ) + +Inherited, see L + +=back + +=head2 "Fake" constructors + +Extends L<""Fake" constructors" in Mail::Field|Mail::Field/""Fake" constructors">. + +=over 4 + +=item $obj-EB(OPTIONS) + +Inherited, see L + +=item $obj-EB() + +Inherited, see L + +=back + +=head2 Accessors + +Extends L<"Accessors" in Mail::Field|Mail::Field/"Accessors">. + +=over 4 + +=item $obj-EB(OPTIONS) + +Inherited, see L + +=item $obj-EB() + +Inherited, see L + +=item $obj-EB() + +=item Mail::Field::AddrList-EB() + +Inherited, see L + +=back + +=head2 Smart accessors + +Extends L<"Smart accessors" in Mail::Field|Mail::Field/"Smart accessors">. + +=over 4 + +=item $obj-EB() + +Returns the collected L objects. + +=item $obj-EB() + +Returns a list if email addresses, found in the field content. + +=item $obj-EB() + +Returns a list of nicely formatted named, for each of the addresses +found in the content. + +=item $obj-EB(EMAIL, NAME) + +Add/replace an EMAIL address to the field. + +=item $obj-EB( [STRING] ) + +Inherited, see L + +=back + +=head1 DETAILS + +Extends L<"DETAILS" in Mail::Field|Mail::Field/"DETAILS">. + +=head1 DIAGNOSTICS + +=over 4 + +=item Error: Undefined subroutine 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. + +=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 Eaas@oslonett.noE. +Mail::Field::AddrList by Peter Orbaek Epoe@cit.dkE. +Mail::Mailer and Mail::Send by Tim Bunce ETim.Bunce@ig.co.ukE. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr Egbarr@pobox.comE and +2001-2017 Mark Overmeer Eperl@overmeer.netE. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F + diff --git a/cpan/dist/MailTools/lib/Mail/Field/Date.pm b/cpan/dist/MailTools/lib/Mail/Field/Date.pm new file mode 100644 index 00000000..303d0ecc --- /dev/null +++ b/cpan/dist/MailTools/lib/Mail/Field/Date.pm @@ -0,0 +1,62 @@ +# Copyrights 1995-2017 by [Mark Overmeer ]. +# For other contributors see ChangeLog. +# See the manual pages for details on the licensing terms. +# Pod stripped from pm file by OODoc 2.02. +use strict; + +package Mail::Field::Date; +use vars '$VERSION'; +$VERSION = '2.19'; + +use base 'Mail::Field'; + +use Date::Format qw(time2str); +use Date::Parse qw(str2time); + +(bless [])->register('Date'); + + +sub set() +{ my $self = shift; + my $arg = @_ == 1 ? shift : { @_ }; + + foreach my $s (qw(Time TimeStr)) + { if(exists $arg->{$s}) + { $self->{$s} = $arg->{$s} } + else { delete $self->{$s} } + } + + $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; + } + + $self->{Time} ||= str2time $self->{TimeStr}; +} + +sub stringify +{ 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; +} + +1; diff --git a/cpan/dist/MailTools/lib/Mail/Field/Date.pod b/cpan/dist/MailTools/lib/Mail/Field/Date.pod new file mode 100644 index 00000000..2a41e19f --- /dev/null +++ b/cpan/dist/MailTools/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-EB(FIELDS) + +Inherited, see L + +=item Mail::Field::Date-EB( TAG, HEAD [, INDEX ] ) + +Inherited, see L + +=item Mail::Field::Date-EB( TAG [, STRING | OPTIONS] ) + +Inherited, see L + +=back + +=head2 "Fake" constructors + +Extends L<""Fake" constructors" in Mail::Field|Mail::Field/""Fake" constructors">. + +=over 4 + +=item $obj-EB(OPTIONS) + +Inherited, see L + +=item $obj-EB() + +Inherited, see L + +=back + +=head2 Accessors + +Extends L<"Accessors" in Mail::Field|Mail::Field/"Accessors">. + +=over 4 + +=item $obj-EB(OPTIONS) + + -Option --Default + Time undef + TimeStr undef + +=over 2 + +=item Time => SECONDS + +=item TimeStr => STRING + +A string acceptable to Date::Parse. + +=back + +=item $obj-EB() + +Inherited, see L + +=item $obj-EB() + +=item Mail::Field::Date-EB() + +Inherited, see L + +=back + +=head2 Smart accessors + +Extends L<"Smart accessors" in Mail::Field|Mail::Field/"Smart accessors">. + +=over 4 + +=item $obj-EB( [STRING] ) + +Inherited, see L + +=item $obj-EB( [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 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. + +=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 Eaas@oslonett.noE. +Mail::Field::AddrList by Peter Orbaek Epoe@cit.dkE. +Mail::Mailer and Mail::Send by Tim Bunce ETim.Bunce@ig.co.ukE. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr Egbarr@pobox.comE and +2001-2017 Mark Overmeer Eperl@overmeer.netE. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F + diff --git a/cpan/dist/MailTools/lib/Mail/Field/Generic.pm b/cpan/dist/MailTools/lib/Mail/Field/Generic.pm new file mode 100644 index 00000000..2a9d193c --- /dev/null +++ b/cpan/dist/MailTools/lib/Mail/Field/Generic.pm @@ -0,0 +1,33 @@ +# Copyrights 1995-2017 by [Mark Overmeer ]. +# For other contributors see ChangeLog. +# See the manual pages for details on the licensing terms. +# Pod stripped from pm file by OODoc 2.02. +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/dist/MailTools/lib/Mail/Field/Generic.pod b/cpan/dist/MailTools/lib/Mail/Field/Generic.pod new file mode 100644 index 00000000..cdb90560 --- /dev/null +++ b/cpan/dist/MailTools/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, C, +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-EB(FIELDS) + +Inherited, see L + +=item Mail::Field::Generic-EB( TAG, HEAD [, INDEX ] ) + +Inherited, see L + +=item Mail::Field::Generic-EB( TAG [, STRING | OPTIONS] ) + +Inherited, see L + +=back + +=head2 "Fake" constructors + +Extends L<""Fake" constructors" in Mail::Field|Mail::Field/""Fake" constructors">. + +=over 4 + +=item $obj-EB(OPTIONS) + + -Option--Default + Text '' + +=over 2 + +=item Text => STRING + +=back + +=item $obj-EB( [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-EB(OPTIONS) + +Inherited, see L + +=item $obj-EB() + +Inherited, see L + +=item $obj-EB() + +=item Mail::Field::Generic-EB() + +Inherited, see L + +=back + +=head2 Smart accessors + +Extends L<"Smart accessors" in Mail::Field|Mail::Field/"Smart accessors">. + +=over 4 + +=item $obj-EB( [STRING] ) + +Inherited, see L + +=back + +=head1 DETAILS + +Extends L<"DETAILS" in Mail::Field|Mail::Field/"DETAILS">. + +=head1 DIAGNOSTICS + +=over 4 + +=item Error: Undefined subroutine 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. + +=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 Eaas@oslonett.noE. +Mail::Field::AddrList by Peter Orbaek Epoe@cit.dkE. +Mail::Mailer and Mail::Send by Tim Bunce ETim.Bunce@ig.co.ukE. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr Egbarr@pobox.comE and +2001-2017 Mark Overmeer Eperl@overmeer.netE. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F + diff --git a/cpan/dist/MailTools/lib/Mail/Filter.pm b/cpan/dist/MailTools/lib/Mail/Filter.pm new file mode 100644 index 00000000..05320f9d --- /dev/null +++ b/cpan/dist/MailTools/lib/Mail/Filter.pm @@ -0,0 +1,70 @@ +# Copyrights 1995-2017 by [Mark Overmeer ]. +# For other contributors see ChangeLog. +# See the manual pages for details on the licensing terms. +# Pod stripped from pm file by OODoc 2.02. +package Mail::Filter; +use vars '$VERSION'; +$VERSION = '2.19'; + + +use strict; +use Carp; + + +sub new(@) +{ my $class = shift; + bless { filters => [ @_ ] }, $class; +} + +#------------ + +sub add(@) +{ my $self = shift; + push @{$self->{filters}}, @_; +} + +#------------ + +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; + } + + $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}; + } + elsif($obj->isa('Mail::Internet')) + { return $self->filter($obj); + } + else + { carp "Cannot process '$obj'"; + return undef; + } +} + + +sub folder() {shift->{folder}} + + +sub msgnum() {shift->{msgnum}} + +1; diff --git a/cpan/dist/MailTools/lib/Mail/Filter.pod b/cpan/dist/MailTools/lib/Mail/Filter.pod new file mode 100644 index 00000000..e4397c72 --- /dev/null +++ b/cpan/dist/MailTools/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 provides an interface to filtering Email through multiple +subroutines. + +C 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 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-EB( [FILTER [, ... ]] ) + +Create a new C object with the given filter subroutines. Each +filter may be either a code reference or the name of a method to call +on the object. + +=back + +=head2 Accessors + +=over 4 + +=item $obj-EB( FILTER [, FILTER ...] ) + +Add the given filters to the end of the filter list. + +=back + +=head2 Processing + +=over 4 + +=item $obj-EB(MAIL-OBJECT | MAIL-FOLDER) + +If the first argument is a C object, then this object will +be passed through the filter list. If the first argument is a C +object, then each message in turn will be passed through the filter list. + +=item $obj-EB() + +While the C method is called with a C object, these +filter subroutines can call this method to obtain the folder object that is +being processed. + +=item $obj-EB() + +If the C method is called with a C 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. + +=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 Eaas@oslonett.noE. +Mail::Field::AddrList by Peter Orbaek Epoe@cit.dkE. +Mail::Mailer and Mail::Send by Tim Bunce ETim.Bunce@ig.co.ukE. +For other contributors see ChangeLog. + +=head1 LICENSE + +Copyrights 1995-2000 Graham Barr Egbarr@pobox.comE and +2001-2017 Mark Overmeer Eperl@overmeer.netE. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. +See F + diff --git a/cpan/dist/MailTools/lib/Mail/Header.pm b/cpan/dist/MailTools/lib/Mail/Header.pm new file mode 100644 index 00000000..a999f656 --- /dev/null +++ b/cpan/dist/MailTools/lib/Mail/Header.pm @@ -0,0 +1,632 @@ +# Copyrights 1995-2017 by [Mark Overmeer ]. +# For other contributors see ChangeLog. +# See the manual pages for details on the licensing terms. +# Pod stripped from pm file by OODoc 2.02. +package Mail::Header; +use vars '$VERSION'; +$VERSION = '2.19'; + + +use strict; +use Carp; + +my $MAIL_FROM = 'KEEP'; +my %HDR_LENGTHS = (); + +our $FIELD_NAME = '[^\x00-\x1f\x7f-\xff :]+:'; + + +## +## Private functions +## + +sub _error { warn @_; () } + +# tidy up internal hash table and list + +sub _tidy_header +{ my $self = shift; + my $deleted = 0; + + for(my $i = 0 ; $i < @{$self->{mail_hdr_list}}; $i++) + { next if defined $self->{mail_hdr_list}[$i]; + + splice @{$self->{mail_hdr_list}}, $i, 1; + $deleted++; + $i--; + } + + if($deleted) + { local $_; + my @del; + + while(my ($key,$ref) = each %{$self->{mail_hdr_hash}} ) + { push @del, $key + unless @$ref = grep { ref $_ && defined $$_ } @$ref; + } + + delete $self->{'mail_hdr_hash'}{$_} for @del; + } +} + +# fold the line to the given length + +my %STRUCTURE = map { (lc $_ => undef) } + qw{ To Cc Bcc From Date Reply-To Sender + Resent-Date Resent-From Resent-Sender Resent-To Return-Path + list-help list-post list-unsubscribe Mailing-List + Received References Message-ID In-Reply-To + Content-Length Content-Type Content-Disposition + Delivered-To + Lines + MIME-Version + Precedence + Status + }; + +sub _fold_line +{ my($ln,$maxlen) = @_; + + $maxlen = 20 + if $maxlen < 20; + + my $max = int($maxlen - 5); # 4 for leading spcs + 1 for [\,\;] + my $min = int($maxlen * 4 / 5) - 4; + + $_[0] =~ s/[\r\n]+//og; # Remove new-lines + $_[0] =~ s/\s*\Z/\n/so; # End line with a EOLN + + return if $_[0] =~ /^From\s/io; + + if(length($_[0]) > $maxlen) + { if($_[0] =~ /^([-\w]+)/ && exists $STRUCTURE{ lc $1 } ) + { #Split the line up + # first bias towards splitting at a , or a ; >4/5 along the line + # next split a whitespace + # else we are looking at a single word and probably don't want to split + my $x = ""; + $x .= "$1\n " while $_[0] =~ + s/^\s* + ( [^"]{$min,$max} [,;] + | [^"]{1,$max} [,;\s] + | [^\s"]*(?:"[^"]*"[ \t]?[^\s"]*)+\s + ) //x; + + $x .= $_[0]; + $_[0] = $x; + $_[0] =~ s/(\A\s+|[\t ]+\Z)//sog; + $_[0] =~ s/\s+\n/\n/sog; + } + else + { $_[0] =~ s/(.{$min,$max})(\s)/$1\n$2/g; + $_[0] =~ s/\s*$/\n/s; + } + } + + $_[0] =~ s/\A(\S+)\n\s*(?=\S)/$1 /so; +} + +# Tags are case-insensitive, but there is a (slightly) preferred construction +# being all characters are lowercase except the first of each word. Also +# if the word is an `acronym' then all characters are uppercase. We decide +# a word is an acronym if it does not contain a vowel. +# In general, this change of capitalization is a bad idea, but it is in +# the code for ages, and therefore probably crucial for existing +# applications. + +sub _tag_case +{ my $tag = shift; + $tag =~ s/\:$//; + join '-' + , map { /^[b-df-hj-np-tv-z]+$|^(?:MIME|SWE|SOAP|LDAP|ID)$/i + ? uc($_) : ucfirst(lc($_)) + } split m/\-/, $tag, -1; +} + +# format a complete line +# ensure line starts with the given tag +# ensure tag is correct case +# change the 'From ' tag as required +# fold the line + +sub _fmt_line +{ my ($self, $tag, $line, $modify) = @_; + $modify ||= $self->{mail_hdr_modify}; + my $ctag = undef; + + ($tag) = $line =~ /^($FIELD_NAME|From )/oi + unless defined $tag; + + if(defined $tag && $tag =~ /^From /io && $self->{mail_hdr_mail_from} ne 'KEEP') + { if($self->{mail_hdr_mail_from} eq 'COERCE') + { $line =~ s/^From /Mail-From: /o; + $tag = "Mail-From:"; + } + elsif($self->{mail_hdr_mail_from} eq 'IGNORE') + { return (); + } + elsif($self->{mail_hdr_mail_from} eq 'ERROR') + { return _error "unadorned 'From ' ignored: <$line>"; + } + } + + if(defined $tag) + { $tag = _tag_case($ctag = $tag); + $ctag = $tag if $modify; + $ctag =~ s/([^ :])$/$1:/o if defined $ctag; + } + + defined $ctag && $ctag =~ /^($FIELD_NAME|From )/oi + or croak "Bad RFC822 field name '$tag'\n"; + + # Ensure the line starts with tag + if(defined $ctag && ($modify || $line !~ /^\Q$ctag\E/i)) + { (my $xtag = $ctag) =~ s/\s*\Z//o; + $line =~ s/^(\Q$ctag\E)?\s*/$xtag /i; + } + + my $maxlen = $self->{mail_hdr_lengths}{$tag} + || $HDR_LENGTHS{$tag} + || $self->fold_length; + + if ($modify && defined $maxlen) + { # folding will fix bad header continuations for us + _fold_line $line, $maxlen; + } + elsif($line =~ /\r?\n\S/) + { return _error "Bad header continuation, skipping '$tag': ", + "no space after newline in '$line'\n"; + } + + + $line =~ s/\n*$/\n/so; + ($tag, $line); +} + +sub _insert +{ my ($self, $tag, $line, $where) = @_; + + if($where < 0) + { $where = @{$self->{mail_hdr_list}} + $where + 1; + $where = 0 if $where < 0; + } + elsif($where >= @{$self->{mail_hdr_list}}) + { $where = @{$self->{mail_hdr_list}}; + } + + my $atend = $where == @{$self->{mail_hdr_list}}; + splice @{$self->{mail_hdr_list}}, $where, 0, $line; + + $self->{mail_hdr_hash}{$tag} ||= []; + my $ref = \${$self->{mail_hdr_list}}[$where]; + + my $def = $self->{mail_hdr_hash}{$tag}; + if($def && $where) + { if($atend) { push @$def, $ref } + else + { my $i = 0; + foreach my $ln (@{$self->{mail_hdr_list}}) + { my $r = \$ln; + last if $r == $ref; + $i++ if $r == $def->[$i]; + } + splice @$def, $i, 0, $ref; + } + } + else + { unshift @$def, $ref; + } +} + +#------------ + +sub new +{ my $call = shift; + my $class = ref($call) || $call; + my $arg = @_ % 2 ? shift : undef; + my %opt = @_; + + $opt{Modify} = delete $opt{Reformat} + unless exists $opt{Modify}; + + my $self = bless + { mail_hdr_list => [] + , mail_hdr_hash => {} + , mail_hdr_modify => (delete $opt{Modify} || 0) + , mail_hdr_foldlen => 79 + , mail_hdr_lengths => {} + }, $class; + + $self->mail_from( uc($opt{MailFrom} || $MAIL_FROM) ); + + $self->fold_length($opt{FoldLength}) + if exists $opt{FoldLength}; + + if(!ref $arg) {} + elsif(ref($arg) eq 'ARRAY') { $self->extract( [ @$arg ] ) } + elsif(defined fileno($arg)) { $self->read($arg) } + + $self; +} + + +sub dup +{ my $self = shift; + my $dup = ref($self)->new; + + %$dup = %$self; + $dup->empty; # rebuild tables + + $dup->{mail_hdr_list} = [ @{$self->{mail_hdr_list}} ]; + + foreach my $ln ( @{$dup->{mail_hdr_list}} ) + { my $tag = _tag_case +($ln =~ /^($FIELD_NAME|From )/oi)[0]; + push @{$dup->{mail_hdr_hash}{$tag}}, \$ln; + } + + $dup; +} + +#------------ + +sub extract +{ my ($self, $lines) = @_; + $self->empty; + + while(@$lines) + { my $line = shift @$lines; + last if $line =~ /^\r?$/; + + $line =~ /^($FIELD_NAME|From )/o or next; + my $tag = $1; + + $line .= shift @$lines + while @$lines && $lines->[0] =~ /^[ \t]+/; + + ($tag, $line) = _fmt_line $self, $tag, $line; + + _insert $self, $tag, $line, -1 + if defined $line; + } + + $self; +} + + +sub read +{ my ($self, $fd) = @_; + $self->empty; + + my ($ln, $tag, $line); + while(1) + { $ln = <$fd>; + + if(defined $ln && defined $line && $ln =~ /^[ \t]+/) + { $line .= $ln; # folded line + next; + } + + if(defined $line) + { ($tag, $line) = _fmt_line $self, $tag, $line; + _insert $self, $tag, $line, -1 + if defined $line; + ($tag, $line) = (); + } + + last if !defined $ln || $ln =~ m/^\r?$/; + + $ln =~ /^($FIELD_NAME|From )/o or next; + ($tag, $line) = ($1, $ln); + } + + $self; +} + + +sub empty +{ my $self = shift; + $self->{mail_hdr_list} = []; + $self->{mail_hdr_hash} = {}; + $self; +} + + +sub header +{ my $self = shift; + + $self->extract(@_) + if @_; + + $self->fold + if $self->{mail_hdr_modify}; + + [ @{$self->{mail_hdr_list}} ]; +} + + +sub header_hashref +{ my ($self, $hashref) = @_; + + while(my ($key, $value) = each %$hashref) + { $self->add($key, $_) for ref $value ? @$value : $value; + } + + $self->fold + if $self->{mail_hdr_modify}; + + defined wantarray # MO, added minimal optimization + or return; + + +{ map { ($_ => [$self->get($_)] ) } # MO: Eh? + keys %{$self->{mail_hdr_hash}} + }; +} + +#------------ + +sub modify +{ my $self = shift; + my $old = $self->{mail_hdr_modify}; + + $self->{mail_hdr_modify} = 0 + shift + if @_; + + $old; +} + + +sub mail_from +{ my $thing = shift; + my $choice = uc shift; + + $choice =~ /^(IGNORE|ERROR|COERCE|KEEP)$/ + or die "bad Mail-From choice: '$choice'"; + + if(ref $thing) { $thing->{mail_hdr_mail_from} = $choice } + else { $MAIL_FROM = $choice } + + $thing; +} + + +sub fold_length +{ my $thing = shift; + my $old; + + if(@_ == 2) + { my $tag = _tag_case shift; + my $len = shift; + + my $hash = ref $thing ? $thing->{mail_hdr_lengths} : \%HDR_LENGTHS; + $old = $hash->{$tag}; + $hash->{$tag} = $len > 20 ? $len : 20; + } + else + { my $self = $thing; + my $len = shift; + $old = $self->{mail_hdr_foldlen}; + + if(defined $len) + { $self->{mail_hdr_foldlen} = $len > 20 ? $len : 20; + $self->fold if $self->{mail_hdr_modify}; + } + } + + $old; +} + +#------------ + +sub fold +{ my ($self, $maxlen) = @_; + + while(my ($tag, $list) = each %{$self->{mail_hdr_hash}}) + { my $len = $maxlen + || $self->{mail_hdr_lengths}{$tag} + || $HDR_LENGTHS{$tag} + || $self->fold_length; + + foreach my $ln (@$list) + { _fold_line $$ln, $len + if defined $ln; + } + } + + $self; +} + + +sub unfold +{ my $self = shift; + + if(@_) + { my $tag = _tag_case shift; + my $list = $self->{mail_hdr_hash}{$tag} + or return $self; + + foreach my $ln (@$list) + { $$ln =~ s/\r?\n\s+/ /sog + if defined $ln && defined $$ln; + } + + return $self; + } + + while( my ($tag, $list) = each %{$self->{mail_hdr_hash}}) + { foreach my $ln (@$list) + { $$ln =~ s/\r?\n\s+/ /sog + if defined $ln && defined $$ln; + } + } + + $self; +} + + +sub add +{ my ($self, $tag, $text, $where) = @_; + ($tag, my $line) = _fmt_line $self, $tag, $text; + + defined $tag && defined $line + or return undef; + + defined $where + or $where = -1; + + _insert $self, $tag, $line, $where; + + $line =~ /^\S+\s(.*)/os; + $1; +} + + +sub replace +{ my $self = shift; + my $idx = @_ % 2 ? pop @_ : 0; + + my ($tag, $line); + TAG: + while(@_) + { ($tag,$line) = _fmt_line $self, splice(@_,0,2); + + defined $tag && defined $line + or return undef; + + my $field = $self->{mail_hdr_hash}{$tag}; + if($field && defined $field->[$idx]) + { ${$field->[$idx]} = $line } + else { _insert $self, $tag, $line, -1 } + } + + $line =~ /^\S+\s*(.*)/os; + $1; +} + + +sub combine +{ my $self = shift; + my $tag = _tag_case shift; + my $with = shift || ' '; + + $tag =~ /^From /io && $self->{mail_hdr_mail_from} ne 'KEEP' + and return _error "unadorned 'From ' ignored"; + + my $def = $self->{mail_hdr_hash}{$tag} + or return undef; + + return $def->[0] + if @$def <= 1; + + my @lines = $self->get($tag); + chomp @lines; + + my $line = (_fmt_line $self, $tag, join($with,@lines), 1)[1]; + + $self->{mail_hdr_hash}{$tag} = [ \$line ]; + $line; +} + + +sub get +{ my $self = shift; + my $tag = _tag_case shift; + my $idx = shift; + + my $def = $self->{mail_hdr_hash}{$tag} + or return (); + + my $l = length $tag; + $l += 1 if $tag !~ / $/o; + + if(defined $idx || !wantarray) + { $idx ||= 0; + defined $def->[$idx] or return undef; + my $val = ${$def->[$idx]}; + defined $val or return undef; + + $val = substr $val, $l; + $val =~ s/^\s+//; + return $val; + } + + map { my $tmp = substr $$_,$l; $tmp =~ s/^\s+//; $tmp } @$def; +} + + + +sub count +{ my $self = shift; + my $tag = _tag_case shift; + my $def = $self->{mail_hdr_hash}{$tag}; + defined $def ? scalar(@$def) : 0; +} + + + +sub delete +{ my $self = shift; + my $tag = _tag_case shift; + my $idx = shift; + my @val; + + if(my $def = $self->{mail_hdr_hash}{$tag}) + { my $l = length $tag; + $l += 2 if $tag !~ / $/; + + if(defined $idx) + { if(defined $def->[$idx]) + { push @val, substr ${$def->[$idx]}, $l; + undef ${$def->[$idx]}; + } + } + else + { @val = map {my $x = substr $$_,$l; undef $$_; $x } @$def; + } + + _tidy_header($self); + } + + @val; +} + + + +sub print +{ my $self = shift; + my $fd = shift || \*STDOUT; + + foreach my $ln (@{$self->{mail_hdr_list}}) + { defined $ln or next; + print $fd $ln or return 0; + } + + 1; +} + + +sub as_string { join '', grep {defined} @{shift->{mail_hdr_list}} } + + +sub tags { keys %{shift->{mail_hdr_hash}} } + + +sub cleanup +{ my $self = shift; + my $deleted = 0; + + foreach my $key (@_ ? @_ : keys %{$self->{mail_hdr_hash}}) + { my $fields = $self->{mail_hdr_hash}{$key}; + foreach my $field (@$fields) + { next if $$field =~ /^\S+\s+\S/s; + undef $$field; + $deleted++; + } + } + + _tidy_header $self + if $deleted; + + $self; +} + +1; diff --git a/cpan/dist/MailTools/lib/Mail/Header.pod b/cpan/dist/MailTools/lib/Mail/Header.pod new file mode 100644 index 00000000..9f90f4f8 --- /dev/null +++ b/cpan/dist/MailTools/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 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-EB() + +Create a duplicate of the current object. + +=item $obj-EB( [ARG], [OPTIONS] ) + +=item Mail::Header-EB( [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. + +=item MailFrom => 'IGNORE'|'COERCE'|'KEEP'|'ERROR' + +See method L. + +=item Modify => BOOLEAN + +If this value is I 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-EB() + +Empty an existing C object of all lines. + +=item $obj-EB(ARRAY) + +Extract a header from the given array into an existing Mail::Header +object. C B this array. +Returns the object that the method was called on. + +=item $obj-EB

( [ARRAY] ) + +C

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-EB( [HASH] ) + +As L, 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 '; + $fields->{To} = ['you@somewhere', 'me@localhost']; + $head->header_hashref($fields); + +=item $obj-EB(FILEHANDLE) + +Read a header from the given file descriptor into an existing Mail::Header +object. + +=back + +=head2 Accessors + +=over 4 + +=item $obj-EB( [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 +is given it sets the default fold length for the current object. + +In the two argument form C may be called as a static method, +setting default fold lengths for tags that will be used by B +C objects. See the C method for +a description on how C uses these values. + +=item $obj-EB('IGNORE'|'COERCE'|'KEEP'|'ERROR') + +This specifies what to do when a C<`From '> line is encountered. +Valid values are C - ignore and discard the header, +C - invoke an error (call die), C - rename them as Mail-From +and C - keep them. + +=item $obj-EB( [VALUE] ) + +If C is I then C 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-EB( TAG, LINE [, INDEX] ) + +Add a new line to the header. If TAG is C 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-EB() + +Returns the header as a single string. + +=item $obj-EB() + +Remove any header line that, other than the tag, only contains whitespace + +=item $obj-EB( 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-EB(TAG) + +Returns the number of times the given atg appears in the header + +=item $obj-EB( 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-EB( [LENGTH] ) + +Fold the header. If LENGTH is not given, then C uses the +following rules to determine what length to fold a line. + +=item $obj-EB( 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 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) + +=item $obj-EB( [FILEHANDLE] ) + +Print the header to the given file descriptor, or C if no +file descriptor is given. + +=item $obj-EB( TAG, LINE [, INDEX ] ) + +Replace a line in the header. If TAG is C 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-EB() + +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