diff options
| author | fukachan <fukachan> | 2001-01-19 13:55:05 +0000 |
|---|---|---|
| committer | fukachan <fukachan> | 2001-01-19 13:55:05 +0000 |
| commit | d63380e790c2f93ae981a0425b85d22601c1acaa (patch) | |
| tree | 255ceabf69b7a95c02f3a648ddf4c194f66eeb3b | |
| parent | 4377641665acbf1a4a83883241afe392e88ec112 (diff) | |
| download | fml8-d63380e790c2f93ae981a0425b85d22601c1acaa.tar.gz fml8-d63380e790c2f93ae981a0425b85d22601c1acaa.tar.bz2 fml8-d63380e790c2f93ae981a0425b85d22601c1acaa.zip | |
Initial revision
48 files changed, 10352 insertions, 0 deletions
diff --git a/cpan/dist/MailTools/ChangeLog b/cpan/dist/MailTools/ChangeLog new file mode 100644 index 00000000..337201da --- /dev/null +++ b/cpan/dist/MailTools/ChangeLog @@ -0,0 +1,482 @@ +Change 583 on 2000/09/04 by <gbarr@pobox.com> (Graham Barr) + + Mail::Address + - Remove some unneeded \'s in regex patterns (to keep 5.7.0 quiet) + +Change 582 on 2000/09/04 by <gbarr@pobox.com> (Graham Barr) + + Mail::Alias + - Removed. Now distributed separatly and maintained by + Tom Zeltwanger (ZELT) + +Change 581 on 2000/09/04 by <gbarr@pobox.com> (Graham Barr) + + Mail::Mailer + - Remove newlines from the lines in the Mail::Header object + +Change 575 on 2000/08/24 by <gbarr@pobox.com> (Graham Barr) + + Mail::Mailer::mail + - Fix problems with open(STDERR) when using under FCGI + +Change 571 on 2000/08/24 by <gbarr@pobox.com> (Graham Barr) + + Mail::Mailer + - Deafulr Win32 to smtp + +Change 521 on 2000/05/16 by <gbarr@pobox.com> (Graham Barr) + + Mail::Internet + - Added Debug and Port options to smtpsend + +Change 520 on 2000/05/16 by <gbarr@pobox.com> (Graham Barr) + + Mail::Header + - Another fix for badly formed headers in _fold_line + - get MIME right in _tag_case + +Change 519 on 2000/05/16 by <gbarr@pobox.com> (Graham Barr) + + t/mailcap.t + - Do not assume user has perl in $PATH + +Change 502 on 2000/05/02 by <gbarr@pobox.com> (Graham Barr) + + Mail::Field + - readdir returns files in the correct case, duh! + +Change 501 on 2000/04/30 by <gbarr@pobox.com> (Graham Barr) + + Mail::Header + * Don't attempt to do a structured fold on non-structured header lines + +Change 498 on 2000/04/30 by <gbarr@pobox.com> (Graham Barr) + + Mail::Cap + - Fix pod typo + +Change 490 on 2000/04/14 by <gbarr@pobox.com> (Graham Barr) + + Remove test in t/internet.t that sends an Email + +Change 457 on 2000/03/29 by <gbarr@pobox.com> (Graham Barr) + + Release 1.14 + +Change 456 on 2000/03/29 by <gbarr@pobox.com> (Graham Barr) + + Makefile.PL + - Added PPD stuff + +Change 429 on 2000/03/28 by <gbarr@pobox.com> (Graham Barr) + + Makefile.PL changes + +Change 428 on 2000/03/28 by <gbarr@pobox.com> (Graham Barr) + + Mail::Mailer::sendmail + - Remove @$to from command line as we pass -t + +Change 427 on 2000/03/28 by <gbarr@pobox.com> (Graham Barr) + + Mail::Send + - to,cc and bcc should pass addresses as a list not as single + string of , separated addresses + +Change 426 on 2000/03/28 by <gbarr@pobox.com> (Graham Barr) + + Mail::Mailer::smtp + - override the close method from Mail::Mailer + +Change 425 on 2000/03/28 by <gbarr@pobox.com> (Graham Barr) + + Mail::Internet + - _prephdr needed to use Mail::Util + +Change 424 on 2000/03/28 by <gbarr@pobox.com> (Graham Barr) + + Mail::Field + - Generic packages do not have a file to require, so only require + if !$pkg->can('stringify') + +Change 416 on 2000/03/28 by <gbarr@pobox.com> (Graham Barr) + + undef warning fix in Mail::Mailer::is_exe + +Change 415 on 2000/03/28 by <gbarr@pobox.com> (Graham Barr) + + Changes from <tobiasb@funcom.com> (Tobias Brox) + Mail::Internet + - now have a send sub for sending emails + Mail::Header + - now have a header_hashref sub which allows modification of the + object through hashrefs + +Change 360 on 2000/02/16 by <gbarr@pobox.com> (Graham Barr) + + Mail::Address + - Fix for nested comments + +Change 350 on 2000/01/26 by <gbarr@pobox.com> (Graham Barr) + + Mail::Header + - combine() should just return the line if there is only one + +Change 349 on 2000/01/26 by <gbarr@pobox.com> (Graham Barr) + + Mail::Header + - Fix bug in fold_line for when a header line only contains + a tag + +Change 335 on 1999/09/24 by <gbarr@pobox.com> (Graham Barr) + + Mail::Internet + - Added Hello option to smtpsend() + +Change 292 on 1999/03/31 by <gbarr@pobox.com> (Graham Barr) + + Release 1.13 + +Change 291 on 1999/03/31 by <gbarr@pobox.com> (Graham Barr) + + Mail::Header + - fold_line now skips X-Face lines + + Mail::Filter + - Applied patch from <pncu_ss@uhura.cc.rochester.edu> (Josh Pincus) + * Added return value to _filter() so that the function returns + the result of the last subroutine in the list of filters. + (the manpage specifies that one should have been able to do this + originally.) + + Mail::Mailer + - Treat VMS the same as MacOS as neither have sendmail et al. + + Mail::Mailer::smtp + - Server can now be specified to Mail::Mailer contructor + + Mail::Alias, Mail::Util,Mail:Internet, Mail::Cap + - local-ize some globals used + + Mail::Cap + - check in $ENV{HOME} is defined + + Mail::Address + - Fix capitalization problems with names like "Ließegang" + +Change 290 on 1999/03/31 by <gbarr@pobox.com> (Graham Barr) + + Increment version + +Change 213 on 1998/10/22 by <gbarr@pobox.com> (Graham Barr) + + Mail::Address + - Fix use of uninitialized warning + +Change 190 on 1998/09/26 by <gbarr@pobox.com> (Graham Barr) + + Update Makefile.PL for release 1.12 + +Change 189 on 1998/09/26 by <gbarr@pobox.com> (Graham Barr) + + Mail::Internet + - Added options to smtpsend + + Mail::Send + - Updated docs for 'smtp' + +Change 188 on 1998/09/26 by <gbarr@pobox.com> (Graham Barr) + + Mail::Header + - Fix _fold_line for lines which contain quoted strings + +Change 172 on 1998/07/10 by <gbarr@pobox.com> (Graham Barr) + + Mail::Address + - avoid warnings if undef is passed to parse() + +Change 169 on 1998/07/04 by <gbarr@pobox.com> (Graham Barr) + + Mail::Address + - tweak to format to ensure comment is delimeted by () + - typo in docs + +Change 168 on 1998/07/04 by <gbarr@pobox.com> (Graham Barr) + + - Documentation update to Mail::Internet + +Change 166 on 1998/07/03 by <gbarr@pobox.com> (Graham Barr) + + Mail::Cap + - Fixed mailcap search so it works on MacOS + +Change 165 on 1998/07/03 by <gbarr@pobox.com> (Graham Barr) + + Mail::Mailer + - Change to use Mail::Util::mailaddress + + Mail::Util + - updated mailaddess to be aware of MacOS + +Change 164 on 1998/06/30 by <gbarr@pobox.com> (Graham Barr) + + Mail::Header + - fix read(0 and extract() not to require non-whitespace characters + on continuation lines, a single leading whitespace char is all + that is needed. + +Change 163 on 1998/06/30 by <gbarr@pobox.com> (Graham Barr) + + - Applied patch from Roderick Schertler to + + - Two places in Mail::Header are changed so they don't use $'. + + - A Mail::Header::as_string method is added. + + - Mail::Internet::as_string and as_mbox_string methods are added. + The mbox variant does encoding appropriate for appending a message + to a Unix mbox file. + + - Tests for the three new methods are added. + +Change 162 on 1998/06/30 by <gbarr@pobox.com> (Graham Barr) + + Mail::Util + - tweak to what maildomain looks for in the sendmail config file + +Sun Jun 28 1998 <gbarr@pobox.com> (Graham Barr) + + Mail::Address + - Split out real handlers into thier own .pm files + - Added Mail::Mailer::smtp, this is the default for MacOS + +Wed Jun 17 1998 <gbarr@pobox.com> (Graham Barr) + + Mail::Mailer + - Applied patch from Slaven Rezic <eserte@cs.tu-berlin.de> to support + FreeBSD properly + + + Mail::Address + - Applied patch from Chuck O'Donnell to improve name extraction + + t/extract.t + - change for new extraction + +Sat Apr 4 1998 <gbarr@pobox.com> (Graham Barr) + + bin/*.PL + - change "#!$Config{'scriptdir'}/perl -w\n" ot + $Config{'startperl'}," -w\n" + +Thu Mar 19 1998 <gbarr@pobox.com> (Graham Barr) + + Mail::Field + - modified so it works with perl < 5.004 + + Makefile.PL + - removed code to prevent installation of Mail::Field + +Wed Feb 18 1998 <gbarr@pobox.com> (Graham Barr) + + Mail::Header + - Added \Q and \E to some regexp's + +Tue Feb 17 1998 <gbarr@pobox.com> (Graham Barr) + + Mail::Mailer + - Added patch from Jeff Slovin to pass correct args to mailx on DG/UX + +*** Release 1.11 + +Fri Jan 2 1998 <gbarr@pobox.com> (Graham Barr) + + Mail::Internet + - Documentation updates + + Mail::Util + - Fixed "Use of inherited AUTOLOAD" warning + + Mail::Mailer + - Some version of mail do not like STDIN bot being a terminal + and also print 'EOT' to stdout when done. Opened STDOUT/ERR to + /dev/null + + Makefile.PL + - Changed so that Mail::Field is not installed if perl version is less + than 5.004 + + Mail::Mailer + - removed all for(my $i ...) and foreach my $d as they break + compatability with pre perl5.004 + +Tue Nov 25 1997 <gbarr@pobox.com> (Graham Barr) + + Mail::Mailer + - Incremented VERSION, for some unknown reason it went backwards. + +Mon Nov 17 1997 <gbarr@pobox.com> (Graham Barr) + + Mail::Util + - Added /var/adm/sendmail to the list of directories to search + for sendmail.cf + +Mon Nov 17 1997 <gbarr@pobox.com> (Graham Barr) + + Mail::Internet + - added options to nntppost + + + Mail::Mailer.pm + - Added check for bsdos to add -I option to Mail + + t/mailcap.t + - MAde less unix specific by changing from using 'test' to using perl + +Sun Nov 16 1997 <gbarr@pobox.com> (Graham Barr) + + Added Mail::Field::AddrList to MANIFEST + +*** Release 1.10 + +Wed Nov 12 1997 <gbarr@pobox.com> (Graham Barr) + + Mail::Field::AddrList, Mail::Filter + - new modules + + Mail::Field + - Changes to the way sub-classes are registered and handled. + + +Wed Nov 5 1997 <gbarr@pobox.com> (Graham Barr) + + Mail::Mailer + - Modified code that searches for the executable to run + +--- --- -- 1997 <gbarr@pobox.com> (Graham Barr) + + Mail::Address + - Documentation updates + + Mail::Header + - Small tweak to _fold_line for lines that are just shorter than the + fold width, but include whitespace + + Mail::Internet + - does not inherit from AutoLoader. Instead AUTOLOAD + is GLOB'd to AutoLoader::AUTOLOAD + + Mail::Mailer and Mail::Send + - Modified PODs to reflect that Tim Bunce is not the maintainer. + +Mon Feb 24 1997 + + o Release 1.09 + o Mail::Header + Fixed a de-reference problem in unfold() + _fold_line will no longer fold the From line that gets added by + the user mail agent. + o Mail::Internet + Added DESTROY, to stop AutoLoader errors + o Mail::Mailer + Fixed an undef problem in new + o Tests + Added t/send.t and t/mailer.t + +Tue Jan 07 1996 + + o Release 1.08 + o fixed Mail::Mailer::new so that it uses Symbol properly + to generate the anonymous glob. + +Thu Jan 02 1996 Graham Barr <gbarr@.ti.com> + + o Release 1.07 + o Removed Mail::MIME as it is now redundant. + See $CPAN/authors/id/ERYQ/MIME-tools-x.xx for MIME related modules + o Attempt to make Mail::Mailer find the correct mail program to invoke + o Added Mail::Internet::unescape_from at the request of <kjj@primenet.com> + o Fixed a bug in _fmt_line, was appling a s/// to a ref ???, now de-ref + o Added Mail::Internet::escape_from at the request of <kjj@primenet.com> + o Modified Mail::Internet::new so that it no longer accepts the message + as an array. It now accepts an arg and key-value aoptions + o Fixed a mis-spelling of Received in Internet.pm + o Fixed a problem in Header.pm when return-ing line text and tag == 'From ' + length($tag) + 2 is incorrect + +Wed Jul 24 1996 Graham Barr <gbarr@.ti.com> + + o Mail::Send, Mail::Mailer Incorporated a patch from Nathan Torkington + <gnat@frii.com> to allow headers to be passed as scalars as well as + list-refs. It also included some doc updates. Many thanks to Nathan + +Tue Nov 21 1995 Graham Barr <gbarr@.ti.com> + + o Added Mail::Internet::nntppost and Mail::Internet::smtpsend + as AutoLoaded methods + o Some small tweaks to mailaddress() + +Thu Nov 16 1995 Graham Barr <gbarr@.ti.com> + + o Modified Mail::Util to use Net::Domain + + +Tue Nov 7 1995 Graham Barr <gbarr@.ti.com> + + o Changed name of Mail::RFC822 to Mail::Internet + + +Wed Nov 1 1995 Graham Barr <gbarr@.ti.com> + + o Fixed remove_signature to be anchor'd to the start of the line + o Re-vamped the reply to method + + +Fri Sep 8 1995 Graham Barr <gbarr@.ti.com> + + o Applied patch from Andreas Koenig to fix problem when + the user defined $\ + + +Wed Aug 30 1995 Graham Barr <gbarr@.ti.com> + + o Updated documentation + + +Tue Aug 29 1995 Graham Barr <gbarr@.ti.com> + + o Modified Mail::Util::maildomain to look in a list of places for sendmail.cf + + +Thu Aug 24 1995 Graham Barr <gbarr@.ti.com> + + o Modified maildomain to look for /usr/lib/smail/config before + attempting smtp + + +Wed Aug 16 1995 Graham Barr <gbarr@.ti.com> + + o Modified maildomain to prepend hostname to domainname if it cannot + find the address via SMTP + + o Added mailaddress() to Mail::Util + + +Tue Aug 15 1995 Graham Barr <gbarr@.ti.com> + + o Modified Mail::Util::maildomain to parse /etc/sendmail.cf if + it exists and extract the mail domain + + +Mon Aug 14 1995 Graham Barr <gbarr@.ti.com> + + o Added maildomain into Mail::Util + + o Applied Andreas Koenig's patches to Mail::Mailer and Mail::Send + + +Wed Jul 12 1995 Graham Barr <gbarr@.ti.com> + + o Added -a/-s switches to rplyto to enable a choice of reply to + all or just the sender + diff --git a/cpan/dist/MailTools/MANIFEST b/cpan/dist/MailTools/MANIFEST new file mode 100644 index 00000000..8fecf273 --- /dev/null +++ b/cpan/dist/MailTools/MANIFEST @@ -0,0 +1,32 @@ +ChangeLog +MANIFEST This File +Mail/Address.pm Manipulation of electronic mail addresses +Mail/Cap.pm Read mailcap files +Mail/Field.pm +Mail/Field/AddrList.pm +Mail/Field/Date.pm +Mail/Filter.pm +Mail/Header.pm +Mail/Internet.pm Functions for RFC822 mail manipulations +Mail/Mailer.pm Simple mail agent interface +Mail/Mailer/mail.pm +Mail/Mailer/rfc822.pm +Mail/Mailer/sendmail.pm +Mail/Mailer/smtp.pm +Mail/Mailer/test.pm +Mail/Send.pm Simple interface for sending mail +Mail/Util.pm Mail related utilities +MailTools.ppd +Makefile.PL Perl MakeMaker Makefile +README +README.demos +bin/forwd_demo.PL example script to forward a message +bin/rplyto_demo.PL example script to reply to a message +bin/send_demo.PL example script to send a message using sendmail +t/extract.t +t/header.t +t/internet.t +t/mailcap.t +t/mailer.t +t/require.t +t/send.t diff --git a/cpan/dist/MailTools/Mail/Address.pm b/cpan/dist/MailTools/Mail/Address.pm new file mode 100644 index 00000000..74a6b580 --- /dev/null +++ b/cpan/dist/MailTools/Mail/Address.pm @@ -0,0 +1,424 @@ +# Mail::Address.pm +# +# Copyright (c) 1995-8 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. + +package Mail::Address; +use strict; + +use Carp; +use vars qw($VERSION); +use locale; + +$VERSION = "1.17"; +sub Version { $VERSION } + +# +# given a comment, attempt to extract a person's name +# + +sub _extract_name +{ + local $_ = shift || ''; + + # trim whitespace + s/^\s+//; + s/\s+$//; + s/\s+/ /; + + # 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/,.*//; + + # 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; + + # 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; + + 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; + } + + 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; +} + + +sub new { + my $pkg = shift; + my $me = bless [@_], $pkg; + return $me; +} + + +sub parse { + my $pkg = shift; + + local $_; + + my @phrase = (); + my @comment = (); + my @address = (); + my @objs = (); + my $depth = 0; + my $idx = 0; + my $tokens = _tokenise(grep { defined $_} @_); + my $len = scalar(@{$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); + unless($depth) { + my $o = _complete($pkg,\@phrase, \@address, \@comment); + push(@objs, $o) if(defined $o); + $depth = 0; + $next = _find_next($idx,$tokens,$len); + } + } + elsif($_ eq ',') { + warn "Unmatched '<>'" 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/ || !scalar(@address) || $address[$#address] =~ /\A[\Q.\@:;\E]\Z/) { + push(@address,$_); + } + else { + warn "Unmatched '<>'" 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]; + + $me->[$i] = shift if(@_); + + $val; +} + + +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 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 host { + my $me = shift; + my $addr = $me->address; + my $i = rindex($addr,'@'); + + my $host = ($i >= 0) ? substr($addr,$i+1) : undef; + + return $host; +} + + +sub user { + my $me = shift; + my $addr = $me->address; + my $i = index($addr,'@'); + + my $user = ($i >= 0) ? substr($addr,0,$i) : $addr; + + return $user; +} + + +sub path { + return (); +} + + +sub canon { + my $me = shift; + return ($me->host, $me->user, $me->path); +} + +1; + + +__END__ + +=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 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 () + +Return the address excluding the '@' and the mail domain + +=item path () + +Unimplemented yet but should return the UUCP path for the message + +=item canon () + +Unimplemented yet but should return the UUCP canon for the message + +=back + +=head1 AUTHOR + +Graham Barr <gbarr@pobox.com> + +=head1 COPYRIGHT + +Copyright (c) 1995-8 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 + diff --git a/cpan/dist/MailTools/Mail/Cap.pm b/cpan/dist/MailTools/Mail/Cap.pm new file mode 100644 index 00000000..3edac654 --- /dev/null +++ b/cpan/dist/MailTools/Mail/Cap.pm @@ -0,0 +1,338 @@ +# + +package Mail::Cap; +use strict; + +use vars qw($VERSION $useCache); + +$VERSION = "1.07"; +sub Version { $VERSION; } + +=head1 NAME + +Mail::Cap - Parse mailcap files + +=head1 SYNOPSIS + + my $mc = new Mail::Cap; + + $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: + + image/gif + text/html + text/plain; charset=iso-8859-1 + +=cut + +$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")); +} + + +=head1 METHODS + +=head2 new() + + $mcap = new Mail::Cap; + $mcap = new Mail::Cap "/mydir/mailcap"; + +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. + +=cut + +sub new +{ + my($class, $file) = @_; + unless (defined $file) { + for (@path) { + if (-r $_) { + $file = $_; + last; + } + } + } + my $self = bless {}, $class; + local *MAILCAP; + if (defined $file && 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} = []; + } + push(@{$self->{$type}}, \%field); + } + close(MAILCAP); + } else { + # Set up default mailcap + $self->{'audio/*'} = [{'view' => "showaudio %s"}]; + $self->{'image/*'} = [{'view' => "xv %s"}]; + $self->{'message/rfc822'} = [{'view' => "xterm -e metamail %s"}]; + } + $self; +} + +=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 + +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) + +=head2 composeCmd($type, $file) + +=head2 editCmd($type, $file) + +=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. + +=cut + +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); + return undef unless $entry; + if (exists $entry->{$method}) { + return $self->expandPercentMacros($entry->{$method}, $type, $file); + } else { + return undef; + } +} + +sub _run +{ + my($self, $cmd) = @_; + if (defined $cmd) { + system $cmd; + return 1; + } + 0; +} + +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) = @_; + 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'); } +sub x11_bitmap { shift->field(shift, 'x11-bitmap'); } +sub nametemplate { shift->field(shift, 'nametemplate'); } + +sub getEntry +{ + my($self, $origtype, $file) = @_; + + if ($useCache) { + if (exists $self->{'_cache'}{$origtype}) { + return $self->{'_cache'}{$origtype}; + } + } + + my($fulltype, @params) = split(/\s*;\s*/, $origtype); + my($type, $subtype) = split(/\//, $fulltype, 2); + $subtype = "" unless defined $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 + last; + } + $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 %params; + for (@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) = @_; + $prefix = "" unless defined $prefix; + for (sort keys %$hash) { + print "$prefix$_ = $hash->{$_}\n"; + } +} + +sub dump +{ + my($self) = @_; + for (keys %$self) { + next if /^_/; + print "$_\n"; + for (@{$self->{$_}}) { + dumpEntry($_, "\t"); + print "\n"; + } + } + if (exists $self->{'_cache'}) { + print "Cached types\n"; + for (keys %{$self->{'_cache'}}) { + print "\t$_\n"; + } + } +} + +=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> + +Maintained by Graham Barr <gbarr@pobox.com> + +=cut + + +1; diff --git a/cpan/dist/MailTools/Mail/Field.pm b/cpan/dist/MailTools/Mail/Field.pm new file mode 100644 index 00000000..0742a6f7 --- /dev/null +++ b/cpan/dist/MailTools/Mail/Field.pm @@ -0,0 +1,507 @@ +# Mail::Field.pm +# +# Copyright (c) 1995-2000 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. + +package Mail::Field; + +# $Id: //depot/MailTools/Mail/Field.pm#7 $ + +use Carp; +use strict; +use vars qw($AUTOLOAD $VERSION); + +$VERSION = "1.08"; + +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; + } +} + +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; +} + +## +## Use the import method to load the sub-classes +## + +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" + } + } + 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; + } + } + _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; + + $method =~ tr/-/_/; + + $pkg = _header_pkg_name($method) + if($pkg eq "Mail::Field"); + + croak "Re-register of $method" + if Mail::Field->can($method); + + no strict 'refs'; + *{$method} = sub { + shift; + unless ($pkg->can('stringify')) { + eval "require $pkg" || die $@; + } + $pkg->_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 $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(@_); +} + +## +## 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); +} + +## +## A default create method. This allows us to do +## $s = Mail::Field->new('Subject'); +## + +sub parse +{ + my $self = shift; + my $type = ref($self) || $self; + + croak "$type: Cannot parse"; +} + +## +## either get the text, or parse a new one +## + +sub text +{ + my $self = shift; + @_ ? $self->parse(@_) + : $self->stringify; +} + +## +## Return the tag (in the correct case) for this item +## + +sub tag +{ + my $self = shift; + my $tag = ref($self) || $self; + + $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; + + $tag; +} + +## +## a constructor +## create a new object by extracting from a Mail::Header object +## + +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)); + } + + 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 }; + } + + $pkg->register($method) + unless(Mail::Field->can($method)); + + goto &$AUTOLOAD; +} + +## +## 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); + +sub create +{ + my $self = shift; + my %arg = @_; + my $text = delete $arg{Text} || ""; + + croak "Unknown options " . join(",", keys %arg) + if %arg; + + $self->{Text} = $text; + + $self; +} + +sub parse +{ + my $self = shift; + + $self->{Text} = shift || ""; + $self; +} + +sub stringify +{ + my $self = shift; + $self->{Text}; +} + +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 + +=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 <gbarr@pobox.com> + +=head1 SEE ALSO + +L<MIME::*>s + +=head1 CREDITS + +Eryq <eryq@rhine.gsfc.nasa.gov> - for all the help in defining this package +so that Mail::* and MIME::* can be integrated together. + +=head1 COPYRIGHT + +Copyright (c) 1995-2000 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 + + diff --git a/cpan/dist/MailTools/Mail/Field/AddrList.pm b/cpan/dist/MailTools/Mail/Field/AddrList.pm new file mode 100644 index 00000000..fa6a0d5c --- /dev/null +++ b/cpan/dist/MailTools/Mail/Field/AddrList.pm @@ -0,0 +1,107 @@ +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 + +Peter Orbaek <poe@cit.dk> 26-Feb-97 +Modified by Graham Barr <gbarr@pobox.com> + +=cut + +use strict; +use vars qw(@ISA $VERSION); +use Mail::Field (); +use Carp; +use Mail::Address; + +@ISA = qw(Mail::Field); +$VERSION = '1.0'; + +# 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'); +} + +sub create { + my ($self, %arg) = @_; # (email => name, email => realname,...) + my($e,$n); + $self->{AddrList} = {}; + + $self->{AddrList}{$e} = Mail::Address->new($n,$e) + while(($e,$n) = each %arg); + + $self; +} + +sub parse { + my ($self, $string) = @_; + my ($a,$email,$name); + + foreach $a (Mail::Address->parse($string)) { + my $e = $a->address; + $self->{AddrList}{$e} = $a; + } + $self; +} + +sub stringify { + my $self = shift; + my ($x, $email, $name); + + join(", ", map { $_->format } values %{$self->{AddrList}}); +} + +sub addresses { + keys %{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/Mail/Field/Date.pm b/cpan/dist/MailTools/Mail/Field/Date.pm new file mode 100644 index 00000000..61ea3e65 --- /dev/null +++ b/cpan/dist/MailTools/Mail/Field/Date.pm @@ -0,0 +1,80 @@ +# 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 + +package Mail::Field::Date; + +use strict; +use Mail::Field (); +use vars qw(@ISA $VERSION); +use Date::Format qw(time2str); +use Date::Parse qw(str2time); + +@ISA = qw(Mail::Field); +$VERSION = do { my @r=(q$Revision: 1.3 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r}; + +bless([])->register('Date'); + +sub set +{ + my $self = shift; + my $arg = @_ == 1 ? shift : { @_ }; + my $s; + + foreach $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; + } + + return $self->{Time} + if exists $self->{Time}; + + $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); +} + +sub reformat +{ + my $self = shift; + $self->time($self->time); + $self->stringify; +} + +1; + diff --git a/cpan/dist/MailTools/Mail/Filter.pm b/cpan/dist/MailTools/Mail/Filter.pm new file mode 100644 index 00000000..1101084a --- /dev/null +++ b/cpan/dist/MailTools/Mail/Filter.pm @@ -0,0 +1,182 @@ +# Mail::Filter.pm +# +# 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. + +package Mail::Filter; + +use Carp; +use strict; +use vars qw($VERSION); + +$VERSION = "1.01"; + +sub new { + my $self = shift; + + bless { + filters => [ @_ ] + }, $self; +} + +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); + } + # the specification indicates that the result of operations on $mail + # should be returned by this function + return $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); + } + delete $self->{'folder'}; + delete $self->{'msgnum'}; + } + elsif($obj->isa('Mail::Internet')) { + return _filter($self,$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. + +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 E<lt>F<gbarr@pobox.com>E<gt> + +=head1 COPYRIGHT + +Copyright (c) 1997 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 + + diff --git a/cpan/dist/MailTools/Mail/Header.pm b/cpan/dist/MailTools/Mail/Header.pm new file mode 100644 index 00000000..e4fd8af6 --- /dev/null +++ b/cpan/dist/MailTools/Mail/Header.pm @@ -0,0 +1,1022 @@ +# Mail::Header.pm +# +# Copyright (c) 1995-7 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. +# + +package Mail::Header; + +require 5.002; + +use strict; +use Carp; +use vars qw($VERSION $FIELD_NAME); + +$VERSION = "1.19"; + +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 :]+:'; + +## +## Private functions +## + +sub _error { warn @_; return (wantarray ? () : undef) } + +# 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--; + } + } + + if($d) + { + local $_; + my @del = (); + + while(($key,$ref) = each %{$me->{'mail_hdr_hash'}} ) + { + push(@del, $key) + unless @$ref = grep { ref($_) && defined $$_ } @$ref; + } + + map { delete $me->{'mail_hdr_hash'}{$_} } @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 + 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]+)/ and 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 + { + my $dif = $max-$min; + + $_[0] =~ s/(?:^|\G) + (?: + (.{$min,$max})\s+ + |(.{$min,$max}) + ) + /$+\n /xg; + } + } + + $_[0] =~ s/\A(\S+)\n\s*(?=\S)/$1 /so; +} + +# attempt to change the case of a tag to that required by RFC822. That +# 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. + +sub _tag_case +{ + my $tag = shift; + + $tag =~ s/:\Z//o; + + # Change the case of the tag + # eq Message-Id + $tag =~ s/\b([a-z]+)/\L\u$1/gio; + $tag =~ s/\b([b-df-hj-np-tv-z]+|MIME)\b/\U$1/gio + if $tag =~ /-/; + + $tag; +} + +# 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 $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>" + } + } + + if(defined $tag) + { + $tag = _tag_case($ctag = $tag); + + $ctag = $tag + if($modify); + + $ctag =~ s/([^ :])\Z/$1:/o if defined $ctag; + } + + croak( "Bad RFC822 field name '$tag'\n") + unless(defined $ctag && $ctag =~ /\A($FIELD_NAME|From )/oi); + + # 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; + } + + my $maxlen = $me->{'mail_hdr_lengths'}{$tag} + || $HDR_LENGTHS{$tag} + || $me->fold_length; + + _fold_line($line,$maxlen) + if $modify && defined $maxlen; + + $line =~ s/\n*\Z/\n/so; + + ($tag, $line); +} + +sub _insert +{ + my($me,$tag,$line,$where) = @_; + + if($where < 0) + { + $where = scalar(@{$me->{'mail_hdr_list'}}) + $where + 1; + + $where = 0 + if($where < 0); + } + elsif($where >= scalar(@{$me->{'mail_hdr_list'}})) + { + $where = scalar(@{$me->{'mail_hdr_list'}}); + } + + my $atend = $where == scalar(@{$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(scalar($me->{'mail_hdr_hash'}{$tag}) && $where) + { + if($atend) + { + push(@{$me->{'mail_hdr_hash'}{$tag}}, $ref); + } + else + { + my($ln,$i,$ref); + $i = 0; + foreach $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(@{$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); + } + } + + $me; +} + +sub modify +{ + my $me = shift; + my $old = $me->{'mail_hdr_modify'}; + + $me->{'mail_hdr_modify'} = 0 + shift + if @_; + + $old; +} + +sub mail_from +{ + my $me = shift; + my $choice = uc(shift); + + $choice =~ /^(IGNORE|ERROR|COERCE|KEEP)$/ + or die "bad Mail-From choice: '$choice'"; + + if(ref($me)) + { + $me->{'mail_hdr_mail_from'} = $choice; + } + else + { + $MAIL_FROM = $choice; + } + + $me; +} + +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; + } + } + + $me; +} + +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; + + while(scalar(@{$arr}) && $arr->[0] =~ /\A($FIELD_NAME|From )/o) + { + my $tag = $1; + + $line = shift @{$arr}; + $line .= shift @{$arr} + while(scalar(@{$arr}) && $arr->[0] =~ /\A[ \t]+/o); + + ($tag,$line) = _fmt_line($me,$tag,$line); + + _insert($me,$tag,$line,-1) + if defined $line; + } + + shift @{$arr} + if(scalar(@{$arr}) && $arr->[0] =~ /\A\s*\Z/o); + + $me; +} + +sub read +{ + my $me = shift; + my $fd = shift; + + $me->empty; + + my $line = undef; + my $ln = ""; + my $tag = undef; + + while(1) + { + $ln = <$fd>; + + if(defined $ln && defined $line && $ln =~ /\A[ \t]+/o) + { + $line .= $ln; + next; + } + + if(defined $line) + { + ($tag,$line) = _fmt_line($me,$tag,$line); + _insert($me,$tag,$line,-1) + if defined $line; + } + + last + unless(defined $ln && $ln =~ /\A($FIELD_NAME|From )/o); + + $tag = $1; + $line = $ln; + } + + $me; +} + +sub empty +{ + my $me = shift; + + $me->{'mail_hdr_list'} = []; + $me->{'mail_hdr_hash'} = {}; + + $me; +} + +sub header +{ + my $me = shift; + + $me->extract(@_) + if(@_); + + $me->fold + if $me->{'mail_hdr_modify'}; + + # 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 :- + + [ @{$me->{'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; + + # Extract the input data + for my $hdrkey (keys %$hashref) { + for (ref $hashref->{$hdrkey} + ? @{$hashref->{$hdrkey}} + : $hashref->{$hdrkey}) { + $me->add($hdrkey, $_); + } + } + + $me->fold + if $me->{'mail_hdr_modify'}; + + # Build a hash + my $hash={ map { $_ => [ $me->get($_) ] } keys %{$me->{'mail_hdr_hash'}} }; + + return $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 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); + } + } + + $line =~ /^\S+\s*(.*)/os; + return $1; +} + +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}}; + + $line = ${$me->{'mail_hdr_hash'}{$tag}[0]} = + (_fmt_line($me,$tag, join($with,@lines),1))[1]; + + _tidy_header($me); + } + else + { + return $me->{'mail_hdr_hash'}{$tag}[0]; + } + + return $line; # post-match +} + +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 exists +{ + carp "Depriciated use of Mail::Header::exists, use count" if $^W; + count(@_); +} + +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]}; + } + } + else + { + local $_; + @val = map { + my $x = substr($$_,$l); + undef $$_; + $x + } @{$me->{'mail_hdr_hash'}{$tag}}; + } + + _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'}}); +} + +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; + } + } + + $old; +} + +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]); + + $dup->{'mail_hdr_hash'}{$tag} ||= []; + push(@{$dup->{'mail_hdr_hash'}{$tag}}, \$ln); + } + + $dup; +} + +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++; + } + } + } + + _tidy_header($me) + if $d; + + $me; +} + +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 + +The default fold length for the object + +=item extract ( ARRAY_REF ) + +Extract a header from the given array. C<extract> B<will modify> this array. +Returns the object that the method was called on. + +=item read ( FD ) + +Read a header from the given file descriptor. + +=item empty () + +Empty the C<Mail::Header> object of all lines. + +=item header ( [ ARRAY_REF ] ) + +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. + +=item header_hashref ( [ HASH_REF ] ) + +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: + + $hashref->{From}='Tobias Brox <tobix@cpan.org>'; + $hashref->{To}=['you@somewhere', 'me@localhost']; + +=item add ( TAG, LINE [, INDEX ] ) + +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. + +=item replace ( TAG, LINE [, INDEX ] ) + +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. + +=item combine ( TAG [, WITH ] ) + +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 ] ) + +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. + +=item delete ( TAG [, INDEX ] ) + +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. + +=item count ( TAG ) + +Returns the number of times the given atg appears in the header + +=item print ( [ FD ] ) + +Print the header to the given file descriptor, or C<STDOUT> if no +file descriptor is given. + +=item as_string () + +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. + +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 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 () + +Create a duplicate of the current object. + +=item cleanup () + +Remove any header line that, other than the tag, only contains whitespace + +=item 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. + +=back + +=head1 AUTHOR + +Graham Barr <gbarr@pobox.com> + +=head1 COPYRIGHT + +Copyright (c) 1995-7 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 diff --git a/cpan/dist/MailTools/Mail/Internet.pm b/cpan/dist/MailTools/Mail/Internet.pm new file mode 100644 index 00000000..57c0e962 --- /dev/null +++ b/cpan/dist/MailTools/Mail/Internet.pm @@ -0,0 +1,953 @@ +# Mail::Internet.pm +# +# Copyright (c) 1995-8 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. +# + +package Mail::Internet; +use strict; + +require 5.002; + +use Carp; +use AutoLoader; +use Mail::Header; +use vars qw($VERSION); + +BEGIN { + $VERSION = "1.33"; + *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; + } + } +} + + +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + my $arg = @_ % 2 ? shift : undef; + my %arg = @_; + + my $me = bless {}, $type; + + $me->{'mail_inet_head'} = $arg{Header} if exists $arg{Header}; + $me->{'mail_inet_body'} = $arg{Body} if exists $arg{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); + + if(defined $arg) + { + if(ref($arg) eq 'ARRAY') + { + $me->header($arg) unless exists $arg{Header}; + $me->body($arg) unless exists $arg{Body}; + } + elsif(defined fileno($arg)) + { + $me->read_header($arg) unless exists $arg{Header}; + $me->read_body($arg) unless exists $arg{Body}; + } + } + + return $me; +} + +sub read +{ + my $me = shift; + + $me->read_header(@_); + $me->read_body(@_); +} + +sub read_body +{ + my($me,$fd) = @_; + + $me->body( [ <$fd> ] ); +} + + +sub extract +{ + my $me = shift; + my $arg = shift; + + $me->head->extract($arg); + $me->body($arg); +} + + +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 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 clean_header +{ + carp "clean_header depreciated, use ->header" if $^W; + shift->header(); +} + +sub tidy_headers +{ + carp "tidy_headers no longer required" if $^W; +} + + +sub add +{ + my $me = shift; + my $head = $me->head; + my $ret; + while(@_) + { + my ($tag,$line) = splice(@_,0,2); + + $ret = $head->add($tag,$line,-1) or + return undef; + } + + $ret; +} + +sub replace +{ + my $me = shift; + my $head = $me->head; + my $ret; + + while(@_) + { + my ($tag,$line) = splice(@_,0,2); + + $ret = $head->replace($tag,$line,0) or + return undef; + } + + $ret; +} + +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 delete +{ + my $me = shift; + my $head = $me->head; + my @ret = (); + my $tag; + + foreach $tag (@_) + { + push(@ret, $head->delete($tag)); + } + + @ret; +} + +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 empty +{ + my $me = shift; + + %{*$me} = (); + + 1; +} + +sub print_body +{ + my $me = shift; + my $fd = shift || \*STDOUT; + my $ln; + + foreach $ln (@{$me->body}) + { + print $fd $ln or + return 0; + } + + 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 $me = shift; + + $me->head->as_string . "\n" . join '', @{ $me->body }; +} + +sub as_mbox_string +{ + my $me = shift->dup; + my $escaped = shift; + + $me->head->delete('Content-Length'); + $me->escape_from unless $escaped; + $me->as_string . "\n"; +} + +sub remove_sig +{ + my $me = shift; + my $nlines = shift || 10; + + my $body = $me->body; + my($line,$i); + + $line = scalar(@{$body}); + return unless($line); + + while($i++ < $nlines && $line--) + { + if($body->[$line] =~ /\A--\040?[\r\n]+/) + { + splice(@{$body},$line,$i); + last; + } + } +} + +sub tidy_body +{ + my $me = shift; + + my $body = $me->body; + my $line; + + if(scalar(@{$body})) + { + shift @$body + while(scalar(@{$body}) && $body->[0] =~ /\A\s*\Z/); + pop @$body + while(scalar(@{$body}) && $body->[-1] =~ /\A\s*\Z/); + } + + return $body; +} + +sub DESTROY {} + +# Auto loaded methods go after __END__ +__END__ + +sub reply; + + +use Mail::Address; + + sub reply +{ + my $me = shift; + my %arg = @_; + my $pkg = ref $me; + my @reply = (); + + local *MAILHDR; + if(open(MAILHDR,"$ENV{HOME}/.mailhdr")) + { + # User has defined a mail header template + @reply = <MAILHDR>; + close(MAILHDR); + } + + my $reply = $pkg->new(\@reply); + + my($to,$cc,$name,$body,$id); + + # The Subject line + + my $subject = $me->get('Subject') || ""; + + $subject = "Re: " . $subject if($subject =~ /\S+/ && $subject !~ /Re:/i); + + $reply->replace('Subject',$subject); + + # 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]; + + $name = $sender->name; + $id = $sender->address; + + unless(defined $name) + { + my $fr = $me->get('From'); + + $fr = (Mail::Address->parse($fr))[0] if(defined $fr); + $name = $fr->name if(defined $fr); + } + + my $indent = $arg{Indent} || ">"; + + if($indent =~ /%/) + { + my %hash = ( '%' => '%'); + my @name = grep(do { length > 0 }, split(/[\n\s]+/,$name || "")); + my @tmp; + + @name = "" unless(@name); + + $hash{f} = $name[0]; + $hash{F} = $#name ? substr($hash{f},0,1) : $hash{f}; + + $hash{l} = $#name ? $name[$#name] : ""; + $hash{L} = substr($hash{l},0,1) || ""; + + $hash{n} = $name || ""; + $hash{I} = join("",grep($_ = substr($_,0,1), @tmp = @name)); + + $indent =~ s/%(.)/defined $hash{$1} ? $hash{$1} : $1/eg; + } + + $reply->replace('To', $id); + + # Find addresses not to include + my %nocc = (); + my $mailaddresses = $ENV{MAILADDRESSES} || ""; + my $addr; + + $nocc{lc $id} = 1; + + foreach $addr (Mail::Address->parse($reply->get('Bcc'),$mailaddresses)) + { + my $lc = lc $addr->address; + $nocc{$lc} = 1; + } + + if($arg{ReplyAll} || 0) + { + # Who shall we copy this to + my %cc = (); + + foreach $addr (Mail::Address->parse($me->get('To'),$me->get('Cc'))) + { + my $lc = lc $addr->address; + $cc{$lc} = $addr->format unless(defined $nocc{$lc}); + } + $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; + + if($sig = delete $arg{File}) + { + local *SIG; + + if(open(SIG,$sig)) + { + local $_; + while(<SIG>) { last unless /\A(--)?\s*\Z/; } + + @sig = ($_,<SIG>,"\n"); + + close(SIG); + } + } + 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 + + $hdr->delete('Received'); + + $hdr->replace('X-Mailer', "Perl5 Mail::Internet v" . $Mail::Internet::VERSION); + + my $name = eval { local $SIG{__DIE__}; (getpwuid($>))[6] } || $ENV{NAME} || ""; + + while($name =~ s/\([^\(\)]*\)//) { 1; } + + if($name =~ /[^\w\s]/) { + $name =~ s/"/\"/g; + $name = '"' . $name . '"'; + } + + my $from = sprintf "%s <%s>", $name, Mail::Util::mailaddress(); + $from =~ s/\s{2,}/ /g; + + my $tag; + + foreach $tag (qw(From Sender)) { + $hdr->add($tag,$from) + unless($hdr->get($tag)); + } +} + +sub smtpsend; + +use Carp; +use Mail::Util qw(mailaddress); +use Mail::Address; +use Net::Domain qw(hostname); +use Net::SMTP; +use strict; + + 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, 'Port', $opt{'Port'}) + if exists $opt{'Port'}; + + push(@hello, 'Debug', $opt{'Debug'}) + if exists $opt{'Debug'}; + + unless(defined($host)) { + local $SIG{__DIE__}; + my @hosts = qw(mailhost localhost); + unshift(@hosts, split(/:/, $ENV{SMTPHOSTS})) if(defined $ENV{SMTPHOSTS}); + + 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; + } + else { + local $SIG{__DIE__}; + $smtp = eval { Net::SMTP->new($host, @hello) }; + } + + return () + unless(defined $smtp); + + my $hdr = $src->head->dup; + + _prephdr($hdr); + + # Who is it to + + my @rcpt = map { ref($_) ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'}; + @rcpt = map { $hdr->get($_) } qw(To Cc Bcc) + unless @rcpt; + my @addr = map($_->address, Mail::Address->parse(@rcpt)); + + return () + unless(@addr); + + $hdr->delete('Bcc'); # Remove blind Cc's + + # Send it + + my $ok = $smtp->mail( mailaddress() ) && + $smtp->to(@addr) && + $smtp->data(join("", @{$hdr->header},"\n",@{$src->body})); + + $smtp->quit + unless $noquit; + + $ok ? @addr : (); +} + +sub send; + +use Mail::Mailer; +use strict; + + sub send +{ + my ($src, $type, @args) = @_; + + my $hdr = $src->head->dup; + + _prephdr($hdr); + + my $headers = $hdr->header_hashref; + + # Actually send it + 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; + + sub nntppost +{ + my $mail = shift; + my %opt = @_; + + my $groups = $mail->get('Newsgroups') || ""; + my @groups = split(/[\s,]+/,$groups); + + return () + unless @groups; + + my $hdr = $mail->head->dup; + + _prephdr($hdr); + + # Remove these incase the NNTP host decides to mail as well as me + $hdr->delete(qw(To Cc Bcc)); + + my $news; + my $noquit = 0; + my $host = $opt{Host}; + + if(ref($host) && UNIVERSAL::isa($host,'Net::NNTP')) { + $news = $host; + $noquit = 1; + } + else { + my @opt = (); + + push(@opt, $opt{'Host'}); + + push(@opt, 'Port', $opt{'Port'}) + if exists $opt{'Port'}; + + push(@opt, 'Debug', $opt{'Debug'}) + if exists $opt{'Debug'}; + + $news = new Net::NNTP(@opt) + or return (); + } + + $news->post(@{$hdr->header},"\n",@{$mail->body}); + + my $code = $news->code; + + $news->quit + unless $noquit; + + return 240 == $code ? @groups : (); +} + +sub escape_from +{ + my $me = shift; + + my $body = $me->body; + local $_; + + 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; +} + +1; # keep require happy + + + +=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. + +=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 () + +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. + +=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 + +L<Mail::Header> +L<Mail::Address> + +=head1 AUTHOR + +Graham Barr <gbarr@pobox.com> + +=head1 COPYRIGHT + +Copyright (c) 1995-7 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 + + diff --git a/cpan/dist/MailTools/Mail/Mailer.pm b/cpan/dist/MailTools/Mail/Mailer.pm new file mode 100644 index 00000000..ec21b26f --- /dev/null +++ b/cpan/dist/MailTools/Mail/Mailer.pm @@ -0,0 +1,332 @@ +# + +package Mail::Mailer; + +=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<mail> + +Use the Unix system C<mail> program to deliver the mail. C<$command> +is the path to C<mail>. Mail::Mailer will search for C<mailx>, C<Mail> +and C<mail> (in this order). + +=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; + +=item C<test> + +Used for debugging, this calls C</bin/echo> to display the data. 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;...:..." + +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" + +=back + +=head1 SEE ALSO + +Mail::Send + +=head1 AUTHORS + +Maintained by Graham Barr E<lt>F<gbarr@pobox.com>E<gt> + +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>. + +For support please contact comp.lang.perl.misc or Graham Barr +E<lt>F<gbarr@pobox.com>E<gt> + +=cut + +use Carp; +use IO::Handle; +use vars qw(@ISA $VERSION $MailerBinary $MailerType %Mailers @Mailers); +use Config; +use strict; + +$VERSION = "1.21"; # $Id: //depot/MailTools/Mail/Mailer.pm#13 $ + +sub Version { $VERSION } + +@ISA = qw(IO::Handle); + +# Suggested binaries for types? Should this be handled in the object class? +@Mailers = ( + + # Body on stdin with tilde escapes + 'mail' => 'mail', + + # Headers-blank-Body all on stdin + 'sendmail' => '/usr/lib/sendmail;/usr/sbin/sendmail;/usr/ucblib/sendmail', + + 'smtp' => undef, + 'test' => 'test' +); + +# There are several flavours of mail, which do we have ???? + +{ + my $cmd = is_exe('mailx;Mail;mail'); + my $osname = $Config{'osname'}; + + if($osname =~ /(?:dgux)|(?:solaris)/io) { + $cmd .= " -~"; + } + elsif($osname =~ /(?:linux)|(?:bsdos)|(?:freebsd)/io) { + $cmd .= " -I"; + } + push @Mailers, 'mail', $cmd; +} + +push(@Mailers, split(/:/,$ENV{PERL_MAILERS})) if $ENV{PERL_MAILERS}; + +%Mailers = @Mailers; + +$MailerBinary = undef; + +# does this really need to be done? or should a default mailer be specfied? + +if($^O eq 'MacOS' || $^O eq 'VMS' || $^O eq 'MSWin32') { + $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; + } + } +} + +sub import { + shift; + + if(@_) { + my $type = shift; + my $exe = shift || $Mailers{$type}; + + carp "Cannot locate '$exe'" + unless is_exe($exe); + + $MailerType = $type; + $Mailers{$MailerType} = $exe; + } +} + +sub to_array { + my($self, $thing) = @_; + if (ref($thing)) { + return @$thing; + } else { + return ($thing); + } +} + +sub is_exe { + my $exe = shift; + my $cmd; + + foreach $cmd (split /;/, $exe) { + $cmd =~ s/^\s+//; + + # 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:/:); + + if (defined $ENV{PATH}) { + my $dir; + foreach $dir (split(/:/, $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; + + my $exe = $Mailers{$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; + } + + $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; +} + + +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); + + $self->close; # just in case; + + # Fork and start a mailer + (defined($exe) && open($self,"|-")) + || $self->exec($exe, $args, \@to) + || 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//; + } + } +} + + +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); +} + +sub can_cc { 1 } # overridden in subclass for mailer that can't + +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}; + } + @to; +} + +sub epilogue { + # This could send a .signature, also see ::smtp subclass +} + +sub close { + my($self, @to) = @_; + if (fileno($self)) { + $self->epilogue; + close($self) + } +} + + +sub DESTROY { + my $self = shift; + $self->close; +} + +1; + diff --git a/cpan/dist/MailTools/Mail/Mailer/mail.pm b/cpan/dist/MailTools/Mail/Mailer/mail.pm new file mode 100644 index 00000000..0eb3595b --- /dev/null +++ b/cpan/dist/MailTools/Mail/Mailer/mail.pm @@ -0,0 +1,27 @@ +package Mail::Mailer::mail; +use vars qw(@ISA); +@ISA = qw(Mail::Mailer); + +my %hdrs = qw(Cc ~c Bcc ~b Subject ~s); + +sub set_headers { + my $self = shift; + my $hdrs = shift; + my($k,$v); + + while(($k,$v) = each %hdrs) { + print $self join(" ",$v, $self->to_array($hdrs->{$k})), "\n" + if defined $hdrs->{$k}; + } +} + +sub exec { + # These fail in FCGI under 5.6 due to 5.6 adding an OPEN to the + # tie interface and FCGI not having one. + eval { + open(STDOUT,">/dev/null"); # this is not portable !!!! + open(STDERR,">/dev/null"); # this is not portable !!!! + }; + shift->SUPER::exec(@_); +} +1; diff --git a/cpan/dist/MailTools/Mail/Mailer/rfc822.pm b/cpan/dist/MailTools/Mail/Mailer/rfc822.pm new file mode 100644 index 00000000..dcb0dbca --- /dev/null +++ b/cpan/dist/MailTools/Mail/Mailer/rfc822.pm @@ -0,0 +1,16 @@ +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]/; + print $self "$_: ", join(",", $self->to_array($hdrs->{$_})), "\n"; + } + print $self "\n"; # terminate headers +} + +1; diff --git a/cpan/dist/MailTools/Mail/Mailer/sendmail.pm b/cpan/dist/MailTools/Mail/Mailer/sendmail.pm new file mode 100644 index 00000000..ea67d7e0 --- /dev/null +++ b/cpan/dist/MailTools/Mail/Mailer/sendmail.pm @@ -0,0 +1,17 @@ +package Mail::Mailer::sendmail; +use vars qw(@ISA); +require Mail::Mailer::rfc822; +@ISA = qw(Mail::Mailer::rfc822); + + +sub exec { + my($self, $exe, $args, $to) = @_; + # 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. + exec( $exe, '-t', @$args ); +} diff --git a/cpan/dist/MailTools/Mail/Mailer/smtp.pm b/cpan/dist/MailTools/Mail/Mailer/smtp.pm new file mode 100644 index 00000000..6db78fa4 --- /dev/null +++ b/cpan/dist/MailTools/Mail/Mailer/smtp.pm @@ -0,0 +1,75 @@ +package Mail::Mailer::smtp; +use vars qw(@ISA); +use Net::SMTP; +use Mail::Util qw(mailaddress); + +require Mail::Mailer::rfc822; +@ISA = qw(Mail::Mailer::rfc822); + +sub can_cc { 0 } + +sub exec { + my($self, $exe, $args, $to) = @_; + my %opt = @$args; + my $host = $opt{'Server'} || undef; + # for Net::SMTP we do not really exec + my $smtp = Net::SMTP->new($host, Debug => 0) + or return undef; + + ${*$self}{'sock'} = $smtp; + + $smtp->mail(mailaddress()); + my $u; + foreach $u (@$to) { + $smtp->to($u); + } + $smtp->data; + 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 epilogue { + my $self = shift; + my $sock = ${*$self}{'sock'}; + $sock->dataend; + $sock->quit; + delete ${*$self}{'sock'}; + untie(*$self); +} + +sub close { + my($self, @to) = @_; + my $sock = ${*$self}{'sock'}; + if ($sock && fileno($sock)) { + $self->epilogue; + close($sock); + } +} + +package Mail::Mailer::smtp::pipe; + +sub TIEHANDLE { + my $pkg = shift; + my $self = shift; + my $sock = ${*$self}{'sock'}; + return bless \$sock; +} + +sub PRINT { + my $self = shift; + my $sock = $$self; + $sock->datasend( @_ ); +} + + +1; diff --git a/cpan/dist/MailTools/Mail/Mailer/test.pm b/cpan/dist/MailTools/Mail/Mailer/test.pm new file mode 100644 index 00000000..062a2b72 --- /dev/null +++ b/cpan/dist/MailTools/Mail/Mailer/test.pm @@ -0,0 +1,13 @@ +package Mail::Mailer::test; +use vars qw(@ISA); +require Mail::Mailer::rfc822; +@ISA = qw(Mail::Mailer::rfc822); + +sub can_cc { 0 } + +sub exec { + my($self, $exe, $args, $to) = @_; + exec('sh', '-c', "echo to: " . join(" ",@{$to}) . "; cat"); +} + +1; diff --git a/cpan/dist/MailTools/Mail/Send.pm b/cpan/dist/MailTools/Mail/Send.pm new file mode 100644 index 00000000..a1d2231c --- /dev/null +++ b/cpan/dist/MailTools/Mail/Send.pm @@ -0,0 +1,110 @@ + +package Mail::Send; + +# $Id: //depot/MailTools/Mail/Send.pm#6 $ + +use strict; +use Carp; +use vars qw($VERSION); +require Mail::Mailer; + +$VERSION = "1.09"; + +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 +} + +sub add { + my($me, $hdr, @values) = @_; + $me->{$hdr} = [] unless $me->{$hdr}; + push(@{$me->{$hdr}}, @values); +} + +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 open { + my $me = shift; + Mail::Mailer->new(@_)->open($me); +} + +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. + + $fh = $msg->open; + + print $fh "Body of message"; + + $fh->close; # complete the message and send it + + $fh->cancel; # not yet implemented + +=head1 DESCRIPTION + +=head1 SEE ALSO + +Mail::Mailer + +=head1 AUTHORS + +Maintained by Graham Barr E<lt>F<gbarr@pobox.com>E<gt> + +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> + +For support please contact comp.lang.perl.misc or Graham Barr +E<lt>F<gbarr@pobox.com>E<gt> + +=cut + + diff --git a/cpan/dist/MailTools/Mail/Util.pm b/cpan/dist/MailTools/Mail/Util.pm new file mode 100644 index 00000000..e0c2a344 --- /dev/null +++ b/cpan/dist/MailTools/Mail/Util.pm @@ -0,0 +1,240 @@ +# Mail::Util.pm +# +# Copyright (c) 1995-8 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. + +package Mail::Util; + +use strict; +use vars qw($VERSION @ISA @EXPORT_OK); +use AutoLoader (); +use Exporter (); + +BEGIN { + require 5.000; + + $VERSION = "1.16"; + + *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 + + Look for a sendmail.cf file and extract DH parameter + Look for a smail config file and usr the first host defined in hostname(s) + Try an SMTP connect (if Net::SMTP exists) first to mailhost then localhost + Use value from Net::Domain::domainname (if Net::Domain exists) + +=head2 mailaddress() + +Return a guess at the current users mail address. The user can force +the return value by setting C<$ENV{MAILADDRESS}> + +=head1 AUTHOR + +Graham Barr <gbarr@pobox.com> + +=head1 COPYRIGHT + +Copyright (c) 1995-8 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 + +__END__ + +sub read_mbox { + my $file = shift; + my @mail = (); + 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}, $_); + } + } + + push(@mail, $mail) if scalar(@{$mail}); + + close(FH); + + return wantarray ? @mail : \@mail; +} + + +sub maildomain { + + ## + ## return imediately if already found + ## + + return $domain + if(defined $domain); + + ## + ## Try sendmail config file if exists + ## + + 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(/\AD([a-zA-Z])([\w.]+)/) { + my($v,$arg) = ($1,$2); + $arg =~ s/\$([a-zA-Z])/exists $var{$1} ? $var{$1} : '$' . $1/eg; + $var{$v} = $arg; + } + } + close(CF); + $domain = $var{'j'} if defined $var{'j'}; + $domain = $var{'M'} if defined $var{'M'}; + return $domain + if(defined $domain); + } + + ## + ## 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]; + last; + } + } + close(CF); + + return $domain + if(defined $domain); + } + + ## + ## Try a SMTP connection to 'mailhost' + ## + + if(eval { require Net::SMTP }) { + my $host; + + foreach $host (qw(mailhost localhost)) { + my $smtp = eval { Net::SMTP->new($host) }; + + 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); + + return $domain; +} + + +sub mailaddress { + + ## + ## Return imediately if already found + ## + + return $mailaddress + if(defined $mailaddress); + + ## + ## Get user name from environment + ## + + $mailaddress = $ENV{MAILADDRESS}; + + unless ($mailaddress || $^O ne 'MacOS') { + require Mac::InternetConfig; + Mac::InternetConfig->import(); + + $mailaddress = $InternetConfig{kICEmail()}; + } + + $mailaddress ||= $ENV{USER} || + $ENV{LOGNAME} || + eval { (getpwuid($>))[6] } || + "postmaster"; + + ## + ## Add domain if it does not exist + ## + + $mailaddress .= '@' . maildomain() + unless($mailaddress =~ /\@/); + + $mailaddress =~ s/(^.*<|>.*$)//g; + + $mailaddress; +} diff --git a/cpan/dist/MailTools/MailTools.ppd b/cpan/dist/MailTools/MailTools.ppd new file mode 100644 index 00000000..1c605e29 --- /dev/null +++ b/cpan/dist/MailTools/MailTools.ppd @@ -0,0 +1,10 @@ +<SOFTPKG NAME="MailTools" VERSION="1,15,0,0"> + <TITLE>MailTools</TITLE> + <ABSTRACT>Various Mail related modules</ABSTRACT> + <AUTHOR>Graham Barr <gbarr@pobox.com></AUTHOR> + <IMPLEMENTATION> + <OS NAME="linux" /> + <ARCHITECTURE NAME="i586-linux" /> + <CODEBASE HREF="" /> + </IMPLEMENTATION> +</SOFTPKG> diff --git a/cpan/dist/MailTools/Makefile.PL b/cpan/dist/MailTools/Makefile.PL new file mode 100644 index 00000000..7f5b1a22 --- /dev/null +++ b/cpan/dist/MailTools/Makefile.PL @@ -0,0 +1,86 @@ +# This -*- perl -*- script makes the Makefile +# $Id: //depot/MailTools/Makefile.PL#10 $ + +#--- Distribution section --- + +$NAME = 'Mail'; +$DISTNAME = "MailTools"; +$VERSION = "1.15"; + +BEGIN { require 5.001 } + +use ExtUtils::MakeMaker; +use ExtUtils::Manifest qw(maniread); + +#--- Installation check + +sub chk_version +{ + my($pkg,$wanted,$msg) = @_; + + $| = 1; + print "Checking for $pkg..."; + + eval { my $p; ($p = $pkg . ".pm") =~ s#::#/#g; require $p; }; + + my $vstr = ${"${pkg}::VERSION"} ? "found v" . ${"${pkg}::VERSION"} + : "not found"; + my $vnum = ${"${pkg}::VERSION"} || 0; + + print $vnum >= $wanted ? "ok\n" : " " . $vstr . "\n"; + + $vnum >= $wanted; +} + +#--- Check for Socket + +chk_version(Net::SMTP => 1.03) or + warn "\n" + . "It is reccomended that you have Net::SMTP version 1.03 or later\n" + . "Look on CPAN for CPAN/modules/by-author/id/GBARR/libnet-x.x.tar.gz\n\n"; + +chk_version(Net::Domain => 1.05) or + warn "\n" + . "It is reccomended that you have Net::Domain version 1.05 or later\n" + . "Look on CPAN for CPAN/modules/by-author/id/GBARR/libnet-x.x.tar.gz\n\n"; + +chk_version(IO::Handle => 0.00) or + warn "\n" + . "To be able to use Mail::Mailer and Mail::Send you will need to\n" + . "install the IO distribution.\n" + . "Look on CPAN for CPAN/modules/by-author/id/GBARR/IO-x.x.tar.gz\n\n"; + +warn "\n" + . "Mail::Field will not be installed as it requires perl 5.004 or later\n" + . "and you only have $]\n\n" + if $] < 5.004; + +#--- Write the Makefile + +my @ppd; + +if ($] >= 5.00503) { + @ppd = ( + AUTHOR => 'Graham Barr <gbarr@pobox.com>', + ABSTRACT => 'Various Mail related modules' + ); +} + +WriteMakefile( + VERSION => $VERSION, + DISTNAME => $DISTNAME, + NAME => $NAME, + @ppd +); + +sub MY::postamble { + + return '' unless $] >= 5.00503; + +<<'ESQ'; + +dist : ppd + +ESQ +} + diff --git a/cpan/dist/MailTools/README b/cpan/dist/MailTools/README new file mode 100644 index 00000000..d5b35a51 --- /dev/null +++ b/cpan/dist/MailTools/README @@ -0,0 +1,23 @@ +This is MailTools, a set of perl modules related to mail applications + +You require perl 5.001 or later to use this library + +You install the library by running these commands: + + perl Makefile.PL + make + make test + make install + +There are also some demo scripts (see README.demos) + +Please report any bugs/suggestions to Graham Barr <gbarr@pobox.com> + +All files contained in this installation are Copyright (c) 1995-2000 +Graham Barr unless otherwise specified. All rights reserved. + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + + + diff --git a/cpan/dist/MailTools/README.demos b/cpan/dist/MailTools/README.demos new file mode 100644 index 00000000..4a6f5121 --- /dev/null +++ b/cpan/dist/MailTools/README.demos @@ -0,0 +1,66 @@ +The bin directory contains some demos to show the use of the Mail library + +To make these demos first type + + perl Makefile.PL + make + +replyto_demo/forwd_demo/send_demo + +these demos will not be installed by make install and will directly +reference the source directory. + +With a few small modifications these +scripts can be made to use the installed files and can be of general +use. In fact these are very close copies of the scripts I use +to send/forward/reply to mail. + +Each of the scripts except an Internet message as input. + +forwd_demo & rplyto_demo both read ~/.mailhdr as an empty header template +for the new mail. Mine looks like + +--%<----%<----%<----%<----%<----%<----%<-- +To: +Cc: +Bcc: gbarr@ti.com,graham.barr@tiuk.ti.com +Newsgroups: +In-Reply-To: +References: +Reply-To: <gbarr@ti.com> +Return-Path: <gbarr@ti.com> +From: Graham Barr <gbarr@ti.com> +Organization: Texas Instruments Ltd. - via, but not speaking for +Subject: +--%<----%<----%<----%<----%<----%<----%<-- + +Any addresses that are included on the Bcc line above will be excluded from +appearing on either the To or Cc lines. + +gbarr@ti.com,graham.barr@tiuk.ti.com are both message ids for myself + +forwd_demo: + +This creates a file under /tmp which contains an Internet message +with empty headers and the input message included in the body. + +rplyto_demo: + +This creates a file under /tmp which contains an Internet message +with headers filled in to send the message to all people who originally +received the message and the input message quoted in the body. + + +send_demo: + +This takes an Internet message as input and uses sendmail to send the message. +It also allows the user to defined aliases in thier ~/.mailrc file in the +same format as would be expected by binmail + + alias name expansion + +If you have News::NNTPClient installed then this script can also be used to post +to a newsgroup by adding a Newsgroups: line into the header an passing a -post +option on the cmdline. + + diff --git a/cpan/dist/MailTools/bin/forwd_demo.PL b/cpan/dist/MailTools/bin/forwd_demo.PL new file mode 100755 index 00000000..840b7bf8 --- /dev/null +++ b/cpan/dist/MailTools/bin/forwd_demo.PL @@ -0,0 +1,60 @@ +# This -*- perl -*- script makes the forwd_demo script +# $Id: forwd_demo.PL,v 1.2 1997/01/16 20:43:34 gbarr Exp $ + +$script = "bin/forwd_demo"; + +use Config; +use Cwd; +unlink($script); +open MIR, ">$script" or die "open for writing $script: $!"; +print MIR $Config{'startperl'}," -w\n"; +$cwd = Cwd::getcwd(); +print MIR "use lib qw($cwd/blib);\n"; +print MIR <DATA>; +chmod(0755, $script); + +__DATA__ +use Mail::Internet; + +@mail = <>; + +$mail = Mail::Internet->new(\@mail); + +$mail->remove_sig; +$mail->tidy_body; + +@reply = (); +if(open(HDR,"$ENV{HOME}/.mailhdr")) { + @reply = <HDR>; + close(HDR); +} + +$rply = Mail::Internet->new(\@reply); + +$subject = $mail->get('Subject'); + +$rply->replace('To', ""); +$rply->replace('Cc', ""); +$rply->replace('Subject',$subject); + +$rply->body($body = $mail->body); + +unshift @{$body},"---------- Begin Included Message ----------\n"; +push @{$body},"----------- End Included Message -----------\n"; + +$file = "/tmp/reply.$$"; + +open(FILE,">$file") || die "Cannot open $file:$!\n"; + +$rply->print(\*FILE); + +close(FILE); + +$editor = $ENV{"EDITOR"} || "ned -S"; + +warn "$editor :$!\n" if (system("$editor $file")); + +unlink($file,$file . '%'); + +exit 0; + diff --git a/cpan/dist/MailTools/bin/rplyto_demo.PL b/cpan/dist/MailTools/bin/rplyto_demo.PL new file mode 100755 index 00000000..5bc40d69 --- /dev/null +++ b/cpan/dist/MailTools/bin/rplyto_demo.PL @@ -0,0 +1,39 @@ +# This -*- perl -*- script makes the rplyto_demo script +# $Id: rplyto_demo.PL,v 1.2 1997/01/16 20:43:35 gbarr Exp $ + +$script = "bin/rplyto_demo"; + +use Config; +use Cwd; +unlink($script); +open MIR, ">$script" or die "open for writing $script: $!"; +print MIR $Config{'startperl'}," -w\n"; +$cwd = Cwd::getcwd(); +print MIR "use lib qw($cwd/blib);\n"; +print MIR <DATA>; +chmod(0755, $script); + +__DATA__ +use Mail::Internet; + +$mail = Mail::Internet->new([<>]); +$rply = $mail->reply(Keep => [qw(Newsgroups)]); + +$file = "/tmp/reply.$$"; + +open(REPLY,">$file") || die "Cannot open $file:$!\n"; + +$rply->print(\*REPLY); + +close(REPLY); + +$editor = $ENV{"EDITOR"} || die "\$EDITOR not defined\n"; + +warn "$editor :$!\n" if (system("$editor $file")); + +# Cleanup +unlink($file,$file . '%',$file . '~'); + +exit 0; + + diff --git a/cpan/dist/MailTools/bin/send_demo.PL b/cpan/dist/MailTools/bin/send_demo.PL new file mode 100755 index 00000000..b0fd753f --- /dev/null +++ b/cpan/dist/MailTools/bin/send_demo.PL @@ -0,0 +1,101 @@ +# This -*- perl -*- script makes the send_demo script +# $Id: send_demo.PL,v 1.2 1997/01/16 20:43:35 gbarr Exp $ + +$script = "bin/send_demo"; + +use Config; +use Cwd; +unlink($script); +$cwd = Cwd::getcwd(); +open MIR, ">$script" or die "open for writing $script: $!"; +print MIR $Config{'startperl'}," -w\n"; +print MIR "use lib qw($cwd/blib);\n"; +print MIR <DATA>; +chmod(0755, $script); + +__DATA__ +require Mail::Internet; +require Mail::Alias; +use Getopt::Long; + +sub expand_aliases +{ + my $mail = shift; + my $aliasfile = $ENV{HOME} . "/.mailrc"; + my($tag,$id); + + if( -f $aliasfile ) + { + my $alias = Mail::Alias::Binmail->new($aliasfile); + # Expand aliases + + foreach $tag (qw(To Cc Bcc)) + { + @ids = (); + foreach $id (Mail::Address->parse($mail->get($tag))) + { + my $addr = $id->address; + my @expn = $alias->expand($addr); + if(scalar(@expn) == 1) + { + $id->address($expn[0]); + push(@ids,$id->format); + } + else + { + push(@ids,@expn); + } + } + $mail->combine($tag,','); + $mail->replace($tag, join(", ", @ids)); + } + } +} + + +### +### Main program +### + +GetOptions(qw(post nosig v)); + +$opt_post = 1 if $0 =~ m#(\A|/)post\Z#; + +$verbose = defined $opt_v && $opt_v ? 1 : 0; +$posting = defined $opt_post && $opt_post ? 1 : 0; +$sign = defined $opt_nosig && $opt_nosig ? 0 : 1; + +$mail = Mail::Internet->new([ <> ]); + +expand_aliases($mail); + +$mail->add_signature if($sign); + +if($posting) + { + my @groups = $mail->nntppost(); + + if($verbose && @groups) + { + $groups = "Newsgroups: " . join(", ", @groups); + $groups =~ s/(.{10,78}),/$1\n/g if(length($groups) > 78); + print $groups,"\n"; + } + } +else + { + $mail->delete('Newsgroups'); + } + +@recp = $mail->smtpsend(); + +if($verbose && @recp) + { + $recp = "Recipients: " . join(", ", @recp); + $recp =~ s/(.{10,78}),/$1\n/g if(length($recp) > 78); + print $recp,"\n"; + } + +exit; + + diff --git a/cpan/dist/MailTools/t/extract.t b/cpan/dist/MailTools/t/extract.t new file mode 100644 index 00000000..91feaa1b --- /dev/null +++ b/cpan/dist/MailTools/t/extract.t @@ -0,0 +1,207 @@ +# +# Test the address/name extraction +# + +require Mail::Address; + +$/ = ""; +chomp(@line = <DATA>); + +print "1..",scalar(@line),"\n"; + +$i = 1; + +foreach $ln (@line) { + next unless($ln =~ /\S/); + + ($test,$format,$name) = (split(/\n+/,$ln)); + + $q = (Mail::Address->parse($test))[0]; + + $ename = $q->name || ""; + $eformat = $q->format || ""; + $name = $ename unless defined $name; + if($ename eq $name && $eformat eq $format) { + print "ok ",$i,"\n"; + } + else { + print "not ok ",$i,"\n"; + print + print "# name '$name' != '$ename'\n" unless $ename eq $name; + print "# format '$format' != '$eformat'\n" unless $eformat eq $format; + } + + $i++; +} + +__DATA__ +"Joe & J. Harvey" <ddd @Org>, JJV @ BBN +"Joe & J. Harvey" <ddd@Org> +Joe & J. Harvey + +"Joe & J. Harvey" <ddd @Org> +"Joe & J. Harvey" <ddd@Org> +Joe & J. Harvey + +JJV @ BBN +JJV@BBN + + +"spickett@tiac.net" <Sean.Pickett@zork.tiac.net> +"spickett@tiac.net" <Sean.Pickett@zork.tiac.net> +Spickett@Tiac.Net + +rls@intgp8.ih.att.com (-Schieve,R.L.) +rls@intgp8.ih.att.com (-Schieve,R.L.) +R.L. -Schieve + +bodg fred@tiuk.ti.com +bodg + + +m-sterni@mars.dsv.su.se +m-sterni@mars.dsv.su.se + + +jrh%cup.portal.com@portal.unix.portal.com +jrh%cup.portal.com@portal.unix.portal.com +Cup Portal Com + +astrachan@austlcm.sps.mot.com ('paul astrachan/xvt3') +astrachan@austlcm.sps.mot.com ('paul astrachan/xvt3') +Paul Astrachan/Xvt3 + +TWINE57%SDELVB.decnet@SNYBUFVA.CS.SNYBUF.EDU (JAMES R. TWINE - THE NERD) +TWINE57%SDELVB.decnet@SNYBUFVA.CS.SNYBUF.EDU (JAMES R. TWINE - THE NERD) +James R. Twine - The Nerd + +David Apfelbaum <da0g+@andrew.cmu.edu> +David Apfelbaum <da0g+@andrew.cmu.edu> +David Apfelbaum + +"JAMES R. TWINE - THE NERD" <TWINE57%SDELVB%SNYDELVA.bitnet@CUNYVM.CUNY.EDU> +"JAMES R. TWINE - THE NERD" <TWINE57%SDELVB%SNYDELVA.bitnet@CUNYVM.CUNY.EDU> +James R. Twine - The Nerd + +bilsby@signal.dra (Fred C. M. Bilsby) +bilsby@signal.dra (Fred C. M. Bilsby) +Fred C. M. Bilsby + +/G=Owen/S=Smith/O=SJ-Research/ADMD=INTERSPAN/C=GB/@mhs-relay.ac.uk +/G=Owen/S=Smith/O=SJ-Research/ADMD=INTERSPAN/C=GB/@mhs-relay.ac.uk +Owen Smith + +apardon@rc1.vub.ac.be (Antoon Pardon) +apardon@rc1.vub.ac.be (Antoon Pardon) +Antoon Pardon + +"Stephen Burke, Liverpool" <BURKE@vxdsya.desy.de> +"Stephen Burke, Liverpool" <BURKE@vxdsya.desy.de> +Stephen Burke + +Andy Duplain <duplain@btcs.bt.co.uk> +Andy Duplain <duplain@btcs.bt.co.uk> +Andy Duplain + +Gunnar Zoetl <zoetl@isa.informatik.th-darmstadt.de> +Gunnar Zoetl <zoetl@isa.informatik.th-darmstadt.de> +Gunnar Zoetl + +The Newcastle Info-Server <info-admin@newcastle.ac.uk> +The Newcastle Info-Server <info-admin@newcastle.ac.uk> +The Newcastle Info-Server + +wsinda@nl.tue.win.info (Dick Alstein) +wsinda@nl.tue.win.info (Dick Alstein) +Dick Alstein + +mserv@rusmv1.rus.uni-stuttgart.de (RUS Mail Server) +mserv@rusmv1.rus.uni-stuttgart.de (RUS Mail Server) +Rus Mail Server + +Suba.Peddada@eng.sun.com (Suba Peddada [CONTRACTOR]) +Suba.Peddada@eng.sun.com (Suba Peddada [CONTRACTOR]) +Suba Peddada + +ftpmail-adm@info2.rus.uni-stuttgart.de +ftpmail-adm@info2.rus.uni-stuttgart.de + + +Paul Manser (0032 memo) <a906187@tiuk.ti.com> +Paul Manser <a906187@tiuk.ti.com> (0032 memo) +Paul Manser + +"gregg (g.) woodcock" <woodcock@bnr.ca> +"gregg (g.) woodcock" <woodcock@bnr.ca> +Gregg Woodcock + +Clive Bittlestone <clyvb@asic.sc.ti.com> +Clive Bittlestone <clyvb@asic.sc.ti.com> +Clive Bittlestone + +Graham.Barr@tiuk.ti.com +Graham.Barr@tiuk.ti.com +Graham Barr + +"Graham Bisset, UK Net Support, +44 224 728109" <GRAHAM@dyce.wireline.slb.com.ti.com.> +"Graham Bisset, UK Net Support, +44 224 728109" <GRAHAM@dyce.wireline.slb.com.ti.com.> +Graham Bisset + +a909937 (Graham Barr (0004 bodg)) +a909937 (Graham Barr (0004 bodg)) +Graham Barr + +a909062@node_cb83.node_cb83 (Colin x Maytum (0013 bro5)) +a909062@node_cb83.node_cb83 (Colin x Maytum (0013 bro5)) +Colin X Maytum + +a909062@node_cb83.node_cb83 (Colin Maytum (0013 bro5)) +a909062@node_cb83.node_cb83 (Colin Maytum (0013 bro5)) +Colin Maytum + +fred@john (Level iii support) +fred@john (Level iii support) +Level III Support + +Derek.Roskell%dero@msg.ti.com +Derek.Roskell%dero@msg.ti.com +Derek Roskell + +":sysmail"@ Some-Group. Some-Org, Muhammed.(I am the greatest) Ali @(the)Vegas.WBA +":sysmail"@Some-Group.Some-Org + + +david d `zoo' zuhn <zoo@aggregate.com> +david d `zoo' zuhn <zoo@aggregate.com> +David D `Zoo' Zuhn + +"Christopher S. Arthur" <csa@halcyon.com> +"Christopher S. Arthur" <csa@halcyon.com> +Christopher S. Arthur + +Jeffrey A Law <law@snake.cs.utah.edu> +Jeffrey A Law <law@snake.cs.utah.edu> +Jeffrey A Law + +lidl@uunet.uu.net (Kurt J. Lidl) +lidl@uunet.uu.net (Kurt J. Lidl) +Kurt J. Lidl + +Kresten_Thorup@NeXT.COM (Kresten Krab Thorup) +Kresten_Thorup@NeXT.COM (Kresten Krab Thorup) +Kresten Krab Thorup + +hjl@nynexst.com (H.J. Lu) +hjl@nynexst.com (H.J. Lu) +H.J. Lu + +berg@POOL.Informatik.RWTH-Aachen.DE (Stephen R. van den Berg) +berg@POOL.Informatik.RWTH-Aachen.DE (Stephen R. van den Berg) +Stephen R. Van Den Berg + +@oleane.net:hugues@afp.com a!b@c.d foo!bar!foobar!root +@oleane.net:hugues@afp.com +Oleane Net:Hugues + +(foo@bar.com (foobar), ned@foo.com (nedfoo) ) <kevin@goess.org> +kevin@goess.org (foo@bar.com (foobar), ned@foo.com (nedfoo) ) diff --git a/cpan/dist/MailTools/t/header.t b/cpan/dist/MailTools/t/header.t new file mode 100644 index 00000000..bfe935d6 --- /dev/null +++ b/cpan/dist/MailTools/t/header.t @@ -0,0 +1,164 @@ +require Mail::Header; + +print "1..22\n"; + +$h = new Mail::Header; + +$t = 0; + +$h->header_hashref({hhrtest1 => 1, + hhrtest2 => [1, "this test line was written by TobiX\n"]}); +$h->add(Date => "a test header"); +$h->add(Date => "a longer test header"); +$h->add(Date => "an even longer test header"); + +$h->print; +$str = $h->get(Date => 0); +print "#$str#\nnot " + unless $str eq "a test header\n"; +printf "ok %d\n",++$t; + +$str = $h->get(Date => 1); +print "#$str#\nnot " + unless $str eq "a longer test header\n"; +printf "ok %d\n",++$t; + +$str = $h->get(Date => 2); +print "#$str#\nnot " + unless $str eq "an even longer test header\n"; +printf "ok %d\n",++$t; + +$str = $h->get('hhrtest2',1); +print "#$str#\nnot " + unless $str eq "this test line was written by TobiX\n"; +printf "ok %d\n",++$t; + +$href=$h->header_hashref(); + +print "not " + unless $href->{Date}->[0] eq "a test header\n"; +printf "ok %d\n",++$t; + +print "not " + unless $href->{Hhrtest2}->[0]; +printf "ok %d\n",++$t; + +print "not " + unless $href->{Hhrtest1}->[0]; +printf "ok %d\n",++$t; + + +$h->fold(30); + +print "not " + unless $h->get(Date => 0) eq "a test header\n"; +printf "ok %d\n",++$t; + +print "not " + unless $h->get(Date => 1) eq "a longer test header\n"; +printf "ok %d\n",++$t; + +print "not " + unless $h->get(Date => 2) eq "an even longer test\n header\n"; +printf "ok %d\n",++$t; + +$h->fold(20); + +print "not " + unless $h->get(Date => 0) eq "a test header\n"; +printf "ok %d\n",++$t; + +print "not " + unless $h->get(Date => 1) eq "a longer\n test header\n"; +printf "ok %d\n",++$t; + +print "not " + unless $h->get(Date => 2) eq "an even\n longer test\n header\n"; +printf "ok %d\n",++$t; + +$h->unfold; + +print "not " + unless $h->get(Date => 0) eq "a test header\n"; +printf "ok %d\n",++$t; + +print "not " + unless $h->get(Date => 1) eq "a longer test header\n"; +printf "ok %d\n",++$t; + +print "not " + unless $h->get(Date => 2) eq "an even longer test header\n"; +printf "ok %d\n",++$t; + +$head = <<EOF; +From from_ +To: to +From: from +Subject:subject +EOF +$body = "body\n"; +$mail = "$head\n$body"; +@mail = map { "$_\n" } split /\n/, $mail; + +print "not " + unless $h = new Mail::Header \@mail, Modify => 0; +printf "ok %d\n",++$t; + +print "not " + unless $h->as_string eq $head; +printf "ok %d\n",++$t; + +print "not " + unless $h->get('Subject') eq "subject\n"; +printf "ok %d\n",++$t; + +print "not " + unless $h->get('To') eq "to\n"; +printf "ok %d\n",++$t; + +$headin = <<EOF; +Content-Type: multipart/mixed; + boundary="---- =_NextPart_000_01BDBF1F.DA8F77EE" +Content-Type: multipart/mixed; + boundary="---- =_NextPart_000_01BDBF1F.DA8F77EE"hkjhgkfhgfhgf"hfkjdhf fhjf fghjghf fdshjfhdsj" hgjhgfjk +Content-Type: multipart/mixed; + boundary="---- =_NextPart_000_01BDBF1F.DA8F77EE"hkjhg kfhgfhgf"hfkjdhf fhjf fghjghf fdshjfhdsj" hgjhgfjk +Content-Type: multipart/mixed; + boundary="---- =_NextPart_000_01BDBF1F.DA8F77EE"hhhhhhhhhhhhhhhhhhhhhhhhh fjsdhfkjsd fhdjsfhkj +Content-Type: multipart/mixed; + boundary="---- =_NextPart_000_01BDBF1F.DA8F77EE" abc def ghfdgfdsgj fdshfgfsdgfdsg hfsdgjfsdg fgsfgjsg +mime-type: text/plain +test1: _abc _def _ghi _fdjhfd _fhdjkfh _dkhkjd _fdjkf _dshfdks _fhdjfdkhfk _dshfds _fdsjk _fdkhfdks _fdsjf _dkf +test1: _abc _def _ghi _fdjhfd _fhdjkfh _dkhaaaaaaaaaaakjdfdjkfdshfdksfhdjfdkhfkdshfdsfdsjkfdkhfdksfdsjf _dkf +EOF +$headout = <<EOF; +Content-Type: multipart/mixed; + boundary="---- =_NextPart_000_01BDBF1F.DA8F77EE" +Content-Type: multipart/mixed; + boundary="---- =_NextPart_000_01BDBF1F.DA8F77EE"hkjhgkfhgfhgf"hfkjdhf fhjf fghjghf fdshjfhdsj" + hgjhgfjk +Content-Type: multipart/mixed; + boundary="---- =_NextPart_000_01BDBF1F.DA8F77EE"hkjhg + kfhgfhgf"hfkjdhf fhjf fghjghf fdshjfhdsj" + hgjhgfjk +Content-Type: multipart/mixed; + boundary="---- =_NextPart_000_01BDBF1F.DA8F77EE"hhhhhhhhhhhhhhhhhhhhhhhhh + fjsdhfkjsd fhdjsfhkj +Content-Type: multipart/mixed; + boundary="---- =_NextPart_000_01BDBF1F.DA8F77EE" + abc def ghfdgfdsgj fdshfgfsdgfdsg hfsdgjfsdg fgsfgjsg +MIME-Type: text/plain +Test1: _abc _def _ghi _fdjhfd _fhdjkfh _dkhkjd _fdjkf _dshfdks _fhdjfdkhfk + _dshfds _fdsjk _fdkhfdks _fdsjf _dkf +Test1: _abc _def _ghi _fdjhfd _fhdjkfh _dkhaaaaaaaaaaakjdfdjkfdshfdksfhdjf + dkhfkdshfdsfdsjkfdkhfdksfdsjf _dkf +EOF +@mail = map { "$_\n" } split /\n/, $headin; + +print "not " + unless $h = new Mail::Header \@mail, Modify => 1; +printf "ok %d\n",++$t; + +print $h->as_string,"\n----\n",$headout,"\nnot " + unless $h->as_string eq $headout; +printf "ok %d\n",++$t; diff --git a/cpan/dist/MailTools/t/internet.t b/cpan/dist/MailTools/t/internet.t new file mode 100644 index 00000000..77c0fa26 --- /dev/null +++ b/cpan/dist/MailTools/t/internet.t @@ -0,0 +1,58 @@ +#!perl -w + +require Mail::Internet; +use Config; + +print "1..3\n"; +$|=1; + +$head = <<EOF; +From from_\@localhost +To: Some perl administrator <$Config{perladmin}> +From: Somebody <$ENV{LOGNAME}\@localhost> +Subject: Mail::Internet test subject +EOF + +$body = <<EOF; +This is a test message that was sent by the test suite of +Mail::Internet. + +Testing. + +one + +From foo +four + +>From bar +seven +EOF + +$mail = "$head\n$body"; +($mbox = $mail) =~ s/^(>*)From /$1>From /gm; +$mbox =~ s/^>From /From / or die; +$mbox .= "\n"; +@mail = map { "$_\n" } split /\n/, $mail; + +sub ok { + my ($n, $result, @info) = @_; + if ($result) { + print "ok $n\n"; + } + else { + for (@info) { + s/^/# /mg; + } + print "not ok $n\n", @info; + print "\n" if @info && $info[-1] !~ /\n$/; + } +} + +ok 1, $i = new Mail::Internet \@mail, Modify => 0; +ok 2, $i->as_string eq $mail, $i->as_string; +ok 3, $i->as_mbox_string eq $mbox, $i->as_mbox_string; +#ok 4, $i->send; + + + + diff --git a/cpan/dist/MailTools/t/mailcap.t b/cpan/dist/MailTools/t/mailcap.t new file mode 100644 index 00000000..cdf71289 --- /dev/null +++ b/cpan/dist/MailTools/t/mailcap.t @@ -0,0 +1,57 @@ +#!/usr/local/bin/perl -w + +require Mail::Cap; + +print "1..5\n"; + +# First we create a mailcap file to test +$mcfile = "mailcap-$$"; + +open(MAILCAP, ">$mcfile") || die "Can't create $mcfile: $!"; + +print MAILCAP <<EOT; + +# This is a comment and should be ignored + +image/*; xv %s \\; echo "Showing image %s"; description=Simple image format + +text/plain; cat %s;\\ + test=$^X -e "exit (!(q{%{charset}} =~ /^iso-8859-1\$/i))";\\ + copiousoutput + +text/plain; smartcat %s; copiousoutput + +local;cat %s;print=lpr %{foo} %{bar} %t %s + +EOT +close(MAILCAP); + +# OK, lets parse it +$mc = new Mail::Cap $mcfile; +unlink($mcfile); # no more need for this file + +$desc = $mc->description('image/gif'); + +print "GIF desc: $desc\n"; +print "ok 1\n" if $desc eq "Simple image format"; + +$cmd1 = $mc->viewCmd('text/plain; charset=iso-8859-1', 'file.txt'); +$cmd2 = $mc->viewCmd('text/plain; charset=iso-8859-2', 'file.txt'); +$cmd3 = $mc->viewCmd('image/gif', 'gisle.gif'); +$cmd4 = $mc->printCmd('local; foo=bar', 'myfile'); + +print "$cmd1\n"; + +print "ok 2\n" if $cmd1 eq "cat file.txt"; + +print "$cmd2\n"; +print "ok 3\n" if $cmd2 eq "smartcat file.txt"; + +print "$cmd3\n"; +print "ok 4\n" if $cmd3 eq qq(xv gisle.gif ; echo "Showing image gisle.gif"); + +print "$cmd4\n"; +print "ok 5\n" if $cmd4 =~ /^lpr\s+bar\s+local\s+myfile$/; + + +#$mc->dump; diff --git a/cpan/dist/MailTools/t/mailer.t b/cpan/dist/MailTools/t/mailer.t new file mode 100755 index 00000000..f0eb4e33 --- /dev/null +++ b/cpan/dist/MailTools/t/mailer.t @@ -0,0 +1,15 @@ +#!/usr/local/bin/perl -w + +use Mail::Mailer; + +print "1..2\n"; + +print "ok 1\n"; + +$mail = new Mail::Mailer or print "not "; +print "ok 2\n"; + +undef $mail; + +# well until I have a way of getting an address, that is all I can do. +# better than nothing :-) diff --git a/cpan/dist/MailTools/t/require.t b/cpan/dist/MailTools/t/require.t new file mode 100755 index 00000000..7801f36d --- /dev/null +++ b/cpan/dist/MailTools/t/require.t @@ -0,0 +1,19 @@ +#!/usr/local/bin/perl -w +print "1..8\n"; +require Mail::Address; +print "ok 1\n"; +require Mail::Cap; +print "ok 2\n"; +require Mail::Field; +print "ok 3\n"; +require Mail::Header; +print "ok 4\n"; +require Mail::Internet; +print "ok 5\n"; +require Mail::Mailer; +print "ok 6\n"; +require Mail::Send; +print "ok 7\n"; +require Mail::Util; +print "ok 8\n"; + diff --git a/cpan/dist/MailTools/t/send.t b/cpan/dist/MailTools/t/send.t new file mode 100755 index 00000000..91789051 --- /dev/null +++ b/cpan/dist/MailTools/t/send.t @@ -0,0 +1,47 @@ +#!/usr/local/bin/perl -w + +use Mail::Send; + +print "1..11\n"; + +my $i = 1; + +$msg = new Mail::Send or print "not "; + +printf "ok %d\n",$i++; + +$msg = new Mail::Send + Subject => 'example subject', + To => 'timbo' + or print "not "; + +$msg->to('user@host') == 1 or print "not "; +printf "ok %d\n",$i++; + +$msg->subject('user@host') == 1 or print "not "; +printf "ok %d\n",$i++; + +$msg->cc('user@host', 'user2@no.where') == 2 or print "not "; +printf "ok %d\n",$i++; + +$msg->bcc('someone@else') == 1 or print "not "; +printf "ok %d\n",$i++; + +$msg->bcc('nobody@here') == 1 or print "not "; +printf "ok %d\n",$i++; + +$msg->set('X-Test', 'a test entry') == 1 or print "not "; +printf "ok %d\n",$i++; + +$msg->add('X-Test', 'another test entry') == 2 or print "not "; +printf "ok %d\n",$i++; + +$msg->set('X-Test2', 'a test2 entry') == 1 or print "not "; +printf "ok %d\n",$i++; + +$msg->set('X-Test2', 'replaced') == 1 or print "not "; +printf "ok %d\n",$i++; + +$msg->delete('X-Test') or print "not "; +printf "ok %d\n",$i++; + diff --git a/cpan/lib/Mail/Address.pm b/cpan/lib/Mail/Address.pm new file mode 100644 index 00000000..74a6b580 --- /dev/null +++ b/cpan/lib/Mail/Address.pm @@ -0,0 +1,424 @@ +# Mail::Address.pm +# +# Copyright (c) 1995-8 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. + +package Mail::Address; +use strict; + +use Carp; +use vars qw($VERSION); +use locale; + +$VERSION = "1.17"; +sub Version { $VERSION } + +# +# given a comment, attempt to extract a person's name +# + +sub _extract_name +{ + local $_ = shift || ''; + + # trim whitespace + s/^\s+//; + s/\s+$//; + s/\s+/ /; + + # 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/,.*//; + + # 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; + + # 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; + + 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; + } + + 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; +} + + +sub new { + my $pkg = shift; + my $me = bless [@_], $pkg; + return $me; +} + + +sub parse { + my $pkg = shift; + + local $_; + + my @phrase = (); + my @comment = (); + my @address = (); + my @objs = (); + my $depth = 0; + my $idx = 0; + my $tokens = _tokenise(grep { defined $_} @_); + my $len = scalar(@{$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); + unless($depth) { + my $o = _complete($pkg,\@phrase, \@address, \@comment); + push(@objs, $o) if(defined $o); + $depth = 0; + $next = _find_next($idx,$tokens,$len); + } + } + elsif($_ eq ',') { + warn "Unmatched '<>'" 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/ || !scalar(@address) || $address[$#address] =~ /\A[\Q.\@:;\E]\Z/) { + push(@address,$_); + } + else { + warn "Unmatched '<>'" 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]; + + $me->[$i] = shift if(@_); + + $val; +} + + +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 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 host { + my $me = shift; + my $addr = $me->address; + my $i = rindex($addr,'@'); + + my $host = ($i >= 0) ? substr($addr,$i+1) : undef; + + return $host; +} + + +sub user { + my $me = shift; + my $addr = $me->address; + my $i = index($addr,'@'); + + my $user = ($i >= 0) ? substr($addr,0,$i) : $addr; + + return $user; +} + + +sub path { + return (); +} + + +sub canon { + my $me = shift; + return ($me->host, $me->user, $me->path); +} + +1; + + +__END__ + +=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 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 () + +Return the address excluding the '@' and the mail domain + +=item path () + +Unimplemented yet but should return the UUCP path for the message + +=item canon () + +Unimplemented yet but should return the UUCP canon for the message + +=back + +=head1 AUTHOR + +Graham Barr <gbarr@pobox.com> + +=head1 COPYRIGHT + +Copyright (c) 1995-8 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 + diff --git a/cpan/lib/Mail/Cap.pm b/cpan/lib/Mail/Cap.pm new file mode 100644 index 00000000..3edac654 --- /dev/null +++ b/cpan/lib/Mail/Cap.pm @@ -0,0 +1,338 @@ +# + +package Mail::Cap; +use strict; + +use vars qw($VERSION $useCache); + +$VERSION = "1.07"; +sub Version { $VERSION; } + +=head1 NAME + +Mail::Cap - Parse mailcap files + +=head1 SYNOPSIS + + my $mc = new Mail::Cap; + + $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: + + image/gif + text/html + text/plain; charset=iso-8859-1 + +=cut + +$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")); +} + + +=head1 METHODS + +=head2 new() + + $mcap = new Mail::Cap; + $mcap = new Mail::Cap "/mydir/mailcap"; + +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. + +=cut + +sub new +{ + my($class, $file) = @_; + unless (defined $file) { + for (@path) { + if (-r $_) { + $file = $_; + last; + } + } + } + my $self = bless {}, $class; + local *MAILCAP; + if (defined $file && 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} = []; + } + push(@{$self->{$type}}, \%field); + } + close(MAILCAP); + } else { + # Set up default mailcap + $self->{'audio/*'} = [{'view' => "showaudio %s"}]; + $self->{'image/*'} = [{'view' => "xv %s"}]; + $self->{'message/rfc822'} = [{'view' => "xterm -e metamail %s"}]; + } + $self; +} + +=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 + +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) + +=head2 composeCmd($type, $file) + +=head2 editCmd($type, $file) + +=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. + +=cut + +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); + return undef unless $entry; + if (exists $entry->{$method}) { + return $self->expandPercentMacros($entry->{$method}, $type, $file); + } else { + return undef; + } +} + +sub _run +{ + my($self, $cmd) = @_; + if (defined $cmd) { + system $cmd; + return 1; + } + 0; +} + +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) = @_; + 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'); } +sub x11_bitmap { shift->field(shift, 'x11-bitmap'); } +sub nametemplate { shift->field(shift, 'nametemplate'); } + +sub getEntry +{ + my($self, $origtype, $file) = @_; + + if ($useCache) { + if (exists $self->{'_cache'}{$origtype}) { + return $self->{'_cache'}{$origtype}; + } + } + + my($fulltype, @params) = split(/\s*;\s*/, $origtype); + my($type, $subtype) = split(/\//, $fulltype, 2); + $subtype = "" unless defined $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 + last; + } + $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 %params; + for (@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) = @_; + $prefix = "" unless defined $prefix; + for (sort keys %$hash) { + print "$prefix$_ = $hash->{$_}\n"; + } +} + +sub dump +{ + my($self) = @_; + for (keys %$self) { + next if /^_/; + print "$_\n"; + for (@{$self->{$_}}) { + dumpEntry($_, "\t"); + print "\n"; + } + } + if (exists $self->{'_cache'}) { + print "Cached types\n"; + for (keys %{$self->{'_cache'}}) { + print "\t$_\n"; + } + } +} + +=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> + +Maintained by Graham Barr <gbarr@pobox.com> + +=cut + + +1; diff --git a/cpan/lib/Mail/Field.pm b/cpan/lib/Mail/Field.pm new file mode 100644 index 00000000..eea94c00 --- /dev/null +++ b/cpan/lib/Mail/Field.pm @@ -0,0 +1,507 @@ +# Mail::Field.pm +# +# Copyright (c) 1995-2000 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. + +package Mail::Field; + +# $Id$ + +use Carp; +use strict; +use vars qw($AUTOLOAD $VERSION); + +$VERSION = "1.08"; + +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; + } +} + +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; +} + +## +## Use the import method to load the sub-classes +## + +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" + } + } + 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; + } + } + _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; + + $method =~ tr/-/_/; + + $pkg = _header_pkg_name($method) + if($pkg eq "Mail::Field"); + + croak "Re-register of $method" + if Mail::Field->can($method); + + no strict 'refs'; + *{$method} = sub { + shift; + unless ($pkg->can('stringify')) { + eval "require $pkg" || die $@; + } + $pkg->_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 $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(@_); +} + +## +## 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); +} + +## +## A default create method. This allows us to do +## $s = Mail::Field->new('Subject'); +## + +sub parse +{ + my $self = shift; + my $type = ref($self) || $self; + + croak "$type: Cannot parse"; +} + +## +## either get the text, or parse a new one +## + +sub text +{ + my $self = shift; + @_ ? $self->parse(@_) + : $self->stringify; +} + +## +## Return the tag (in the correct case) for this item +## + +sub tag +{ + my $self = shift; + my $tag = ref($self) || $self; + + $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; + + $tag; +} + +## +## a constructor +## create a new object by extracting from a Mail::Header object +## + +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)); + } + + 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 }; + } + + $pkg->register($method) + unless(Mail::Field->can($method)); + + goto &$AUTOLOAD; +} + +## +## 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); + +sub create +{ + my $self = shift; + my %arg = @_; + my $text = delete $arg{Text} || ""; + + croak "Unknown options " . join(",", keys %arg) + if %arg; + + $self->{Text} = $text; + + $self; +} + +sub parse +{ + my $self = shift; + + $self->{Text} = shift || ""; + $self; +} + +sub stringify +{ + my $self = shift; + $self->{Text}; +} + +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 + +=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 <gbarr@pobox.com> + +=head1 SEE ALSO + +L<MIME::*>s + +=head1 CREDITS + +Eryq <eryq@rhine.gsfc.nasa.gov> - for all the help in defining this package +so that Mail::* and MIME::* can be integrated together. + +=head1 COPYRIGHT + +Copyright (c) 1995-2000 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 + + diff --git a/cpan/lib/Mail/Field/AddrList.pm b/cpan/lib/Mail/Field/AddrList.pm new file mode 100644 index 00000000..fa6a0d5c --- /dev/null +++ b/cpan/lib/Mail/Field/AddrList.pm @@ -0,0 +1,107 @@ +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 + +Peter Orbaek <poe@cit.dk> 26-Feb-97 +Modified by Graham Barr <gbarr@pobox.com> + +=cut + +use strict; +use vars qw(@ISA $VERSION); +use Mail::Field (); +use Carp; +use Mail::Address; + +@ISA = qw(Mail::Field); +$VERSION = '1.0'; + +# 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'); +} + +sub create { + my ($self, %arg) = @_; # (email => name, email => realname,...) + my($e,$n); + $self->{AddrList} = {}; + + $self->{AddrList}{$e} = Mail::Address->new($n,$e) + while(($e,$n) = each %arg); + + $self; +} + +sub parse { + my ($self, $string) = @_; + my ($a,$email,$name); + + foreach $a (Mail::Address->parse($string)) { + my $e = $a->address; + $self->{AddrList}{$e} = $a; + } + $self; +} + +sub stringify { + my $self = shift; + my ($x, $email, $name); + + join(", ", map { $_->format } values %{$self->{AddrList}}); +} + +sub addresses { + keys %{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/lib/Mail/Field/Date.pm b/cpan/lib/Mail/Field/Date.pm new file mode 100644 index 00000000..a90d431a --- /dev/null +++ b/cpan/lib/Mail/Field/Date.pm @@ -0,0 +1,80 @@ +# 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 + +package Mail::Field::Date; + +use strict; +use Mail::Field (); +use vars qw(@ISA $VERSION); +use Date::Format qw(time2str); +use Date::Parse qw(str2time); + +@ISA = qw(Mail::Field); +$VERSION = do { my @r=(q$Revision$=~/\d+/g); sprintf "%d."."%02d"x$#r,@r}; + +bless([])->register('Date'); + +sub set +{ + my $self = shift; + my $arg = @_ == 1 ? shift : { @_ }; + my $s; + + foreach $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; + } + + return $self->{Time} + if exists $self->{Time}; + + $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); +} + +sub reformat +{ + my $self = shift; + $self->time($self->time); + $self->stringify; +} + +1; + diff --git a/cpan/lib/Mail/Filter.pm b/cpan/lib/Mail/Filter.pm new file mode 100644 index 00000000..1101084a --- /dev/null +++ b/cpan/lib/Mail/Filter.pm @@ -0,0 +1,182 @@ +# Mail::Filter.pm +# +# 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. + +package Mail::Filter; + +use Carp; +use strict; +use vars qw($VERSION); + +$VERSION = "1.01"; + +sub new { + my $self = shift; + + bless { + filters => [ @_ ] + }, $self; +} + +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); + } + # the specification indicates that the result of operations on $mail + # should be returned by this function + return $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); + } + delete $self->{'folder'}; + delete $self->{'msgnum'}; + } + elsif($obj->isa('Mail::Internet')) { + return _filter($self,$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. + +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 E<lt>F<gbarr@pobox.com>E<gt> + +=head1 COPYRIGHT + +Copyright (c) 1997 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 + + diff --git a/cpan/lib/Mail/Header.pm b/cpan/lib/Mail/Header.pm new file mode 100644 index 00000000..e4fd8af6 --- /dev/null +++ b/cpan/lib/Mail/Header.pm @@ -0,0 +1,1022 @@ +# Mail::Header.pm +# +# Copyright (c) 1995-7 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. +# + +package Mail::Header; + +require 5.002; + +use strict; +use Carp; +use vars qw($VERSION $FIELD_NAME); + +$VERSION = "1.19"; + +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 :]+:'; + +## +## Private functions +## + +sub _error { warn @_; return (wantarray ? () : undef) } + +# 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--; + } + } + + if($d) + { + local $_; + my @del = (); + + while(($key,$ref) = each %{$me->{'mail_hdr_hash'}} ) + { + push(@del, $key) + unless @$ref = grep { ref($_) && defined $$_ } @$ref; + } + + map { delete $me->{'mail_hdr_hash'}{$_} } @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 + 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]+)/ and 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 + { + my $dif = $max-$min; + + $_[0] =~ s/(?:^|\G) + (?: + (.{$min,$max})\s+ + |(.{$min,$max}) + ) + /$+\n /xg; + } + } + + $_[0] =~ s/\A(\S+)\n\s*(?=\S)/$1 /so; +} + +# attempt to change the case of a tag to that required by RFC822. That +# 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. + +sub _tag_case +{ + my $tag = shift; + + $tag =~ s/:\Z//o; + + # Change the case of the tag + # eq Message-Id + $tag =~ s/\b([a-z]+)/\L\u$1/gio; + $tag =~ s/\b([b-df-hj-np-tv-z]+|MIME)\b/\U$1/gio + if $tag =~ /-/; + + $tag; +} + +# 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 $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>" + } + } + + if(defined $tag) + { + $tag = _tag_case($ctag = $tag); + + $ctag = $tag + if($modify); + + $ctag =~ s/([^ :])\Z/$1:/o if defined $ctag; + } + + croak( "Bad RFC822 field name '$tag'\n") + unless(defined $ctag && $ctag =~ /\A($FIELD_NAME|From )/oi); + + # 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; + } + + my $maxlen = $me->{'mail_hdr_lengths'}{$tag} + || $HDR_LENGTHS{$tag} + || $me->fold_length; + + _fold_line($line,$maxlen) + if $modify && defined $maxlen; + + $line =~ s/\n*\Z/\n/so; + + ($tag, $line); +} + +sub _insert +{ + my($me,$tag,$line,$where) = @_; + + if($where < 0) + { + $where = scalar(@{$me->{'mail_hdr_list'}}) + $where + 1; + + $where = 0 + if($where < 0); + } + elsif($where >= scalar(@{$me->{'mail_hdr_list'}})) + { + $where = scalar(@{$me->{'mail_hdr_list'}}); + } + + my $atend = $where == scalar(@{$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(scalar($me->{'mail_hdr_hash'}{$tag}) && $where) + { + if($atend) + { + push(@{$me->{'mail_hdr_hash'}{$tag}}, $ref); + } + else + { + my($ln,$i,$ref); + $i = 0; + foreach $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(@{$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); + } + } + + $me; +} + +sub modify +{ + my $me = shift; + my $old = $me->{'mail_hdr_modify'}; + + $me->{'mail_hdr_modify'} = 0 + shift + if @_; + + $old; +} + +sub mail_from +{ + my $me = shift; + my $choice = uc(shift); + + $choice =~ /^(IGNORE|ERROR|COERCE|KEEP)$/ + or die "bad Mail-From choice: '$choice'"; + + if(ref($me)) + { + $me->{'mail_hdr_mail_from'} = $choice; + } + else + { + $MAIL_FROM = $choice; + } + + $me; +} + +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; + } + } + + $me; +} + +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; + + while(scalar(@{$arr}) && $arr->[0] =~ /\A($FIELD_NAME|From )/o) + { + my $tag = $1; + + $line = shift @{$arr}; + $line .= shift @{$arr} + while(scalar(@{$arr}) && $arr->[0] =~ /\A[ \t]+/o); + + ($tag,$line) = _fmt_line($me,$tag,$line); + + _insert($me,$tag,$line,-1) + if defined $line; + } + + shift @{$arr} + if(scalar(@{$arr}) && $arr->[0] =~ /\A\s*\Z/o); + + $me; +} + +sub read +{ + my $me = shift; + my $fd = shift; + + $me->empty; + + my $line = undef; + my $ln = ""; + my $tag = undef; + + while(1) + { + $ln = <$fd>; + + if(defined $ln && defined $line && $ln =~ /\A[ \t]+/o) + { + $line .= $ln; + next; + } + + if(defined $line) + { + ($tag,$line) = _fmt_line($me,$tag,$line); + _insert($me,$tag,$line,-1) + if defined $line; + } + + last + unless(defined $ln && $ln =~ /\A($FIELD_NAME|From )/o); + + $tag = $1; + $line = $ln; + } + + $me; +} + +sub empty +{ + my $me = shift; + + $me->{'mail_hdr_list'} = []; + $me->{'mail_hdr_hash'} = {}; + + $me; +} + +sub header +{ + my $me = shift; + + $me->extract(@_) + if(@_); + + $me->fold + if $me->{'mail_hdr_modify'}; + + # 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 :- + + [ @{$me->{'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; + + # Extract the input data + for my $hdrkey (keys %$hashref) { + for (ref $hashref->{$hdrkey} + ? @{$hashref->{$hdrkey}} + : $hashref->{$hdrkey}) { + $me->add($hdrkey, $_); + } + } + + $me->fold + if $me->{'mail_hdr_modify'}; + + # Build a hash + my $hash={ map { $_ => [ $me->get($_) ] } keys %{$me->{'mail_hdr_hash'}} }; + + return $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 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); + } + } + + $line =~ /^\S+\s*(.*)/os; + return $1; +} + +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}}; + + $line = ${$me->{'mail_hdr_hash'}{$tag}[0]} = + (_fmt_line($me,$tag, join($with,@lines),1))[1]; + + _tidy_header($me); + } + else + { + return $me->{'mail_hdr_hash'}{$tag}[0]; + } + + return $line; # post-match +} + +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 exists +{ + carp "Depriciated use of Mail::Header::exists, use count" if $^W; + count(@_); +} + +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]}; + } + } + else + { + local $_; + @val = map { + my $x = substr($$_,$l); + undef $$_; + $x + } @{$me->{'mail_hdr_hash'}{$tag}}; + } + + _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'}}); +} + +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; + } + } + + $old; +} + +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]); + + $dup->{'mail_hdr_hash'}{$tag} ||= []; + push(@{$dup->{'mail_hdr_hash'}{$tag}}, \$ln); + } + + $dup; +} + +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++; + } + } + } + + _tidy_header($me) + if $d; + + $me; +} + +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 + +The default fold length for the object + +=item extract ( ARRAY_REF ) + +Extract a header from the given array. C<extract> B<will modify> this array. +Returns the object that the method was called on. + +=item read ( FD ) + +Read a header from the given file descriptor. + +=item empty () + +Empty the C<Mail::Header> object of all lines. + +=item header ( [ ARRAY_REF ] ) + +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. + +=item header_hashref ( [ HASH_REF ] ) + +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: + + $hashref->{From}='Tobias Brox <tobix@cpan.org>'; + $hashref->{To}=['you@somewhere', 'me@localhost']; + +=item add ( TAG, LINE [, INDEX ] ) + +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. + +=item replace ( TAG, LINE [, INDEX ] ) + +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. + +=item combine ( TAG [, WITH ] ) + +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 ] ) + +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. + +=item delete ( TAG [, INDEX ] ) + +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. + +=item count ( TAG ) + +Returns the number of times the given atg appears in the header + +=item print ( [ FD ] ) + +Print the header to the given file descriptor, or C<STDOUT> if no +file descriptor is given. + +=item as_string () + +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. + +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 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 () + +Create a duplicate of the current object. + +=item cleanup () + +Remove any header line that, other than the tag, only contains whitespace + +=item 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. + +=back + +=head1 AUTHOR + +Graham Barr <gbarr@pobox.com> + +=head1 COPYRIGHT + +Copyright (c) 1995-7 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 diff --git a/cpan/lib/Mail/Internet.pm b/cpan/lib/Mail/Internet.pm new file mode 100644 index 00000000..57c0e962 --- /dev/null +++ b/cpan/lib/Mail/Internet.pm @@ -0,0 +1,953 @@ +# Mail::Internet.pm +# +# Copyright (c) 1995-8 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. +# + +package Mail::Internet; +use strict; + +require 5.002; + +use Carp; +use AutoLoader; +use Mail::Header; +use vars qw($VERSION); + +BEGIN { + $VERSION = "1.33"; + *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; + } + } +} + + +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + my $arg = @_ % 2 ? shift : undef; + my %arg = @_; + + my $me = bless {}, $type; + + $me->{'mail_inet_head'} = $arg{Header} if exists $arg{Header}; + $me->{'mail_inet_body'} = $arg{Body} if exists $arg{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); + + if(defined $arg) + { + if(ref($arg) eq 'ARRAY') + { + $me->header($arg) unless exists $arg{Header}; + $me->body($arg) unless exists $arg{Body}; + } + elsif(defined fileno($arg)) + { + $me->read_header($arg) unless exists $arg{Header}; + $me->read_body($arg) unless exists $arg{Body}; + } + } + + return $me; +} + +sub read +{ + my $me = shift; + + $me->read_header(@_); + $me->read_body(@_); +} + +sub read_body +{ + my($me,$fd) = @_; + + $me->body( [ <$fd> ] ); +} + + +sub extract +{ + my $me = shift; + my $arg = shift; + + $me->head->extract($arg); + $me->body($arg); +} + + +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 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 clean_header +{ + carp "clean_header depreciated, use ->header" if $^W; + shift->header(); +} + +sub tidy_headers +{ + carp "tidy_headers no longer required" if $^W; +} + + +sub add +{ + my $me = shift; + my $head = $me->head; + my $ret; + while(@_) + { + my ($tag,$line) = splice(@_,0,2); + + $ret = $head->add($tag,$line,-1) or + return undef; + } + + $ret; +} + +sub replace +{ + my $me = shift; + my $head = $me->head; + my $ret; + + while(@_) + { + my ($tag,$line) = splice(@_,0,2); + + $ret = $head->replace($tag,$line,0) or + return undef; + } + + $ret; +} + +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 delete +{ + my $me = shift; + my $head = $me->head; + my @ret = (); + my $tag; + + foreach $tag (@_) + { + push(@ret, $head->delete($tag)); + } + + @ret; +} + +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 empty +{ + my $me = shift; + + %{*$me} = (); + + 1; +} + +sub print_body +{ + my $me = shift; + my $fd = shift || \*STDOUT; + my $ln; + + foreach $ln (@{$me->body}) + { + print $fd $ln or + return 0; + } + + 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 $me = shift; + + $me->head->as_string . "\n" . join '', @{ $me->body }; +} + +sub as_mbox_string +{ + my $me = shift->dup; + my $escaped = shift; + + $me->head->delete('Content-Length'); + $me->escape_from unless $escaped; + $me->as_string . "\n"; +} + +sub remove_sig +{ + my $me = shift; + my $nlines = shift || 10; + + my $body = $me->body; + my($line,$i); + + $line = scalar(@{$body}); + return unless($line); + + while($i++ < $nlines && $line--) + { + if($body->[$line] =~ /\A--\040?[\r\n]+/) + { + splice(@{$body},$line,$i); + last; + } + } +} + +sub tidy_body +{ + my $me = shift; + + my $body = $me->body; + my $line; + + if(scalar(@{$body})) + { + shift @$body + while(scalar(@{$body}) && $body->[0] =~ /\A\s*\Z/); + pop @$body + while(scalar(@{$body}) && $body->[-1] =~ /\A\s*\Z/); + } + + return $body; +} + +sub DESTROY {} + +# Auto loaded methods go after __END__ +__END__ + +sub reply; + + +use Mail::Address; + + sub reply +{ + my $me = shift; + my %arg = @_; + my $pkg = ref $me; + my @reply = (); + + local *MAILHDR; + if(open(MAILHDR,"$ENV{HOME}/.mailhdr")) + { + # User has defined a mail header template + @reply = <MAILHDR>; + close(MAILHDR); + } + + my $reply = $pkg->new(\@reply); + + my($to,$cc,$name,$body,$id); + + # The Subject line + + my $subject = $me->get('Subject') || ""; + + $subject = "Re: " . $subject if($subject =~ /\S+/ && $subject !~ /Re:/i); + + $reply->replace('Subject',$subject); + + # 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]; + + $name = $sender->name; + $id = $sender->address; + + unless(defined $name) + { + my $fr = $me->get('From'); + + $fr = (Mail::Address->parse($fr))[0] if(defined $fr); + $name = $fr->name if(defined $fr); + } + + my $indent = $arg{Indent} || ">"; + + if($indent =~ /%/) + { + my %hash = ( '%' => '%'); + my @name = grep(do { length > 0 }, split(/[\n\s]+/,$name || "")); + my @tmp; + + @name = "" unless(@name); + + $hash{f} = $name[0]; + $hash{F} = $#name ? substr($hash{f},0,1) : $hash{f}; + + $hash{l} = $#name ? $name[$#name] : ""; + $hash{L} = substr($hash{l},0,1) || ""; + + $hash{n} = $name || ""; + $hash{I} = join("",grep($_ = substr($_,0,1), @tmp = @name)); + + $indent =~ s/%(.)/defined $hash{$1} ? $hash{$1} : $1/eg; + } + + $reply->replace('To', $id); + + # Find addresses not to include + my %nocc = (); + my $mailaddresses = $ENV{MAILADDRESSES} || ""; + my $addr; + + $nocc{lc $id} = 1; + + foreach $addr (Mail::Address->parse($reply->get('Bcc'),$mailaddresses)) + { + my $lc = lc $addr->address; + $nocc{$lc} = 1; + } + + if($arg{ReplyAll} || 0) + { + # Who shall we copy this to + my %cc = (); + + foreach $addr (Mail::Address->parse($me->get('To'),$me->get('Cc'))) + { + my $lc = lc $addr->address; + $cc{$lc} = $addr->format unless(defined $nocc{$lc}); + } + $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; + + if($sig = delete $arg{File}) + { + local *SIG; + + if(open(SIG,$sig)) + { + local $_; + while(<SIG>) { last unless /\A(--)?\s*\Z/; } + + @sig = ($_,<SIG>,"\n"); + + close(SIG); + } + } + 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 + + $hdr->delete('Received'); + + $hdr->replace('X-Mailer', "Perl5 Mail::Internet v" . $Mail::Internet::VERSION); + + my $name = eval { local $SIG{__DIE__}; (getpwuid($>))[6] } || $ENV{NAME} || ""; + + while($name =~ s/\([^\(\)]*\)//) { 1; } + + if($name =~ /[^\w\s]/) { + $name =~ s/"/\"/g; + $name = '"' . $name . '"'; + } + + my $from = sprintf "%s <%s>", $name, Mail::Util::mailaddress(); + $from =~ s/\s{2,}/ /g; + + my $tag; + + foreach $tag (qw(From Sender)) { + $hdr->add($tag,$from) + unless($hdr->get($tag)); + } +} + +sub smtpsend; + +use Carp; +use Mail::Util qw(mailaddress); +use Mail::Address; +use Net::Domain qw(hostname); +use Net::SMTP; +use strict; + + 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, 'Port', $opt{'Port'}) + if exists $opt{'Port'}; + + push(@hello, 'Debug', $opt{'Debug'}) + if exists $opt{'Debug'}; + + unless(defined($host)) { + local $SIG{__DIE__}; + my @hosts = qw(mailhost localhost); + unshift(@hosts, split(/:/, $ENV{SMTPHOSTS})) if(defined $ENV{SMTPHOSTS}); + + 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; + } + else { + local $SIG{__DIE__}; + $smtp = eval { Net::SMTP->new($host, @hello) }; + } + + return () + unless(defined $smtp); + + my $hdr = $src->head->dup; + + _prephdr($hdr); + + # Who is it to + + my @rcpt = map { ref($_) ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'}; + @rcpt = map { $hdr->get($_) } qw(To Cc Bcc) + unless @rcpt; + my @addr = map($_->address, Mail::Address->parse(@rcpt)); + + return () + unless(@addr); + + $hdr->delete('Bcc'); # Remove blind Cc's + + # Send it + + my $ok = $smtp->mail( mailaddress() ) && + $smtp->to(@addr) && + $smtp->data(join("", @{$hdr->header},"\n",@{$src->body})); + + $smtp->quit + unless $noquit; + + $ok ? @addr : (); +} + +sub send; + +use Mail::Mailer; +use strict; + + sub send +{ + my ($src, $type, @args) = @_; + + my $hdr = $src->head->dup; + + _prephdr($hdr); + + my $headers = $hdr->header_hashref; + + # Actually send it + 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; + + sub nntppost +{ + my $mail = shift; + my %opt = @_; + + my $groups = $mail->get('Newsgroups') || ""; + my @groups = split(/[\s,]+/,$groups); + + return () + unless @groups; + + my $hdr = $mail->head->dup; + + _prephdr($hdr); + + # Remove these incase the NNTP host decides to mail as well as me + $hdr->delete(qw(To Cc Bcc)); + + my $news; + my $noquit = 0; + my $host = $opt{Host}; + + if(ref($host) && UNIVERSAL::isa($host,'Net::NNTP')) { + $news = $host; + $noquit = 1; + } + else { + my @opt = (); + + push(@opt, $opt{'Host'}); + + push(@opt, 'Port', $opt{'Port'}) + if exists $opt{'Port'}; + + push(@opt, 'Debug', $opt{'Debug'}) + if exists $opt{'Debug'}; + + $news = new Net::NNTP(@opt) + or return (); + } + + $news->post(@{$hdr->header},"\n",@{$mail->body}); + + my $code = $news->code; + + $news->quit + unless $noquit; + + return 240 == $code ? @groups : (); +} + +sub escape_from +{ + my $me = shift; + + my $body = $me->body; + local $_; + + 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; +} + +1; # keep require happy + + + +=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. + +=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 () + +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. + +=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 + +L<Mail::Header> +L<Mail::Address> + +=head1 AUTHOR + +Graham Barr <gbarr@pobox.com> + +=head1 COPYRIGHT + +Copyright (c) 1995-7 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 + + diff --git a/cpan/lib/Mail/Mailer.pm b/cpan/lib/Mail/Mailer.pm new file mode 100644 index 00000000..e5a42ff0 --- /dev/null +++ b/cpan/lib/Mail/Mailer.pm @@ -0,0 +1,332 @@ +# + +package Mail::Mailer; + +=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<mail> + +Use the Unix system C<mail> program to deliver the mail. C<$command> +is the path to C<mail>. Mail::Mailer will search for C<mailx>, C<Mail> +and C<mail> (in this order). + +=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; + +=item C<test> + +Used for debugging, this calls C</bin/echo> to display the data. 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;...:..." + +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" + +=back + +=head1 SEE ALSO + +Mail::Send + +=head1 AUTHORS + +Maintained by Graham Barr E<lt>F<gbarr@pobox.com>E<gt> + +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>. + +For support please contact comp.lang.perl.misc or Graham Barr +E<lt>F<gbarr@pobox.com>E<gt> + +=cut + +use Carp; +use IO::Handle; +use vars qw(@ISA $VERSION $MailerBinary $MailerType %Mailers @Mailers); +use Config; +use strict; + +$VERSION = "1.21"; # $Id$ + +sub Version { $VERSION } + +@ISA = qw(IO::Handle); + +# Suggested binaries for types? Should this be handled in the object class? +@Mailers = ( + + # Body on stdin with tilde escapes + 'mail' => 'mail', + + # Headers-blank-Body all on stdin + 'sendmail' => '/usr/lib/sendmail;/usr/sbin/sendmail;/usr/ucblib/sendmail', + + 'smtp' => undef, + 'test' => 'test' +); + +# There are several flavours of mail, which do we have ???? + +{ + my $cmd = is_exe('mailx;Mail;mail'); + my $osname = $Config{'osname'}; + + if($osname =~ /(?:dgux)|(?:solaris)/io) { + $cmd .= " -~"; + } + elsif($osname =~ /(?:linux)|(?:bsdos)|(?:freebsd)/io) { + $cmd .= " -I"; + } + push @Mailers, 'mail', $cmd; +} + +push(@Mailers, split(/:/,$ENV{PERL_MAILERS})) if $ENV{PERL_MAILERS}; + +%Mailers = @Mailers; + +$MailerBinary = undef; + +# does this really need to be done? or should a default mailer be specfied? + +if($^O eq 'MacOS' || $^O eq 'VMS' || $^O eq 'MSWin32') { + $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; + } + } +} + +sub import { + shift; + + if(@_) { + my $type = shift; + my $exe = shift || $Mailers{$type}; + + carp "Cannot locate '$exe'" + unless is_exe($exe); + + $MailerType = $type; + $Mailers{$MailerType} = $exe; + } +} + +sub to_array { + my($self, $thing) = @_; + if (ref($thing)) { + return @$thing; + } else { + return ($thing); + } +} + +sub is_exe { + my $exe = shift; + my $cmd; + + foreach $cmd (split /;/, $exe) { + $cmd =~ s/^\s+//; + + # 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:/:); + + if (defined $ENV{PATH}) { + my $dir; + foreach $dir (split(/:/, $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; + + my $exe = $Mailers{$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; + } + + $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; +} + + +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); + + $self->close; # just in case; + + # Fork and start a mailer + (defined($exe) && open($self,"|-")) + || $self->exec($exe, $args, \@to) + || 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//; + } + } +} + + +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); +} + +sub can_cc { 1 } # overridden in subclass for mailer that can't + +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}; + } + @to; +} + +sub epilogue { + # This could send a .signature, also see ::smtp subclass +} + +sub close { + my($self, @to) = @_; + if (fileno($self)) { + $self->epilogue; + close($self) + } +} + + +sub DESTROY { + my $self = shift; + $self->close; +} + +1; + diff --git a/cpan/lib/Mail/Mailer/mail.pm b/cpan/lib/Mail/Mailer/mail.pm new file mode 100644 index 00000000..0eb3595b --- /dev/null +++ b/cpan/lib/Mail/Mailer/mail.pm @@ -0,0 +1,27 @@ +package Mail::Mailer::mail; +use vars qw(@ISA); +@ISA = qw(Mail::Mailer); + +my %hdrs = qw(Cc ~c Bcc ~b Subject ~s); + +sub set_headers { + my $self = shift; + my $hdrs = shift; + my($k,$v); + + while(($k,$v) = each %hdrs) { + print $self join(" ",$v, $self->to_array($hdrs->{$k})), "\n" + if defined $hdrs->{$k}; + } +} + +sub exec { + # These fail in FCGI under 5.6 due to 5.6 adding an OPEN to the + # tie interface and FCGI not having one. + eval { + open(STDOUT,">/dev/null"); # this is not portable !!!! + open(STDERR,">/dev/null"); # this is not portable !!!! + }; + shift->SUPER::exec(@_); +} +1; diff --git a/cpan/lib/Mail/Mailer/rfc822.pm b/cpan/lib/Mail/Mailer/rfc822.pm new file mode 100644 index 00000000..dcb0dbca --- /dev/null +++ b/cpan/lib/Mail/Mailer/rfc822.pm @@ -0,0 +1,16 @@ +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]/; + print $self "$_: ", join(",", $self->to_array($hdrs->{$_})), "\n"; + } + print $self "\n"; # terminate headers +} + +1; diff --git a/cpan/lib/Mail/Mailer/sendmail.pm b/cpan/lib/Mail/Mailer/sendmail.pm new file mode 100644 index 00000000..ea67d7e0 --- /dev/null +++ b/cpan/lib/Mail/Mailer/sendmail.pm @@ -0,0 +1,17 @@ +package Mail::Mailer::sendmail; +use vars qw(@ISA); +require Mail::Mailer::rfc822; +@ISA = qw(Mail::Mailer::rfc822); + + +sub exec { + my($self, $exe, $args, $to) = @_; + # 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. + exec( $exe, '-t', @$args ); +} diff --git a/cpan/lib/Mail/Mailer/smtp.pm b/cpan/lib/Mail/Mailer/smtp.pm new file mode 100644 index 00000000..6db78fa4 --- /dev/null +++ b/cpan/lib/Mail/Mailer/smtp.pm @@ -0,0 +1,75 @@ +package Mail::Mailer::smtp; +use vars qw(@ISA); +use Net::SMTP; +use Mail::Util qw(mailaddress); + +require Mail::Mailer::rfc822; +@ISA = qw(Mail::Mailer::rfc822); + +sub can_cc { 0 } + +sub exec { + my($self, $exe, $args, $to) = @_; + my %opt = @$args; + my $host = $opt{'Server'} || undef; + # for Net::SMTP we do not really exec + my $smtp = Net::SMTP->new($host, Debug => 0) + or return undef; + + ${*$self}{'sock'} = $smtp; + + $smtp->mail(mailaddress()); + my $u; + foreach $u (@$to) { + $smtp->to($u); + } + $smtp->data; + 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 epilogue { + my $self = shift; + my $sock = ${*$self}{'sock'}; + $sock->dataend; + $sock->quit; + delete ${*$self}{'sock'}; + untie(*$self); +} + +sub close { + my($self, @to) = @_; + my $sock = ${*$self}{'sock'}; + if ($sock && fileno($sock)) { + $self->epilogue; + close($sock); + } +} + +package Mail::Mailer::smtp::pipe; + +sub TIEHANDLE { + my $pkg = shift; + my $self = shift; + my $sock = ${*$self}{'sock'}; + return bless \$sock; +} + +sub PRINT { + my $self = shift; + my $sock = $$self; + $sock->datasend( @_ ); +} + + +1; diff --git a/cpan/lib/Mail/Mailer/test.pm b/cpan/lib/Mail/Mailer/test.pm new file mode 100644 index 00000000..062a2b72 --- /dev/null +++ b/cpan/lib/Mail/Mailer/test.pm @@ -0,0 +1,13 @@ +package Mail::Mailer::test; +use vars qw(@ISA); +require Mail::Mailer::rfc822; +@ISA = qw(Mail::Mailer::rfc822); + +sub can_cc { 0 } + +sub exec { + my($self, $exe, $args, $to) = @_; + exec('sh', '-c', "echo to: " . join(" ",@{$to}) . "; cat"); +} + +1; diff --git a/cpan/lib/Mail/Send.pm b/cpan/lib/Mail/Send.pm new file mode 100644 index 00000000..346a2002 --- /dev/null +++ b/cpan/lib/Mail/Send.pm @@ -0,0 +1,110 @@ + +package Mail::Send; + +# $Id$ + +use strict; +use Carp; +use vars qw($VERSION); +require Mail::Mailer; + +$VERSION = "1.09"; + +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 +} + +sub add { + my($me, $hdr, @values) = @_; + $me->{$hdr} = [] unless $me->{$hdr}; + push(@{$me->{$hdr}}, @values); +} + +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 open { + my $me = shift; + Mail::Mailer->new(@_)->open($me); +} + +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. + + $fh = $msg->open; + + print $fh "Body of message"; + + $fh->close; # complete the message and send it + + $fh->cancel; # not yet implemented + +=head1 DESCRIPTION + +=head1 SEE ALSO + +Mail::Mailer + +=head1 AUTHORS + +Maintained by Graham Barr E<lt>F<gbarr@pobox.com>E<gt> + +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> + +For support please contact comp.lang.perl.misc or Graham Barr +E<lt>F<gbarr@pobox.com>E<gt> + +=cut + + diff --git a/cpan/lib/Mail/Util.pm b/cpan/lib/Mail/Util.pm new file mode 100644 index 00000000..e0c2a344 --- /dev/null +++ b/cpan/lib/Mail/Util.pm @@ -0,0 +1,240 @@ +# Mail::Util.pm +# +# Copyright (c) 1995-8 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. + +package Mail::Util; + +use strict; +use vars qw($VERSION @ISA @EXPORT_OK); +use AutoLoader (); +use Exporter (); + +BEGIN { + require 5.000; + + $VERSION = "1.16"; + + *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 + + Look for a sendmail.cf file and extract DH parameter + Look for a smail config file and usr the first host defined in hostname(s) + Try an SMTP connect (if Net::SMTP exists) first to mailhost then localhost + Use value from Net::Domain::domainname (if Net::Domain exists) + +=head2 mailaddress() + +Return a guess at the current users mail address. The user can force +the return value by setting C<$ENV{MAILADDRESS}> + +=head1 AUTHOR + +Graham Barr <gbarr@pobox.com> + +=head1 COPYRIGHT + +Copyright (c) 1995-8 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 + +__END__ + +sub read_mbox { + my $file = shift; + my @mail = (); + 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}, $_); + } + } + + push(@mail, $mail) if scalar(@{$mail}); + + close(FH); + + return wantarray ? @mail : \@mail; +} + + +sub maildomain { + + ## + ## return imediately if already found + ## + + return $domain + if(defined $domain); + + ## + ## Try sendmail config file if exists + ## + + 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(/\AD([a-zA-Z])([\w.]+)/) { + my($v,$arg) = ($1,$2); + $arg =~ s/\$([a-zA-Z])/exists $var{$1} ? $var{$1} : '$' . $1/eg; + $var{$v} = $arg; + } + } + close(CF); + $domain = $var{'j'} if defined $var{'j'}; + $domain = $var{'M'} if defined $var{'M'}; + return $domain + if(defined $domain); + } + + ## + ## 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]; + last; + } + } + close(CF); + + return $domain + if(defined $domain); + } + + ## + ## Try a SMTP connection to 'mailhost' + ## + + if(eval { require Net::SMTP }) { + my $host; + + foreach $host (qw(mailhost localhost)) { + my $smtp = eval { Net::SMTP->new($host) }; + + 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); + + return $domain; +} + + +sub mailaddress { + + ## + ## Return imediately if already found + ## + + return $mailaddress + if(defined $mailaddress); + + ## + ## Get user name from environment + ## + + $mailaddress = $ENV{MAILADDRESS}; + + unless ($mailaddress || $^O ne 'MacOS') { + require Mac::InternetConfig; + Mac::InternetConfig->import(); + + $mailaddress = $InternetConfig{kICEmail()}; + } + + $mailaddress ||= $ENV{USER} || + $ENV{LOGNAME} || + eval { (getpwuid($>))[6] } || + "postmaster"; + + ## + ## Add domain if it does not exist + ## + + $mailaddress .= '@' . maildomain() + unless($mailaddress =~ /\@/); + + $mailaddress =~ s/(^.*<|>.*$)//g; + + $mailaddress; +} |