p147685/CardiacPhase
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Initial class construction

Browse Source
This commit is contained in:
João Narciso
2019-05-06 16:34:28 +02:00
parent 67f2d57e03
commit 431ff5f7d4
5813 changed files with 1622108 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

280
Git/usr/share/perl5/vendor_perl/Mail/Address.pm Normal file
View File

@ -0,0 +1,280 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Address;
use vars '$VERSION';
$VERSION = '2.20';
use strict;
use Carp;
# use locale; removed in version 1.78, because it causes taint problems
sub Version { our $VERSION }
# given a comment, attempt to extract a person's name
sub _extract_name
{ # This function can be called as method as well
my $self = @_ && ref $_[0] ? shift : undef;
local $_ = shift
or return '';
# Using encodings, too hard. See Mail::Message::Field::Full.
return '' if m/\=\?.*?\?\=/;
# trim whitespace
s/^\s+//;
s/\s+$//;
s/\s+/ /;
# Disregard numeric names (e.g. 123456.1234@compuserve.com)
return "" if /^[\d ]+$/;
s/^\((.*)\)$/$1/; # remove outermost parenthesis
s/^"(.*)"$/$1/; # remove outer quotation marks
s/\(.*?\)//g; # remove minimal embedded comments
s/\\//g; # remove all escapes
s/^"(.*)"$/$1/; # remove internal quotation marks
s/^([^\s]+) ?, ?(.*)$/$2 $1/; # reverse "Last, First M." if applicable
s/,.*//;
# Change casing only when the name contains only upper or only
# lower cased characters.
unless( m/[A-Z]/ && m/[a-z]/ )
{ # Set the case of the name to first char upper rest lower
s/\b(\w+)/\L\u$1/igo; # Upcase first letter on name
s/\bMc(\w)/Mc\u$1/igo; # Scottish names such as 'McLeod'
s/\bo'(\w)/O'\u$1/igo; # Irish names such as 'O'Malley, O'Reilly'
s/\b(x*(ix)?v*(iv)?i*)\b/\U$1/igo; # Roman numerals, eg 'Level III Support'
}
# some cleanup
s/\[[^\]]*\]//g;
s/(^[\s'"]+|[\s'"]+$)//g;
s/\s{2,}/ /g;
$_;
}
sub _tokenise
{ local $_ = join ',', @_;
my (@words,$snippet,$field);
s/\A\s+//;
s/[\r\n]+/ /g;
while ($_ ne '')
{ $field = '';
if(s/^\s*\(/(/ ) # (...)
{ my $depth = 0;
PAREN: while(s/^(\(([^\(\)\\]|\\.)*)//)
{ $field .= $1;
$depth++;
while(s/^(([^\(\)\\]|\\.)*\)\s*)//)
{ $field .= $1;
last PAREN unless --$depth;
$field .= $1 if s/^(([^\(\)\\]|\\.)+)//;
}
}
carp "Unmatched () '$field' '$_'"
if $depth;
$field =~ s/\s+\Z//;
push @words, $field;
next;
}
if( s/^("(?:[^"\\]+|\\.)*")\s*// # "..."
|| s/^(\[(?:[^\]\\]+|\\.)*\])\s*// # [...]
|| s/^([^\s()<>\@,;:\\".[\]]+)\s*//
|| s/^([()<>\@,;:\\".[\]])\s*//
)
{ push @words, $1;
next;
}
croak "Unrecognised line: $_";
}
push @words, ",";
\@words;
}
sub _find_next
{ my ($idx, $tokens, $len) = @_;
while($idx < $len)
{ my $c = $tokens->[$idx];
return $c if $c eq ',' || $c eq ';' || $c eq '<';
$idx++;
}
"";
}
sub _complete
{ my ($class, $phrase, $address, $comment) = @_;
@$phrase || @$comment || @$address
or return undef;
my $o = $class->new(join(" ",@$phrase), join("",@$address), join(" ",@$comment));
@$phrase = @$address = @$comment = ();
$o;
}
#------------
sub new(@)
{ my $class = shift;
bless [@_], $class;
}
sub parse(@)
{ my $class = shift;
my @line = grep {defined} @_;
my $line = join '', @line;
my (@phrase, @comment, @address, @objs);
my ($depth, $idx) = (0, 0);
my $tokens = _tokenise @line;
my $len = @$tokens;
my $next = _find_next $idx, $tokens, $len;
local $_;
for(my $idx = 0; $idx < $len; $idx++)
{ $_ = $tokens->[$idx];
if(substr($_,0,1) eq '(') { push @comment, $_ }
elsif($_ eq '<') { $depth++ }
elsif($_ eq '>') { $depth-- if $depth }
elsif($_ eq ',' || $_ eq ';')
{ warn "Unmatched '<>' in $line" if $depth;
my $o = $class->_complete(\@phrase, \@address, \@comment);
push @objs, $o if defined $o;
$depth = 0;
$next = _find_next $idx+1, $tokens, $len;
}
elsif($depth) { push @address, $_ }
elsif($next eq '<') { push @phrase, $_ }
elsif( /^[.\@:;]$/ || !@address || $address[-1] =~ /^[.\@:;]$/ )
{ push @address, $_ }
else
{ warn "Unmatched '<>' in $line" if $depth;
my $o = $class->_complete(\@phrase, \@address, \@comment);
push @objs, $o if defined $o;
$depth = 0;
push @address, $_;
}
}
@objs;
}
#------------
sub phrase { shift->set_or_get(0, @_) }
sub address { shift->set_or_get(1, @_) }
sub comment { shift->set_or_get(2, @_) }
sub set_or_get($)
{ my ($self, $i) = (shift, shift);
@_ or return $self->[$i];
my $val = $self->[$i];
$self->[$i] = shift if @_;
$val;
}
my $atext = '[\-\w !#$%&\'*+/=?^`{|}~]';
sub format
{ my @addrs;
foreach (@_)
{ my ($phrase, $email, $comment) = @$_;
my @addr;
if(defined $phrase && length $phrase)
{ push @addr
, $phrase =~ /^(?:\s*$atext\s*)+$/o ? $phrase
: $phrase =~ /(?<!\\)"/ ? $phrase
: qq("$phrase");
push @addr, "<$email>"
if defined $email && length $email;
}
elsif(defined $email && length $email)
{ push @addr, $email;
}
if(defined $comment && $comment =~ /\S/)
{ $comment =~ s/^\s*\(?/(/;
$comment =~ s/\)?\s*$/)/;
}
push @addr, $comment
if defined $comment && length $comment;
push @addrs, join(" ", @addr)
if @addr;
}
join ", ", @addrs;
}
#------------
sub name
{ my $self = shift;
my $phrase = $self->phrase;
my $addr = $self->address;
$phrase = $self->comment
unless defined $phrase && length $phrase;
my $name = $self->_extract_name($phrase);
# first.last@domain address
if($name eq '' && $addr =~ /([^\%\.\@_]+([\._][^\%\.\@_]+)+)[\@\%]/)
{ ($name = $1) =~ s/[\._]+/ /g;
$name = _extract_name $name;
}
if($name eq '' && $addr =~ m#/g=#i) # X400 style address
{ my ($f) = $addr =~ m#g=([^/]*)#i;
my ($l) = $addr =~ m#s=([^/]*)#i;
$name = _extract_name "$f $l";
}
length $name ? $name : undef;
}
sub host
{ my $addr = shift->address || '';
my $i = rindex $addr, '@';
$i >= 0 ? substr($addr, $i+1) : undef;
}
sub user
{ my $addr = shift->address || '';
my $i = rindex $addr, '@';
$i >= 0 ? substr($addr,0,$i) : $addr;
}
1;

255
Git/usr/share/perl5/vendor_perl/Mail/Cap.pm Normal file
View File

@ -0,0 +1,255 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Cap;
use vars '$VERSION';
$VERSION = '2.20';
use strict;
sub Version { our $VERSION }
our $useCache = 1; # don't evaluate tests every time
my @path;
if($^O eq "MacOS")
{ @path = split /\,/, $ENV{MAILCAPS} || "$ENV{HOME}mailcap";
}
else
{ @path = split /\:/
, ( $ENV{MAILCAPS} || (defined $ENV{HOME} ? "$ENV{HOME}/.mailcap:" : '')
. '/etc/mailcap:/usr/etc/mailcap:/usr/local/etc/mailcap'
); # this path is specified under RFC1524 appendix A
}
#--------
sub new
{ my $class = shift;
unshift @_, 'filename' if @_ % 2;
my %args = @_;
my $take_all = $args{take} && uc $args{take} eq 'ALL';
my $self = bless {_count => 0}, $class;
$self->_process_file($args{filename})
if defined $args{filename} && -r $args{filename};
if(!defined $args{filename} || $take_all)
{ foreach my $fname (@path)
{ -r $fname or next;
$self->_process_file($fname);
last unless $take_all;
}
}
unless($self->{_count})
{ # Set up default mailcap
$self->{'audio/*'} = [{'view' => "showaudio %s"}];
$self->{'image/*'} = [{'view' => "xv %s"}];
$self->{'message/rfc822'} = [{'view' => "xterm -e metamail %s"}];
}
$self;
}
sub _process_file
{ my $self = shift;
my $file = shift or return;
local *MAILCAP;
open MAILCAP, $file
or return;
$self->{_file} = $file;
local $_;
while(<MAILCAP>)
{ next if /^\s*#/; # comment
next if /^\s*$/; # blank line
$_ .= <MAILCAP> # continuation line
while s/(^|[^\\])((?:\\\\)*)\\\s*$/$1$2/;
chomp;
s/\0//g; # ensure no NULs in the line
s/(^|[^\\]);/$1\0/g; # make field separator NUL
my ($type, $view, @parts) = split /\s*\0\s*/;
$type .= "/*" if $type !~ m[/];
$view =~ s/\\;/;/g;
$view =~ s/\\\\/\\/g;
my %field = (view => $view);
foreach (@parts)
{ my($key, $val) = split /\s*\=\s*/, $_, 2;
if(defined $val)
{ $val =~ s/\\;/;/g;
$val =~ s/\\\\/\\/g;
$field{$key} = $val;
}
else
{ $field{$key} = 1;
}
}
if(my $test = $field{test})
{ unless ($test =~ /\%/)
{ # No parameters in test, can perform it right away
system $test;
next if $?;
}
}
# record this entry
unless(exists $self->{$type})
{ $self->{$type} = [];
$self->{_count}++;
}
push @{$self->{$type}}, \%field;
}
close MAILCAP;
}
#------------------
sub view { my $self = shift; $self->_run($self->viewCmd(@_)) }
sub compose { my $self = shift; $self->_run($self->composeCmd(@_)) }
sub edit { my $self = shift; $self->_run($self->editCmd(@_)) }
sub print { my $self = shift; $self->_run($self->printCmd(@_)) }
sub _run($)
{ my ($self, $cmd) = @_;
defined $cmd or return 0;
system $cmd;
1;
}
#------------------
sub viewCmd { shift->_createCommand(view => @_) }
sub composeCmd { shift->_createCommand(compose => @_) }
sub editCmd { shift->_createCommand(edit => @_) }
sub printCmd { shift->_createCommand(print => @_) }
sub _createCommand($$$)
{ my ($self, $method, $type, $file) = @_;
my $entry = $self->getEntry($type, $file);
$entry && exists $entry->{$method}
or return undef;
$self->expandPercentMacros($entry->{$method}, $type, $file);
}
sub makeName($$)
{ my ($self, $type, $basename) = @_;
my $template = $self->nametemplate($type)
or return $basename;
$template =~ s/%s/$basename/g;
$template;
}
#------------------
sub field($$)
{ my($self, $type, $field) = @_;
my $entry = $self->getEntry($type);
$entry->{$field};
}
sub description { shift->field(shift, 'description'); }
sub textualnewlines { shift->field(shift, 'textualnewlines'); }
sub x11_bitmap { shift->field(shift, 'x11-bitmap'); }
sub nametemplate { shift->field(shift, 'nametemplate'); }
sub getEntry
{ my($self, $origtype, $file) = @_;
return $self->{_cache}{$origtype}
if $useCache && exists $self->{_cache}{$origtype};
my ($fulltype, @params) = split /\s*;\s*/, $origtype;
my ($type, $subtype) = split m[/], $fulltype, 2;
$subtype ||= '';
my $entry;
foreach (@{$self->{"$type/$subtype"}}, @{$self->{"$type/*"}})
{ if(exists $_->{'test'})
{ # must run test to see if it applies
my $test = $self->expandPercentMacros($_->{'test'},
$origtype, $file);
system $test;
next if $?;
}
$entry = { %$_ }; # make copy
last;
}
$self->{_cache}{$origtype} = $entry if $useCache;
$entry;
}
sub expandPercentMacros
{ my ($self, $text, $type, $file) = @_;
defined $type or return $text;
defined $file or $file = "";
my ($fulltype, @params) = split /\s*;\s*/, $type;
($type, my $subtype) = split m[/], $fulltype, 2;
my %params;
foreach (@params)
{ my($key, $val) = split /\s*=\s*/, $_, 2;
$params{$key} = $val;
}
$text =~ s/\\%/\0/g; # hide all escaped %'s
$text =~ s/%t/$fulltype/g; # expand %t
$text =~ s/%s/$file/g; # expand %s
{ # expand %{field}
local $^W = 0; # avoid warnings when expanding %params
$text =~ s/%\{\s*(.*?)\s*\}/$params{$1}/g;
}
$text =~ s/\0/%/g;
$text;
}
# This following procedures can be useful for debugging purposes
sub dumpEntry
{ my($hash, $prefix) = @_;
defined $prefix or $prefix = "";
print "$prefix$_ = $hash->{$_}\n"
for sort keys %$hash;
}
sub dump
{ my $self = shift;
foreach (keys %$self)
{ next if /^_/;
print "$_\n";
foreach (@{$self->{$_}})
{ dumpEntry($_, "\t");
print "\n";
}
}
if(exists $self->{_cache})
{ print "Cached types\n";
print "\t$_\n"
for keys %{$self->{_cache}};
}
}
1;

231
Git/usr/share/perl5/vendor_perl/Mail/Field.pm Normal file
View File

@ -0,0 +1,231 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Field;
use vars '$VERSION';
$VERSION = '2.20';
use strict;
use Carp;
use Mail::Field::Generic;
sub _header_pkg_name
{ my $header = lc shift;
$header =~ s/((\b|_)\w)/\U$1/g;
if(length($header) > 8)
{ my @header = split /[-_]+/, $header;
my $chars = int((7 + @header) / @header) || 1;
$header = substr join('', map {substr $_,0,$chars} @header), 0, 8;
}
else
{ $header =~ s/[-_]+//g;
}
'Mail::Field::' . $header;
}
sub _require_dir
{ my($class, $dir, $dir_sep) = @_;
local *DIR;
opendir DIR, $dir
or return;
my @inc;
foreach my $f (readdir DIR)
{ $f =~ /^([\w\-]+)/ or next;
my $p = $1;
my $n = "$dir$dir_sep$p";
if(-d $n )
{ _require_dir("${class}::$f", $n, $dir_sep);
}
else
{ $p =~ s/-/_/go;
eval "require ${class}::$p";
# added next warning in 2.14, may be ignored for ancient code
warn $@ if $@;
}
}
closedir DIR;
}
sub import
{ my $class = shift;
if(@_)
{ local $_;
eval "require " . _header_pkg_name($_) || die $@
for @_;
return;
}
my ($dir, $dir_sep);
foreach my $f (grep defined $INC{$_}, keys %INC)
{ next if $f !~ /^Mail(\W)Field\W/i;
$dir_sep = $1;
# $dir = ($INC{$f} =~ /(.*Mail\W+Field)/i)[0] . $dir_sep;
($dir = $INC{$f}) =~ s/(Mail\W+Field).*/$1$dir_sep/;
last;
}
_require_dir('Mail::Field', $dir, $dir_sep);
}
# register a header class, this creates a new method in Mail::Field
# which will call new on that class
sub register
{ my $thing = shift;
my $method = lc shift;
my $class = shift || ref($thing) || $thing;
$method =~ tr/-/_/;
$class = _header_pkg_name $method
if $class eq "Mail::Field";
croak "Re-register of $method"
if Mail::Field->can($method);
no strict 'refs';
*{$method} = sub {
shift;
$class->can('stringify') or eval "require $class" or die $@;
$class->_build(@_);
};
}
# the *real* constructor
# if called with one argument then the `parse' method will be called
# otherwise the `create' method is called
sub _build
{ my $self = bless {}, shift;
@_==1 ? $self->parse(@_) : $self->create(@_);
}
#-------------
sub new
{ my $class = shift;
my $field = lc shift;
$field =~ tr/-/_/;
$class->$field(@_);
}
sub combine {confess "Combine not implemented" }
our $AUTOLOAD;
sub AUTOLOAD
{ my $method = $AUTOLOAD;
$method =~ s/.*:://;
$method =~ /^[^A-Z\x00-\x1f\x80-\xff :]+$/
or croak "Undefined subroutine &$AUTOLOAD called";
my $class = _header_pkg_name $method;
unless(eval "require $class")
{ my $tag = $method;
$tag =~ s/_/-/g;
$tag = join '-',
map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) }
split /\-/, $tag;
no strict;
@{"${class}::ISA"} = qw(Mail::Field::Generic);
*{"${class}::tag"} = sub { $tag };
}
Mail::Field->can($method)
or $class->register($method);
goto &$AUTOLOAD;
}
# Of course, the functionality should have been in the Mail::Header class
sub extract
{ my ($class, $tag, $head) = (shift, shift, shift);
my $method = lc $tag;
$method =~ tr/-/_/;
if(@_==0 && wantarray)
{ my @ret;
my $text; # need real copy!
foreach $text ($head->get($tag))
{ chomp $text;
push @ret, $class->$method($text);
}
return @ret;
}
my $idx = shift || 0;
my $text = $head->get($tag,$idx)
or return undef;
chomp $text;
$class->$method($text);
}
#-------------
# before 2.00, this method could be called as class method, however
# not all extensions supported that.
sub create
{ my ($self, %arg) = @_;
%$self = ();
$self->set(\%arg);
}
# before 2.00, this method could be called as class method, however
# not all extensions supported that.
sub parse
{ my $class = ref shift;
confess "parse() not implemented";
}
#-------------
sub stringify { confess "stringify() not implemented" }
sub tag
{ my $thing = shift;
my $tag = ref($thing) || $thing;
$tag =~ s/.*:://;
$tag =~ s/_/-/g;
join '-',
map { /^[b-df-hj-np-tv-z]+$|^MIME$/i ? uc($_) : ucfirst(lc $_) }
split /\-/, $tag;
}
sub set(@) { confess "set() not implemented" }
# prevent the calling of AUTOLOAD for DESTROY :-)
sub DESTROY {}
#-------------
sub text
{ my $self = shift;
@_ ? $self->parse(@_) : $self->stringify;
}
#-------------
1;

72
Git/usr/share/perl5/vendor_perl/Mail/Field/AddrList.pm Normal file
View File

@ -0,0 +1,72 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
use strict;
package Mail::Field::AddrList;
use vars '$VERSION';
$VERSION = '2.20';
use base 'Mail::Field';
use Carp;
use Mail::Address;
my $x = bless [];
$x->register('To');
$x->register('From');
$x->register('Cc');
$x->register('Reply-To');
$x->register('Sender');
sub create(@)
{ my ($self, %arg) = @_;
$self->{AddrList} = {};
while(my ($e, $n) = each %arg)
{ $self->{AddrList}{$e} = Mail::Address->new($n, $e);
}
$self;
}
sub parse($)
{ my ($self, $string) = @_;
foreach my $a (Mail::Address->parse($string))
{ my $e = $a->address;
$self->{AddrList}{$e} = $a;
}
$self;
}
sub stringify()
{ my $self = shift;
join(", ", map { $_->format } values %{$self->{AddrList}});
}
sub addresses { keys %{shift->{AddrList}} }
# someone forgot to implement a method to return the Mail::Address
# objects. Added in 2.00; a pity that the name addresses() is already
# given :( That one should have been named emails()
sub addr_list { values %{shift->{AddrList}} }
sub names { map { $_->name } values %{shift->{AddrList}} }
sub set_address($$)
{ my ($self, $email, $name) = @_;
$self->{AddrList}{$email} = Mail::Address->new($name, $email);
$self;
}
1;

66
Git/usr/share/perl5/vendor_perl/Mail/Field/Date.pm Normal file
View File

@ -0,0 +1,66 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Field::Date;
use vars '$VERSION';
$VERSION = '2.20';
use base 'Mail::Field';
use strict;
use Date::Format qw(time2str);
use Date::Parse qw(str2time);
(bless [])->register('Date');
sub set()
{ my $self = shift;
my $arg = @_ == 1 ? shift : { @_ };
foreach my $s (qw(Time TimeStr))
{ if(exists $arg->{$s})
{ $self->{$s} = $arg->{$s} }
else { delete $self->{$s} }
}
$self;
}
sub parse($)
{ my $self = shift;
delete $self->{Time};
$self->{TimeStr} = shift;
$self;
}
sub time(;$)
{ my $self = shift;
if(@_)
{ delete $self->{TimeStr};
return $self->{Time} = shift;
}
$self->{Time} ||= str2time $self->{TimeStr};
}
sub stringify
{ my $self = shift;
$self->{TimeStr} ||= time2str("%a, %e %b %Y %T %z", $self->time);
}
sub reformat
{ my $self = shift;
$self->time($self->time);
$self->stringify;
}
1;

37
Git/usr/share/perl5/vendor_perl/Mail/Field/Generic.pm Normal file
View File

@ -0,0 +1,37 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Field::Generic;
use vars '$VERSION';
$VERSION = '2.20';
use base 'Mail::Field';
use Carp;
sub create
{ my ($self, %arg) = @_;
$self->{Text} = delete $arg{Text};
croak "Unknown options " . join(",", keys %arg)
if %arg;
$self;
}
sub parse
{ my $self = shift;
$self->{Text} = shift || "";
$self;
}
sub stringify { shift->{Text} }
1;

74
Git/usr/share/perl5/vendor_perl/Mail/Filter.pm Normal file
View File

@ -0,0 +1,74 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Filter;
use vars '$VERSION';
$VERSION = '2.20';
use strict;
use Carp;
sub new(@)
{ my $class = shift;
bless { filters => [ @_ ] }, $class;
}
#------------
sub add(@)
{ my $self = shift;
push @{$self->{filters}}, @_;
}
#------------
sub _filter($)
{ my ($self, $mail) = @_;
foreach my $sub ( @{$self->{filters}} )
{ my $mail
= ref $sub eq 'CODE' ? $sub->($self,$mail)
: !ref $sub ? $self->$sub($mail)
: carp "Cannot call filter '$sub', ignored";
ref $mail or last;
}
$mail;
}
sub filter
{ my ($self, $obj) = @_;
if($obj->isa('Mail::Folder'))
{ $self->{folder} = $obj;
foreach my $m ($obj->message_list)
{ my $mail = $obj->get_message($m) or next;
$self->{msgnum} = $m;
$self->_filter($mail);
}
delete $self->{folder};
delete $self->{msgnum};
}
elsif($obj->isa('Mail::Internet'))
{ return $self->filter($obj);
}
else
{ carp "Cannot process '$obj'";
return undef;
}
}
sub folder() {shift->{folder}}
sub msgnum() {shift->{msgnum}}
1;

636
Git/usr/share/perl5/vendor_perl/Mail/Header.pm Normal file
View File

@ -0,0 +1,636 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Header;
use vars '$VERSION';
$VERSION = '2.20';
use strict;
use Carp;
my $MAIL_FROM = 'KEEP';
my %HDR_LENGTHS = ();
our $FIELD_NAME = '[^\x00-\x1f\x7f-\xff :]+:';
##
## Private functions
##
sub _error { warn @_; () }
# tidy up internal hash table and list
sub _tidy_header
{ my $self = shift;
my $deleted = 0;
for(my $i = 0 ; $i < @{$self->{mail_hdr_list}}; $i++)
{ next if defined $self->{mail_hdr_list}[$i];
splice @{$self->{mail_hdr_list}}, $i, 1;
$deleted++;
$i--;
}
if($deleted)
{ local $_;
my @del;
while(my ($key,$ref) = each %{$self->{mail_hdr_hash}} )
{ push @del, $key
unless @$ref = grep { ref $_ && defined $$_ } @$ref;
}
delete $self->{'mail_hdr_hash'}{$_} for @del;
}
}
# fold the line to the given length
my %STRUCTURE = map { (lc $_ => undef) }
qw{ To Cc Bcc From Date Reply-To Sender
Resent-Date Resent-From Resent-Sender Resent-To Return-Path
list-help list-post list-unsubscribe Mailing-List
Received References Message-ID In-Reply-To
Content-Length Content-Type Content-Disposition
Delivered-To
Lines
MIME-Version
Precedence
Status
};
sub _fold_line
{ my($ln,$maxlen) = @_;
$maxlen = 20
if $maxlen < 20;
my $max = int($maxlen - 5); # 4 for leading spcs + 1 for [\,\;]
my $min = int($maxlen * 4 / 5) - 4;
$_[0] =~ s/[\r\n]+//og; # Remove new-lines
$_[0] =~ s/\s*\Z/\n/so; # End line with an EOLN
return if $_[0] =~ /^From\s/io;
if(length($_[0]) > $maxlen)
{ if($_[0] =~ /^([-\w]+)/ && exists $STRUCTURE{ lc $1 } )
{ #Split the line up
# first bias towards splitting at a , or a ; >4/5 along the line
# next split a whitespace
# else we are looking at a single word and probably don't want to split
my $x = "";
$x .= "$1\n " while $_[0] =~
s/^\s*
( [^"]{$min,$max} [,;]
| [^"]{1,$max} [,;\s]
| [^\s"]*(?:"[^"]*"[ \t]?[^\s"]*)+\s
) //x;
$x .= $_[0];
$_[0] = $x;
$_[0] =~ s/(\A\s+|[\t ]+\Z)//sog;
$_[0] =~ s/\s+\n/\n/sog;
}
else
{ $_[0] =~ s/(.{$min,$max})(\s)/$1\n$2/g;
$_[0] =~ s/\s*$/\n/s;
}
}
$_[0] =~ s/\A(\S+)\n\s*(?=\S)/$1 /so;
}
# Tags are case-insensitive, but there is a (slightly) preferred construction
# being all characters are lowercase except the first of each word. Also
# if the word is an `acronym' then all characters are uppercase. We decide
# a word is an acronym if it does not contain a vowel.
# In general, this change of capitalization is a bad idea, but it is in
# the code for ages, and therefore probably crucial for existing
# applications.
sub _tag_case
{ my $tag = shift;
$tag =~ s/\:$//;
join '-'
, map { /^[b-df-hj-np-tv-z]+$|^(?:MIME|SWE|SOAP|LDAP|ID)$/i
? uc($_) : ucfirst(lc($_))
} split m/\-/, $tag, -1;
}
# format a complete line
# ensure line starts with the given tag
# ensure tag is correct case
# change the 'From ' tag as required
# fold the line
sub _fmt_line
{ my ($self, $tag, $line, $modify) = @_;
$modify ||= $self->{mail_hdr_modify};
my $ctag = undef;
($tag) = $line =~ /^($FIELD_NAME|From )/oi
unless defined $tag;
if(defined $tag && $tag =~ /^From /io && $self->{mail_hdr_mail_from} ne 'KEEP')
{ if($self->{mail_hdr_mail_from} eq 'COERCE')
{ $line =~ s/^From /Mail-From: /o;
$tag = "Mail-From:";
}
elsif($self->{mail_hdr_mail_from} eq 'IGNORE')
{ return ();
}
elsif($self->{mail_hdr_mail_from} eq 'ERROR')
{ return _error "unadorned 'From ' ignored: <$line>";
}
}
if(defined $tag)
{ $tag = _tag_case($ctag = $tag);
$ctag = $tag if $modify;
$ctag =~ s/([^ :])$/$1:/o if defined $ctag;
}
defined $ctag && $ctag =~ /^($FIELD_NAME|From )/oi
or croak "Bad RFC822 field name '$tag'\n";
# Ensure the line starts with tag
if(defined $ctag && ($modify || $line !~ /^\Q$ctag\E/i))
{ (my $xtag = $ctag) =~ s/\s*\Z//o;
$line =~ s/^(\Q$ctag\E)?\s*/$xtag /i;
}
my $maxlen = $self->{mail_hdr_lengths}{$tag}
|| $HDR_LENGTHS{$tag}
|| $self->fold_length;
if ($modify && defined $maxlen)
{ # folding will fix bad header continuations for us
_fold_line $line, $maxlen;
}
elsif($line =~ /\r?\n\S/)
{ return _error "Bad header continuation, skipping '$tag': ",
"no space after newline in '$line'\n";
}
$line =~ s/\n*$/\n/so;
($tag, $line);
}
sub _insert
{ my ($self, $tag, $line, $where) = @_;
if($where < 0)
{ $where = @{$self->{mail_hdr_list}} + $where + 1;
$where = 0 if $where < 0;
}
elsif($where >= @{$self->{mail_hdr_list}})
{ $where = @{$self->{mail_hdr_list}};
}
my $atend = $where == @{$self->{mail_hdr_list}};
splice @{$self->{mail_hdr_list}}, $where, 0, $line;
$self->{mail_hdr_hash}{$tag} ||= [];
my $ref = \${$self->{mail_hdr_list}}[$where];
my $def = $self->{mail_hdr_hash}{$tag};
if($def && $where)
{ if($atend) { push @$def, $ref }
else
{ my $i = 0;
foreach my $ln (@{$self->{mail_hdr_list}})
{ my $r = \$ln;
last if $r == $ref;
$i++ if $r == $def->[$i];
}
splice @$def, $i, 0, $ref;
}
}
else
{ unshift @$def, $ref;
}
}
#------------
sub new
{ my $call = shift;
my $class = ref($call) || $call;
my $arg = @_ % 2 ? shift : undef;
my %opt = @_;
$opt{Modify} = delete $opt{Reformat}
unless exists $opt{Modify};
my $self = bless
{ mail_hdr_list => []
, mail_hdr_hash => {}
, mail_hdr_modify => (delete $opt{Modify} || 0)
, mail_hdr_foldlen => 79
, mail_hdr_lengths => {}
}, $class;
$self->mail_from( uc($opt{MailFrom} || $MAIL_FROM) );
$self->fold_length($opt{FoldLength})
if exists $opt{FoldLength};
if(!ref $arg) {}
elsif(ref($arg) eq 'ARRAY') { $self->extract( [ @$arg ] ) }
elsif(defined fileno($arg)) { $self->read($arg) }
$self;
}
sub dup
{ my $self = shift;
my $dup = ref($self)->new;
%$dup = %$self;
$dup->empty; # rebuild tables
$dup->{mail_hdr_list} = [ @{$self->{mail_hdr_list}} ];
foreach my $ln ( @{$dup->{mail_hdr_list}} )
{ my $tag = _tag_case +($ln =~ /^($FIELD_NAME|From )/oi)[0];
push @{$dup->{mail_hdr_hash}{$tag}}, \$ln;
}
$dup;
}
#------------
sub extract
{ my ($self, $lines) = @_;
$self->empty;
while(@$lines)
{ my $line = shift @$lines;
last if $line =~ /^\r?$/;
$line =~ /^($FIELD_NAME|From )/o or next;
my $tag = $1;
$line .= shift @$lines
while @$lines && $lines->[0] =~ /^[ \t]+/;
($tag, $line) = _fmt_line $self, $tag, $line;
_insert $self, $tag, $line, -1
if defined $line;
}
$self;
}
sub read
{ my ($self, $fd) = @_;
$self->empty;
my ($ln, $tag, $line);
while(1)
{ $ln = <$fd>;
if(defined $ln && defined $line && $ln =~ /^[ \t]+/)
{ $line .= $ln; # folded line
next;
}
if(defined $line)
{ ($tag, $line) = _fmt_line $self, $tag, $line;
_insert $self, $tag, $line, -1
if defined $line;
($tag, $line) = ();
}
last if !defined $ln || $ln =~ m/^\r?$/;
$ln =~ /^($FIELD_NAME|From )/o or next;
($tag, $line) = ($1, $ln);
}
$self;
}
sub empty
{ my $self = shift;
$self->{mail_hdr_list} = [];
$self->{mail_hdr_hash} = {};
$self;
}
sub header
{ my $self = shift;
$self->extract(@_)
if @_;
$self->fold
if $self->{mail_hdr_modify};
[ @{$self->{mail_hdr_list}} ];
}
sub header_hashref
{ my ($self, $hashref) = @_;
while(my ($key, $value) = each %$hashref)
{ $self->add($key, $_) for ref $value ? @$value : $value;
}
$self->fold
if $self->{mail_hdr_modify};
defined wantarray # MO, added minimal optimization
or return;
+{ map { ($_ => [$self->get($_)] ) } # MO: Eh?
keys %{$self->{mail_hdr_hash}}
};
}
#------------
sub modify
{ my $self = shift;
my $old = $self->{mail_hdr_modify};
$self->{mail_hdr_modify} = 0 + shift
if @_;
$old;
}
sub mail_from
{ my $thing = shift;
my $choice = uc shift;
$choice =~ /^(IGNORE|ERROR|COERCE|KEEP)$/
or die "bad Mail-From choice: '$choice'";
if(ref $thing) { $thing->{mail_hdr_mail_from} = $choice }
else { $MAIL_FROM = $choice }
$thing;
}
sub fold_length
{ my $thing = shift;
my $old;
if(@_ == 2)
{ my $tag = _tag_case shift;
my $len = shift;
my $hash = ref $thing ? $thing->{mail_hdr_lengths} : \%HDR_LENGTHS;
$old = $hash->{$tag};
$hash->{$tag} = $len > 20 ? $len : 20;
}
else
{ my $self = $thing;
my $len = shift;
$old = $self->{mail_hdr_foldlen};
if(defined $len)
{ $self->{mail_hdr_foldlen} = $len > 20 ? $len : 20;
$self->fold if $self->{mail_hdr_modify};
}
}
$old;
}
#------------
sub fold
{ my ($self, $maxlen) = @_;
while(my ($tag, $list) = each %{$self->{mail_hdr_hash}})
{ my $len = $maxlen
|| $self->{mail_hdr_lengths}{$tag}
|| $HDR_LENGTHS{$tag}
|| $self->fold_length;
foreach my $ln (@$list)
{ _fold_line $$ln, $len
if defined $ln;
}
}
$self;
}
sub unfold
{ my $self = shift;
if(@_)
{ my $tag = _tag_case shift;
my $list = $self->{mail_hdr_hash}{$tag}
or return $self;
foreach my $ln (@$list)
{ $$ln =~ s/\r?\n\s+/ /sog
if defined $ln && defined $$ln;
}
return $self;
}
while( my ($tag, $list) = each %{$self->{mail_hdr_hash}})
{ foreach my $ln (@$list)
{ $$ln =~ s/\r?\n\s+/ /sog
if defined $ln && defined $$ln;
}
}
$self;
}
sub add
{ my ($self, $tag, $text, $where) = @_;
($tag, my $line) = _fmt_line $self, $tag, $text;
defined $tag && defined $line
or return undef;
defined $where
or $where = -1;
_insert $self, $tag, $line, $where;
$line =~ /^\S+\s(.*)/os;
$1;
}
sub replace
{ my $self = shift;
my $idx = @_ % 2 ? pop @_ : 0;
my ($tag, $line);
TAG:
while(@_)
{ ($tag,$line) = _fmt_line $self, splice(@_,0,2);
defined $tag && defined $line
or return undef;
my $field = $self->{mail_hdr_hash}{$tag};
if($field && defined $field->[$idx])
{ ${$field->[$idx]} = $line }
else { _insert $self, $tag, $line, -1 }
}
$line =~ /^\S+\s*(.*)/os;
$1;
}
sub combine
{ my $self = shift;
my $tag = _tag_case shift;
my $with = shift || ' ';
$tag =~ /^From /io && $self->{mail_hdr_mail_from} ne 'KEEP'
and return _error "unadorned 'From ' ignored";
my $def = $self->{mail_hdr_hash}{$tag}
or return undef;
return $def->[0]
if @$def <= 1;
my @lines = $self->get($tag);
chomp @lines;
my $line = (_fmt_line $self, $tag, join($with,@lines), 1)[1];
$self->{mail_hdr_hash}{$tag} = [ \$line ];
$line;
}
sub get
{ my $self = shift;
my $tag = _tag_case shift;
my $idx = shift;
my $def = $self->{mail_hdr_hash}{$tag}
or return ();
my $l = length $tag;
$l += 1 if $tag !~ / $/o;
if(defined $idx || !wantarray)
{ $idx ||= 0;
defined $def->[$idx] or return undef;
my $val = ${$def->[$idx]};
defined $val or return undef;
$val = substr $val, $l;
$val =~ s/^\s+//;
return $val;
}
map { my $tmp = substr $$_,$l; $tmp =~ s/^\s+//; $tmp } @$def;
}
sub count
{ my $self = shift;
my $tag = _tag_case shift;
my $def = $self->{mail_hdr_hash}{$tag};
defined $def ? scalar(@$def) : 0;
}
sub delete
{ my $self = shift;
my $tag = _tag_case shift;
my $idx = shift;
my @val;
if(my $def = $self->{mail_hdr_hash}{$tag})
{ my $l = length $tag;
$l += 2 if $tag !~ / $/;
if(defined $idx)
{ if(defined $def->[$idx])
{ push @val, substr ${$def->[$idx]}, $l;
undef ${$def->[$idx]};
}
}
else
{ @val = map {my $x = substr $$_,$l; undef $$_; $x } @$def;
}
_tidy_header($self);
}
@val;
}
sub print
{ my $self = shift;
my $fd = shift || \*STDOUT;
foreach my $ln (@{$self->{mail_hdr_list}})
{ defined $ln or next;
print $fd $ln or return 0;
}
1;
}
sub as_string { join '', grep {defined} @{shift->{mail_hdr_list}} }
sub tags { keys %{shift->{mail_hdr_hash}} }
sub cleanup
{ my $self = shift;
my $deleted = 0;
foreach my $key (@_ ? @_ : keys %{$self->{mail_hdr_hash}})
{ my $fields = $self->{mail_hdr_hash}{$key};
foreach my $field (@$fields)
{ next if $$field =~ /^\S+\s+\S/s;
undef $$field;
$deleted++;
}
}
_tidy_header $self
if $deleted;
$self;
}
1;

558
Git/usr/share/perl5/vendor_perl/Mail/Internet.pm Normal file
View File

@ -0,0 +1,558 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Internet;
use vars '$VERSION';
$VERSION = '2.20';
use strict;
# use warnings? probably breaking too much code
use Carp;
use Mail::Header;
use Mail::Util qw/mailaddress/;
use Mail::Address;
sub new(@)
{ my $call = shift;
my $arg = @_ % 2 ? shift : undef;
my %opt = @_;
my $class = ref($call) || $call;
my $self = bless {}, $class;
$self->{mail_inet_head} = $opt{Header} if exists $opt{Header};
$self->{mail_inet_body} = $opt{Body} if exists $opt{Body};
my $head = $self->head;
$head->fold_length(delete $opt{FoldLength} || 79);
$head->mail_from($opt{MailFrom}) if exists $opt{MailFrom};
$head->modify(exists $opt{Modify} ? $opt{Modify} : 1);
if(!defined $arg) { }
elsif(ref($arg) eq 'ARRAY')
{ $self->header($arg) unless exists $opt{Header};
$self->body($arg) unless exists $opt{Body};
}
elsif(defined fileno($arg))
{ $self->read_header($arg) unless exists $opt{Header};
$self->read_body($arg) unless exists $opt{Body};
}
else
{ croak "couldn't understand $arg to Mail::Internet constructor";
}
$self;
}
sub read(@)
{ my $self = shift;
$self->read_header(@_);
$self->read_body(@_);
}
sub read_body($)
{ my ($self, $fd) = @_;
$self->body( [ <$fd> ] );
}
sub read_header(@)
{ my $head = shift->head;
$head->read(@_);
$head->header;
}
sub extract($)
{ my ($self, $lines) = @_;
$self->head->extract($lines);
$self->body($lines);
}
sub dup()
{ my $self = shift;
my $dup = ref($self)->new;
my $body = $self->{mail_inet_body} || [];
my $head = $self->{mail_inet_head};;
$dup->{mail_inet_body} = [ @$body ];
$dup->{mail_inet_head} = $head->dup if $head;
$dup;
}
#---------------
sub body(;$@)
{ my $self = shift;
return $self->{mail_inet_body} ||= []
unless @_;
$self->{mail_inet_body} = ref $_[0] eq 'ARRAY' ? $_[0] : [ @_ ];
}
sub head { shift->{mail_inet_head} ||= Mail::Header->new }
#---------------
sub print($)
{ my $self = shift;
my $fd = shift || \*STDOUT;
$self->print_header($fd)
and print $fd "\n"
and $self->print_body($fd);
}
sub print_header($) { shift->head->print(@_) }
sub print_body($)
{ my $self = shift;
my $fd = shift || \*STDOUT;
foreach my $ln (@{$self->body})
{ print $fd $ln or return 0;
}
1;
}
sub as_string()
{ my $self = shift;
$self->head->as_string . "\n" . join '', @{$self->body};
}
sub as_mbox_string($)
{ my $self = shift->dup;
my $escaped = shift;
$self->head->delete('Content-Length');
$self->escape_from unless $escaped;
$self->as_string . "\n";
}
#---------------
sub header { shift->head->header(@_) }
sub fold { shift->head->fold(@_) }
sub fold_length { shift->head->fold_length(@_) }
sub combine { shift->head->combine(@_) }
sub add(@)
{ my $head = shift->head;
my $ret;
while(@_)
{ my ($tag, $line) = splice @_, 0, 2;
$ret = $head->add($tag, $line, -1)
or return undef;
}
$ret;
}
sub replace(@)
{ my $head = shift->head;
my $ret;
while(@_)
{ my ($tag, $line) = splice @_, 0, 2;
$ret = $head->replace($tag, $line, 0)
or return undef;
}
$ret;
}
sub get(@)
{ my $head = shift->head;
return map { $head->get($_) } @_
if wantarray;
foreach my $tag (@_)
{ my $r = $head->get($tag);
return $r if defined $r;
}
undef;
}
sub delete(@)
{ my $head = shift->head;
map { $head->delete($_) } @_;
}
# Undocumented; unused???
sub empty()
{ my $self = shift;
%$self = ();
1;
}
#---------------
sub remove_sig($)
{ my $body = shift->body;
my $nlines = shift || 10;
my $start = @$body;
my $i = 0;
while($i++ < $nlines && $start--)
{ next if $body->[$start] !~ /^--[ ]?[\r\n]/;
splice @$body, $start, $i;
last;
}
}
sub sign(@)
{ my ($self, %arg) = @_;
my ($sig, @sig);
if($sig = delete $arg{File})
{ local *SIG;
if(open(SIG, $sig))
{ local $_;
while(<SIG>) { last unless /^(--)?\s*$/ }
@sig = ($_, <SIG>, "\n");
close SIG;
}
}
elsif($sig = delete $arg{Signature})
{ @sig = ref($sig) ? @$sig : split(/\n/, $sig);
}
if(@sig)
{ $self->remove_sig;
s/[\r\n]*$/\n/ for @sig;
push @{$self->body}, "-- \n", @sig;
}
$self;
}
sub tidy_body()
{ my $body = shift->body;
shift @$body while @$body && $body->[0] =~ /^\s*$/;
pop @$body while @$body && $body->[-1] =~ /^\s*$/;
$body;
}
#---------------
sub reply(@)
{ my ($self, %arg) = @_;
my $class = ref $self;
my @reply;
local *MAILHDR;
if(open(MAILHDR, "$ENV{HOME}/.mailhdr"))
{ # User has defined a mail header template
@reply = <MAILHDR>;
close MAILHDR;
}
my $reply = $class->new(\@reply);
# The Subject line
my $subject = $self->get('Subject') || "";
$subject = "Re: " . $subject
if $subject =~ /\S+/ && $subject !~ /Re:/i;
$reply->replace(Subject => $subject);
# Locate who we are sending to
my $to = $self->get('Reply-To')
|| $self->get('From')
|| $self->get('Return-Path')
|| "";
my $sender = (Mail::Address->parse($to))[0];
my $name = $sender->name;
unless(defined $name)
{ my $fr = $self->get('From');
$fr = (Mail::Address->parse($fr))[0] if defined $fr;
$name = $fr->name if defined $fr;
}
my $indent = $arg{Indent} || ">";
if($indent =~ /\%/)
{ my %hash = ( '%' => '%');
my @name = $name ? grep( {length $_} split /[\n\s]+/, $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 "", map {substr($_,0,1)} @name;
$indent =~ s/\%(.)/defined $hash{$1} ? $hash{$1} : $1/eg;
}
my $id = $sender->address;
$reply->replace(To => $id);
# Find addresses not to include
my $mailaddresses = $ENV{MAILADDRESSES} || "";
my %nocc = (lc($id) => 1);
$nocc{lc $_->address} = 1
for Mail::Address->parse($reply->get('Bcc'), $mailaddresses);
if($arg{ReplyAll}) # Who shall we copy this to
{ my %cc;
foreach my $addr (Mail::Address->parse($self->get('To'), $self->get('Cc')))
{ my $lc = lc $addr->address;
$cc{$lc} = $addr->format
unless $nocc{$lc};
}
my $cc = join ', ', values %cc;
$reply->replace(Cc => $cc);
}
# References
my $refs = $self->get('References') || "";
my $mid = $self->get('Message-Id');
$refs .= " " . $mid if defined $mid;
$reply->replace(References => $refs);
# In-Reply-To
my $date = $self->get('Date');
my $inreply = "";
if(defined $mid)
{ $inreply = $mid;
my @comment;
push @comment, "from $name" if defined $name;
push @comment, "on $date" if defined $date;
local $" = ' ';
$inreply .= " (@comment)" if @comment;
}
elsif(defined $name)
{ $inreply = $name . "'s message";
$inreply .= "of " . $date if defined $date;
}
$reply->replace('In-Reply-To' => $inreply);
# Quote the body
my $body = $reply->body;
@$body = @{$self->body}; # copy body
$reply->remove_sig;
$reply->tidy_body;
s/\A/$indent/ for @$body;
# Add references
unshift @{$body}, (defined $name ? $name . " " : "") . "<$id> writes:\n";
if(defined $arg{Keep} && ref $arg{Keep} eq 'ARRAY') # Include lines
{ foreach my $keep (@{$arg{Keep}})
{ my $ln = $self->get($keep);
$reply->replace($keep => $ln) if defined $ln;
}
}
if(defined $arg{Exclude} && ref $arg{Exclude} eq 'ARRAY') # Exclude lines
{ $reply->delete(@{$arg{Exclude}});
}
$reply->head->cleanup; # remove empty header lines
$reply;
}
sub smtpsend($@)
{ my ($self, %opt) = @_;
require Net::SMTP;
require Net::Domain;
my $host = $opt{Host};
my $envelope = $opt{MailFrom} || mailaddress();
my $quit = 1;
my ($smtp, @hello);
push @hello, Hello => $opt{Hello}
if defined $opt{Hello};
push @hello, Port => $opt{Port}
if exists $opt{Port};
push @hello, Debug => $opt{Debug}
if exists $opt{Debug};
if(!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(UNIVERSAL::isa($host,'Net::SMTP')
|| UNIVERSAL::isa($host,'Net::SMTP::SSL'))
{ $smtp = $host;
$quit = 0;
}
else
{ local $SIG{__DIE__};
$smtp = eval { Net::SMTP->new($host, @hello) };
}
defined $smtp or return ();
my $head = $self->cleaned_header_dup;
# Who is it to
my @rcpt = map { ref $_ ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'};
@rcpt = map { $head->get($_) } qw(To Cc Bcc)
unless @rcpt;
my @addr = map {$_->address} Mail::Address->parse(@rcpt);
@addr or return ();
$head->delete('Bcc');
# Send it
my $ok = $smtp->mail($envelope)
&& $smtp->to(@addr)
&& $smtp->data(join("", @{$head->header}, "\n", @{$self->body}));
$quit && $smtp->quit;
$ok ? @addr : ();
}
sub send($@)
{ my ($self, $type, @args) = @_;
require Mail::Mailer;
my $head = $self->cleaned_header_dup;
my $mailer = Mail::Mailer->new($type, @args);
$mailer->open($head->header_hashref);
$self->print_body($mailer);
$mailer->close;
}
sub nntppost
{ my ($self, %opt) = @_;
require Net::NNTP;
my $groups = $self->get('Newsgroups') || "";
my @groups = split /[\s,]+/, $groups;
@groups or return ();
my $head = $self->cleaned_header_dup;
# Remove these incase the NNTP host decides to mail as well as me
$head->delete(qw(To Cc Bcc));
my $news;
my $quit = 1;
my $host = $opt{Host};
if(ref($host) && UNIVERSAL::isa($host,'Net::NNTP'))
{ $news = $host;
$quit = 0;
}
else
{ my @opt = $opt{Host};
push @opt, Port => $opt{Port}
if exists $opt{Port};
push @opt, Debug => $opt{Debug}
if exists $opt{Debug};
$news = Net::NNTP->new(@opt)
or return ();
}
$news->post(@{$head->header}, "\n", @{$self->body});
my $rc = $news->code;
$news->quit if $quit;
$rc == 240 ? @groups : ();
}
sub escape_from
{ my $body = shift->body;
scalar grep { s/\A(>*From) />$1 /o } @$body;
}
sub unescape_from
{ my $body = shift->body;
scalar grep { s/\A>(>*From) /$1 /o } @$body;
}
# Don't tell people it exists
sub cleaned_header_dup()
{ my $head = shift->head->dup;
$head->delete('From '); # Just in case :-)
# An original message should not have any Received lines
$head->delete('Received');
$head->replace('X-Mailer', "Perl5 Mail::Internet v".$Mail::Internet::VERSION)
unless $head->count('X-Mailer');
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, mailaddress();
$from =~ s/\s{2,}/ /g;
foreach my $tag (qw(From Sender))
{ $head->get($tag) or $head->add($tag, $from);
}
$head;
}
1;

221
Git/usr/share/perl5/vendor_perl/Mail/Mailer.pm Normal file
View File

@ -0,0 +1,221 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Mailer;
use vars '$VERSION';
$VERSION = '2.20';
use base 'IO::Handle';
use strict;
use POSIX qw/_exit/;
use Carp;
use Config;
#--------------
sub is_exe($);
sub Version { our $VERSION }
our @Mailers =
( sendmail => '/usr/lib/sendmail;/usr/sbin/sendmail;/usr/ucblib/sendmail'
, smtp => undef
, smtps => undef
, qmail => '/usr/sbin/qmail-inject;/var/qmail/bin/qmail-inject'
, testfile => undef
);
push @Mailers, map { split /\:/, $_, 2 }
split /$Config{path_sep}/, $ENV{PERL_MAILERS}
if $ENV{PERL_MAILERS};
our %Mailers = @Mailers;
our $MailerType;
our $MailerBinary;
# does this really need to be done? or should a default mailer be specified?
$Mailers{sendmail} = 'sendmail'
if $^O eq 'os2' && ! is_exe $Mailers{sendmail};
if($^O =~ m/MacOS|VMS|MSWin|os2|NetWare/i )
{ $MailerType = 'smtp';
$MailerBinary = $Mailers{$MailerType};
}
else
{ for(my $i = 0 ; $i < @Mailers ; $i += 2)
{ $MailerType = $Mailers[$i];
if(my $binary = is_exe $Mailers{$MailerType})
{ $MailerBinary = $binary;
last;
}
}
}
sub import
{ shift; # class
@_ or return;
my $type = shift;
my $exe = shift || $Mailers{$type};
is_exe $exe
or carp "Cannot locate '$exe'";
$MailerType = $type;
$Mailers{$MailerType} = $exe;
}
sub to_array($)
{ my ($self, $thing) = @_;
ref $thing ? @$thing : $thing;
}
sub is_exe($)
{ my $exe = shift || '';
foreach my $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 && ! -d $name && $name =~ m![\\/]!;
if(defined $ENV{PATH})
{ foreach my $dir (split /$Config{path_sep}/, $ENV{PATH})
{ return "$dir/$cmd"
if -x "$dir/$name" && ! -d "$dir/$name";
}
}
}
0;
}
sub new($@)
{ my ($class, $type, @args) = @_;
unless($type)
{ $MailerType or croak "No MailerType specified";
warn "No real MTA found, using '$MailerType'"
if $MailerType eq 'testfile';
$type = $MailerType;
}
my $exe = $Mailers{$type};
if(defined $exe)
{ $exe = is_exe $exe
if defined $type;
$exe ||= $MailerBinary
or croak "No mailer type specified (and no default available), thus can not find executable program.";
}
$class = "Mail::Mailer::$type";
eval "require $class" or die $@;
my $glob = $class->SUPER::new; # object is a GLOB!
%{*$glob} = (Exe => $exe, Args => [ @args ]);
$glob;
}
sub open($)
{ my ($self, $hdrs) = @_;
my $exe = *$self->{Exe}; # no exe, then direct smtp
my $args = *$self->{Args};
my @to = $self->who_to($hdrs);
my $sender = $self->who_sender($hdrs);
$self->close; # just in case;
if(defined $exe)
{ # Fork and start a mailer
my $child = open $self, '|-';
defined $child or die "Failed to send: $!";
if($child==0)
{ # Child process will handle sending, but this is not real exec()
# this is a setup!!!
unless($self->exec($exe, $args, \@to, $sender))
{ warn $!; # setup failed
_exit(1); # no DESTROY(), keep it for parent
}
}
}
else
{ # Sending is handled by a subclass
$self->exec(undef, $args, \@to)
or die $!;
}
$self->set_headers($hdrs);
$self;
}
sub _cleanup_hdrs($)
{ foreach my $h (values %{(shift)})
{ foreach (ref $h ? @$h : $h)
{ s/\n\s*/ /g;
s/\s+$//;
}
}
}
sub exec($$$$)
{ my($self, $exe, $args, $to, $sender) = @_;
# 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});
unless($self->can_cc) # Can't cc/bcc so add them to @to
{ push @to, $self->to_array($hdrs->{Cc} ) if $hdrs->{Cc};
push @to, $self->to_array($hdrs->{Bcc}) if $hdrs->{Bcc};
}
@to;
}
sub who_sender($)
{ my ($self, $hdrs) = @_;
($self->to_array($hdrs->{Sender} || $hdrs->{From}))[0];
}
sub epilogue {
# This could send a .signature, also see ::smtp subclass
}
sub close(@)
{ my $self = shift;
fileno $self or return;
$self->epilogue;
CORE::close $self;
}
sub DESTROY { shift->close }
#--------------
1;

25
Git/usr/share/perl5/vendor_perl/Mail/Mailer/qmail.pm Normal file
View File

@ -0,0 +1,25 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Mailer::qmail;
use vars '$VERSION';
$VERSION = '2.20';
use base 'Mail::Mailer::rfc822';
use strict;
sub exec($$$$)
{ my($self, $exe, $args, $to, $sender) = @_;
my $address = defined $sender && $sender =~ m/\<(.*?)\>/ ? $1 : $sender;
exec($exe, (defined $address ? "-f$address" : ()));
die "ERROR: cannot run $exe: $!";
}
1;

34
Git/usr/share/perl5/vendor_perl/Mail/Mailer/rfc822.pm Normal file
View File

@ -0,0 +1,34 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Mailer::rfc822;
use vars '$VERSION';
$VERSION = '2.20';
use base 'Mail::Mailer';
use strict;
sub set_headers
{ my ($self, $hdrs) = @_;
local $\ = "";
foreach (keys %$hdrs)
{ next unless m/^[A-Z]/;
foreach my $h ($self->to_array($hdrs->{$_}))
{ $h =~ s/\n+\Z//;
print $self "$_: $h\n";
}
}
print $self "\n"; # terminate headers
}
1;

30
Git/usr/share/perl5/vendor_perl/Mail/Mailer/sendmail.pm Normal file
View File

@ -0,0 +1,30 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Mailer::sendmail;
use vars '$VERSION';
$VERSION = '2.20';
use base 'Mail::Mailer::rfc822';
use strict;
sub exec($$$$)
{ my($self, $exe, $args, $to, $sender) = @_;
# Fork and exec the mailer (no shell involved to avoid risks)
# We should always use a -t on sendmail so that Cc: and Bcc: work
# Rumor: some sendmails may ignore or break with -t (AIX?)
# Chopped out the @$to arguments, because -t means
# they are sent in the body, and postfix complains if they
# are also given on command line.
exec( $exe, '-t', @$args );
}
1;

107
Git/usr/share/perl5/vendor_perl/Mail/Mailer/smtp.pm Normal file
View File

@ -0,0 +1,107 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Mailer::smtp;
use vars '$VERSION';
$VERSION = '2.20';
use base 'Mail::Mailer::rfc822';
use strict;
use Net::SMTP;
use Mail::Util qw(mailaddress);
use Carp;
sub can_cc { 0 }
sub exec {
my ($self, $exe, $args, $to) = @_;
my %opt = @$args;
my $host = $opt{Server} || undef;
$opt{Debug} ||= 0;
my $smtp = Net::SMTP->new($host, %opt)
or return undef;
if($opt{Auth})
{ $smtp->auth(@{$opt{Auth}})
or return undef;
}
${*$self}{sock} = $smtp;
$smtp->mail($opt{From} || mailaddress());
$smtp->to($_) for @$to;
$smtp->data;
untie *$self if tied *$self;
tie *$self, 'Mail::Mailer::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};
my $ok = $sock->dataend;
$sock->quit;
delete ${*$self}{sock};
untie *$self;
$ok;
}
sub close(@)
{ my ($self, @to) = @_;
my $sock = ${*$self}{sock};
$sock && fileno $sock
or return 1;
my $ok = $self->epilogue;
# Epilogue should destroy the SMTP filehandle,
# but just to be on the safe side.
$sock && fileno $sock
or return $ok;
close $sock
or croak 'Cannot destroy socket filehandle';
$ok;
}
package Mail::Mailer::smtp::pipe;
use vars '$VERSION';
$VERSION = '2.20';
sub TIEHANDLE
{ my ($class, $self) = @_;
my $sock = ${*$self}{sock};
bless \$sock, $class;
}
sub PRINT
{ my $self = shift;
my $sock = $$self;
$sock->datasend( @_ );
}
1;

112
Git/usr/share/perl5/vendor_perl/Mail/Mailer/smtps.pm Normal file
View File

@ -0,0 +1,112 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
# Based on smtp.pm, adapted by Maciej Żenczykowski
package Mail::Mailer::smtps;
use vars '$VERSION';
$VERSION = '2.20';
use base 'Mail::Mailer::rfc822';
use strict;
use Net::SMTP::SSL;
use Mail::Util qw(mailaddress);
use Carp;
sub can_cc { 0 }
sub exec {
my ($self, $exe, $args, $to) = @_;
my %opt = @$args;
my $host = $opt{Server} || undef;
$opt{Debug} ||= 0;
$opt{Port} ||= 465;
my $smtp = Net::SMTP::SSL->new($host, %opt)
or return undef;
if($opt{Auth})
{ $smtp->auth(@{$opt{Auth}})
or return undef;
}
${*$self}{sock} = $smtp;
$smtp->mail($opt{From} || mailaddress);
$smtp->to($_) for @$to;
$smtp->data;
untie *$self if tied *$self;
tie *$self, 'Mail::Mailer::smtps::pipe', $self;
$self;
}
sub set_headers($)
{ my ($self, $hdrs) = @_;
$self->SUPER::set_headers
( { From => "<" . mailaddress() . ">"
, %$hdrs
, 'X-Mailer' => "Mail::Mailer[v$Mail::Mailer::VERSION] "
. " Net::SMTP[v$Net::SMTP::VERSION]"
. " Net::SMTP::SSL[v$Net::SMTP::SSL::VERSION]"
}
);
}
sub epilogue()
{ my $self = shift;
my $sock = ${*$self}{sock};
my $ok = $sock->dataend;
$sock->quit;
delete ${*$self}{sock};
untie *$self;
$ok;
}
sub close(@)
{ my ($self, @to) = @_;
my $sock = ${*$self}{sock};
$sock && fileno $sock
or return 1;
my $ok = $self->epilogue;
# Epilogue should destroy the SMTP filehandle,
# but just to be on the safe side.
$sock && fileno $sock
or return $ok;
close $sock
or croak 'Cannot destroy socket filehandle';
$ok;
}
package Mail::Mailer::smtps::pipe;
use vars '$VERSION';
$VERSION = '2.20';
sub TIEHANDLE
{ my ($class, $self) = @_;
my $sock = ${*$self}{sock};
bless \$sock, $class;
}
sub PRINT
{ my $self = shift;
my $sock = $$self;
$sock->datasend( @_ );
}
1;

58
Git/usr/share/perl5/vendor_perl/Mail/Mailer/testfile.pm Normal file
View File

@ -0,0 +1,58 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Mailer::testfile;
use vars '$VERSION';
$VERSION = '2.20';
use base 'Mail::Mailer::rfc822';
use strict;
use Mail::Util qw/mailaddress/;
my $num = 0;
sub can_cc() { 0 }
sub exec($$$)
{ my ($self, $exe, $args, $to) = @_;
my $outfn = $Mail::Mailer::testfile::config{outfile} || 'mailer.testfile';
open F, '>>', $outfn
or die "Cannot append message to testfile $outfn: $!";
print F "\n===\ntest ", ++$num, " ", (scalar localtime),
"\nfrom: " . mailaddress(),
"\nto: " . join(' ',@{$to}), "\n\n";
close F;
untie *$self if tied *$self;
tie *$self, 'Mail::Mailer::testfile::pipe', $self;
$self;
}
sub close { 1 }
package Mail::Mailer::testfile::pipe;
use vars '$VERSION';
$VERSION = '2.20';
sub TIEHANDLE
{ my ($class, $self) = @_;
bless \$self, $class;
}
sub PRINT
{ my $self = shift;
open F, '>>', $Mail::Mailer::testfile::config{outfile} || 'mailer.testfile';
print F @_;
close F;
}
1;

67
Git/usr/share/perl5/vendor_perl/Mail/Send.pm Normal file
View File

@ -0,0 +1,67 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Send;
use vars '$VERSION';
$VERSION = '2.20';
use strict;
use Mail::Mailer ();
sub Version { our $VERSION }
#------------------
sub new(@)
{ my ($class, %attr) = @_;
my $self = bless {}, $class;
while(my($key, $value) = each %attr)
{ $key = lc $key;
$self->$key($value);
}
$self;
}
#---------------
sub set($@)
{ my ($self, $hdr, @values) = @_;
$self->{$hdr} = [ @values ] if @values;
@{$self->{$hdr} || []}; # return new (or original) values
}
sub add($@)
{ my ($self, $hdr, @values) = @_;
push @{$self->{$hdr}}, @values;
}
sub delete($)
{ my($self, $hdr) = @_;
delete $self->{$hdr};
}
sub to { my $self=shift; $self->set('To', @_); }
sub cc { my $self=shift; $self->set('Cc', @_); }
sub bcc { my $self=shift; $self->set('Bcc', @_); }
sub subject { my $self=shift; $self->set('Subject', join (' ', @_)); }
#---------------
sub open(@)
{ my $self = shift;
Mail::Mailer->new(@_)->open($self);
}
1;

155
Git/usr/share/perl5/vendor_perl/Mail/Util.pm Normal file
View File

@ -0,0 +1,155 @@
# Copyrights 1995-2018 by [Mark Overmeer].
# For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.02.
# This code is part of the bundle MailTools. Meta-POD processed with
# OODoc into POD and HTML manual-pages. See README.md for Copyright.
# Licensed under the same terms as Perl itself.
package Mail::Util;
use vars '$VERSION';
$VERSION = '2.20';
use base 'Exporter';
use strict;
use Carp;
our @EXPORT_OK = qw(read_mbox maildomain mailaddress);
sub Version { our $VERSION }
my ($domain, $mailaddress);
my @sendmailcf = qw(/etc /etc/sendmail /etc/ucblib
/etc/mail /usr/lib /var/adm/sendmail);
sub read_mbox($)
{ my $file = shift;
local *FH;
open FH,'<', $file
or croak "cannot open '$file': $!\n";
local $_;
my @mbox;
my $mail = [];
my $blank = 1;
while(<FH>)
{ if($blank && /^From .*\d{4}/)
{ push @mbox, $mail if @$mail;
$mail = [ $_ ];
$blank = 0;
}
else
{ $blank = m/^$/ ? 1 : 0;
push @$mail, $_;
}
}
push @mbox, $mail if @$mail;
close FH;
wantarray ? @mbox : \@mbox;
}
sub maildomain()
{ return $domain
if defined $domain;
$domain = $ENV{MAILDOMAIN}
and return $domain;
# Try sendmail configuration file
my $config = (grep -r, map {"$_/sendmail.cf"} @sendmailcf)[0];
local *CF;
local $_;
if(defined $config && open CF, '<', $config)
{ my %var;
while(<CF>)
{ if(my ($v, $arg) = /^D([a-zA-Z])([\w.\$\-]+)/)
{ $arg =~ s/\$([a-zA-Z])/exists $var{$1} ? $var{$1} : '$'.$1/eg;
$var{$v} = $arg;
}
}
close CF;
$domain = $var{j} if defined $var{j};
$domain = $var{M} if defined $var{M};
$domain = $1
if $domain && $domain =~ m/([A-Za-z0-9](?:[\.\-A-Za-z0-9]+))/;
return $domain
if defined $domain && $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})
{ foreach my $host (qw(mailhost localhost))
{ # hosts are local, so short timeout
my $smtp = eval { Net::SMTP->new($host, Timeout => 5) };
if(defined $smtp)
{ $domain = $smtp->domain;
$smtp->quit;
last;
}
}
}
# Use internet(DNS) domain name, if it can be found
$domain = Net::Domain::domainname()
if !defined $domain && eval {require Net::Domain};
$domain ||= "localhost";
}
sub mailaddress(;$)
{ $mailaddress = shift if @_;
return $mailaddress
if defined $mailaddress;
# Get user name from environment
$mailaddress = $ENV{MAILADDRESS};
unless($mailaddress || $^O ne 'MacOS')
{ require Mac::InternetConfig;
no strict;
Mac::InternetConfig->import;
$mailaddress = $InternetConfig{kICEmail()};
}
$mailaddress ||= $ENV{USER} || $ENV{LOGNAME} || eval {getpwuid $>}
|| "postmaster";
# Add domain if it does not exist
$mailaddress .= '@' . maildomain
if $mailaddress !~ /\@/;
$mailaddress =~ s/(^.*<|>.*$)//g;
$mailaddress;
}
1;