KevinSchoenmayer/GseTDDUebungKCLR
2
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Commit

Browse Source
This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

394
database/perl/vendor/lib/Email/Abstract.pm vendored Normal file
View File

@@ -0,0 +1,394 @@
use 5.006;
use warnings;
use strict;
package Email::Abstract;
# ABSTRACT: unified interface to mail representations
$Email::Abstract::VERSION = '3.008';
use Carp;
use Email::Simple;
use MRO::Compat;
use Module::Pluggable 1.5
search_path => [__PACKAGE__],
except => 'Email::Abstract::Plugin',
require => 1;
use Scalar::Util ();
my @plugins = __PACKAGE__->plugins(); # Requires them.
my %adapter_for =
map { $_->target => $_ }
grep {
my $avail = eval { $_->is_available };
$@ ? ($@ =~ /Can't locate object method "is_available"/) : $avail;
}
@plugins;
sub object {
my ($self) = @_;
return unless ref $self;
return $self->[0];
}
sub new {
my ($class, $foreign) = @_;
return $foreign if eval { $foreign->isa($class) };
$foreign = Email::Simple->new($foreign)
unless Scalar::Util::blessed($foreign);
my $adapter = $class->__class_for($foreign); # dies if none available
return bless [ $foreign, $adapter ] => $class;
}
sub __class_for {
my ($self, $foreign, $method, $skip_super) = @_;
$method ||= 'handle';
my $f_class = ref $foreign;
$f_class = $foreign unless $f_class;
return $f_class if ref $foreign and $f_class->isa($self);
return $adapter_for{$f_class} if $adapter_for{$f_class};
if (not $skip_super) {
my @bases = @{ mro::get_linear_isa($f_class) };
shift @bases;
for my $base (@bases) {
return $adapter_for{$base} if $adapter_for{$base};
}
}
Carp::croak "Don't know how to $method $f_class";
}
sub _adapter_obj_and_args {
my $self = shift;
if (my $thing = $self->object) {
return ($self->[1], $thing, @_);
} else {
my $thing = shift;
my $adapter = $self->__class_for(
Scalar::Util::blessed($thing) ? $thing : 'Email::Simple'
);
return ($adapter, $thing, @_);
}
}
for my $func (qw(get_header get_body set_header set_body as_string)) {
no strict 'refs';
*$func = sub {
my $self = shift;
my ($adapter, $thing, @args) = $self->_adapter_obj_and_args(@_);
# In the event of Email::Abstract->get_body($email_abstract), convert
# it into an object method call.
$thing = $thing->object if eval { $thing->isa($self) };
# I suppose we could work around this by leaving @_ intact and assigning to
# it. That seems ... not good. -- rjbs, 2007-07-18
unless (Scalar::Util::blessed($thing)) {
Carp::croak "can't alter string in place" if substr($func, 0, 3) eq 'set';
$thing = Email::Simple->new(
ref $thing ? \do{my$str=$$thing} : $thing
);
}
return $adapter->$func($thing, @args);
};
}
sub cast {
my $self = shift;
my ($from_adapter, $from, $to) = $self->_adapter_obj_and_args(@_);
my $adapter = $self->__class_for($to, 'construct', 1);
my $from_string = ref($from) ? $from_adapter->as_string($from) : $from;
return $adapter->construct($from_string);
}
1;
=pod
=encoding UTF-8
=head1 NAME
Email::Abstract - unified interface to mail representations
=head1 VERSION
version 3.008
=head1 SYNOPSIS
my $message = Mail::Message->read($rfc822)
|| Email::Simple->new($rfc822)
|| Mail::Internet->new([split /\n/, $rfc822])
|| ...
|| $rfc822;
my $email = Email::Abstract->new($message);
my $subject = $email->get_header("Subject");
$email->set_header(Subject => "My new subject");
my $body = $email->get_body;
$rfc822 = $email->as_string;
my $mail_message = $email->cast("Mail::Message");
=head1 DESCRIPTION
C<Email::Abstract> provides module writers with the ability to write
simple, representation-independent mail handling code. For instance, in the
cases of C<Mail::Thread> or C<Mail::ListDetector>, a key part of the code
involves reading the headers from a mail object. Where previously one would
either have to specify the mail class required, or to build a new object from
scratch, C<Email::Abstract> can be used to perform certain simple operations on
an object regardless of its underlying representation.
C<Email::Abstract> currently supports C<Mail::Internet>, C<MIME::Entity>,
C<Mail::Message>, C<Email::Simple>, C<Email::MIME>, and C<Courriel>. Other
representations are encouraged to create their own C<Email::Abstract::*> class
by copying C<Email::Abstract::EmailSimple>. All modules installed under the
C<Email::Abstract> hierarchy will be automatically picked up and used.
=head1 METHODS
All of these methods may be called either as object methods or as class
methods. When called as class methods, the email object (of any class
supported by Email::Abstract) must be prepended to the list of arguments, like
so:
my $return = Email::Abstract->method($message, @args);
This is provided primarily for backwards compatibility.
=head2 new
my $email = Email::Abstract->new($message);
Given a message, either as a string or as an object for which an adapter is
installed, this method will return a Email::Abstract object wrapping the
message.
If the message is given as a string, it will be used to construct an object,
which will then be wrapped.
=head2 get_header
my $header = $email->get_header($header_name);
my @headers = $email->get_header($header_name);
This returns the values for the given header. In scalar context, it returns
the first value.
=head2 set_header
$email->set_header($header => @values);
This sets the C<$header> header to the given one or more values.
=head2 get_body
my $body = $email->get_body;
This returns the body as a string.
=head2 set_body
$email->set_body($string);
This changes the body of the email to the given string.
B<WARNING!> You probably don't want to call this method, despite what you may
think. Email message bodies are complicated, and rely on things like content
type, encoding, and various MIME requirements. If you call C<set_body> on a
message more complicated than a single-part seven-bit plain-text message, you
are likely to break something. If you need to do this sort of thing, you
should probably use a specific message class from end to end.
This method is left in place for backwards compatibility.
=head2 as_string
my $string = $email->as_string;
This returns the whole email as a decoded string.
=head2 cast
my $mime_entity = $email->cast('MIME::Entity');
This method will convert a message from one message class to another. It will
throw an exception if no adapter for the target class is known, or if the
adapter does not provide a C<construct> method.
=head2 object
my $message = $email->object;
This method returns the message object wrapped by Email::Abstract. If called
as a class method, it returns false.
Note that, because strings are converted to message objects before wrapping,
this method will return an object when the Email::Abstract was constructed from
a string.
=head1 AUTHORS
=over 4
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Simon Cozens <simon@cpan.org>
=item *
Casey West <casey@geeknest.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
#pod =head1 SYNOPSIS
#pod
#pod my $message = Mail::Message->read($rfc822)
#pod || Email::Simple->new($rfc822)
#pod || Mail::Internet->new([split /\n/, $rfc822])
#pod || ...
#pod || $rfc822;
#pod
#pod my $email = Email::Abstract->new($message);
#pod
#pod my $subject = $email->get_header("Subject");
#pod $email->set_header(Subject => "My new subject");
#pod
#pod my $body = $email->get_body;
#pod
#pod $rfc822 = $email->as_string;
#pod
#pod my $mail_message = $email->cast("Mail::Message");
#pod
#pod =head1 DESCRIPTION
#pod
#pod C<Email::Abstract> provides module writers with the ability to write
#pod simple, representation-independent mail handling code. For instance, in the
#pod cases of C<Mail::Thread> or C<Mail::ListDetector>, a key part of the code
#pod involves reading the headers from a mail object. Where previously one would
#pod either have to specify the mail class required, or to build a new object from
#pod scratch, C<Email::Abstract> can be used to perform certain simple operations on
#pod an object regardless of its underlying representation.
#pod
#pod C<Email::Abstract> currently supports C<Mail::Internet>, C<MIME::Entity>,
#pod C<Mail::Message>, C<Email::Simple>, C<Email::MIME>, and C<Courriel>. Other
#pod representations are encouraged to create their own C<Email::Abstract::*> class
#pod by copying C<Email::Abstract::EmailSimple>. All modules installed under the
#pod C<Email::Abstract> hierarchy will be automatically picked up and used.
#pod
#pod =head1 METHODS
#pod
#pod All of these methods may be called either as object methods or as class
#pod methods. When called as class methods, the email object (of any class
#pod supported by Email::Abstract) must be prepended to the list of arguments, like
#pod so:
#pod
#pod my $return = Email::Abstract->method($message, @args);
#pod
#pod This is provided primarily for backwards compatibility.
#pod
#pod =head2 new
#pod
#pod my $email = Email::Abstract->new($message);
#pod
#pod Given a message, either as a string or as an object for which an adapter is
#pod installed, this method will return a Email::Abstract object wrapping the
#pod message.
#pod
#pod If the message is given as a string, it will be used to construct an object,
#pod which will then be wrapped.
#pod
#pod =head2 get_header
#pod
#pod my $header = $email->get_header($header_name);
#pod
#pod my @headers = $email->get_header($header_name);
#pod
#pod This returns the values for the given header. In scalar context, it returns
#pod the first value.
#pod
#pod =head2 set_header
#pod
#pod $email->set_header($header => @values);
#pod
#pod This sets the C<$header> header to the given one or more values.
#pod
#pod =head2 get_body
#pod
#pod my $body = $email->get_body;
#pod
#pod This returns the body as a string.
#pod
#pod =head2 set_body
#pod
#pod $email->set_body($string);
#pod
#pod This changes the body of the email to the given string.
#pod
#pod B<WARNING!> You probably don't want to call this method, despite what you may
#pod think. Email message bodies are complicated, and rely on things like content
#pod type, encoding, and various MIME requirements. If you call C<set_body> on a
#pod message more complicated than a single-part seven-bit plain-text message, you
#pod are likely to break something. If you need to do this sort of thing, you
#pod should probably use a specific message class from end to end.
#pod
#pod This method is left in place for backwards compatibility.
#pod
#pod =head2 as_string
#pod
#pod my $string = $email->as_string;
#pod
#pod This returns the whole email as a decoded string.
#pod
#pod =head2 cast
#pod
#pod my $mime_entity = $email->cast('MIME::Entity');
#pod
#pod This method will convert a message from one message class to another. It will
#pod throw an exception if no adapter for the target class is known, or if the
#pod adapter does not provide a C<construct> method.
#pod
#pod =head2 object
#pod
#pod my $message = $email->object;
#pod
#pod This method returns the message object wrapped by Email::Abstract. If called
#pod as a class method, it returns false.
#pod
#pod Note that, because strings are converted to message objects before wrapping,
#pod this method will return an object when the Email::Abstract was constructed from
#pod a string.
#pod
#pod =cut

87
database/perl/vendor/lib/Email/Abstract/EmailMIME.pm vendored Normal file
View File

@@ -0,0 +1,87 @@
use strict;
use warnings;
package Email::Abstract::EmailMIME;
# ABSTRACT: Email::Abstract wrapper for Email::MIME
$Email::Abstract::EmailMIME::VERSION = '3.008';
use Email::Abstract::EmailSimple;
BEGIN { @Email::Abstract::EmailMIME::ISA = 'Email::Abstract::EmailSimple' };
sub target { "Email::MIME" }
sub construct {
require Email::MIME;
my ($class, $rfc822) = @_;
Email::MIME->new($rfc822);
}
sub get_body {
my ($class, $obj) = @_;
# Return the same thing you'd get from Email::Simple.
#
# Ugh. -- rjbs, 2014-12-27
return $obj->body_raw;
}
1;
#pod =head1 DESCRIPTION
#pod
#pod This module wraps the Email::MIME mail handling library with an
#pod abstract interface, to be used with L<Email::Abstract>
#pod
#pod =head1 SEE ALSO
#pod
#pod L<Email::Abstract>, L<Email::MIME>.
#pod
#pod =cut
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Abstract::EmailMIME - Email::Abstract wrapper for Email::MIME
=head1 VERSION
version 3.008
=head1 DESCRIPTION
This module wraps the Email::MIME mail handling library with an
abstract interface, to be used with L<Email::Abstract>
=head1 SEE ALSO
L<Email::Abstract>, L<Email::MIME>.
=head1 AUTHORS
=over 4
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Simon Cozens <simon@cpan.org>
=item *
Casey West <casey@geeknest.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

103
database/perl/vendor/lib/Email/Abstract/EmailSimple.pm vendored Normal file
View File

@@ -0,0 +1,103 @@
use strict;
use warnings;
package Email::Abstract::EmailSimple;
# ABSTRACT: Email::Abstract wrapper for Email::Simple
$Email::Abstract::EmailSimple::VERSION = '3.008';
use Email::Abstract::Plugin;
BEGIN { @Email::Abstract::EmailSimple::ISA = 'Email::Abstract::Plugin' };
sub target { "Email::Simple" }
sub construct {
require Email::Simple;
my ($class, $rfc822) = @_;
Email::Simple->new($rfc822);
}
sub get_header {
my ($class, $obj, $header) = @_;
$obj->header($header);
}
sub get_body {
my ($class, $obj) = @_;
$obj->body();
}
sub set_header {
my ($class, $obj, $header, @data) = @_;
$obj->header_set($header, @data);
}
sub set_body {
my ($class, $obj, $body) = @_;
$obj->body_set($body);
}
sub as_string {
my ($class, $obj) = @_;
$obj->as_string();
}
1;
#pod =head1 DESCRIPTION
#pod
#pod This module wraps the Email::Simple mail handling library with an
#pod abstract interface, to be used with L<Email::Abstract>
#pod
#pod =head1 SEE ALSO
#pod
#pod L<Email::Abstract>, L<Email::Simple>.
#pod
#pod =cut
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Abstract::EmailSimple - Email::Abstract wrapper for Email::Simple
=head1 VERSION
version 3.008
=head1 DESCRIPTION
This module wraps the Email::Simple mail handling library with an
abstract interface, to be used with L<Email::Abstract>
=head1 SEE ALSO
L<Email::Abstract>, L<Email::Simple>.
=head1 AUTHORS
=over 4
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Simon Cozens <simon@cpan.org>
=item *
Casey West <casey@geeknest.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

100
database/perl/vendor/lib/Email/Abstract/MIMEEntity.pm vendored Normal file
View File

@@ -0,0 +1,100 @@
use strict;
package Email::Abstract::MIMEEntity;
# ABSTRACT: Email::Abstract wrapper for MIME::Entity
$Email::Abstract::MIMEEntity::VERSION = '3.008';
use Email::Abstract::Plugin;
BEGIN { @Email::Abstract::MIMEEntity::ISA = 'Email::Abstract::MailInternet' };
my $is_avail;
sub is_available {
return $is_avail if defined $is_avail;
eval { require MIME::Entity; MIME::Entity->VERSION(5.501); 1 };
return $is_avail = $@ ? 0 : 1;
}
sub target { "MIME::Entity" }
sub construct {
require MIME::Parser;
my $parser = MIME::Parser->new;
$parser->output_to_core(1);
my ($class, $rfc822) = @_;
$parser->parse_data($rfc822);
}
sub get_body {
my ($self, $obj) = @_;
my $handle = $obj->bodyhandle;
return $handle ? $handle->as_string : join('', @{ $obj->body });
}
sub set_body {
my ($class, $obj, $body) = @_;
my @lines = split /\n/, $body;
my $io = $obj->bodyhandle->open("w");
foreach (@lines) { $io->print($_."\n") }
$io->close;
}
1;
#pod =head1 DESCRIPTION
#pod
#pod This module wraps the MIME::Entity mail handling library with an
#pod abstract interface, to be used with L<Email::Abstract>
#pod
#pod =head1 SEE ALSO
#pod
#pod L<Email::Abstract>, L<MIME::Entity>.
#pod
#pod =cut
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Abstract::MIMEEntity - Email::Abstract wrapper for MIME::Entity
=head1 VERSION
version 3.008
=head1 DESCRIPTION
This module wraps the MIME::Entity mail handling library with an
abstract interface, to be used with L<Email::Abstract>
=head1 SEE ALSO
L<Email::Abstract>, L<MIME::Entity>.
=head1 AUTHORS
=over 4
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Simon Cozens <simon@cpan.org>
=item *
Casey West <casey@geeknest.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

118
database/perl/vendor/lib/Email/Abstract/MailInternet.pm vendored Normal file
View File

@@ -0,0 +1,118 @@
use strict;
package Email::Abstract::MailInternet;
# ABSTRACT: Email::Abstract wrapper for Mail::Internet
$Email::Abstract::MailInternet::VERSION = '3.008';
use Email::Abstract::Plugin;
BEGIN { @Email::Abstract::MailInternet::ISA = 'Email::Abstract::Plugin' };
sub target { "Mail::Internet" }
# We need 1.77 because otherwise headers unfold badly.
my $is_avail;
sub is_available {
return $is_avail if defined $is_avail;
require Mail::Internet;
eval { Mail::Internet->VERSION(1.77) };
return $is_avail = $@ ? 0 : 1;
}
sub construct {
require Mail::Internet;
my ($class, $rfc822) = @_;
Mail::Internet->new([ map { "$_\x0d\x0a" } split /\x0d\x0a/, $rfc822]);
}
sub get_header {
my ($class, $obj, $header) = @_;
my @values = $obj->head->get($header);
return unless @values;
# No reason to s/// lots of values if we're just going to return one.
$#values = 0 if not wantarray;
chomp @values;
s/(?:\x0d\x0a|\x0a\x0d|\x0a|\x0d)\s+/ /g for @values;
return wantarray ? @values : $values[0];
}
sub get_body {
my ($class, $obj) = @_;
join "", @{$obj->body()};
}
sub set_header {
my ($class, $obj, $header, @data) = @_;
my $count = 0;
$obj->head->replace($header, shift @data, ++$count) while @data;
}
sub set_body {
my ($class, $obj, $body) = @_;
$obj->body( map { "$_\n" } split /\n/, $body );
}
sub as_string { my ($class, $obj) = @_; $obj->as_string(); }
1;
#pod =head1 DESCRIPTION
#pod
#pod This module wraps the Mail::Internet mail handling library with an
#pod abstract interface, to be used with L<Email::Abstract>
#pod
#pod =head1 SEE ALSO
#pod
#pod L<Email::Abstract>, L<Mail::Internet>.
#pod
#pod =cut
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Abstract::MailInternet - Email::Abstract wrapper for Mail::Internet
=head1 VERSION
version 3.008
=head1 DESCRIPTION
This module wraps the Mail::Internet mail handling library with an
abstract interface, to be used with L<Email::Abstract>
=head1 SEE ALSO
L<Email::Abstract>, L<Mail::Internet>.
=head1 AUTHORS
=over 4
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Simon Cozens <simon@cpan.org>
=item *
Casey West <casey@geeknest.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

103
database/perl/vendor/lib/Email/Abstract/MailMessage.pm vendored Normal file
View File

@@ -0,0 +1,103 @@
use strict;
package Email::Abstract::MailMessage;
# ABSTRACT: Email::Abstract wrapper for Mail::Message
$Email::Abstract::MailMessage::VERSION = '3.008';
use Email::Abstract::Plugin;
BEGIN { @Email::Abstract::MailMessage::ISA = 'Email::Abstract::Plugin' };
sub target { "Mail::Message" }
sub construct {
require Mail::Message;
my ($class, $rfc822) = @_;
Mail::Message->read($rfc822);
}
sub get_header {
my ($class, $obj, $header) = @_;
$obj->head->get($header);
}
sub get_body {
my ($class, $obj) = @_;
$obj->decoded->string;
}
sub set_header {
my ($class, $obj, $header, @data) = @_;
$obj->head->delete($header);
$obj->head->add($header, $_) for @data;
}
sub set_body {
my ($class, $obj, $body) = @_;
$obj->body(Mail::Message::Body->new(data => $body));
}
sub as_string {
my ($class, $obj) = @_;
$obj->string;
}
1;
#pod =head1 DESCRIPTION
#pod
#pod This module wraps the Mail::Message mail handling library with an
#pod abstract interface, to be used with L<Email::Abstract>
#pod
#pod =head1 SEE ALSO
#pod
#pod L<Email::Abstract>, L<Mail::Message>.
#pod
#pod =cut
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Abstract::MailMessage - Email::Abstract wrapper for Mail::Message
=head1 VERSION
version 3.008
=head1 DESCRIPTION
This module wraps the Mail::Message mail handling library with an
abstract interface, to be used with L<Email::Abstract>
=head1 SEE ALSO
L<Email::Abstract>, L<Mail::Message>.
=head1 AUTHORS
=over 4
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Simon Cozens <simon@cpan.org>
=item *
Casey West <casey@geeknest.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

65
database/perl/vendor/lib/Email/Abstract/Plugin.pm vendored Normal file
View File

@@ -0,0 +1,65 @@
use strict;
use warnings;
package Email::Abstract::Plugin;
# ABSTRACT: a base class for Email::Abstract plugins
$Email::Abstract::Plugin::VERSION = '3.008';
#pod =method is_available
#pod
#pod This method returns true if the plugin should be considered available for
#pod registration. Plugins that return false from this method will not be
#pod registered when Email::Abstract is loaded.
#pod
#pod =cut
sub is_available { 1 }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Abstract::Plugin - a base class for Email::Abstract plugins
=head1 VERSION
version 3.008
=head1 METHODS
=head2 is_available
This method returns true if the plugin should be considered available for
registration. Plugins that return false from this method will not be
registered when Email::Abstract is loaded.
=head1 AUTHORS
=over 4
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Simon Cozens <simon@cpan.org>
=item *
Casey West <casey@geeknest.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

920
database/perl/vendor/lib/Email/Address.pm vendored Normal file
View File

@@ -0,0 +1,920 @@
use strict;
use warnings;
package Email::Address;
# ABSTRACT: RFC 2822 Address Parsing and Creation
$Email::Address::VERSION = '1.912';
our $COMMENT_NEST_LEVEL ||= 1;
our $STRINGIFY ||= 'format';
our $COLLAPSE_SPACES = 1 unless defined $COLLAPSE_SPACES; # I miss //=
#pod =head1 SYNOPSIS
#pod
#pod use Email::Address;
#pod
#pod my @addresses = Email::Address->parse($line);
#pod my $address = Email::Address->new(Casey => 'casey@localhost');
#pod
#pod print $address->format;
#pod
#pod =head1 DESCRIPTION
#pod
#pod This class implements a regex-based RFC 2822 parser that locates email
#pod addresses in strings and returns a list of C<Email::Address> objects found.
#pod Alternatively you may construct objects manually. The goal of this software is
#pod to be correct, and very very fast.
#pod
#pod Version 1.909 and earlier of this module had vulnerabilies
#pod (L<CVE-2015-7686|https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2015-7686>)
#pod and (L<CVE-2015-12558|https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2018-12558>)
#pod which allowed specially constructed email to cause a denial of service. The
#pod reported vulnerabilities and some other pathalogical cases (meaning they really
#pod shouldn't occur in normal email) have been addressed in version 1.910 and newer.
#pod If you're running version 1.909 or older, you should update!
#pod
#pod Alternatively, you could switch to L<B<Email::Address::XS>|Email::Address::XS>
#pod which has a backward compatible API.
#pod
#pod =cut
my $CTL = q{\x00-\x1F\x7F};
my $special = q{()<>\\[\\]:;@\\\\,."};
my $text = qr/[^\x0A\x0D]/;
my $quoted_pair = qr/\\$text/;
my $ctext = qr/(?>[^()\\]+)/;
my ($ccontent, $comment) = (q{})x2;
for (1 .. $COMMENT_NEST_LEVEL) {
$ccontent = qr/$ctext|$quoted_pair|$comment/;
$comment = qr/(?>\s*\((?:\s*$ccontent)*\s*\)\s*)/;
}
my $cfws = qr/$comment|(?>\s+)/;
my $atext = qq/[^$CTL$special\\s]/;
my $atom = qr/(?>$cfws*$atext+$cfws*)/;
my $dot_atom_text = qr/(?>$atext+(?:\.$atext+)*)/;
my $dot_atom = qr/(?>$cfws*$dot_atom_text$cfws*)/;
my $qtext = qr/[^\\"]/;
my $qcontent = qr/$qtext|$quoted_pair/;
my $quoted_string = qr/(?>$cfws*"$qcontent*"$cfws*)/;
my $word = qr/$atom|$quoted_string/;
# XXX: This ($phrase) used to just be: my $phrase = qr/$word+/; It was changed
# to resolve bug 22991, creating a significant slowdown. Given current speed
# problems. Once 16320 is resolved, this section should be dealt with.
# -- rjbs, 2006-11-11
#my $obs_phrase = qr/$word(?:$word|\.|$cfws)*/;
# XXX: ...and the above solution caused endless problems (never returned) when
# examining this address, now in a test:
# admin+=E6=96=B0=E5=8A=A0=E5=9D=A1_Weblog-- ATAT --test.socialtext.com
# So we disallow the hateful CFWS in this context for now. Of modern mail
# agents, only Apple Web Mail 2.0 is known to produce obs-phrase.
# -- rjbs, 2006-11-19
my $simple_word = qr/(?>$atom|\.|\s*"$qcontent+"\s*)/;
my $obs_phrase = qr/(?>$simple_word+)/;
my $phrase = qr/$obs_phrase|(?>$word+)/;
my $local_part = qr/$dot_atom|$quoted_string/;
my $dtext = qr/[^\[\]\\]/;
my $dcontent = qr/$dtext|$quoted_pair/;
my $domain_literal = qr/(?>$cfws*\[(?:\s*$dcontent)*\s*\]$cfws*)/;
my $domain = qr/$dot_atom|$domain_literal/;
my $display_name = $phrase;
#pod =head2 Package Variables
#pod
#pod B<ACHTUNG!> Email isn't easy (if even possible) to parse with a regex, I<at
#pod least> if you're on a C<perl> prior to 5.10.0. Providing regular expressions
#pod for use by other programs isn't a great idea, because it makes it hard to
#pod improve the parser without breaking the "it's a regex" feature. Using these
#pod regular expressions is not encouraged, and methods like C<<
#pod Email::Address->is_addr_spec >> should be provided in the future.
#pod
#pod Several regular expressions used in this package are useful to others.
#pod For convenience, these variables are declared as package variables that
#pod you may access from your program.
#pod
#pod These regular expressions conform to the rules specified in RFC 2822.
#pod
#pod You can access these variables using the full namespace. If you want
#pod short names, define them yourself.
#pod
#pod my $addr_spec = $Email::Address::addr_spec;
#pod
#pod =over 4
#pod
#pod =item $Email::Address::addr_spec
#pod
#pod This regular expression defined what an email address is allowed to
#pod look like.
#pod
#pod =item $Email::Address::angle_addr
#pod
#pod This regular expression defines an C<$addr_spec> wrapped in angle
#pod brackets.
#pod
#pod =item $Email::Address::name_addr
#pod
#pod This regular expression defines what an email address can look like
#pod with an optional preceding display name, also known as the C<phrase>.
#pod
#pod =item $Email::Address::mailbox
#pod
#pod This is the complete regular expression defining an RFC 2822 email
#pod address with an optional preceding display name and optional
#pod following comment.
#pod
#pod =back
#pod
#pod =cut
our $addr_spec = qr/$local_part\@$domain/;
our $angle_addr = qr/(?>$cfws*<$addr_spec>$cfws*)/;
our $name_addr = qr/(?>$display_name?)$angle_addr/;
our $mailbox = qr/(?:$name_addr|$addr_spec)(?>$comment*)/;
sub _PHRASE () { 0 }
sub _ADDRESS () { 1 }
sub _COMMENT () { 2 }
sub _ORIGINAL () { 3 }
sub _IN_CACHE () { 4 }
sub __dump {
return {
phrase => $_[0][_PHRASE],
address => $_[0][_ADDRESS],
comment => $_[0][_COMMENT],
original => $_[0][_ORIGINAL],
}
}
#pod =head2 Class Methods
#pod
#pod =over
#pod
#pod =item parse
#pod
#pod my @addrs = Email::Address->parse(
#pod q[me@local, Casey <me@local>, "Casey" <me@local> (West)]
#pod );
#pod
#pod This method returns a list of C<Email::Address> objects it finds in the input
#pod string. B<Please note> that it returns a list, and expects that it may find
#pod multiple addresses. The behavior in scalar context is undefined.
#pod
#pod The specification for an email address allows for infinitely nestable comments.
#pod That's nice in theory, but a little over done. By default this module allows
#pod for one (C<1>) level of nested comments. If you think you need more, modify the
#pod C<$Email::Address::COMMENT_NEST_LEVEL> package variable to allow more.
#pod
#pod $Email::Address::COMMENT_NEST_LEVEL = 10; # I'm deep
#pod
#pod The reason for this hardly-limiting limitation is simple: efficiency.
#pod
#pod Long strings of whitespace can be problematic for this module to parse, a bug
#pod which has not yet been adequately addressed. The default behavior is now to
#pod collapse multiple spaces into a single space, which avoids this problem. To
#pod prevent this behavior, set C<$Email::Address::COLLAPSE_SPACES> to zero. This
#pod variable will go away when the bug is resolved properly.
#pod
#pod In accordance with RFC 822 and its descendants, this module demands that email
#pod addresses be ASCII only. Any non-ASCII content in the parsed addresses will
#pod cause the parser to return no results.
#pod
#pod =cut
our (%PARSE_CACHE, %FORMAT_CACHE, %NAME_CACHE);
my $NOCACHE;
sub __get_cached_parse {
return if $NOCACHE;
my ($class, $line) = @_;
return @{$PARSE_CACHE{$line}} if exists $PARSE_CACHE{$line};
return;
}
sub __cache_parse {
return if $NOCACHE;
my ($class, $line, $addrs) = @_;
$PARSE_CACHE{$line} = $addrs;
}
sub parse {
my ($class, $line) = @_;
return unless $line;
$line =~ s/[ \t]+/ /g if $COLLAPSE_SPACES;
if (my @cached = $class->__get_cached_parse($line)) {
return @cached;
}
my %mailboxes;
my $str = $line;
$str =~ s!($name_addr(?>$comment*))!$mailboxes{pos($str)} = $1; ',' x length $1!ego
if $str =~ /$angle_addr/;
$str =~ s!($addr_spec(?>$comment*))!$mailboxes{pos($str)} = $1; ',' x length $1!ego;
my @mailboxes = map { $mailboxes{$_} } sort { $a <=> $b } keys %mailboxes;
my @addrs;
foreach (@mailboxes) {
my $original = $_;
my @comments = /($comment)/go;
s/$comment//go if @comments;
my ($user, $host, $com);
($user, $host) = ($1, $2) if s/<($local_part)\@($domain)>\s*\z//o;
if (! defined($user) || ! defined($host)) {
s/($local_part)\@($domain)//o;
($user, $host) = ($1, $2);
}
next if $user =~ /\P{ASCII}/;
next if $host =~ /\P{ASCII}/;
my ($phrase) = /($display_name)/o;
for ( $phrase, $host, $user, @comments ) {
next unless defined $_;
s/^\s+//;
s/\s+$//;
$_ = undef unless length $_;
}
$phrase =~ s/\\(.)/$1/g if $phrase;
my $new_comment = join q{ }, @comments;
push @addrs,
$class->new($phrase, "$user\@$host", $new_comment, $original);
$addrs[-1]->[_IN_CACHE] = [ \$line, $#addrs ]
}
$class->__cache_parse($line, \@addrs);
return @addrs;
}
#pod =item new
#pod
#pod my $address = Email::Address->new(undef, 'casey@local');
#pod my $address = Email::Address->new('Casey West', 'casey@local');
#pod my $address = Email::Address->new(undef, 'casey@local', '(Casey)');
#pod
#pod Constructs and returns a new C<Email::Address> object. Takes four
#pod positional arguments: phrase, email, and comment, and original string.
#pod
#pod The original string should only really be set using C<parse>.
#pod
#pod =cut
sub new {
my ($class, $phrase, $email, $comment, $orig) = @_;
$phrase =~ s/\A"(.+)"\z/$1/ if $phrase;
bless [ $phrase, $email, $comment, $orig ] => $class;
}
#pod =item purge_cache
#pod
#pod Email::Address->purge_cache;
#pod
#pod One way this module stays fast is with internal caches. Caches live
#pod in memory and there is the remote possibility that you will have a
#pod memory problem. On the off chance that you think you're one of those
#pod people, this class method will empty those caches.
#pod
#pod I've loaded over 12000 objects and not encountered a memory problem.
#pod
#pod =cut
sub purge_cache {
%NAME_CACHE = ();
%FORMAT_CACHE = ();
%PARSE_CACHE = ();
}
#pod =item disable_cache
#pod
#pod =item enable_cache
#pod
#pod Email::Address->disable_cache if memory_low();
#pod
#pod If you'd rather not cache address parses at all, you can disable (and
#pod re-enable) the Email::Address cache with these methods. The cache is enabled
#pod by default.
#pod
#pod =cut
sub disable_cache {
my ($class) = @_;
$class->purge_cache;
$NOCACHE = 1;
}
sub enable_cache {
$NOCACHE = undef;
}
#pod =back
#pod
#pod =head2 Instance Methods
#pod
#pod =over 4
#pod
#pod =item phrase
#pod
#pod my $phrase = $address->phrase;
#pod $address->phrase( "Me oh my" );
#pod
#pod Accessor and mutator for the phrase portion of an address.
#pod
#pod =item address
#pod
#pod my $addr = $address->address;
#pod $addr->address( "me@PROTECTED.com" );
#pod
#pod Accessor and mutator for the address portion of an address.
#pod
#pod =item comment
#pod
#pod my $comment = $address->comment;
#pod $address->comment( "(Work address)" );
#pod
#pod Accessor and mutator for the comment portion of an address.
#pod
#pod =item original
#pod
#pod my $orig = $address->original;
#pod
#pod Accessor for the original address found when parsing, or passed
#pod to C<new>.
#pod
#pod =item host
#pod
#pod my $host = $address->host;
#pod
#pod Accessor for the host portion of an address's address.
#pod
#pod =item user
#pod
#pod my $user = $address->user;
#pod
#pod Accessor for the user portion of an address's address.
#pod
#pod =cut
BEGIN {
my %_INDEX = (
phrase => _PHRASE,
address => _ADDRESS,
comment => _COMMENT,
original => _ORIGINAL,
);
for my $method (keys %_INDEX) {
no strict 'refs';
my $index = $_INDEX{ $method };
*$method = sub {
if ($_[1]) {
if ($_[0][_IN_CACHE]) {
my $replicant = bless [ @{$_[0]} ] => ref $_[0];
$PARSE_CACHE{ ${ $_[0][_IN_CACHE][0] } }[ $_[0][_IN_CACHE][1] ]
= $replicant;
$_[0][_IN_CACHE] = undef;
}
$_[0]->[ $index ] = $_[1];
} else {
$_[0]->[ $index ];
}
};
}
}
sub host { ($_[0]->[_ADDRESS] =~ /\@($domain)/o)[0] }
sub user { ($_[0]->[_ADDRESS] =~ /($local_part)\@/o)[0] }
#pod =pod
#pod
#pod =item format
#pod
#pod my $printable = $address->format;
#pod
#pod Returns a properly formatted RFC 2822 address representing the
#pod object.
#pod
#pod =cut
sub format {
my $cache_str = do { no warnings 'uninitialized'; "@{$_[0]}" };
return $FORMAT_CACHE{$cache_str} if exists $FORMAT_CACHE{$cache_str};
$FORMAT_CACHE{$cache_str} = $_[0]->_format;
}
sub _format {
my ($self) = @_;
unless (
defined $self->[_PHRASE] && length $self->[_PHRASE]
||
defined $self->[_COMMENT] && length $self->[_COMMENT]
) {
return defined $self->[_ADDRESS] ? $self->[_ADDRESS] : '';
}
my $comment = defined $self->[_COMMENT] ? $self->[_COMMENT] : '';
$comment = "($comment)" if length $comment and $comment !~ /\A\(.*\)\z/;
my $format = sprintf q{%s <%s> %s},
$self->_enquoted_phrase,
(defined $self->[_ADDRESS] ? $self->[_ADDRESS] : ''),
$comment;
$format =~ s/^\s+//;
$format =~ s/\s+$//;
return $format;
}
sub _enquoted_phrase {
my ($self) = @_;
my $phrase = $self->[_PHRASE];
return '' unless defined $phrase and length $phrase;
# if it's encoded -- rjbs, 2007-02-28
return $phrase if $phrase =~ /\A=\?.+\?=\z/;
$phrase =~ s/\A"(.+)"\z/$1/;
$phrase =~ s/([\\"])/\\$1/g;
return qq{"$phrase"};
}
#pod =item name
#pod
#pod my $name = $address->name;
#pod
#pod This method tries very hard to determine the name belonging to the address.
#pod First the C<phrase> is checked. If that doesn't work out the C<comment>
#pod is looked into. If that still doesn't work out, the C<user> portion of
#pod the C<address> is returned.
#pod
#pod This method does B<not> try to massage any name it identifies and instead
#pod leaves that up to someone else. Who is it to decide if someone wants their
#pod name capitalized, or if they're Irish?
#pod
#pod =cut
sub name {
my $cache_str = do { no warnings 'uninitialized'; "@{$_[0]}" };
return $NAME_CACHE{$cache_str} if exists $NAME_CACHE{$cache_str};
my ($self) = @_;
my $name = q{};
if ( $name = $self->[_PHRASE] ) {
$name =~ s/^"//;
$name =~ s/"$//;
$name =~ s/($quoted_pair)/substr $1, -1/goe;
} elsif ( $name = $self->[_COMMENT] ) {
$name =~ s/^\(//;
$name =~ s/\)$//;
$name =~ s/($quoted_pair)/substr $1, -1/goe;
$name =~ s/$comment/ /go;
} else {
($name) = $self->[_ADDRESS] =~ /($local_part)\@/o;
}
$NAME_CACHE{$cache_str} = $name;
}
#pod =back
#pod
#pod =head2 Overloaded Operators
#pod
#pod =over 4
#pod
#pod =item stringify
#pod
#pod print "I have your email address, $address.";
#pod
#pod Objects stringify to C<format> by default. It's possible that you don't
#pod like that idea. Okay, then, you can change it by modifying
#pod C<$Email:Address::STRINGIFY>. Please consider modifying this package
#pod variable using C<local>. You might step on someone else's toes if you
#pod don't.
#pod
#pod {
#pod local $Email::Address::STRINGIFY = 'host';
#pod print "I have your address, $address.";
#pod # geeknest.com
#pod }
#pod print "I have your address, $address.";
#pod # "Casey West" <casey@geeknest.com>
#pod
#pod Modifying this package variable is now deprecated. Subclassing is now the
#pod recommended approach.
#pod
#pod =cut
sub as_string {
warn 'altering $Email::Address::STRINGIFY is deprecated; subclass instead'
if $STRINGIFY ne 'format';
$_[0]->can($STRINGIFY)->($_[0]);
}
use overload '""' => 'as_string', fallback => 1;
#pod =pod
#pod
#pod =back
#pod
#pod =cut
1;
=pod
=encoding UTF-8
=head1 NAME
Email::Address - RFC 2822 Address Parsing and Creation
=head1 VERSION
version 1.912
=head1 SYNOPSIS
use Email::Address;
my @addresses = Email::Address->parse($line);
my $address = Email::Address->new(Casey => 'casey@localhost');
print $address->format;
=head1 DESCRIPTION
This class implements a regex-based RFC 2822 parser that locates email
addresses in strings and returns a list of C<Email::Address> objects found.
Alternatively you may construct objects manually. The goal of this software is
to be correct, and very very fast.
Version 1.909 and earlier of this module had vulnerabilies
(L<CVE-2015-7686|https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2015-7686>)
and (L<CVE-2015-12558|https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2018-12558>)
which allowed specially constructed email to cause a denial of service. The
reported vulnerabilities and some other pathalogical cases (meaning they really
shouldn't occur in normal email) have been addressed in version 1.910 and newer.
If you're running version 1.909 or older, you should update!
Alternatively, you could switch to L<B<Email::Address::XS>|Email::Address::XS>
which has a backward compatible API.
=head2 Package Variables
B<ACHTUNG!> Email isn't easy (if even possible) to parse with a regex, I<at
least> if you're on a C<perl> prior to 5.10.0. Providing regular expressions
for use by other programs isn't a great idea, because it makes it hard to
improve the parser without breaking the "it's a regex" feature. Using these
regular expressions is not encouraged, and methods like C<<
Email::Address->is_addr_spec >> should be provided in the future.
Several regular expressions used in this package are useful to others.
For convenience, these variables are declared as package variables that
you may access from your program.
These regular expressions conform to the rules specified in RFC 2822.
You can access these variables using the full namespace. If you want
short names, define them yourself.
my $addr_spec = $Email::Address::addr_spec;
=over 4
=item $Email::Address::addr_spec
This regular expression defined what an email address is allowed to
look like.
=item $Email::Address::angle_addr
This regular expression defines an C<$addr_spec> wrapped in angle
brackets.
=item $Email::Address::name_addr
This regular expression defines what an email address can look like
with an optional preceding display name, also known as the C<phrase>.
=item $Email::Address::mailbox
This is the complete regular expression defining an RFC 2822 email
address with an optional preceding display name and optional
following comment.
=back
=head2 Class Methods
=over
=item parse
my @addrs = Email::Address->parse(
q[me@local, Casey <me@local>, "Casey" <me@local> (West)]
);
This method returns a list of C<Email::Address> objects it finds in the input
string. B<Please note> that it returns a list, and expects that it may find
multiple addresses. The behavior in scalar context is undefined.
The specification for an email address allows for infinitely nestable comments.
That's nice in theory, but a little over done. By default this module allows
for one (C<1>) level of nested comments. If you think you need more, modify the
C<$Email::Address::COMMENT_NEST_LEVEL> package variable to allow more.
$Email::Address::COMMENT_NEST_LEVEL = 10; # I'm deep
The reason for this hardly-limiting limitation is simple: efficiency.
Long strings of whitespace can be problematic for this module to parse, a bug
which has not yet been adequately addressed. The default behavior is now to
collapse multiple spaces into a single space, which avoids this problem. To
prevent this behavior, set C<$Email::Address::COLLAPSE_SPACES> to zero. This
variable will go away when the bug is resolved properly.
In accordance with RFC 822 and its descendants, this module demands that email
addresses be ASCII only. Any non-ASCII content in the parsed addresses will
cause the parser to return no results.
=item new
my $address = Email::Address->new(undef, 'casey@local');
my $address = Email::Address->new('Casey West', 'casey@local');
my $address = Email::Address->new(undef, 'casey@local', '(Casey)');
Constructs and returns a new C<Email::Address> object. Takes four
positional arguments: phrase, email, and comment, and original string.
The original string should only really be set using C<parse>.
=item purge_cache
Email::Address->purge_cache;
One way this module stays fast is with internal caches. Caches live
in memory and there is the remote possibility that you will have a
memory problem. On the off chance that you think you're one of those
people, this class method will empty those caches.
I've loaded over 12000 objects and not encountered a memory problem.
=item disable_cache
=item enable_cache
Email::Address->disable_cache if memory_low();
If you'd rather not cache address parses at all, you can disable (and
re-enable) the Email::Address cache with these methods. The cache is enabled
by default.
=back
=head2 Instance Methods
=over 4
=item phrase
my $phrase = $address->phrase;
$address->phrase( "Me oh my" );
Accessor and mutator for the phrase portion of an address.
=item address
my $addr = $address->address;
$addr->address( "me@PROTECTED.com" );
Accessor and mutator for the address portion of an address.
=item comment
my $comment = $address->comment;
$address->comment( "(Work address)" );
Accessor and mutator for the comment portion of an address.
=item original
my $orig = $address->original;
Accessor for the original address found when parsing, or passed
to C<new>.
=item host
my $host = $address->host;
Accessor for the host portion of an address's address.
=item user
my $user = $address->user;
Accessor for the user portion of an address's address.
=item format
my $printable = $address->format;
Returns a properly formatted RFC 2822 address representing the
object.
=item name
my $name = $address->name;
This method tries very hard to determine the name belonging to the address.
First the C<phrase> is checked. If that doesn't work out the C<comment>
is looked into. If that still doesn't work out, the C<user> portion of
the C<address> is returned.
This method does B<not> try to massage any name it identifies and instead
leaves that up to someone else. Who is it to decide if someone wants their
name capitalized, or if they're Irish?
=back
=head2 Overloaded Operators
=over 4
=item stringify
print "I have your email address, $address.";
Objects stringify to C<format> by default. It's possible that you don't
like that idea. Okay, then, you can change it by modifying
C<$Email:Address::STRINGIFY>. Please consider modifying this package
variable using C<local>. You might step on someone else's toes if you
don't.
{
local $Email::Address::STRINGIFY = 'host';
print "I have your address, $address.";
# geeknest.com
}
print "I have your address, $address.";
# "Casey West" <casey@geeknest.com>
Modifying this package variable is now deprecated. Subclassing is now the
recommended approach.
=back
=head2 Did I Mention Fast?
On his 1.8GHz Apple MacBook, rjbs gets these results:
$ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 5
Rate Mail::Address Email::Address
Mail::Address 2.59/s -- -44%
Email::Address 4.59/s 77% --
$ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 25
Rate Mail::Address Email::Address
Mail::Address 2.58/s -- -67%
Email::Address 7.84/s 204% --
$ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 50
Rate Mail::Address Email::Address
Mail::Address 2.57/s -- -70%
Email::Address 8.53/s 232% --
...unfortunately, a known bug causes a loss of speed the string to parse has
certain known characteristics, and disabling cache will also degrade
performance.
=head1 ACKNOWLEDGEMENTS
Thanks to Kevin Riggle and Tatsuhiko Miyagawa for tests for annoying
phrase-quoting bugs!
=head1 AUTHORS
=over 4
=item *
Casey West
=item *
Ricardo SIGNES <rjbs@cpan.org>
=back
=head1 CONTRIBUTORS
=for stopwords Alex Vandiver David Golden Steinbrunner Glenn Fowler Jim Brandt Kevin Falcone Pali Ruslan Zakirov sunnavy William Yardley
=over 4
=item *
Alex Vandiver <alex@chmrr.net>
=item *
David Golden <dagolden@cpan.org>
=item *
David Steinbrunner <dsteinbrunner@pobox.com>
=item *
Glenn Fowler <cebjyre@cpan.org>
=item *
Jim Brandt <jbrandt@bestpractical.com>
=item *
Kevin Falcone <kevin@jibsheet.com>
=item *
Pali <pali@cpan.org>
=item *
Ruslan Zakirov <ruz@bestpractical.com>
=item *
sunnavy <sunnavy@bestpractical.com>
=item *
William Yardley <pep@veggiechinese.net>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Casey West.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
#pod =head2 Did I Mention Fast?
#pod
#pod On his 1.8GHz Apple MacBook, rjbs gets these results:
#pod
#pod $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 5
#pod Rate Mail::Address Email::Address
#pod Mail::Address 2.59/s -- -44%
#pod Email::Address 4.59/s 77% --
#pod
#pod $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 25
#pod Rate Mail::Address Email::Address
#pod Mail::Address 2.58/s -- -67%
#pod Email::Address 7.84/s 204% --
#pod
#pod $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 50
#pod Rate Mail::Address Email::Address
#pod Mail::Address 2.57/s -- -70%
#pod Email::Address 8.53/s 232% --
#pod
#pod ...unfortunately, a known bug causes a loss of speed the string to parse has
#pod certain known characteristics, and disabling cache will also degrade
#pod performance.
#pod
#pod =head1 ACKNOWLEDGEMENTS
#pod
#pod Thanks to Kevin Riggle and Tatsuhiko Miyagawa for tests for annoying
#pod phrase-quoting bugs!
#pod
#pod =cut

680
database/perl/vendor/lib/Email/Address/XS.pm vendored Normal file
View File

@@ -0,0 +1,680 @@
# Copyright (c) 2015-2018 by Pali <pali@cpan.org>
package Email::Address::XS;
use 5.006;
use strict;
use warnings;
our $VERSION = '1.04';
use Carp;
use base 'Exporter';
our @EXPORT_OK = qw(parse_email_addresses parse_email_groups format_email_addresses format_email_groups compose_address split_address);
use XSLoader;
XSLoader::load(__PACKAGE__, $VERSION);
=head1 NAME
Email::Address::XS - Parse and format RFC 5322 email addresses and groups
=head1 SYNOPSIS
use Email::Address::XS;
my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', user => 'winston.smith', host => 'recdep.minitrue', comment => 'Records Department');
print $winstons_address->address();
# winston.smith@recdep.minitrue
my $julias_address = Email::Address::XS->new('Julia', 'julia@ficdep.minitrue');
print $julias_address->format();
# Julia <julia@ficdep.minitrue>
my $users_address = Email::Address::XS->parse('user <user@oceania>');
print $users_address->host();
# oceania
my $goldsteins_address = Email::Address::XS->parse_bare_address('goldstein@brotherhood.oceania');
print $goldsteins_address->user();
# goldstein
my @addresses = Email::Address::XS->parse('"Winston Smith" <winston.smith@recdep.minitrue> (Records Department), Julia <julia@ficdep.minitrue>');
# ($winstons_address, $julias_address)
use Email::Address::XS qw(format_email_addresses format_email_groups parse_email_addresses parse_email_groups);
my $addresses_string = format_email_addresses($winstons_address, $julias_address, $users_address);
# "Winston Smith" <winston.smith@recdep.minitrue> (Records Department), Julia <julia@ficdep.minitrue>, user <user@oceania>
my @addresses = map { $_->address() } parse_email_addresses($addresses_string);
# ('winston.smith@recdep.minitrue', 'julia@ficdep.minitrue', 'user@oceania')
my $groups_string = format_email_groups('Brotherhood' => [ $winstons_address, $julias_address ], undef() => [ $users_address ]);
# Brotherhood: "Winston Smith" <winston.smith@recdep.minitrue> (Records Department), Julia <julia@ficdep.minitrue>;, user <user@oceania>
my @groups = parse_email_groups($groups_string);
# ('Brotherhood' => [ $winstons_address, $julias_address ], undef() => [ $users_address ])
use Email::Address::XS qw(compose_address split_address);
my ($user, $host) = split_address('julia(outer party)@ficdep.minitrue');
# ('julia', 'ficdep.minitrue')
my $string = compose_address('charrington"@"shop', 'thought.police.oceania');
# "charrington\"@\"shop"@thought.police.oceania
=head1 DESCRIPTION
This module implements L<RFC 5322|https://tools.ietf.org/html/rfc5322>
parser and formatter of email addresses and groups. It parses an input
string from email headers which contain a list of email addresses or
a groups of email addresses (like From, To, Cc, Bcc, Reply-To, Sender,
...). Also it can generate a string value for those headers from a
list of email addresses objects. Module is backward compatible with
L<RFC 2822|https://tools.ietf.org/html/rfc2822> and
L<RFC 822|https://tools.ietf.org/html/rfc822>.
Parser and formatter functionality is implemented in XS and uses
shared code from Dovecot IMAP server.
It is a drop-in replacement for L<the Email::Address module|Email::Address>
which has several security issues. E.g. issue L<CVE-2015-7686 (Algorithmic complexity vulnerability)|https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-2015-7686>,
which allows remote attackers to cause denial of service, is still
present in L<Email::Address|Email::Address> version 1.908.
Email::Address::XS module was created to finally fix CVE-2015-7686.
Existing applications that use Email::Address module could be easily
switched to Email::Address::XS module. In most cases only changing
C<use Email::Address> to C<use Email::Address::XS> and replacing every
C<Email::Address> occurrence with C<Email::Address::XS> is sufficient.
So unlike L<Email::Address|Email::Address>, this module does not use
regular expressions for parsing but instead native XS implementation
parses input string sequentially according to RFC 5322 grammar.
Additionally it has support also for named groups and so can be use
instead of L<the Email::Address::List module|Email::Address::List>.
If you are looking for the module which provides object representation
for the list of email addresses suitable for the MIME email headers,
see L<Email::MIME::Header::AddressList|Email::MIME::Header::AddressList>.
=head2 EXPORT
None by default. Exportable functions are:
L<C<parse_email_addresses>|/parse_email_addresses>,
L<C<parse_email_groups>|/parse_email_groups>,
L<C<format_email_addresses>|/format_email_addresses>,
L<C<format_email_groups>|/format_email_groups>,
L<C<compose_address>|/compose_address>,
L<C<split_address>|/split_address>.
=head2 Exportable Functions
=over 4
=item format_email_addresses
use Email::Address::XS qw(format_email_addresses);
my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston@recdep.minitrue');
my $julias_address = Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue');
my @addresses = ($winstons_address, $julias_address);
my $string = format_email_addresses(@addresses);
print $string;
# "Winston Smith" <winston@recdep.minitrue>, Julia <julia@ficdep.minitrue>
Takes a list of email address objects and returns one formatted string
of those email addresses.
=cut
sub format_email_addresses {
my (@args) = @_;
return format_email_groups(undef, \@args);
}
=item format_email_groups
use Email::Address::XS qw(format_email_groups);
my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', user => 'winston.smith', host => 'recdep.minitrue');
my $julias_address = Email::Address::XS->new('Julia', 'julia@ficdep.minitrue');
my $users_address = Email::Address::XS->new(address => 'user@oceania');
my $groups_string = format_email_groups('Brotherhood' => [ $winstons_address, $julias_address ], undef() => [ $users_address ]);
print $groups_string;
# Brotherhood: "Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>;, user@oceania
my $undisclosed_string = format_email_groups('undisclosed-recipients' => []);
print $undisclosed_string;
# undisclosed-recipients:;
Like L<C<format_email_addresses>|/format_email_addresses> but this
method takes pairs which consist of a group display name and a
reference to address list. If a group is not undef then address
list is formatted inside named group.
=item parse_email_addresses
use Email::Address::XS qw(parse_email_addresses);
my $string = '"Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>, user@oceania';
my @addresses = parse_email_addresses($string);
# @addresses now contains three Email::Address::XS objects, one for each address
Parses an input string and returns a list of Email::Address::XS
objects. Optional second string argument specifies class name for
blessing new objects.
=cut
sub parse_email_addresses {
my (@args) = @_;
my $t = 1;
return map { @{$_} } grep { $t ^= 1 } parse_email_groups(@args);
}
=item parse_email_groups
use Email::Address::XS qw(parse_email_groups);
my $string = 'Brotherhood: "Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>;, user@oceania, undisclosed-recipients:;';
my @groups = parse_email_groups($string);
# @groups now contains list ('Brotherhood' => [ $winstons_object, $julias_object ], undef() => [ $users_object ], 'undisclosed-recipients' => [])
Like L<C<parse_email_addresses>|/parse_email_addresses> but this
function returns a list of pairs: a group display name and a
reference to a list of addresses which belongs to that named group.
An undef value for a group means that a following list of addresses
is not inside any named group. An output is in a same format as a
input for the function L<C<format_email_groups>|/format_email_groups>.
This function preserves order of groups and does not do any
de-duplication or merging.
=item compose_address
use Email::Address::XS qw(compose_address);
my $string_address = compose_address($user, $host);
Takes an unescaped user part and unescaped host part of an address
and returns escaped address.
Available since version 1.01.
=item split_address
use Email::Address::XS qw(split_address);
my ($user, $host) = split_address($string_address);
Takes an escaped address and split it into pair of unescaped user
part and unescaped host part of address. If splitting input address
into these two parts is not possible then this function returns
pair of undefs.
Available since version 1.01.
=back
=head2 Class Methods
=over 4
=item new
my $empty_address = Email::Address::XS->new();
my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', user => 'winston.smith', host => 'recdep.minitrue', comment => 'Records Department');
my $julias_address = Email::Address::XS->new('Julia', 'julia@ficdep.minitrue');
my $users_address = Email::Address::XS->new(address => 'user@oceania');
my $only_name = Email::Address::XS->new(phrase => 'Name');
my $copy_of_winstons_address = Email::Address::XS->new(copy => $winstons_address);
Constructs and returns a new C<Email::Address::XS> object. Takes named
list of arguments: phrase, address, user, host, comment and copy.
An argument address takes precedence over user and host.
When an argument copy is specified then it is expected an
Email::Address::XS object and a cloned copy of that object is
returned. All other parameters are ignored.
Old syntax L<from the Email::Address module|Email::Address/new> is
supported too. Takes one to four positional arguments: phrase, address
comment, and original string. Passing an argument original is
deprecated, ignored and throws a warning.
=cut
sub new {
my ($class, @args) = @_;
my %hash_keys = (phrase => 1, address => 1, user => 1, host => 1, comment => 1, copy => 1);
my $is_hash;
if ( scalar @args == 2 and defined $args[0] ) {
$is_hash = 1 if exists $hash_keys{$args[0]};
} elsif ( scalar @args == 4 and defined $args[0] and defined $args[2] ) {
$is_hash = 1 if exists $hash_keys{$args[0]} and exists $hash_keys{$args[2]};
} elsif ( scalar @args > 4 ) {
$is_hash = 1;
}
my %args;
if ( $is_hash ) {
%args = @args;
} else {
carp 'Argument original is deprecated and ignored' if scalar @args > 3;
$args{comment} = $args[2] if scalar @args > 2;
$args{address} = $args[1] if scalar @args > 1;
$args{phrase} = $args[0] if scalar @args > 0;
}
my $invalid;
my $original;
if ( exists $args{copy} ) {
if ( $class->is_obj($args{copy}) ) {
$args{phrase} = $args{copy}->phrase();
$args{comment} = $args{copy}->comment();
$args{user} = $args{copy}->user();
$args{host} = $args{copy}->host();
$invalid = $args{copy}->{invalid};
$original = $args{copy}->{original};
delete $args{address};
} else {
carp 'Named argument copy does not contain a valid object';
}
}
my $self = bless {}, $class;
$self->phrase($args{phrase});
$self->comment($args{comment});
if ( exists $args{address} ) {
$self->address($args{address});
} else {
$self->user($args{user});
$self->host($args{host});
}
$self->{invalid} = 1 if $invalid;
$self->{original} = $original;
return $self;
}
=item parse
my $winstons_address = Email::Address::XS->parse('"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)');
my @users_addresses = Email::Address::XS->parse('user1@oceania, user2@oceania');
Parses an input string and returns a list of an Email::Address::XS
objects. Same as the function L<C<parse_email_addresses>|/parse_email_addresses>
but this one is class method.
In scalar context this function returns just first parsed object.
If more then one object was parsed then L<C<is_valid>|/is_valid>
method on returned object returns false. If no object was parsed
then empty Email::Address::XS object is returned.
Prior to version 1.01 return value in scalar context is undef when
no object was parsed.
=cut
sub parse {
my ($class, $string) = @_;
my @addresses = parse_email_addresses($string, $class);
return @addresses if wantarray;
my $self = @addresses ? $addresses[0] : Email::Address::XS->new();
$self->{invalid} = 1 if scalar @addresses != 1;
$self->{original} = $string unless defined $self->{original};
return $self;
}
=item parse_bare_address
my $winstons_address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue');
Parses an input string as one bare email address (addr spec) which
does not allow phrase part or angle brackets around email address and
returns an Email::Address::XS object. It is just a wrapper around
L<C<address>|/address> method. Method L<C<is_valid>|/is_valid> can be
used to check if parsing was successful.
Available since version 1.01.
=cut
sub parse_bare_address {
my ($class, $string) = @_;
my $self = $class->new();
if ( defined $string ) {
$self->address($string);
$self->{original} = $string;
} else {
carp 'Use of uninitialized value for string';
}
return $self;
}
=back
=head2 Object Methods
=over 4
=item format
my $string = $address->format();
Returns formatted Email::Address::XS object as a string. This method
throws a warning when L<C<user>|/user> or L<C<host>|/host> part of
the email address is invalid or empty string.
=cut
sub format {
my ($self) = @_;
return format_email_addresses($self);
}
=item is_valid
my $is_valid = $address->is_valid();
Returns true if the parse function or method which created this
Email::Address::XS object had not received any syntax error on input
string and also that L<C<user>|/user> and L<C<host>|/host> part of
the email address are not empty strings.
Thus this function can be used for checking if Email::Address::XS
object is valid before calling L<C<format>|/format> method on it.
Available since version 1.01.
=cut
sub is_valid {
my ($self) = @_;
my $user = $self->user();
my $host = $self->host();
return (defined $user and defined $host and length $host and not $self->{invalid});
}
=item phrase
my $phrase = $address->phrase();
$address->phrase('Winston Smith');
Accessor and mutator for the phrase (display name).
=cut
sub phrase {
my ($self, @args) = @_;
return $self->{phrase} unless @args;
delete $self->{invalid} if exists $self->{invalid};
return $self->{phrase} = $args[0];
}
=item user
my $user = $address->user();
$address->user('winston.smith');
Accessor and mutator for the unescaped user (local/mailbox) part of
an address.
=cut
sub user {
my ($self, @args) = @_;
return $self->{user} unless @args;
delete $self->{cached_address} if exists $self->{cached_address};
delete $self->{invalid} if exists $self->{invalid};
return $self->{user} = $args[0];
}
=item host
my $host = $address->host();
$address->host('recdep.minitrue');
Accessor and mutator for the unescaped host (domain) part of an address.
Since version 1.03 this method checks if setting a new value is syntactically
valid. If not undef is set and returned.
=cut
sub host {
my ($self, @args) = @_;
return $self->{host} unless @args;
delete $self->{cached_address} if exists $self->{cached_address};
delete $self->{invalid} if exists $self->{invalid};
if (defined $args[0] and $args[0] =~ /^(?:\[.*\]|[^\x00-\x20\x7F()<>\[\]:;@\\,"]+)$/) {
return $self->{host} = $args[0];
} else {
return $self->{host} = undef;
}
}
=item address
my $string_address = $address->address();
$address->address('winston.smith@recdep.minitrue');
Accessor and mutator for the escaped address (addr spec).
Internally this module stores a user and a host part of an address
separately. Function L<C<compose_address>|/compose_address> is used
for composing full address and function L<C<split_address>|/split_address>
for splitting into a user and a host parts. If splitting new address
into these two parts is not possible then this method returns undef
and sets both parts to undef.
=cut
sub address {
my ($self, @args) = @_;
my $user;
my $host;
if ( @args ) {
delete $self->{invalid} if exists $self->{invalid};
($user, $host) = split_address($args[0]) if defined $args[0];
if ( not defined $user or not defined $host ) {
$user = undef;
$host = undef;
}
$self->{user} = $user;
$self->{host} = $host;
} else {
return $self->{cached_address} if exists $self->{cached_address};
$user = $self->user();
$host = $self->host();
}
if ( defined $user and defined $host and length $host ) {
return $self->{cached_address} = compose_address($user, $host);
} else {
return $self->{cached_address} = undef;
}
}
=item comment
my $comment = $address->comment();
$address->comment('Records Department');
Accessor and mutator for the comment which is formatted after an
address. A comment can contain another nested comments in round
brackets. When setting new comment this method check if brackets are
balanced. If not undef is set and returned.
=cut
sub comment {
my ($self, @args) = @_;
return $self->{comment} unless @args;
delete $self->{invalid} if exists $self->{invalid};
return $self->{comment} = undef unless defined $args[0];
my $count = 0;
my $cleaned = $args[0];
$cleaned =~ s/(?:\\.|[^\(\)\x00])//g;
foreach ( split //, $cleaned ) {
$count++ if $_ eq '(';
$count-- if $_ eq ')';
$count = -1 if $_ eq "\x00";
last if $count < 0;
}
return $self->{comment} = undef if $count != 0;
return $self->{comment} = $args[0];
}
=item name
my $name = $address->name();
This method tries to return a name which belongs to the address. It
returns either L<C<phrase>|/phrase> or L<C<comment>|/comment> or
L<C<user>|/user> part of the address or empty string (first defined
value in this order). But it never returns undef.
=cut
sub name {
my ($self) = @_;
my $phrase = $self->phrase();
return $phrase if defined $phrase and length $phrase;
my $comment = $self->comment();
return $comment if defined $comment and length $comment;
my $user = $self->user();
return $user if defined $user;
return '';
}
=item as_string
my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue');
my $stringified = $address->as_string();
This method is used for object L<stringification|/stringify>. It
returns string representation of object. By default object is
stringified to L<C<format>|/format>.
Available since version 1.01.
=cut
our $STRINGIFY; # deprecated
sub as_string {
my ($self) = @_;
return $self->format() unless defined $STRINGIFY;
carp 'Variable $Email::Address::XS::STRINGIFY is deprecated; subclass instead';
my $method = $self->can($STRINGIFY);
croak 'Stringify method ' . $STRINGIFY . ' does not exist' unless defined $method;
return $method->($self);
}
=item original
my $address = Email::Address::XS->parse('(Winston) "Smith" <winston.smith@recdep.minitrue> (Minitrue)');
my $original = $address->original();
# (Winston) "Smith" <winston.smith@recdep.minitrue> (Minitrue)
my $format = $address->format();
# Smith <winston.smith@recdep.minitrue> (Minitrue)
This method returns original part of the string which was used for
parsing current Email::Address::XS object. If object was not created
by parsing input string, then this method returns undef.
Note that L<C<format>|/format> method does not have to return same
original string.
Available since version 1.01.
=cut
sub original {
my ($self) = @_;
return $self->{original};
}
=back
=head2 Overloaded Operators
=over 4
=item stringify
my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue');
print "Winston's address is $address.";
# Winston's address is "Winston Smith" <winston.smith@recdep.minitrue>.
Stringification is done by method L<C<as_string>|/as_string>.
=cut
use overload '""' => \&as_string;
=back
=head2 Deprecated Functions and Variables
For compatibility with L<the Email::Address module|Email::Address>
there are defined some deprecated functions and variables.
Do not use them in new code. Their usage throws warnings.
Altering deprecated variable C<$Email::Address::XS::STRINGIFY> changes
method which is called for objects stringification.
Deprecated cache functions C<purge_cache>, C<disable_cache> and
C<enable_cache> are noop and do nothing.
=cut
sub purge_cache {
carp 'Function purge_cache is deprecated and does nothing';
}
sub disable_cache {
carp 'Function disable_cache is deprecated and does nothing';
}
sub enable_cache {
carp 'Function enable_cache is deprecated and does nothing';
}
=head1 SEE ALSO
L<RFC 822|https://tools.ietf.org/html/rfc822>,
L<RFC 2822|https://tools.ietf.org/html/rfc2822>,
L<RFC 5322|https://tools.ietf.org/html/rfc5322>,
L<Email::MIME::Header::AddressList>,
L<Email::Address>,
L<Email::Address::List>,
L<Email::AddressParser>
=head1 AUTHOR
Pali E<lt>pali@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2015-2018 by Pali E<lt>pali@cpan.orgE<gt>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.6.0 or,
at your option, any later version of Perl 5 you may have available.
Dovecot parser is licensed under The MIT License and copyrighted by
Dovecot authors.
=cut
1;

174
database/perl/vendor/lib/Email/Date/Format.pm vendored Normal file
View File

@@ -0,0 +1,174 @@
use 5.006;
use strict;
use warnings;
package Email::Date::Format;
# ABSTRACT: produce RFC 2822 date strings
$Email::Date::Format::VERSION = '1.005';
our @EXPORT_OK = qw[email_date email_gmdate];
use Exporter 5.57 'import';
use Time::Local ();
#pod =head1 SYNOPSIS
#pod
#pod use Email::Date::Format qw(email_date);
#pod
#pod my $header = email_date($date->epoch);
#pod
#pod Email::Simple->create(
#pod header => [
#pod Date => $header,
#pod ],
#pod body => '...',
#pod );
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module provides a simple means for generating an RFC 2822 compliant
#pod datetime string. (In case you care, they're not RFC 822 dates, because they
#pod use a four digit year, which is not allowed in RFC 822.)
#pod
#pod =func email_date
#pod
#pod my $date = email_date; # now
#pod my $date = email_date( time - 60*60 ); # one hour ago
#pod
#pod C<email_date> accepts an epoch value, such as the one returned by C<time>.
#pod It returns a string representing the date and time of the input, as
#pod specified in RFC 2822. If no input value is provided, the current value
#pod of C<time> is used.
#pod
#pod C<email_date> is exported only if requested.
#pod
#pod =func email_gmdate
#pod
#pod my $date = email_gmdate;
#pod
#pod C<email_gmdate> is identical to C<email_date>, but it will return a string
#pod indicating the time in Greenwich Mean Time, rather than local time.
#pod
#pod C<email_gmdate> is exported only if requested.
#pod
#pod =cut
sub _tz_diff {
my ($time) = @_;
my $diff = Time::Local::timegm(localtime $time)
- Time::Local::timegm(gmtime $time);
my $direc = $diff < 0 ? '-' : '+';
$diff = abs $diff;
my $tz_hr = int( $diff / 3600 );
my $tz_mi = int( $diff / 60 - $tz_hr * 60 );
return ($direc, $tz_hr, $tz_mi);
}
sub _format_date {
my ($local) = @_;
sub {
my ($time) = @_;
$time = time unless defined $time;
my ($sec, $min, $hour, $mday, $mon, $year, $wday)
= $local ? (localtime $time) : (gmtime $time);
my $day = (qw[Sun Mon Tue Wed Thu Fri Sat])[$wday];
my $month = (qw[Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec])[$mon];
$year += 1900;
my ($direc, $tz_hr, $tz_mi) = $local ? _tz_diff($time)
: ('+', 0, 0);
sprintf "%s, %d %s %d %02d:%02d:%02d %s%02d%02d",
$day, $mday, $month, $year, $hour, $min, $sec, $direc, $tz_hr, $tz_mi;
}
}
BEGIN {
*email_date = _format_date(1);
*email_gmdate = _format_date(0);
};
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Date::Format - produce RFC 2822 date strings
=head1 VERSION
version 1.005
=head1 SYNOPSIS
use Email::Date::Format qw(email_date);
my $header = email_date($date->epoch);
Email::Simple->create(
header => [
Date => $header,
],
body => '...',
);
=head1 DESCRIPTION
This module provides a simple means for generating an RFC 2822 compliant
datetime string. (In case you care, they're not RFC 822 dates, because they
use a four digit year, which is not allowed in RFC 822.)
=head1 FUNCTIONS
=head2 email_date
my $date = email_date; # now
my $date = email_date( time - 60*60 ); # one hour ago
C<email_date> accepts an epoch value, such as the one returned by C<time>.
It returns a string representing the date and time of the input, as
specified in RFC 2822. If no input value is provided, the current value
of C<time> is used.
C<email_date> is exported only if requested.
=head2 email_gmdate
my $date = email_gmdate;
C<email_gmdate> is identical to C<email_date>, but it will return a string
indicating the time in Greenwich Mean Time, rather than local time.
C<email_gmdate> is exported only if requested.
=head1 AUTHORS
=over 4
=item *
Casey West
=item *
Ricardo SIGNES <rjbs@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Casey West.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

1624
database/perl/vendor/lib/Email/MIME.pm vendored Normal file
View File

File diff suppressed because it is too large Load Diff

702
database/perl/vendor/lib/Email/MIME/ContentType.pm vendored Normal file
View File

@@ -0,0 +1,702 @@
use strict;
use warnings;
package Email::MIME::ContentType;
# ABSTRACT: Parse and build a MIME Content-Type or Content-Disposition Header
$Email::MIME::ContentType::VERSION = '1.026';
use Carp;
use Encode 2.87 qw(encode find_mime_encoding);
use Exporter 5.57 'import';
use Text::Unidecode;
our @EXPORT = qw(parse_content_type parse_content_disposition build_content_type build_content_disposition);
#pod =head1 SYNOPSIS
#pod
#pod use Email::MIME::ContentType;
#pod
#pod # Content-Type: text/plain; charset="us-ascii"; format=flowed
#pod my $ct = 'text/plain; charset="us-ascii"; format=flowed';
#pod my $data = parse_content_type($ct);
#pod
#pod $data = {
#pod type => "text",
#pod subtype => "plain",
#pod attributes => {
#pod charset => "us-ascii",
#pod format => "flowed"
#pod }
#pod };
#pod
#pod my $ct_new = build_content_type($data);
#pod # text/plain; charset=us-ascii; format=flowed
#pod
#pod
#pod # Content-Type: application/x-stuff;
#pod # title*0*=us-ascii'en'This%20is%20even%20more%20;
#pod # title*1*=%2A%2A%2Afun%2A%2A%2A%20;
#pod # title*2="isn't it!"
#pod my $ct = q(application/x-stuff;
#pod title*0*=us-ascii'en'This%20is%20even%20more%20;
#pod title*1*=%2A%2A%2Afun%2A%2A%2A%20;
#pod title*2="isn't it!");
#pod my $data = parse_content_type($ct);
#pod
#pod $data = {
#pod type => "application",
#pod subtype => "x-stuff",
#pod attributes => {
#pod title => "This is even more ***fun*** isn't it!"
#pod }
#pod };
#pod
#pod
#pod # Content-Disposition: attachment; filename=genome.jpeg;
#pod # modification-date="Wed, 12 Feb 1997 16:29:51 -0500"
#pod my $cd = q(attachment; filename=genome.jpeg;
#pod modification-date="Wed, 12 Feb 1997 16:29:51 -0500");
#pod my $data = parse_content_disposition($cd);
#pod
#pod $data = {
#pod type => "attachment",
#pod attributes => {
#pod filename => "genome.jpeg",
#pod "modification-date" => "Wed, 12 Feb 1997 16:29:51 -0500"
#pod }
#pod };
#pod
#pod my $cd_new = build_content_disposition($data);
#pod # attachment; filename=genome.jpeg; modification-date="Wed, 12 Feb 1997 16:29:51 -0500"
#pod
#pod =cut
our $STRICT_PARAMS = 1;
my $ct_default = 'text/plain; charset=us-ascii';
my $re_token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/; # US-ASCII except SPACE, CTLs and tspecials ()<>@,;:\\"/[]?=
my $re_token_non_strict = qr/([\x00-\x08\x0B\x0C\x0E-\x1F\x7E-\xFF]+|$re_token)/; # allow CTLs and above ASCII
my $re_qtext = qr/[\x01-\x08\x0B\x0C\x0E-\x1F\x21\x23-\x5B\x5D-\x7E\x7F]/; # US-ASCII except CR, LF, white space, backslash and quote
my $re_quoted_pair = qr/\\[\x00-\x7F]/;
my $re_quoted_string = qr/"((?:[ \t]*(?:$re_qtext|$re_quoted_pair))*[ \t]*)"/;
my $re_qtext_non_strict = qr/[\x80-\xFF]|$re_qtext/;
my $re_quoted_pair_non_strict = qr/\\[\x00-\xFF]/;
my $re_quoted_string_non_strict = qr/"((?:[ \t]*(?:$re_qtext_non_strict|$re_quoted_pair_non_strict))*[ \t]*)"/;
my $re_charset = qr/[!"#\$%&'+\-0-9A-Z\\\^_`a-z\{\|\}~]+/;
my $re_language = qr/[A-Za-z]{1,8}(?:-[0-9A-Za-z]{1,8})*/;
my $re_exvalue = qr/($re_charset)?'(?:$re_language)?'(.*)/;
sub parse_content_type {
my $ct = shift;
# If the header isn't there or is empty, give default answer.
return parse_content_type($ct_default) unless defined $ct and length $ct;
_unfold_lines($ct);
_clean_comments($ct);
# It is also recommend (sic.) that this default be assumed when a
# syntactically invalid Content-Type header field is encountered.
unless ($ct =~ s/^($re_token)\/($re_token)//) {
unless ($STRICT_PARAMS and $ct =~ s/^($re_token_non_strict)\/($re_token_non_strict)//) {
carp "Invalid Content-Type '$ct'";
return parse_content_type($ct_default);
}
}
my ($type, $subtype) = (lc $1, lc $2);
_clean_comments($ct);
$ct =~ s/\s+$//;
my $attributes = {};
if ($STRICT_PARAMS and length $ct and $ct !~ /^;/) {
carp "Missing semicolon before first Content-Type parameter '$ct'";
} else {
$attributes = _process_rfc2231(_parse_attributes($ct));
}
return {
type => $type,
subtype => $subtype,
attributes => $attributes,
# This is dumb. Really really dumb. For backcompat. -- rjbs,
# 2013-08-10
discrete => $type,
composite => $subtype,
};
}
my $cd_default = 'attachment';
sub parse_content_disposition {
my $cd = shift;
return parse_content_disposition($cd_default) unless defined $cd and length $cd;
_unfold_lines($cd);
_clean_comments($cd);
unless ($cd =~ s/^($re_token)//) {
unless ($STRICT_PARAMS and $cd =~ s/^($re_token_non_strict)//) {
carp "Invalid Content-Disposition '$cd'";
return parse_content_disposition($cd_default);
}
}
my $type = lc $1;
_clean_comments($cd);
$cd =~ s/\s+$//;
my $attributes = {};
if ($STRICT_PARAMS and length $cd and $cd !~ /^;/) {
carp "Missing semicolon before first Content-Disposition parameter '$cd'";
} else {
$attributes = _process_rfc2231(_parse_attributes($cd));
}
return {
type => $type,
attributes => $attributes,
};
}
my $re_invalid_for_quoted_value = qr/[\x00-\x08\x0A-\x1F\x7F-\xFF]/; # non-US-ASCII and CTLs without SPACE and TAB
my $re_escape_extended_value = qr/[\x00-\x20\x7F-\xFF\*'%()<>@,;:\\"\/\[\]?=]/; # non-US-ASCII, SPACE, CTLs, *'% and tspecials ()<>@,;:\\"/[]?=
sub build_content_type {
my $ct = shift;
croak 'Missing Content-Type \'type\' parameter' unless exists $ct->{type};
croak 'Missing Content-Type \'subtype\' parameter' unless exists $ct->{subtype};
croak 'Invalid Content-Type \'type\' parameter' if $ct->{type} !~ /^(?:$re_token)*$/;
croak 'Invalid Content-Type \'subtype\' parameter' if $ct->{subtype} !~ /^(?:$re_token)*$/;
croak 'Too long Content-Type \'type\' and \'subtype\' parameters' if length($ct->{type}) + length($ct->{subtype}) > 76;
my ($extra) = grep !/(?:type|subtype|attributes)/, sort keys %{$ct};
croak "Extra Content-Type '$extra' parameter" if defined $extra;
my $ret = $ct->{type} . '/' . $ct->{subtype};
my $attrs = exists $ct->{attributes} ? _build_attributes($ct->{attributes}) : '';
$ret .= "; $attrs" if length($attrs);
return $ret;
}
sub build_content_disposition {
my $cd = shift;
croak 'Missing Content-Type \'type\' parameter' unless exists $cd->{type};
croak 'Invalid Content-Type \'type\' parameter' if $cd->{type} !~ /^(?:$re_token)*$/;
croak 'Too long Content-Type \'type\' parameter' if length($cd->{type}) > 77;
my ($extra) = grep !/(?:type|attributes)/, sort keys %{$cd};
croak "Extra Content-Type '$extra' parameter" if defined $extra;
my $ret = $cd->{type};
my $attrs = exists $cd->{attributes} ? _build_attributes($cd->{attributes}) : '';
$ret .= "; $attrs" if length($attrs);
return $ret;
}
sub _build_attributes {
my $attributes = shift;
my $ret = '';
foreach my $key (sort keys %{$attributes}) {
my $value = $attributes->{$key};
my $ascii_value = $value;
my @continuous_value;
my $extended_value_charset;
croak "Invalid attribute '$key'" if $key =~ /$re_escape_extended_value/; # complement to attribute-char in 8bit space
croak "Undefined attribute '$key'" unless defined $value;
if ($value =~ /\P{ASCII}/) {
$ascii_value = unidecode($value);
$ascii_value =~ s/\P{ASCII}/_/g;
@continuous_value = map { encode('UTF-8', $_) } split //, $value;
$extended_value_charset = 'UTF-8';
}
if ($ascii_value !~ /^(?:$re_token)*$/ or $ascii_value =~ /'/) {
if ($ascii_value =~ /$re_invalid_for_quoted_value/) {
@continuous_value = split //, $value unless @continuous_value;
$ascii_value =~ s/[\n\r]/ /g;
$ascii_value =~ s/$re_invalid_for_quoted_value/_/g;
}
$ascii_value =~ s/(["\\])/\\$1/g;
$ascii_value = "\"$ascii_value\"";
}
if (length($key) + length($ascii_value) > 75) { # length(" $key=$ascii_value;") > 78
croak "Too long attribute '$key'" if length($key) > 71; # length(" $key=...;") > 78
my $pos = $ascii_value =~ /"$/ ? 71 : 72;
substr($ascii_value, $pos - length($key), length($ascii_value) + length($key) - 72, '...');
@continuous_value = split //, $value unless @continuous_value;
}
if (@continuous_value) {
my $needs_quote;
unless (defined $extended_value_charset) {
$needs_quote = 1 if grep { $_ !~ /^(?:$re_token)*$/ or $_ =~ /'/ } @continuous_value;
$extended_value_charset = 'US-ASCII' if $needs_quote and grep /$re_invalid_for_quoted_value/, @continuous_value;
}
my $add_param_len = 4; # for '; *='
if (defined $extended_value_charset) {
$_ =~ s/($re_escape_extended_value)/sprintf('%%%02X', ord($1))/eg foreach @continuous_value;
substr($continuous_value[0], 0, 0, "$extended_value_charset''");
$add_param_len += 1; # for '*' - charset
} elsif ($needs_quote) {
$_ =~ s/(["\\])/\\$1/g foreach @continuous_value;
$add_param_len += 2; # for quotes
}
if ($value =~ /\P{ASCII}/ and length(my $oneparameter = "; $key*=" . join '', @continuous_value) <= 78) {
$ret .= $oneparameter;
} else {
my $buf = '';
my $count = 0;
foreach (@continuous_value) {
if (length($key) + length($count) + length($buf) + length($_) + $add_param_len > 78) {
$buf = "\"$buf\"" if $needs_quote;
my $parameter = "; $key*$count";
$parameter .= '*' if defined $extended_value_charset;
$parameter .= "=$buf";
croak "Too long attribute '$key'" if length($parameter) > 78;
$ret .= $parameter;
$buf = '';
$count++;
}
$buf .= $_;
}
if (length($buf)) {
$buf = "\"$buf\"" if $needs_quote;
my $parameter = "; $key*$count";
$parameter .= '*' if defined $extended_value_charset;
$parameter .= "=$buf";
croak "Too long attribute '$key'" if length($parameter) > 78;
$ret .= $parameter;
}
}
}
$ret .= "; $key=$ascii_value";
}
substr($ret, 0, 2, '') if length $ret;
return $ret;
}
sub _unfold_lines {
$_[0] =~ s/(?:\r\n|[\r\n])(?=[ \t])//g;
}
sub _clean_comments {
my $ret = ($_[0] =~ s/^\s+//);
while (length $_[0]) {
last unless $_[0] =~ s/^\(//;
my $level = 1;
while (length $_[0]) {
my $ch = substr $_[0], 0, 1, '';
if ($ch eq '(') {
$level++;
} elsif ($ch eq ')') {
$level--;
last if $level == 0;
} elsif ($ch eq '\\') {
substr $_[0], 0, 1, '';
}
}
carp "Unbalanced comment" if $level != 0 and $STRICT_PARAMS;
$ret |= ($_[0] =~ s/^\s+//);
}
return $ret;
}
sub _process_rfc2231 {
my ($attribs) = @_;
my %cont;
my %encoded;
foreach (keys %{$attribs}) {
next unless $_ =~ m/^(.*)\*([0-9]+)\*?$/;
my ($attr, $sec) = ($1, $2);
$cont{$attr}->{$sec} = $attribs->{$_};
$encoded{$attr} = 1 if $_ =~ m/\*$/;
delete $attribs->{$_};
}
foreach (keys %cont) {
my $key = $_;
$key .= '*' if $encoded{$_};
$attribs->{$key} = join '', @{$cont{$_}}{sort { $a <=> $b } keys %{$cont{$_}}};
}
foreach (keys %{$attribs}) {
next unless $_ =~ m/^(.*)\*$/;
my $key = $1;
next unless defined $attribs->{$_} and $attribs->{$_} =~ m/^$re_exvalue$/;
my ($charset, $value) = ($1, $2);
$value =~ s/%([0-9A-Fa-f]{2})/pack('C', hex($1))/eg;
if (length $charset) {
my $enc = find_mime_encoding($charset);
if (defined $enc) {
$value = $enc->decode($value);
} else {
carp "Unknown charset '$charset' in attribute '$key' value";
}
}
$attribs->{$key} = $value;
delete $attribs->{$_};
}
return $attribs;
}
sub _parse_attributes {
local $_ = shift;
substr($_, 0, 0, '; ') if length $_ and $_ !~ /^;/;
my $attribs = {};
while (length $_) {
s/^;// or $STRICT_PARAMS and do {
carp "Missing semicolon before parameter '$_'";
return $attribs;
};
_clean_comments($_);
unless (length $_) {
# Some mail software generates a Content-Type like this:
# "Content-Type: text/plain;"
# RFC 1521 section 3 says a parameter must exist if there is a
# semicolon.
carp "Extra semicolon after last parameter" if $STRICT_PARAMS;
return $attribs;
}
my $attribute;
if (s/^($re_token)=//) {
$attribute = lc $1;
} else {
if ($STRICT_PARAMS) {
carp "Illegal parameter '$_'";
return $attribs;
}
if (s/^($re_token_non_strict)=//) {
$attribute = lc $1;
} else {
unless (s/^([^;=\s]+)\s*=//) {
carp "Cannot parse parameter '$_'";
return $attribs;
}
$attribute = lc $1;
}
}
_clean_comments($_);
my $value = _extract_attribute_value();
$attribs->{$attribute} = $value;
_clean_comments($_);
}
return $attribs;
}
sub _extract_attribute_value { # EXPECTS AND MODIFIES $_
my $value;
while (length $_) {
if (s/^($re_token)//) {
$value .= $1;
} elsif (s/^$re_quoted_string//) {
my $sub = $1;
$sub =~ s/\\(.)/$1/g;
$value .= $sub;
} elsif ($STRICT_PARAMS) {
my $char = substr $_, 0, 1;
carp "Unquoted '$char' not allowed";
return;
} elsif (s/^($re_token_non_strict)//) {
$value .= $1;
} elsif (s/^$re_quoted_string_non_strict//) {
my $sub = $1;
$sub =~ s/\\(.)/$1/g;
$value .= $sub;
}
my $erased = _clean_comments($_);
last if !length $_ or /^;/;
if ($STRICT_PARAMS) {
my $char = substr $_, 0, 1;
carp "Extra '$char' found after parameter";
return;
}
if ($erased) {
# Sometimes semicolon is missing, so check for = char
last if m/^$re_token_non_strict=/;
$value .= ' ';
}
$value .= substr $_, 0, 1, '';
}
return $value;
}
1;
#pod =func parse_content_type
#pod
#pod This routine is exported by default.
#pod
#pod This routine parses email content type headers according to section 5.1 of RFC
#pod 2045 and also RFC 2231 (Character Set and Parameter Continuations). It returns
#pod a hash as above, with entries for the C<type>, the C<subtype>, and a hash of
#pod C<attributes>.
#pod
#pod For backward compatibility with a really unfortunate misunderstanding of RFC
#pod 2045 by the early implementors of this module, C<discrete> and C<composite> are
#pod also present in the returned hashref, with the values of C<type> and C<subtype>
#pod respectively.
#pod
#pod =func parse_content_disposition
#pod
#pod This routine is exported by default.
#pod
#pod This routine parses email Content-Disposition headers according to RFC 2183 and
#pod RFC 2231. It returns a hash as above, with entries for the C<type>, and a hash
#pod of C<attributes>.
#pod
#pod =func build_content_type
#pod
#pod This routine is exported by default.
#pod
#pod This routine builds email Content-Type header according to RFC 2045 and RFC 2231.
#pod It takes a hash as above, with entries for the C<type>, the C<subtype>, and
#pod optionally also a hash of C<attributes>. It returns a string representing
#pod Content-Type header. Non-ASCII attributes are encoded to UTF-8 according to
#pod Character Set section of RFC 2231. Attribute which has more then 78 ASCII
#pod characters is split into more attributes accorrding to Parameter Continuations
#pod of RFC 2231. For compatibility reasons with clients which do not support
#pod RFC 2231, output string contains also truncated ASCII version of any too long or
#pod non-ASCII attribute. Encoding to ASCII is done via Text::Unidecode module.
#pod
#pod =func build_content_disposition
#pod
#pod This routine is exported by default.
#pod
#pod This routine builds email Content-Disposition header according to RFC 2182 and
#pod RFC 2231. It takes a hash as above, with entries for the C<type>, and
#pod optionally also a hash of C<attributes>. It returns a string representing
#pod Content-Disposition header. Non-ASCII or too long attributes are handled in
#pod the same way like in L<build_content_type function|/build_content_type>.
#pod
#pod =head1 WARNINGS
#pod
#pod This is not a valid content-type header, according to both RFC 1521 and RFC
#pod 2045:
#pod
#pod Content-Type: type/subtype;
#pod
#pod If a semicolon appears, a parameter must. C<parse_content_type> will carp if
#pod it encounters a header of this type, but you can suppress this by setting
#pod C<$Email::MIME::ContentType::STRICT_PARAMS> to a false value. Please consider
#pod localizing this assignment!
#pod
#pod Same applies for C<parse_content_disposition>.
#pod
#pod =cut
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::ContentType - Parse and build a MIME Content-Type or Content-Disposition Header
=head1 VERSION
version 1.026
=head1 SYNOPSIS
use Email::MIME::ContentType;
# Content-Type: text/plain; charset="us-ascii"; format=flowed
my $ct = 'text/plain; charset="us-ascii"; format=flowed';
my $data = parse_content_type($ct);
$data = {
type => "text",
subtype => "plain",
attributes => {
charset => "us-ascii",
format => "flowed"
}
};
my $ct_new = build_content_type($data);
# text/plain; charset=us-ascii; format=flowed
# Content-Type: application/x-stuff;
# title*0*=us-ascii'en'This%20is%20even%20more%20;
# title*1*=%2A%2A%2Afun%2A%2A%2A%20;
# title*2="isn't it!"
my $ct = q(application/x-stuff;
title*0*=us-ascii'en'This%20is%20even%20more%20;
title*1*=%2A%2A%2Afun%2A%2A%2A%20;
title*2="isn't it!");
my $data = parse_content_type($ct);
$data = {
type => "application",
subtype => "x-stuff",
attributes => {
title => "This is even more ***fun*** isn't it!"
}
};
# Content-Disposition: attachment; filename=genome.jpeg;
# modification-date="Wed, 12 Feb 1997 16:29:51 -0500"
my $cd = q(attachment; filename=genome.jpeg;
modification-date="Wed, 12 Feb 1997 16:29:51 -0500");
my $data = parse_content_disposition($cd);
$data = {
type => "attachment",
attributes => {
filename => "genome.jpeg",
"modification-date" => "Wed, 12 Feb 1997 16:29:51 -0500"
}
};
my $cd_new = build_content_disposition($data);
# attachment; filename=genome.jpeg; modification-date="Wed, 12 Feb 1997 16:29:51 -0500"
=head1 FUNCTIONS
=head2 parse_content_type
This routine is exported by default.
This routine parses email content type headers according to section 5.1 of RFC
2045 and also RFC 2231 (Character Set and Parameter Continuations). It returns
a hash as above, with entries for the C<type>, the C<subtype>, and a hash of
C<attributes>.
For backward compatibility with a really unfortunate misunderstanding of RFC
2045 by the early implementors of this module, C<discrete> and C<composite> are
also present in the returned hashref, with the values of C<type> and C<subtype>
respectively.
=head2 parse_content_disposition
This routine is exported by default.
This routine parses email Content-Disposition headers according to RFC 2183 and
RFC 2231. It returns a hash as above, with entries for the C<type>, and a hash
of C<attributes>.
=head2 build_content_type
This routine is exported by default.
This routine builds email Content-Type header according to RFC 2045 and RFC 2231.
It takes a hash as above, with entries for the C<type>, the C<subtype>, and
optionally also a hash of C<attributes>. It returns a string representing
Content-Type header. Non-ASCII attributes are encoded to UTF-8 according to
Character Set section of RFC 2231. Attribute which has more then 78 ASCII
characters is split into more attributes accorrding to Parameter Continuations
of RFC 2231. For compatibility reasons with clients which do not support
RFC 2231, output string contains also truncated ASCII version of any too long or
non-ASCII attribute. Encoding to ASCII is done via Text::Unidecode module.
=head2 build_content_disposition
This routine is exported by default.
This routine builds email Content-Disposition header according to RFC 2182 and
RFC 2231. It takes a hash as above, with entries for the C<type>, and
optionally also a hash of C<attributes>. It returns a string representing
Content-Disposition header. Non-ASCII or too long attributes are handled in
the same way like in L<build_content_type function|/build_content_type>.
=head1 WARNINGS
This is not a valid content-type header, according to both RFC 1521 and RFC
2045:
Content-Type: type/subtype;
If a semicolon appears, a parameter must. C<parse_content_type> will carp if
it encounters a header of this type, but you can suppress this by setting
C<$Email::MIME::ContentType::STRICT_PARAMS> to a false value. Please consider
localizing this assignment!
Same applies for C<parse_content_disposition>.
=head1 AUTHORS
=over 4
=item *
Simon Cozens <simon@cpan.org>
=item *
Casey West <casey@geeknest.com>
=item *
Ricardo SIGNES <rjbs@cpan.org>
=back
=head1 CONTRIBUTORS
=for stopwords Matthew Green Pali Ricardo Signes Thomas Szukala
=over 4
=item *
Matthew Green <mrg@eterna.com.au>
=item *
Pali <pali@cpan.org>
=item *
Ricardo Signes <rjbs@semiotic.systems>
=item *
Thomas Szukala <ts@abusix.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

78
database/perl/vendor/lib/Email/MIME/Creator.pm vendored Normal file
View File

@@ -0,0 +1,78 @@
use 5.008001;
use strict;
use warnings;
package Email::MIME::Creator;
# ABSTRACT: obsolete do-nothing library
$Email::MIME::Creator::VERSION = '1.949';
use parent q[Email::Simple::Creator];
use Email::MIME;
use Encode ();
sub _construct_part {
my ($class, $body) = @_;
my $is_binary = $body =~ /[\x00\x80-\xFF]/;
my $content_type = $is_binary ? 'application/x-binary' : 'text/plain';
Email::MIME->create(
attributes => {
content_type => $content_type,
encoding => ($is_binary ? 'base64' : ''), # be safe
},
body => $body,
);
}
1;
#pod =head1 SYNOPSIS
#pod
#pod You don't need to use this module for anything.
#pod
#pod =cut
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Creator - obsolete do-nothing library
=head1 VERSION
version 1.949
=head1 SYNOPSIS
You don't need to use this module for anything.
=head1 AUTHORS
=over 4
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Casey West <casey@geeknest.com>
=item *
Simon Cozens <simon@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens and Casey West.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

210
database/perl/vendor/lib/Email/MIME/Encode.pm vendored Normal file
View File

@@ -0,0 +1,210 @@
use strict;
use warnings;
package Email::MIME::Encode;
# ABSTRACT: a private helper for MIME header encoding
$Email::MIME::Encode::VERSION = '1.949';
use Carp ();
use Encode ();
use Email::MIME::Header;
use MIME::Base64();
use Module::Runtime ();
use Scalar::Util;
our @CARP_NOT;
my %no_mime_headers = map { $_ => undef } qw(date message-id in-reply-to references downgraded-message-id downgraded-in-reply-to downgraded-references);
sub maybe_mime_encode_header {
my ($header, $val, $charset) = @_;
$header = lc $header;
my $header_name_length = length($header) + length(": ");
if (Scalar::Util::blessed($val) && $val->can("as_mime_string")) {
return $val->as_mime_string({
charset => $charset,
header_name_length => $header_name_length,
});
}
return _object_encode($val, $charset, $header_name_length, $Email::MIME::Header::header_to_class_map{$header})
if exists $Email::MIME::Header::header_to_class_map{$header};
my $min_wrap_length = 78 - $header_name_length + 1;
return $val
unless _needs_mime_encode($val) || $val =~ /[^\s]{$min_wrap_length,}/;
return $val
if exists $no_mime_headers{$header};
return mime_encode($val, $charset, $header_name_length);
}
sub _needs_mime_encode {
my ($val) = @_;
return defined $val && $val =~ /(?:\P{ASCII}|=\?|[^\s]{79,}|^\s+|\s+$)/s;
}
sub _needs_mime_encode_addr {
my ($val) = @_;
return _needs_mime_encode($val) || ( defined $val && $val =~ /[:;,]/ );
}
sub _object_encode {
my ($val, $charset, $header_name_length, $class) = @_;
local @CARP_NOT = qw(Email::MIME Email::MIME::Header);
{
local $@;
Carp::croak("Cannot load package '$class': $@") unless eval { Module::Runtime::require_module($class) };
}
Carp::croak("Class '$class' does not have method 'from_string'") unless $class->can('from_string');
my $object = $class->from_string(ref $val eq 'ARRAY' ? @{$val} : $val);
Carp::croak("Object from class '$class' does not have method 'as_mime_string'") unless $object->can('as_mime_string');
return $object->as_mime_string({
charset => $charset,
header_name_length => $header_name_length,
});
}
# XXX this is copied directly out of Courriel::Header
# eventually, this should be extracted out into something that could be shared
sub mime_encode {
my ($text, $charset, $header_name_length) = @_;
$header_name_length = 0 unless defined $header_name_length;
$charset = 'UTF-8' unless defined $charset;
my $enc_obj = Encode::find_encoding($charset);
my $head = '=?' . $enc_obj->mime_name() . '?B?';
my $tail = '?=';
my $mime_length = length($head) + length($tail);
# This code is copied from Mail::Message::Field::Full in the Mail-Box
# distro.
my $real_length = int( ( 75 - $mime_length ) / 4 ) * 3;
my $first_length = int( ( 75 - $header_name_length - $mime_length ) / 4 ) * 3;
my @result;
my $chunk = q{};
my $first_processed = 0;
while ( length( my $chr = substr( $text, 0, 1, '' ) ) ) {
my $chr = $enc_obj->encode( $chr, 0 );
if ( length($chunk) + length($chr) > ( $first_processed ? $real_length : $first_length ) ) {
if ( length($chunk) > 0 ) {
push @result, $head . MIME::Base64::encode_base64( $chunk, q{} ) . $tail;
$chunk = q{};
}
$first_processed = 1
unless $first_processed;
}
$chunk .= $chr;
}
push @result, $head . MIME::Base64::encode_base64( $chunk, q{} ) . $tail
if length $chunk;
return join q{ }, @result;
}
sub maybe_mime_decode_header {
my ($header, $val) = @_;
$header = lc $header;
return _object_decode($val, $Email::MIME::Header::header_to_class_map{$header})
if exists $Email::MIME::Header::header_to_class_map{$header};
return $val
if exists $no_mime_headers{$header};
return $val
unless $val =~ /=\?/;
return mime_decode($val);
}
sub _object_decode {
my ($string, $class) = @_;
local @CARP_NOT = qw(Email::MIME Email::MIME::Header);
{
local $@;
Carp::croak("Cannot load package '$class': $@") unless eval { Module::Runtime::require_module($class) };
}
Carp::croak("Class '$class' does not have method 'from_mime_string'") unless $class->can('from_mime_string');
my $object = $class->from_mime_string($string);
Carp::croak("Object from class '$class' does not have method 'as_string'") unless $object->can('as_string');
return $object->as_string();
}
sub mime_decode {
my ($text) = @_;
return undef unless defined $text;
# The eval is to cope with unknown encodings, like Latin-62, or other
# nonsense that gets put in there by spammers and weirdos
# -- rjbs, 2014-12-04
local $@;
my $result = eval { Encode::decode("MIME-Header", $text) };
return defined $result ? $result : $text;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Encode - a private helper for MIME header encoding
=head1 VERSION
version 1.949
=head1 AUTHORS
=over 4
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Casey West <casey@geeknest.com>
=item *
Simon Cozens <simon@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens and Casey West.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

123
database/perl/vendor/lib/Email/MIME/Encodings.pm vendored Normal file
View File

@@ -0,0 +1,123 @@
use strict;
use warnings;
package Email::MIME::Encodings;
{
$Email::MIME::Encodings::VERSION = '1.315';
}
# ABSTRACT: A unified interface to MIME encoding and decoding
use MIME::Base64 3.05;
use MIME::QuotedPrint 3.05;
sub identity { $_[0] }
for (qw(7bit 8bit binary)) {
no strict 'refs';
*{"encode_$_"} = *{"decode_$_"} = \&identity;
}
sub codec {
my ($which, $how, $what, $fb) = @_;
$how = lc $how;
$how = "qp" if $how eq "quotedprint" or $how eq "quoted-printable";
my $sub = __PACKAGE__->can("$which\_$how");
if (! $sub && $fb) {
$fb = lc $fb;
$fb = "qp" if $fb eq "quotedprint" or $fb eq "quoted-printable";
$sub = __PACKAGE__->can("$which\_$fb");
}
unless ($sub) {
require Carp;
Carp::croak("Don't know how to $which $how");
}
# RFC2822 requires all email lines to end in CRLF. The Quoted-Printable
# RFC requires CRLF to not be encoded, when representing newlins. We will
# assume, in this code, that QP is being used for plain text and not binary
# data. This may, someday, be wrong -- but if you are using QP to encode
# binary data, you are already doing something bizarre.
#
# The only way to achieve this with MIME::QuotedPrint is to replace all
# CRLFs with just LF and then let MIME::QuotedPrint replace all LFs with
# CRLF. Otherwise MIME::QuotedPrint (by default) encodes CR as =0D, which
# is against RFCs and breaks MUAs (such as Thunderbird).
#
# We don't modify data before Base64 encoding it because that is usually
# binary data and modifying it at all is a bad idea. We do however specify
# that the encoder should end lines with CRLF (since that's the email
# standard).
# -- rjbs and mkanat, 2009-04-16
my $eol = "\x0d\x0a";
if ($which eq 'encode') {
$what =~ s/$eol/\x0a/sg if $how eq 'qp';
return $sub->($what, $eol);
} else {
my $txt = $sub->($what);
$txt =~ s/\x0a/$eol/sg if $how eq 'qp';
return $txt;
}
}
sub decode { return codec("decode", @_) }
sub encode { return codec("encode", @_) }
1;
__END__
=pod
=head1 NAME
Email::MIME::Encodings - A unified interface to MIME encoding and decoding
=head1 VERSION
version 1.315
=head1 SYNOPSIS
use Email::MIME::Encodings;
my $encoded = Email::MIME::Encodings::encode(base64 => $body);
my $decoded = Email::MIME::Encodings::decode(base64 => $encoded);
If a third argument is given, it is the encoding to which to fall back. If no
valid codec can be found (considering both the first and third arguments) then
an exception is raised.
=head1 DESCRIPTION
This module simply wraps C<MIME::Base64> and C<MIME::QuotedPrint>
so that you can throw the contents of a C<Content-Transfer-Encoding>
header at some text and have the right thing happen.
C<MIME::Base64>, C<MIME::QuotedPrint>, C<Email::MIME>.
=head1 AUTHORS
=over 4
=item *
Simon Cozens <simon@cpan.org>
=item *
Casey West <casey@geeknest.com>
=item *
Ricardo SIGNES <rjbs@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens and Casey West.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

208
database/perl/vendor/lib/Email/MIME/Header.pm vendored Normal file
View File

@@ -0,0 +1,208 @@
use strict;
use warnings;
package Email::MIME::Header;
# ABSTRACT: the header of a MIME message
$Email::MIME::Header::VERSION = '1.949';
use parent 'Email::Simple::Header';
use Carp ();
use Email::MIME::Encode;
use Encode 1.9801;
use Module::Runtime ();
our @CARP_NOT;
our %header_to_class_map;
BEGIN {
my @address_list_headers = qw(from sender reply-to to cc bcc);
push @address_list_headers, map { "resent-$_" } @address_list_headers;
push @address_list_headers, map { "downgraded-$_" } @address_list_headers; # RFC 5504
push @address_list_headers, qw(original-from disposition-notification-to); # RFC 5703 and RFC 3798
$header_to_class_map{$_} = 'Email::MIME::Header::AddressList' foreach @address_list_headers;
}
#pod =head1 DESCRIPTION
#pod
#pod This object behaves like a standard Email::Simple header, with the following
#pod changes:
#pod
#pod =for :list
#pod * the C<header> method automatically decodes encoded headers if possible
#pod * the C<header_as_obj> method returns an object representation of the header value
#pod * the C<header_raw> method returns the raw header; (read only for now)
#pod * stringification uses C<header_raw> rather than C<header>
#pod
#pod Note that C<header_set> does not do encoding for you, and expects an
#pod encoded header. Thus, C<header_set> round-trips with C<header_raw>,
#pod not C<header>! Be sure to properly encode your headers with
#pod C<Encode::encode('MIME-Header', $value)> before passing them to
#pod C<header_set>. And be sure to use minimal version 2.83 of Encode
#pod module due to L<bugs in MIME-Header|Encode::MIME::Header/BUGS>.
#pod
#pod Alternately, if you have Unicode (character) strings to set in headers, use the
#pod C<header_str_set> method.
#pod
#pod =cut
sub header_str {
my $self = shift;
my $wanta = wantarray;
return unless defined $wanta; # ??
my @header = $wanta ? $self->header_raw(@_)
: scalar $self->header_raw(@_);
foreach my $header (@header) {
next unless defined $header;
next unless $header =~ /=\?/;
_maybe_decode($_[0], \$header);
}
return $wanta ? @header : $header[0];
}
sub header {
my $self = shift;
return $self->header_str(@_);
}
sub header_str_set {
my ($self, $name, @vals) = @_;
my @values = map {
Email::MIME::Encode::maybe_mime_encode_header($name, $_, 'UTF-8')
} @vals;
$self->header_raw_set($name => @values);
}
sub header_str_pairs {
my ($self) = @_;
my @pairs = $self->header_pairs;
for (grep { $_ % 2 } (1 .. $#pairs)) {
_maybe_decode($pairs[$_-1], \$pairs[$_]);
}
return @pairs;
}
sub header_as_obj {
my ($self, $name, $index, $class) = @_;
$class = $self->get_class_for_header($name) unless defined $class;
{
local @CARP_NOT = qw(Email::MIME);
local $@;
Carp::croak("No class for header '$name' was specified") unless defined $class;
Carp::croak("Cannot load package '$class' for header '$name': $@") unless eval { Module::Runtime::require_module($class) };
Carp::croak("Class '$class' does not have method 'from_mime_string'") unless $class->can('from_mime_string');
}
my @values = $self->header_raw($name, $index);
if (wantarray) {
return map { $class->from_mime_string($_) } @values;
} else {
return $class->from_mime_string(@values);
}
}
sub _maybe_decode {
my ($name, $str_ref) = @_;
$$str_ref = Email::MIME::Encode::maybe_mime_decode_header($name, $$str_ref);
return;
}
sub get_class_for_header {
my ($self, $name) = @_;
return $header_to_class_map{lc $name};
}
sub set_class_for_header {
my ($self, $class, $header) = @_;
$header = lc $header;
Carp::croak("Class for header '$header' is already set") if defined $header_to_class_map{$header};
$header_to_class_map{$header} = $class;
return;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Header - the header of a MIME message
=head1 VERSION
version 1.949
=head1 DESCRIPTION
This object behaves like a standard Email::Simple header, with the following
changes:
=over 4
=item *
the C<header> method automatically decodes encoded headers if possible
=item *
the C<header_as_obj> method returns an object representation of the header value
=item *
the C<header_raw> method returns the raw header; (read only for now)
=item *
stringification uses C<header_raw> rather than C<header>
=back
Note that C<header_set> does not do encoding for you, and expects an
encoded header. Thus, C<header_set> round-trips with C<header_raw>,
not C<header>! Be sure to properly encode your headers with
C<Encode::encode('MIME-Header', $value)> before passing them to
C<header_set>. And be sure to use minimal version 2.83 of Encode
module due to L<bugs in MIME-Header|Encode::MIME::Header/BUGS>.
Alternately, if you have Unicode (character) strings to set in headers, use the
C<header_str_set> method.
=head1 AUTHORS
=over 4
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Casey West <casey@geeknest.com>
=item *
Simon Cozens <simon@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens and Casey West.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

507
database/perl/vendor/lib/Email/MIME/Header/AddressList.pm vendored Normal file
View File

@@ -0,0 +1,507 @@
# Copyright (c) 2016-2017 by Pali <pali@cpan.org>
package Email::MIME::Header::AddressList;
$Email::MIME::Header::AddressList::VERSION = '1.949';
use strict;
use warnings;
use Carp ();
use Email::Address::XS;
use Email::MIME::Encode;
#pod =encoding utf8
#pod
#pod =head1 NAME
#pod
#pod Email::MIME::Header::AddressList - MIME support for list of Email::Address::XS objects
#pod
#pod =head1 SYNOPSIS
#pod
#pod my $address1 = Email::Address::XS->new('Name1' => 'address1@host.com');
#pod my $address2 = Email::Address::XS->new("Name2 \N{U+263A}" => 'address2@host.com');
#pod my $mime_address = Email::Address::XS->new('=?UTF-8?B?TmFtZTIg4pi6?=' => 'address2@host.com');
#pod
#pod my $list1 = Email::MIME::Header::AddressList->new($address1, $address2);
#pod
#pod $list1->append_groups('undisclosed-recipients' => []);
#pod
#pod $list1->first_address();
#pod # returns $address1
#pod
#pod $list1->groups();
#pod # returns (undef, [ $address1, $address2 ], 'undisclosed-recipients', [])
#pod
#pod $list1->as_string();
#pod # returns 'Name1 <address1@host.com>, "Name2 ☺" <address2@host.com>, undisclosed-recipients:;'
#pod
#pod $list1->as_mime_string();
#pod # returns 'Name1 <address1@host.com>, =?UTF-8?B?TmFtZTIg4pi6?= <address2@host.com>, undisclosed-recipients:;'
#pod
#pod my $list2 = Email::MIME::Header::AddressList->new_groups(Group => [ $address1, $address2 ]);
#pod
#pod $list2->append_addresses($address2);
#pod
#pod $list2->addresses();
#pod # returns ($address2, $address1, $address2)
#pod
#pod $list2->groups();
#pod # returns (undef, [ $address2 ], 'Group', [ $address1, $address2 ])
#pod
#pod my $list3 = Email::MIME::Header::AddressList->new_mime_groups('=?UTF-8?B?4pi6?=' => [ $mime_address ]);
#pod $list3->as_string();
#pod # returns '☺: "Name2 ☺" <address2@host.com>;'
#pod
#pod my $list4 = Email::MIME::Header::AddressList->from_string('Name1 <address1@host.com>, "Name2 ☺" <address2@host.com>, undisclosed-recipients:;');
#pod my $list5 = Email::MIME::Header::AddressList->from_string('Name1 <address1@host.com>', '"Name2 ☺" <address2@host.com>', 'undisclosed-recipients:;');
#pod
#pod my $list6 = Email::MIME::Header::AddressList->from_mime_string('Name1 <address1@host.com>, =?UTF-8?B?TmFtZTIg4pi6?= <address2@host.com>, undisclosed-recipients:;');
#pod my $list7 = Email::MIME::Header::AddressList->from_mime_string('Name1 <address1@host.com>', '=?UTF-8?B?TmFtZTIg4pi6?= <address2@host.com>', 'undisclosed-recipients:;');
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module implements object representation for the list of the
#pod L<Email::Address::XS|Email::Address::XS> objects. It provides methods for
#pod L<RFC 2047|https://tools.ietf.org/html/rfc2047> MIME encoding and decoding
#pod suitable for L<RFC 2822|https://tools.ietf.org/html/rfc2822> address-list
#pod structure.
#pod
#pod =head2 EXPORT
#pod
#pod None
#pod
#pod =head2 Class Methods
#pod
#pod =over 4
#pod
#pod =item new_empty
#pod
#pod Construct new empty C<Email::MIME::Header::AddressList> object.
#pod
#pod =cut
sub new_empty {
my ($class) = @_;
return bless { addresses => [], groups => [] }, $class;
}
#pod =item new
#pod
#pod Construct new C<Email::MIME::Header::AddressList> object from list of
#pod L<Email::Address::XS|Email::Address::XS> objects.
#pod
#pod =cut
sub new {
my ($class, @addresses) = @_;
my $self = $class->new_empty();
$self->append_addresses(@addresses);
return $self;
}
#pod =item new_groups
#pod
#pod Construct new C<Email::MIME::Header::AddressList> object from named groups of
#pod L<Email::Address::XS|Email::Address::XS> objects.
#pod
#pod =cut
sub new_groups {
my ($class, @groups) = @_;
my $self = $class->new_empty();
$self->append_groups(@groups);
return $self;
}
#pod =item new_mime_groups
#pod
#pod Like L<C<new_groups>|/new_groups> but in this method group names and objects properties are
#pod expected to be already MIME encoded, thus ASCII strings.
#pod
#pod =cut
sub new_mime_groups {
my ($class, @groups) = @_;
if (scalar @groups % 2) {
Carp::carp 'Odd number of elements in argument list';
return;
}
foreach (0 .. scalar @groups / 2 - 1) {
$groups[2 * $_] = Email::MIME::Encode::mime_decode($groups[2 * $_])
if defined $groups[2 * $_] and $groups[2 * $_] =~ /=\?/;
$groups[2 * $_ + 1] = [ @{$groups[2 * $_ + 1]} ];
foreach (@{$groups[2 * $_ + 1]}) {
next unless Email::Address::XS->is_obj($_);
my $decode_phrase = (defined $_->phrase and $_->phrase =~ /=\?/);
my $decode_comment = (defined $_->comment and $_->comment =~ /=\?/);
next unless $decode_phrase or $decode_comment;
$_ = ref($_)->new(copy => $_);
$_->phrase(Email::MIME::Encode::mime_decode($_->phrase))
if $decode_phrase;
$_->comment(Email::MIME::Encode::mime_decode($_->comment))
if $decode_comment;
}
}
return $class->new_groups(@groups);
}
#pod =item from_string
#pod
#pod Construct new C<Email::MIME::Header::AddressList> object from input string arguments.
#pod Calls L<Email::Address::XS::parse_email_groups|Email::Address::XS/parse_email_groups>.
#pod
#pod =cut
sub from_string {
my ($class, @strings) = @_;
return $class->new_groups(map { Email::Address::XS::parse_email_groups($_) } @strings);
}
#pod =item from_mime_string
#pod
#pod Like L<C<from_string>|/from_string> but input string arguments are expected to
#pod be already MIME encoded.
#pod
#pod =cut
sub from_mime_string {
my ($class, @strings) = @_;
return $class->new_mime_groups(map { Email::Address::XS::parse_email_groups($_) } @strings);
}
#pod =back
#pod
#pod =head2 Object Methods
#pod
#pod =over 4
#pod
#pod =item as_string
#pod
#pod Returns string representation of C<Email::MIME::Header::AddressList> object.
#pod Calls L<Email::Address::XS::format_email_groups|Email::Address::XS/format_email_groups>.
#pod
#pod =cut
sub as_string {
my ($self) = @_;
return Email::Address::XS::format_email_groups($self->groups());
}
#pod =item as_mime_string
#pod
#pod Like L<C<as_string>|/as_string> but output string will be properly and
#pod unambiguously MIME encoded. MIME encoding is done before calling
#pod L<Email::Address::XS::format_email_groups|Email::Address::XS/format_email_groups>.
#pod
#pod =cut
sub as_mime_string {
my ($self, $arg) = @_;
my $charset = $arg->{charset};
my $header_name_length = $arg->{header_name_length};
my @groups = $self->groups();
foreach (0 .. scalar @groups / 2 - 1) {
$groups[2 * $_] = Email::MIME::Encode::mime_encode($groups[2 * $_], $charset)
if Email::MIME::Encode::_needs_mime_encode_addr($groups[2 * $_]);
$groups[2 * $_ + 1] = [ @{$groups[2 * $_ + 1]} ];
foreach (@{$groups[2 * $_ + 1]}) {
my $encode_phrase = Email::MIME::Encode::_needs_mime_encode_addr($_->phrase);
my $encode_comment = Email::MIME::Encode::_needs_mime_encode_addr($_->comment);
next unless $encode_phrase or $encode_comment;
$_ = ref($_)->new(copy => $_);
$_->phrase(Email::MIME::Encode::mime_encode($_->phrase, $charset))
if $encode_phrase;
$_->comment(Email::MIME::Encode::mime_encode($_->comment, $charset))
if $encode_comment;
}
}
return Email::Address::XS::format_email_groups(@groups);
}
#pod =item first_address
#pod
#pod Returns first L<Email::Address::XS|Email::Address::XS> object.
#pod
#pod =cut
sub first_address {
my ($self) = @_;
return $self->{addresses}->[0] if @{$self->{addresses}};
my $groups = $self->{groups};
foreach (0 .. @{$groups} / 2 - 1) {
next unless @{$groups->[2 * $_ + 1]};
return $groups->[2 * $_ + 1]->[0];
}
return undef;
}
#pod =item addresses
#pod
#pod Returns list of all L<Email::Address::XS|Email::Address::XS> objects.
#pod
#pod =cut
sub addresses {
my ($self) = @_;
my $t = 1;
my @addresses = @{$self->{addresses}};
push @addresses, map { @{$_} } grep { $t ^= 1 } @{$self->{groups}};
return @addresses;
}
#pod =item groups
#pod
#pod Like L<C<addresses>|/addresses> but returns objects with named groups.
#pod
#pod =cut
sub groups {
my ($self) = @_;
my @groups = @{$self->{groups}};
$groups[2 * $_ + 1] = [ @{$groups[2 * $_ + 1]} ]
foreach 0 .. scalar @groups / 2 - 1;
unshift @groups, undef, [ @{$self->{addresses}} ]
if @{$self->{addresses}};
return @groups;
}
#pod =item append_addresses
#pod
#pod Append L<Email::Address::XS|Email::Address::XS> objects.
#pod
#pod =cut
sub append_addresses {
my ($self, @addresses) = @_;
my @valid_addresses = grep { Email::Address::XS->is_obj($_) } @addresses;
Carp::carp 'Argument is not an Email::Address::XS object' if scalar @valid_addresses != scalar @addresses;
push @{$self->{addresses}}, @valid_addresses;
}
#pod =item append_groups
#pod
#pod Like L<C<append_addresses>|/append_addresses> but arguments are pairs of name of
#pod group and array reference of L<Email::Address::XS|Email::Address::XS> objects.
#pod
#pod =cut
sub append_groups {
my ($self, @groups) = @_;
if (scalar @groups % 2) {
Carp::carp 'Odd number of elements in argument list';
return;
}
my $carp_invalid = 1;
my @valid_groups;
foreach (0 .. scalar @groups / 2 - 1) {
push @valid_groups, $groups[2 * $_];
my $addresses = $groups[2 * $_ + 1];
my @valid_addresses = grep { Email::Address::XS->is_obj($_) } @{$addresses};
if ($carp_invalid and scalar @valid_addresses != scalar @{$addresses}) {
Carp::carp 'Array element is not an Email::Address::XS object';
$carp_invalid = 0;
}
push @valid_groups, \@valid_addresses;
}
push @{$self->{groups}}, @valid_groups;
}
#pod =back
#pod
#pod =head1 SEE ALSO
#pod
#pod L<RFC 2047|https://tools.ietf.org/html/rfc2047>,
#pod L<RFC 2822|https://tools.ietf.org/html/rfc2822>,
#pod L<Email::MIME>,
#pod L<Email::Address::XS>
#pod
#pod =head1 AUTHOR
#pod
#pod Pali E<lt>pali@cpan.orgE<gt>
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Header::AddressList
=head1 VERSION
version 1.949
=head1 SYNOPSIS
my $address1 = Email::Address::XS->new('Name1' => 'address1@host.com');
my $address2 = Email::Address::XS->new("Name2 \N{U+263A}" => 'address2@host.com');
my $mime_address = Email::Address::XS->new('=?UTF-8?B?TmFtZTIg4pi6?=' => 'address2@host.com');
my $list1 = Email::MIME::Header::AddressList->new($address1, $address2);
$list1->append_groups('undisclosed-recipients' => []);
$list1->first_address();
# returns $address1
$list1->groups();
# returns (undef, [ $address1, $address2 ], 'undisclosed-recipients', [])
$list1->as_string();
# returns 'Name1 <address1@host.com>, "Name2 ☺" <address2@host.com>, undisclosed-recipients:;'
$list1->as_mime_string();
# returns 'Name1 <address1@host.com>, =?UTF-8?B?TmFtZTIg4pi6?= <address2@host.com>, undisclosed-recipients:;'
my $list2 = Email::MIME::Header::AddressList->new_groups(Group => [ $address1, $address2 ]);
$list2->append_addresses($address2);
$list2->addresses();
# returns ($address2, $address1, $address2)
$list2->groups();
# returns (undef, [ $address2 ], 'Group', [ $address1, $address2 ])
my $list3 = Email::MIME::Header::AddressList->new_mime_groups('=?UTF-8?B?4pi6?=' => [ $mime_address ]);
$list3->as_string();
# returns '☺: "Name2 ☺" <address2@host.com>;'
my $list4 = Email::MIME::Header::AddressList->from_string('Name1 <address1@host.com>, "Name2 ☺" <address2@host.com>, undisclosed-recipients:;');
my $list5 = Email::MIME::Header::AddressList->from_string('Name1 <address1@host.com>', '"Name2 ☺" <address2@host.com>', 'undisclosed-recipients:;');
my $list6 = Email::MIME::Header::AddressList->from_mime_string('Name1 <address1@host.com>, =?UTF-8?B?TmFtZTIg4pi6?= <address2@host.com>, undisclosed-recipients:;');
my $list7 = Email::MIME::Header::AddressList->from_mime_string('Name1 <address1@host.com>', '=?UTF-8?B?TmFtZTIg4pi6?= <address2@host.com>', 'undisclosed-recipients:;');
=head1 DESCRIPTION
This module implements object representation for the list of the
L<Email::Address::XS|Email::Address::XS> objects. It provides methods for
L<RFC 2047|https://tools.ietf.org/html/rfc2047> MIME encoding and decoding
suitable for L<RFC 2822|https://tools.ietf.org/html/rfc2822> address-list
structure.
=head2 EXPORT
None
=head2 Class Methods
=over 4
=item new_empty
Construct new empty C<Email::MIME::Header::AddressList> object.
=item new
Construct new C<Email::MIME::Header::AddressList> object from list of
L<Email::Address::XS|Email::Address::XS> objects.
=item new_groups
Construct new C<Email::MIME::Header::AddressList> object from named groups of
L<Email::Address::XS|Email::Address::XS> objects.
=item new_mime_groups
Like L<C<new_groups>|/new_groups> but in this method group names and objects properties are
expected to be already MIME encoded, thus ASCII strings.
=item from_string
Construct new C<Email::MIME::Header::AddressList> object from input string arguments.
Calls L<Email::Address::XS::parse_email_groups|Email::Address::XS/parse_email_groups>.
=item from_mime_string
Like L<C<from_string>|/from_string> but input string arguments are expected to
be already MIME encoded.
=back
=head2 Object Methods
=over 4
=item as_string
Returns string representation of C<Email::MIME::Header::AddressList> object.
Calls L<Email::Address::XS::format_email_groups|Email::Address::XS/format_email_groups>.
=item as_mime_string
Like L<C<as_string>|/as_string> but output string will be properly and
unambiguously MIME encoded. MIME encoding is done before calling
L<Email::Address::XS::format_email_groups|Email::Address::XS/format_email_groups>.
=item first_address
Returns first L<Email::Address::XS|Email::Address::XS> object.
=item addresses
Returns list of all L<Email::Address::XS|Email::Address::XS> objects.
=item groups
Like L<C<addresses>|/addresses> but returns objects with named groups.
=item append_addresses
Append L<Email::Address::XS|Email::Address::XS> objects.
=item append_groups
Like L<C<append_addresses>|/append_addresses> but arguments are pairs of name of
group and array reference of L<Email::Address::XS|Email::Address::XS> objects.
=back
=head1 NAME
Email::MIME::Header::AddressList - MIME support for list of Email::Address::XS objects
=head1 SEE ALSO
L<RFC 2047|https://tools.ietf.org/html/rfc2047>,
L<RFC 2822|https://tools.ietf.org/html/rfc2822>,
L<Email::MIME>,
L<Email::Address::XS>
=head1 AUTHOR
Pali E<lt>pali@cpan.orgE<gt>
=head1 AUTHORS
=over 4
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Casey West <casey@geeknest.com>
=item *
Simon Cozens <simon@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens and Casey West.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

447
database/perl/vendor/lib/Email/MIME/Kit.pm vendored Normal file
View File

@@ -0,0 +1,447 @@
package Email::MIME::Kit;
# ABSTRACT: build messages from templates
$Email::MIME::Kit::VERSION = '3.000006';
require 5.008;
use Moose 0.65; # maybe_type
use Moose::Util::TypeConstraints;
use Email::MIME 1.930; # header_raw
use Email::MessageID 1.400; # for in_brackets method
use Module::Runtime ();
use String::RewritePrefix;
#pod =head1 SYNOPSIS
#pod
#pod use Email::MIME::Kit;
#pod
#pod my $kit = Email::MIME::Kit->new({ source => 'mkits/sample.mkit' });
#pod
#pod my $email = $kit->assemble({
#pod account => $new_signup,
#pod verification_code => $token,
#pod ... and any other template vars ...
#pod });
#pod
#pod $transport->send($email, { ... });
#pod
#pod =head1 DESCRIPTION
#pod
#pod Email::MIME::Kit is a templating system for email messages. Instead of trying
#pod to be yet another templating system for chunks of text, it makes it easy to
#pod build complete email messages.
#pod
#pod It handles the construction of multipart messages, text and HTML alternatives,
#pod attachments, interpart linking, string encoding, and parameter validation.
#pod
#pod Although nearly every part of Email::MIME::Kit is a replaceable component, the
#pod stock configuration is probably enough for most use. A message kit will be
#pod stored as a directory that might look like this:
#pod
#pod sample.mkit/
#pod manifest.json
#pod body.txt
#pod body.html
#pod logo.jpg
#pod
#pod The manifest file tells Email::MIME::Kit how to put it all together, and might
#pod look something like this:
#pod
#pod {
#pod "renderer": "TT",
#pod "header": [
#pod { "From": "WY Corp <noreplies@wy.example.com>" },
#pod { "Subject": "Welcome aboard, [% recruit.name %]!" }
#pod ],
#pod "alternatives": [
#pod { "type": "text/plain", "path": "body.txt" },
#pod {
#pod "type": "text/html",
#pod "path": "body.html",
#pod "container_type": "multipart/related",
#pod "attachments": [ { "type": "image/jpeg", "path": "logo.jpg" } ]
#pod }
#pod ]
#pod }
#pod
#pod B<Inline images> may be accessed with the function C<cid_for>, for example to include the above logo.jpg:
#pod
#pod <img style="margin: 0 auto" src="cid:[% cid_for("logo.jpg") %]">
#pod
#pod B<Please note:> the assembly of HTML documents as multipart/related bodies may
#pod be simplified with an alternate assembler in the future.
#pod
#pod The above manifest would build a multipart alternative message. GUI mail
#pod clients would see a rendered HTML document with the logo graphic visible from
#pod the attachment. Text mail clients would see the plaintext.
#pod
#pod Both the HTML and text parts would be rendered using the named renderer, which
#pod here is Template-Toolkit.
#pod
#pod The message would be assembled and returned as an Email::MIME object, just as
#pod easily as suggested in the L</SYNOPSIS> above.
#pod
#pod =head1 ENCODING ISSUES
#pod
#pod In general, "it should all just work" ... starting in version v3.
#pod
#pod Email::MIME::Kit assumes that any file read for the purpose of becoming a
#pod C<text/*>-type part is encoded in UTF-8. It will decode them and work with
#pod their contents as text strings. Renderers will be passed text strings to
#pod render, and so on. This, further, means that strings passed to the C<assemble>
#pod method for use in rendering should also be text strings.
#pod
#pod In older versions of Email::MIME::Kit, files read from disk were read in raw
#pod mode and then handled as octet strings. Meanwhile, the manifest's contents
#pod (and, thus, any templates stored as strings in the manifest) were decoded into
#pod text strings. This could lead to serious problems. For example: the
#pod F<manifest.json> file might contain:
#pod
#pod "header": [
#pod { "Subject": "Message for [% customer_name %]" },
#pod ...
#pod ]
#pod
#pod ...while a template on disk might contain:
#pod
#pod Dear [% customer_name %],
#pod ...
#pod
#pod If the customer's name isn't ASCII, there was no right way to pass it in. The
#pod template on disk would expect UTF-8, but the template in the manifest would
#pod expect Unicode text. Users prior to v3 may have taken strange steps to get
#pod around this problem, understanding that some templates were treated differently
#pod than others. This means that some review of kits is in order when upgrading
#pod from earlier versions of Email::MIME::Kit.
#pod
#pod =cut
has source => (is => 'ro', required => 1);
has manifest => (reader => 'manifest', writer => '_set_manifest');
my @auto_attrs = (
[ manifest_reader => ManifestReader => JSON => [ 'read_manifest' ] ],
[ kit_reader => KitReader => Dir => [ 'get_kit_entry',
'get_decoded_kit_entry' ] ],
);
for my $tuple (@auto_attrs) {
my ($attr, $role, $default, $handles) = @$tuple;
my $seed = "_${attr}_seed";
my $base_ns = "Email::MIME::Kit::$role";
my $role_pkg = "Email::MIME::Kit::Role::$role";
has $seed => (
is => 'ro',
init_arg => $attr,
default => "=Email::MIME::Kit::${role}::$default",
);
has $attr => (
reader => $attr,
writer => "_set_$attr",
isa => role_type($role_pkg),
init_arg => undef,
lazy => 1,
default => sub {
my ($self) = @_;
my $comp = $self->_build_component($base_ns, $self->$seed);
return $comp;
},
handles => $handles,
);
}
has validator => (
is => 'ro',
isa => maybe_type(role_type('Email::MIME::Kit::Role::Validator')),
lazy => 1, # is this really needed? -- rjbs, 2009-01-20
default => sub {
my ($self) = @_;
return $self->_build_component(
'Email::MIME::Kit::Validator',
$self->manifest->{validator},
);
},
);
sub _build_component {
my ($self, $base_namespace, $entry, $extra) = @_;
return unless $entry;
my ($class, $arg);
if (ref $entry) {
($class, $arg) = @$entry;
} else {
($class, $arg) = ($entry, {});
}
$class = String::RewritePrefix->rewrite(
{ '=' => '', '' => ($base_namespace . q{::}) },
$class,
);
Module::Runtime::require_module($class);
$class->new({ %$arg, %{ $extra || {} }, kit => $self });
}
sub BUILD {
my ($self) = @_;
my $manifest = $self->read_manifest;
$self->_set_manifest($manifest);
if ($manifest->{kit_reader}) {
my $kit_reader = $self->_build_component(
'Email::MIME::Kit::KitReader',
$manifest->{kit_reader},
);
$self->_set_kit_reader($kit_reader);
}
$self->_setup_default_renderer;
}
sub _setup_default_renderer {
my ($self) = @_;
return unless my $renderer = $self->_build_component(
'Email::MIME::Kit::Renderer',
$self->manifest->{renderer},
);
$self->_set_default_renderer($renderer);
}
sub assemble {
my ($self, $stash) = @_;
$self->validator->validate($stash) if $self->validator;
# Do I really need or want to do this? Anything that alters the stash should
# do so via localization. -- rjbs, 2009-01-20
my $copied_stash = { %{ $stash || {} } };
my $email = $self->assembler->assemble($copied_stash);
my $header = $email->header('Message-ID');
$email->header_set('Message-ID' => $self->_generate_content_id->in_brackets)
unless defined $header;
return $email;
}
sub kit { $_[0] }
sub _assembler_from_manifest {
my ($self, $manifest, $parent) = @_;
$self->_build_component(
'Email::MIME::Kit::Assembler',
$manifest->{assembler} || 'Standard',
{
manifest => $manifest,
parent => $parent,
},
);
}
has default_renderer => (
reader => 'default_renderer',
writer => '_set_default_renderer',
isa => role_type('Email::MIME::Kit::Role::Renderer'),
);
has assembler => (
reader => 'assembler',
isa => role_type('Email::MIME::Kit::Role::Assembler'),
required => 1,
lazy => 1,
default => sub {
my ($self) = @_;
return $self->_assembler_from_manifest($self->manifest);
}
);
sub _generate_content_id {
Email::MessageID->new;
}
#pod =head1 AUTHOR
#pod
#pod This code was written in 2009 by Ricardo SIGNES. It was based on a previous
#pod implementation by Hans Dieter Pearcey written in 2006.
#pod
#pod The development of this code was sponsored by Pobox.com. Thanks, Pobox!
#pod
#pod =cut
no Moose::Util::TypeConstraints;
no Moose;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit - build messages from templates
=head1 VERSION
version 3.000006
=head1 SYNOPSIS
use Email::MIME::Kit;
my $kit = Email::MIME::Kit->new({ source => 'mkits/sample.mkit' });
my $email = $kit->assemble({
account => $new_signup,
verification_code => $token,
... and any other template vars ...
});
$transport->send($email, { ... });
=head1 DESCRIPTION
Email::MIME::Kit is a templating system for email messages. Instead of trying
to be yet another templating system for chunks of text, it makes it easy to
build complete email messages.
It handles the construction of multipart messages, text and HTML alternatives,
attachments, interpart linking, string encoding, and parameter validation.
Although nearly every part of Email::MIME::Kit is a replaceable component, the
stock configuration is probably enough for most use. A message kit will be
stored as a directory that might look like this:
sample.mkit/
manifest.json
body.txt
body.html
logo.jpg
The manifest file tells Email::MIME::Kit how to put it all together, and might
look something like this:
{
"renderer": "TT",
"header": [
{ "From": "WY Corp <noreplies@wy.example.com>" },
{ "Subject": "Welcome aboard, [% recruit.name %]!" }
],
"alternatives": [
{ "type": "text/plain", "path": "body.txt" },
{
"type": "text/html",
"path": "body.html",
"container_type": "multipart/related",
"attachments": [ { "type": "image/jpeg", "path": "logo.jpg" } ]
}
]
}
B<Inline images> may be accessed with the function C<cid_for>, for example to include the above logo.jpg:
<img style="margin: 0 auto" src="cid:[% cid_for("logo.jpg") %]">
B<Please note:> the assembly of HTML documents as multipart/related bodies may
be simplified with an alternate assembler in the future.
The above manifest would build a multipart alternative message. GUI mail
clients would see a rendered HTML document with the logo graphic visible from
the attachment. Text mail clients would see the plaintext.
Both the HTML and text parts would be rendered using the named renderer, which
here is Template-Toolkit.
The message would be assembled and returned as an Email::MIME object, just as
easily as suggested in the L</SYNOPSIS> above.
=head1 ENCODING ISSUES
In general, "it should all just work" ... starting in version v3.
Email::MIME::Kit assumes that any file read for the purpose of becoming a
C<text/*>-type part is encoded in UTF-8. It will decode them and work with
their contents as text strings. Renderers will be passed text strings to
render, and so on. This, further, means that strings passed to the C<assemble>
method for use in rendering should also be text strings.
In older versions of Email::MIME::Kit, files read from disk were read in raw
mode and then handled as octet strings. Meanwhile, the manifest's contents
(and, thus, any templates stored as strings in the manifest) were decoded into
text strings. This could lead to serious problems. For example: the
F<manifest.json> file might contain:
"header": [
{ "Subject": "Message for [% customer_name %]" },
...
]
...while a template on disk might contain:
Dear [% customer_name %],
...
If the customer's name isn't ASCII, there was no right way to pass it in. The
template on disk would expect UTF-8, but the template in the manifest would
expect Unicode text. Users prior to v3 may have taken strange steps to get
around this problem, understanding that some templates were treated differently
than others. This means that some review of kits is in order when upgrading
from earlier versions of Email::MIME::Kit.
=head1 AUTHOR
This code was written in 2009 by Ricardo SIGNES. It was based on a previous
implementation by Hans Dieter Pearcey written in 2006.
The development of this code was sponsored by Pobox.com. Thanks, Pobox!
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 CONTRIBUTORS
=for stopwords Charlie Garrison fREW Schmidt hdp Kaitlyn Parkhurst
=over 4
=item *
Charlie Garrison <garrison@zeta.org.au>
=item *
fREW Schmidt <frioux@gmail.com>
=item *
hdp <hdp@1bcdbe44-fcfd-0310-b51b-975661d93aa0>
=item *
Kaitlyn Parkhurst <symkat@symkat.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

391
database/perl/vendor/lib/Email/MIME/Kit/Assembler/Standard.pm vendored Normal file
View File

@@ -0,0 +1,391 @@
package Email::MIME::Kit::Assembler::Standard;
# ABSTRACT: the standard kit assembler
$Email::MIME::Kit::Assembler::Standard::VERSION = '3.000006';
use Moose;
use Moose::Util::TypeConstraints;
#pod =head1 WARNING
#pod
#pod Email::MIME::Kit::Assembler::Standard works well, but is poorly decomposed,
#pod internally. Its methods may change substantially in the future, so relying on
#pod it as a base class is a bad idea.
#pod
#pod Because I<being able to> rely on it would be so useful, its behaviors will in
#pod the future be more reliable or factored out into roles. Until then, be
#pod careful.
#pod
#pod =cut
with 'Email::MIME::Kit::Role::Assembler';
use Email::MIME::Creator;
use Encode ();
use File::Basename;
sub BUILD {
my ($self) = @_;
$self->_setup_content_ids;
$self->_pick_and_set_renderer;
$self->_build_subassemblies;
}
has parent => (
is => 'ro',
isa => maybe_type(role_type('Email::MIME::Kit::Role::Assembler')),
weak_ref => 1,
);
has renderer => (
reader => 'renderer',
writer => '_set_renderer',
clearer => '_unset_renderer',
isa => maybe_type(role_type('Email::MIME::Kit::Role::Renderer')),
init_arg => undef,
);
sub assemble {
my ($self, $stash) = @_;
my $manifest = $self->manifest;
my $has_body = defined $manifest->{body};
my $has_path = defined $manifest->{path};
my $has_alts = @{ $manifest->{alternatives} || [] };
my $has_att = @{ $manifest->{attachments} || [] };
Carp::croak("neither body, path, nor alternatives provided")
unless $has_body or $has_path or $has_alts;
Carp::croak("you must provide only one of body, path, or alternatives")
unless (grep {$_} $has_body, $has_path, $has_alts) == 1;
my $assembly_method = $has_body ? '_assemble_from_manifest_body'
: $has_path ? '_assemble_from_kit'
: $has_alts ? '_assemble_mp_alt'
: confess "unreachable code is a mistake";
$self->$assembly_method($stash);
}
sub _assemble_from_string {
my ($self, $body, $stash) = @_;
my %attr = %{ $self->manifest->{attributes} || {} };
$attr{content_type} ||= 'text/plain';
if ($attr{content_type} =~ m{^text/}) {
# I really shouldn't have to do this, but I'm not going to go screw around
# with @#$@#$ Email::Simple/MIME just to deal with it right now. -- rjbs,
# 2009-01-19
$body .= "\x0d\x0a" unless $body =~ /[\x0d|\x0a]\z/;
}
my $body_ref = $self->render(\$body, $stash);
my $email = $self->_contain_attachments({
attributes => \%attr,
header => $self->manifest->{header},
stash => $stash,
body => $$body_ref,
container_type => $self->manifest->{container_type},
});
}
sub _assemble_from_manifest_body {
my ($self, $stash) = @_;
$self->_assemble_from_string(
$self->manifest->{body},
$stash,
);
}
sub _assemble_from_kit {
my ($self, $stash) = @_;
my $type = $self->manifest->{attributes}{content_type} || 'text/plain';
my $method = $type =~ m{^text/} ? 'get_decoded_kit_entry' : 'get_kit_entry';
my $body_ref = $self->kit->$method($self->manifest->{path});
$self->_assemble_from_string($$body_ref, $stash);
}
sub _assemble_mp_alt {
my ($self, $stash) = @_;
my %attr = %{ $self->manifest->{attributes} || {} };
$attr{content_type} = $attr{content_type} || 'multipart/alternative';
if ($attr{content_type} !~ qr{\Amultipart/alternative\b}) {
confess "illegal content_type for mail with alts: $attr{content_type}";
}
my $parts = [ map { $_->assemble($stash) } @{ $self->_alternatives } ];
my $email = $self->_contain_attachments({
attributes => \%attr,
header => $self->manifest->{header},
stash => $stash,
parts => $parts,
});
}
sub _renderer_from_override {
my ($self, $override) = @_;
# Allow an explicit undef to mean "no rendering is to be done." -- rjbs,
# 2009-01-19
return undef unless defined $override;
return $self->kit->_build_component(
'Email::MIME::Kit::Renderer',
$override,
);
}
sub _pick_and_set_renderer {
my ($self) = @_;
# "renderer" entry at top-level sets the kit default_renderer, so trying to
# look at the "renderer" entry at top-level for an override is nonsensical
# -- rjbs, 2009-01-22
unless ($self->parent) {
$self->_set_renderer($self->kit->default_renderer);
return;
}
# If there's no override, we just use the parent. We don't need to worry
# about the "there is no parent" case, because that was handled above. --
# rjbs, 2009-01-22
unless (exists $self->manifest->{renderer}) {
$self->_set_renderer($self->parent->renderer);
return;
}
my $renderer = $self->_renderer_from_override($self->manifest->{renderer});
$self->_set_renderer($renderer);
}
has manifest => (
is => 'ro',
required => 1,
);
has [ qw(_attachments _alternatives) ] => (
is => 'ro',
isa => 'ArrayRef',
init_arg => undef,
default => sub { [] },
);
has _body => (
reader => 'body',
writer => '_set_body',
);
sub _build_subassemblies {
my ($self) = @_;
if (my $body = $self->manifest->{body}) {
$self->_set_body($body);
}
for my $attach (@{ $self->manifest->{attachments} || [] }) {
my $assembler = $self->kit->_assembler_from_manifest($attach, $self);
$assembler->_set_attachment_info($attach)
if $assembler->can('_set_attachment_info');
push @{ $self->_attachments }, $assembler;
}
for my $alt (@{ $self->manifest->{alternatives} || [] }) {
push @{ $self->_alternatives },
$self->kit->_assembler_from_manifest($alt, $self);
}
}
sub _set_attachment_info {
my ($self, $manifest) = @_;
my $attr = $manifest->{attributes} ||= {};
$attr->{encoding} = 'base64' unless exists $attr->{encoding};
$attr->{disposition} = 'attachment' unless exists $attr->{disposition};
unless (exists $attr->{filename}) {
my $filename;
($filename) = File::Basename::fileparse($manifest->{path})
if $manifest->{path};
# XXX: Steal the attachment-name-generator from Email::MIME::Modifier, or
# something. -- rjbs, 2009-01-20
$filename ||= "unknown-attachment";
$attr->{filename} = $filename;
}
}
sub render {
my ($self, $input_ref, $stash) = @_;
local $stash->{cid_for} = sub { $self->cid_for_path($_[0]) };
return $input_ref unless my $renderer = $self->renderer;
return $renderer->render($input_ref, $stash);
}
sub _prep_header {
my ($self, $header, $stash) = @_;
my @done_header;
for my $entry (@$header) {
confess "no field name candidates"
unless my (@hval) = grep { /^[^:]/ } keys %$entry;
confess "multiple field name candidates: @hval" if @hval > 1;
my $value = $entry->{ $hval[ 0 ] };
if (ref $value) {
my ($v, $p) = @$value;
$value = join q{; }, $v, map { "$_=$p->{$_}" } keys %$p;
} else {
# I don't think I need to bother with $self->render, which will set up
# the cid_for callback. Honestly, who is going to be referencing a
# content-id from a header? Let's hope I never find out... -- rjbs,
# 2009-01-22
my $renderer = exists $entry->{':renderer'}
? $self->_renderer_from_override($entry->{':renderer'})
: $self->renderer;
$value = ${ $renderer->render(\$value, $stash) } if defined $renderer;
}
push @done_header, $hval[0] => $value;
}
return \@done_header;
}
sub _contain_attachments {
my ($self, $arg) = @_;
my @attachments = @{ $self->_attachments };
my $header = $self->_prep_header($arg->{header}, $arg->{stash});
my $ct = $arg->{container_type};
my %attr = %{ $arg->{attributes} };
my $body_type = 'body';
if ($attr{content_type} =~ m{^text/}) {
$body_type = 'body_str';
$attr{encoding} ||= 'quoted-printable';
$attr{charset} ||= 'UTF-8'
} elsif (($arg->{body} || '') =~ /\P{ASCII}/) {
$attr{encoding} ||= 'base64';
}
unless (@attachments) {
confess "container_type given for single-part assembly" if $ct;
return Email::MIME->create(
attributes => \%attr,
header_str => $header,
$body_type => $arg->{body},
parts => $arg->{parts},
);
}
my $email = Email::MIME->create(
attributes => \%attr,
$body_type => $arg->{body},
parts => $arg->{parts},
);
my @att_parts = map { $_->assemble($arg->{stash}) } @attachments;
my $container = Email::MIME->create(
attributes => { content_type => ($ct || 'multipart/mixed') },
header_str => $header,
parts => [ $email, @att_parts ],
);
return $container;
}
has _cid_registry => (
is => 'ro',
init_arg => undef,
default => sub { { } },
);
sub cid_for_path {
my ($self, $path) = @_;
my $cid = $self->_cid_registry->{ $path };
confess "no content-id for path $path" unless $cid;
return $cid;
}
sub _setup_content_ids {
my ($self) = @_;
for my $att (@{ $self->manifest->{attachments} || [] }) {
next unless $att->{path};
for my $header (@{ $att->{header} }) {
my ($header) = grep { /^[^:]/ } keys %$header;
Carp::croak("attachments must not supply content-id")
if lc $header eq 'content-id';
}
my $cid = $self->kit->_generate_content_id;
push @{ $att->{header} }, {
'Content-Id' => $cid->in_brackets,
':renderer' => undef,
};
$self->_cid_registry->{ $att->{path} } = $cid->as_string;
}
}
no Moose::Util::TypeConstraints;
no Moose;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit::Assembler::Standard - the standard kit assembler
=head1 VERSION
version 3.000006
=head1 WARNING
Email::MIME::Kit::Assembler::Standard works well, but is poorly decomposed,
internally. Its methods may change substantially in the future, so relying on
it as a base class is a bad idea.
Because I<being able to> rely on it would be so useful, its behaviors will in
the future be more reliable or factored out into roles. Until then, be
careful.
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

51
database/perl/vendor/lib/Email/MIME/Kit/KitReader/Dir.pm vendored Normal file
View File

@@ -0,0 +1,51 @@
package Email::MIME::Kit::KitReader::Dir;
# ABSTRACT: read kit entries out of a directory
$Email::MIME::Kit::KitReader::Dir::VERSION = '3.000006';
use Moose;
with 'Email::MIME::Kit::Role::KitReader';
use File::Spec;
# cache sometimes
sub get_kit_entry {
my ($self, $path) = @_;
my $fullpath = File::Spec->catfile($self->kit->source, $path);
open my $fh, '<:raw', $fullpath
or die "can't open $fullpath for reading: $!";
my $content = do { local $/; <$fh> };
return \$content;
}
no Moose;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit::KitReader::Dir - read kit entries out of a directory
=head1 VERSION
version 3.000006
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

48
database/perl/vendor/lib/Email/MIME/Kit/ManifestReader/JSON.pm vendored Normal file
View File

@@ -0,0 +1,48 @@
package Email::MIME::Kit::ManifestReader::JSON;
# ABSTRACT: read manifest.json files
$Email::MIME::Kit::ManifestReader::JSON::VERSION = '3.000006';
use Moose;
with 'Email::MIME::Kit::Role::ManifestReader';
with 'Email::MIME::Kit::Role::ManifestDesugarer';
use JSON 2;
sub read_manifest {
my ($self) = @_;
my $json_ref = $self->kit->kit_reader->get_kit_entry('manifest.json');
my $content = JSON->new->utf8->decode($$json_ref);
}
no Moose;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit::ManifestReader::JSON - read manifest.json files
=head1 VERSION
version 3.000006
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

51
database/perl/vendor/lib/Email/MIME/Kit/ManifestReader/YAML.pm vendored Normal file
View File

@@ -0,0 +1,51 @@
package Email::MIME::Kit::ManifestReader::YAML;
# ABSTRACT: read manifest.yaml files
$Email::MIME::Kit::ManifestReader::YAML::VERSION = '3.000006';
use Moose;
with 'Email::MIME::Kit::Role::ManifestReader';
with 'Email::MIME::Kit::Role::ManifestDesugarer';
use YAML::XS ();
sub read_manifest {
my ($self) = @_;
my $yaml_ref = $self->kit->kit_reader->get_kit_entry('manifest.yaml');
# YAML::XS is documented as expecting UTF-8 bytes, which we give it.
my ($content) = YAML::XS::Load($$yaml_ref);
return $content;
}
no Moose;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit::ManifestReader::YAML - read manifest.yaml files
=head1 VERSION
version 3.000006
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

118
database/perl/vendor/lib/Email/MIME/Kit/Renderer/TestRenderer.pm vendored Normal file
View File

@@ -0,0 +1,118 @@
package Email::MIME::Kit::Renderer::TestRenderer;
# ABSTRACT: extremely simple renderer for testing purposes only
$Email::MIME::Kit::Renderer::TestRenderer::VERSION = '3.000006';
use Moose;
with 'Email::MIME::Kit::Role::Renderer';
#pod =head1 WARNING
#pod
#pod Seriously, this is horrible code. If you want, look at it. It's swell for
#pod testing simple things, but if you use this for real mkits, you're going to be
#pod upset by something horrible soon.
#pod
#pod =head1 DESCRIPTION
#pod
#pod The test renderer is like a version of Template Toolkit 2 that has had a crayon
#pod shoved up its nose and into its brain. It can only do a very few things, but
#pod it does them well enough to test simple kits.
#pod
#pod Given the following template:
#pod
#pod This will say "I love pie": [% actor %] [% m_obj.verb() %] [% z_by("me") %]
#pod
#pod ...and the following set of variables:
#pod
#pod {
#pod actor => 'I',
#pod m_obj => $object_whose_verb_method_returns_love,
#pod z_by => sub { 'me' },
#pod }
#pod
#pod ..then it will be a true statement.
#pod
#pod In method calls, the parens are B<not> optional. Anything between them (or
#pod between the parens in a coderef call) is evaluated like perl code. For
#pod example, this will actually get the OS:
#pod
#pod [% z_by($^O) %]
#pod
#pod =cut
sub render {
my ($self, $content_ref, $stash) = @_;
my $output = $$content_ref;
for my $key (sort %$stash) {
$output =~
s<\[%\s+\Q$key\E(?:(?:\.(\w+))?\((.*?)\))?\s+%\]>
[ defined $2
? ($1 ? $stash->{$key}->$1(eval $2) : $stash->{$key}->(eval $2))
: $stash->{$key}
]ge;
}
return \$output;
}
no Moose;
__PACKAGE__->meta->make_immutable;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit::Renderer::TestRenderer - extremely simple renderer for testing purposes only
=head1 VERSION
version 3.000006
=head1 DESCRIPTION
The test renderer is like a version of Template Toolkit 2 that has had a crayon
shoved up its nose and into its brain. It can only do a very few things, but
it does them well enough to test simple kits.
Given the following template:
This will say "I love pie": [% actor %] [% m_obj.verb() %] [% z_by("me") %]
...and the following set of variables:
{
actor => 'I',
m_obj => $object_whose_verb_method_returns_love,
z_by => sub { 'me' },
}
..then it will be a true statement.
In method calls, the parens are B<not> optional. Anything between them (or
between the parens in a coderef call) is evaluated like perl code. For
example, this will actually get the OS:
[% z_by($^O) %]
=head1 WARNING
Seriously, this is horrible code. If you want, look at it. It's swell for
testing simple things, but if you use this for real mkits, you're going to be
upset by something horrible soon.
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

55
database/perl/vendor/lib/Email/MIME/Kit/Role/Assembler.pm vendored Normal file
View File

@@ -0,0 +1,55 @@
package Email::MIME::Kit::Role::Assembler;
# ABSTRACT: things that assemble messages (or parts)
$Email::MIME::Kit::Role::Assembler::VERSION = '3.000006';
use Moose::Role;
with 'Email::MIME::Kit::Role::Component';
#pod =head1 IMPLEMENTING
#pod
#pod This role also performs L<Email::MIME::Kit::Role::Component>.
#pod
#pod Classes implementing this role must provide an C<assemble> method. This method
#pod will be passed a hashref of assembly parameters, and should return the fully
#pod assembled Email::MIME object.
#pod
#pod =cut
requires 'assemble';
no Moose::Role;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit::Role::Assembler - things that assemble messages (or parts)
=head1 VERSION
version 3.000006
=head1 IMPLEMENTING
This role also performs L<Email::MIME::Kit::Role::Component>.
Classes implementing this role must provide an C<assemble> method. This method
will be passed a hashref of assembly parameters, and should return the fully
assembled Email::MIME object.
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

55
database/perl/vendor/lib/Email/MIME/Kit/Role/Component.pm vendored Normal file
View File

@@ -0,0 +1,55 @@
package Email::MIME::Kit::Role::Component;
# ABSTRACT: things that are kit components
$Email::MIME::Kit::Role::Component::VERSION = '3.000006';
use Moose::Role;
#pod =head1 DESCRIPTION
#pod
#pod All (or most, anyway) components of an Email::MIME::Kit will perform this role.
#pod Its primary function is to provide a C<kit> attribute that refers back to the
#pod Email::MIME::Kit into which the component was installed.
#pod
#pod =cut
has kit => (
is => 'ro',
isa => 'Email::MIME::Kit',
required => 1,
weak_ref => 1,
);
no Moose::Role;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit::Role::Component - things that are kit components
=head1 VERSION
version 3.000006
=head1 DESCRIPTION
All (or most, anyway) components of an Email::MIME::Kit will perform this role.
Its primary function is to provide a C<kit> attribute that refers back to the
Email::MIME::Kit into which the component was installed.
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

74
database/perl/vendor/lib/Email/MIME/Kit/Role/KitReader.pm vendored Normal file
View File

@@ -0,0 +1,74 @@
package Email::MIME::Kit::Role::KitReader;
# ABSTRACT: things that can read kit contents
$Email::MIME::Kit::Role::KitReader::VERSION = '3.000006';
use Moose::Role;
with 'Email::MIME::Kit::Role::Component';
#pod =head1 IMPLEMENTING
#pod
#pod This role also performs L<Email::MIME::Kit::Role::Component>.
#pod
#pod Classes implementing this role must provide a C<get_kit_entry> method. It will
#pod be called with one parameter, the name of a path to an entry in the kit. It
#pod should return a reference to a scalar holding the contents (as octets) of the
#pod named entry. If no entry is found, it should raise an exception.
#pod
#pod A method called C<get_decoded_kit_entry> is provided. It behaves like
#pod C<get_kit_entry>, but assumes that the entry for that name is stored in UTF-8
#pod and will decode it to text before returning.
#pod
#pod =cut
requires 'get_kit_entry';
sub get_decoded_kit_entry {
my ($self, $name) = @_;
my $content_ref = $self->get_kit_entry($name);
require Encode;
my $decoded = Encode::decode('utf-8', $$content_ref);
return \$decoded;
}
no Moose::Role;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit::Role::KitReader - things that can read kit contents
=head1 VERSION
version 3.000006
=head1 IMPLEMENTING
This role also performs L<Email::MIME::Kit::Role::Component>.
Classes implementing this role must provide a C<get_kit_entry> method. It will
be called with one parameter, the name of a path to an entry in the kit. It
should return a reference to a scalar holding the contents (as octets) of the
named entry. If no entry is found, it should raise an exception.
A method called C<get_decoded_kit_entry> is provided. It behaves like
C<get_kit_entry>, but assumes that the entry for that name is stored in UTF-8
and will decode it to text before returning.
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

116
database/perl/vendor/lib/Email/MIME/Kit/Role/ManifestDesugarer.pm vendored Normal file
View File

@@ -0,0 +1,116 @@
package Email::MIME::Kit::Role::ManifestDesugarer;
# ABSTRACT: helper for desugaring manifests
$Email::MIME::Kit::Role::ManifestDesugarer::VERSION = '3.000006';
use Moose::Role;
#pod =head1 IMPLEMENTING
#pod
#pod This role also performs L<Email::MIME::Kit::Role::Component>.
#pod
#pod This is a role more likely to be consumed than implemented. It wraps C<around>
#pod the C<read_manifest> method in the consuming class, and "desugars" the contents
#pod of the loaded manifest before returning it.
#pod
#pod At present, desugaring is what allows the C<type> attribute in attachments and
#pod alternatives to be given instead of a C<content_type> entry in the
#pod C<attributes> entry. In other words, desugaring turns:
#pod
#pod {
#pod header => [ ... ],
#pod type => 'text/plain',
#pod }
#pod
#pod Into:
#pod
#pod {
#pod header => [ ... ],
#pod attributes => { content_type => 'text/plain' },
#pod }
#pod
#pod More behavior may be added to the desugarer later.
#pod
#pod =cut
my $ct_desugar;
$ct_desugar = sub {
my ($self, $content) = @_;
for my $thing (qw(alternatives attachments)) {
for my $part (@{ $content->{ $thing } }) {
my $headers = $part->{header} ||= [];
if (my $type = delete $part->{type}) {
confess "specified both type and content_type attribute"
if $part->{attributes}{content_type};
$part->{attributes}{content_type} = $type;
}
$self->$ct_desugar($part);
}
}
};
around read_manifest => sub {
my ($orig, $self, @args) = @_;
my $content = $self->$orig(@args);
$self->$ct_desugar($content);
return $content;
};
no Moose::Role;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit::Role::ManifestDesugarer - helper for desugaring manifests
=head1 VERSION
version 3.000006
=head1 IMPLEMENTING
This role also performs L<Email::MIME::Kit::Role::Component>.
This is a role more likely to be consumed than implemented. It wraps C<around>
the C<read_manifest> method in the consuming class, and "desugars" the contents
of the loaded manifest before returning it.
At present, desugaring is what allows the C<type> attribute in attachments and
alternatives to be given instead of a C<content_type> entry in the
C<attributes> entry. In other words, desugaring turns:
{
header => [ ... ],
type => 'text/plain',
}
Into:
{
header => [ ... ],
attributes => { content_type => 'text/plain' },
}
More behavior may be added to the desugarer later.
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

55
database/perl/vendor/lib/Email/MIME/Kit/Role/ManifestReader.pm vendored Normal file
View File

@@ -0,0 +1,55 @@
package Email::MIME::Kit::Role::ManifestReader;
# ABSTRACT: things that read kit manifests
$Email::MIME::Kit::Role::ManifestReader::VERSION = '3.000006';
use Moose::Role;
with 'Email::MIME::Kit::Role::Component';
#pod =head1 IMPLEMENTING
#pod
#pod This role also performs L<Email::MIME::Kit::Role::Component>.
#pod
#pod Classes implementing this role must provide a C<read_manifest> method, which is
#pod expected to locate and read a manifest for the kit. Classes implementing this
#pod role should probably include L<Email::MIME::Kit::Role::ManifestDesugarer>, too.
#pod
#pod =cut
requires 'read_manifest';
no Moose::Role;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit::Role::ManifestReader - things that read kit manifests
=head1 VERSION
version 3.000006
=head1 IMPLEMENTING
This role also performs L<Email::MIME::Kit::Role::Component>.
Classes implementing this role must provide a C<read_manifest> method, which is
expected to locate and read a manifest for the kit. Classes implementing this
role should probably include L<Email::MIME::Kit::Role::ManifestDesugarer>, too.
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

59
database/perl/vendor/lib/Email/MIME/Kit/Role/Renderer.pm vendored Normal file
View File

@@ -0,0 +1,59 @@
package Email::MIME::Kit::Role::Renderer;
# ABSTRACT: things that render templates into contents
$Email::MIME::Kit::Role::Renderer::VERSION = '3.000006';
use Moose::Role;
with 'Email::MIME::Kit::Role::Component';
#pod =head1 IMPLEMENTING
#pod
#pod This role also performs L<Email::MIME::Kit::Role::Component>.
#pod
#pod Classes implementing this role must provide a C<render> method, which is
#pod expected to turn a template and arguments into rendered output. The method is
#pod used like this:
#pod
#pod my $output_ref = $renderer->render($input_ref, \%arg);
#pod
#pod =cut
requires 'render';
no Moose::Role;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit::Role::Renderer - things that render templates into contents
=head1 VERSION
version 3.000006
=head1 IMPLEMENTING
This role also performs L<Email::MIME::Kit::Role::Component>.
Classes implementing this role must provide a C<render> method, which is
expected to turn a template and arguments into rendered output. The method is
used like this:
my $output_ref = $renderer->render($input_ref, \%arg);
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

60
database/perl/vendor/lib/Email/MIME/Kit/Role/Validator.pm vendored Normal file
View File

@@ -0,0 +1,60 @@
package Email::MIME::Kit::Role::Validator;
# ABSTRACT: things that validate assembly parameters
$Email::MIME::Kit::Role::Validator::VERSION = '3.000006';
use Moose::Role;
#pod =head1 IMPLEMENTING
#pod
#pod This role also performs L<Email::MIME::Kit::Role::Component>.
#pod
#pod Classes implementing this role are used to validate that the arguments passed
#pod to C<< $mkit->assemble >> are valid. Classes must provide a C<validate> method
#pod which will be called with the hashref of values passed to the kit's C<assemble>
#pod method. If the arguments are not valid for the kit, the C<validate> method
#pod should raise an exception.
#pod
#pod =cut
with 'Email::MIME::Kit::Role::Component';
requires 'validate';
no Moose::Role;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Kit::Role::Validator - things that validate assembly parameters
=head1 VERSION
version 3.000006
=head1 IMPLEMENTING
This role also performs L<Email::MIME::Kit::Role::Component>.
Classes implementing this role are used to validate that the arguments passed
to C<< $mkit->assemble >> are valid. Classes must provide a C<validate> method
which will be called with the hashref of values passed to the kit's C<assemble>
method. If the arguments are not valid for the kit, the C<validate> method
should raise an exception.
=head1 AUTHOR
Ricardo Signes <rjbs@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2018 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

47
database/perl/vendor/lib/Email/MIME/Modifier.pm vendored Normal file
View File

@@ -0,0 +1,47 @@
use strict;
use warnings;
package Email::MIME::Modifier;
# ABSTRACT: obsolete do-nothing library
$Email::MIME::Modifier::VERSION = '1.949';
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MIME::Modifier - obsolete do-nothing library
=head1 VERSION
version 1.949
=head1 AUTHORS
=over 4
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Casey West <casey@geeknest.com>
=item *
Simon Cozens <simon@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Simon Cozens and Casey West.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

244
database/perl/vendor/lib/Email/MessageID.pm vendored Normal file
View File

@@ -0,0 +1,244 @@
use strict;
use warnings;
package Email::MessageID;
# ABSTRACT: Generate world unique message-ids.
$Email::MessageID::VERSION = '1.406';
use overload '""' => 'as_string', fallback => 1;
#pod =head1 SYNOPSIS
#pod
#pod use Email::MessageID;
#pod
#pod my $mid = Email::MessageID->new->in_brackets;
#pod
#pod print "Message-ID: $mid\x0D\x0A";
#pod
#pod =head1 DESCRIPTION
#pod
#pod Message-ids are optional, but highly recommended, headers that identify a
#pod message uniquely. This software generates a unique message-id.
#pod
#pod =method new
#pod
#pod my $mid = Email::MessageID->new;
#pod
#pod my $new_mid = Email::MessageID->new( host => $myhost );
#pod
#pod This class method constructs an L<Email::Address|Email::Address> object
#pod containing a unique message-id. You may specify custom C<host> and C<user>
#pod parameters.
#pod
#pod By default, the C<host> is generated from C<Sys::Hostname::hostname>.
#pod
#pod By default, the C<user> is generated using C<Time::HiRes>'s C<gettimeofday>
#pod and the process ID.
#pod
#pod Using these values we have the ability to ensure world uniqueness down to
#pod a specific process running on a specific host, and the exact time down to
#pod six digits of microsecond precision.
#pod
#pod =cut
sub new {
my ($class, %args) = @_;
$args{user} ||= $class->create_user;
$args{host} ||= $class->create_host;
my $str = "$args{user}\@$args{host}";
bless \$str => $class;
}
#pod =method create_host
#pod
#pod my $domain_part = Email::MessageID->create_host;
#pod
#pod This method returns the domain part of the message-id.
#pod
#pod =cut
my $_SYS_HOSTNAME_LONG;
sub create_host {
unless (defined $_SYS_HOSTNAME_LONG) {
$_SYS_HOSTNAME_LONG = (eval { require Sys::Hostname::Long; 1 }) || 0;
require Sys::Hostname unless $_SYS_HOSTNAME_LONG;
}
return $_SYS_HOSTNAME_LONG ? Sys::Hostname::Long::hostname_long()
: Sys::Hostname::hostname();
}
#pod =method create_user
#pod
#pod my $local_part = Email::MessageID->create_user;
#pod
#pod This method returns a unique local part for the message-id. It includes some
#pod random data and some predictable data.
#pod
#pod =cut
my @CHARS = ('A'..'F','a'..'f',0..9);
my %uniq;
sub create_user {
my $noise = join '',
map {; $CHARS[rand @CHARS] } (0 .. (3 + int rand 6));
my $t = time;
my $u = exists $uniq{$t} ? ++$uniq{$t} : (%uniq = ($t => 0))[1];
my $user = join '.', $t . $u, $noise, $$;
return $user;
}
#pod =method in_brackets
#pod
#pod When using Email::MessageID directly to populate the C<Message-ID> field, be
#pod sure to use C<in_brackets> to get the string inside angle brackets:
#pod
#pod header => [
#pod ...
#pod 'Message-Id' => Email::MessageID->new->in_brackets,
#pod ],
#pod
#pod Don't make this common mistake:
#pod
#pod header => [
#pod ...
#pod 'Message-Id' => Email::MessageID->new->as_string, # WRONG!
#pod ],
#pod
#pod =for Pod::Coverage address as_string host user
#pod
#pod =cut
sub user { (split /@/, ${ $_[0] }, 2)[0] }
sub host { (split /@/, ${ $_[0] }, 2)[1] }
sub in_brackets {
my ($self) = @_;
return "<$$self>";
}
sub address {
my ($self) = @_;
return "$$self";
}
sub as_string {
my ($self) = @_;
return "$$self";
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::MessageID - Generate world unique message-ids.
=head1 VERSION
version 1.406
=head1 SYNOPSIS
use Email::MessageID;
my $mid = Email::MessageID->new->in_brackets;
print "Message-ID: $mid\x0D\x0A";
=head1 DESCRIPTION
Message-ids are optional, but highly recommended, headers that identify a
message uniquely. This software generates a unique message-id.
=head1 METHODS
=head2 new
my $mid = Email::MessageID->new;
my $new_mid = Email::MessageID->new( host => $myhost );
This class method constructs an L<Email::Address|Email::Address> object
containing a unique message-id. You may specify custom C<host> and C<user>
parameters.
By default, the C<host> is generated from C<Sys::Hostname::hostname>.
By default, the C<user> is generated using C<Time::HiRes>'s C<gettimeofday>
and the process ID.
Using these values we have the ability to ensure world uniqueness down to
a specific process running on a specific host, and the exact time down to
six digits of microsecond precision.
=head2 create_host
my $domain_part = Email::MessageID->create_host;
This method returns the domain part of the message-id.
=head2 create_user
my $local_part = Email::MessageID->create_user;
This method returns a unique local part for the message-id. It includes some
random data and some predictable data.
=head2 in_brackets
When using Email::MessageID directly to populate the C<Message-ID> field, be
sure to use C<in_brackets> to get the string inside angle brackets:
header => [
...
'Message-Id' => Email::MessageID->new->in_brackets,
],
Don't make this common mistake:
header => [
...
'Message-Id' => Email::MessageID->new->as_string, # WRONG!
],
=for Pod::Coverage address as_string host user
=head1 AUTHORS
=over 4
=item *
Casey West <casey@geeknest.com>
=item *
Ricardo SIGNES <rjbs@cpan.org>
=back
=head1 CONTRIBUTOR
=for stopwords Aaron Crane
Aaron Crane <arc@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Casey West.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

203
database/perl/vendor/lib/Email/Sender.pm vendored Normal file
View File

@@ -0,0 +1,203 @@
package Email::Sender;
# ABSTRACT: a library for sending email
$Email::Sender::VERSION = '1.300035';
use Moo::Role;
requires 'send';
#pod =head1 SYNOPSIS
#pod
#pod my $message = Email::MIME->create( ... );
#pod # produce an Email::Abstract compatible message object,
#pod # e.g. produced by Email::Simple, Email::MIME, Email::Stuff
#pod
#pod use Email::Sender::Simple qw(sendmail);
#pod use Email::Sender::Transport::SMTP qw();
#pod use Try::Tiny;
#pod
#pod try {
#pod sendmail(
#pod $message,
#pod {
#pod from => $SMTP_ENVELOPE_FROM_ADDRESS,
#pod transport => Email::Sender::Transport::SMTP->new({
#pod host => $SMTP_HOSTNAME,
#pod port => $SMTP_PORT,
#pod })
#pod }
#pod );
#pod } catch {
#pod warn "sending failed: $_";
#pod };
#pod
#pod =head1 OVERVIEW
#pod
#pod Email::Sender replaces the old and sometimes problematic Email::Send library,
#pod which did a decent job at handling very simple email sending tasks, but was not
#pod suitable for serious use, for a variety of reasons.
#pod
#pod Most users will be able to use L<Email::Sender::Simple> to send mail. Users
#pod with more specific needs should look at the available Email::Sender::Transport
#pod classes.
#pod
#pod Documentation may be found in L<Email::Sender::Manual>, and new users should
#pod start with L<Email::Sender::Manual::QuickStart>.
#pod
#pod =head1 IMPLEMENTING
#pod
#pod Email::Sender itself is a Moo role. Any class that implements Email::Sender
#pod is required to provide a method called C<send>. This method should accept any
#pod input that can be understood by L<Email::Abstract>, followed by a hashref
#pod containing C<to> and C<from> arguments to be used as the envelope. The method
#pod should return an L<Email::Sender::Success> object on success or throw an
#pod L<Email::Sender::Failure> on failure.
#pod
#pod =cut
no Moo::Role;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender - a library for sending email
=head1 VERSION
version 1.300035
=head1 SYNOPSIS
my $message = Email::MIME->create( ... );
# produce an Email::Abstract compatible message object,
# e.g. produced by Email::Simple, Email::MIME, Email::Stuff
use Email::Sender::Simple qw(sendmail);
use Email::Sender::Transport::SMTP qw();
use Try::Tiny;
try {
sendmail(
$message,
{
from => $SMTP_ENVELOPE_FROM_ADDRESS,
transport => Email::Sender::Transport::SMTP->new({
host => $SMTP_HOSTNAME,
port => $SMTP_PORT,
})
}
);
} catch {
warn "sending failed: $_";
};
=head1 OVERVIEW
Email::Sender replaces the old and sometimes problematic Email::Send library,
which did a decent job at handling very simple email sending tasks, but was not
suitable for serious use, for a variety of reasons.
Most users will be able to use L<Email::Sender::Simple> to send mail. Users
with more specific needs should look at the available Email::Sender::Transport
classes.
Documentation may be found in L<Email::Sender::Manual>, and new users should
start with L<Email::Sender::Manual::QuickStart>.
=head1 IMPLEMENTING
Email::Sender itself is a Moo role. Any class that implements Email::Sender
is required to provide a method called C<send>. This method should accept any
input that can be understood by L<Email::Abstract>, followed by a hashref
containing C<to> and C<from> arguments to be used as the envelope. The method
should return an L<Email::Sender::Success> object on success or throw an
L<Email::Sender::Failure> on failure.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 CONTRIBUTORS
=for stopwords Alex Efros Aristotle Pagaltzis Bernhard Graf Christian Walde David Golden Steinbrunner Hans Dieter Pearcey HIROSE Masaaki James E Keenan Justin Hunter Karen Etheridge Kenichi Ishigaki kga Kris Matthews Stefan Hornburg (Racke) William Blunn
=over 4
=item *
Alex Efros <powerman@powerman.name>
=item *
Aristotle Pagaltzis <pagaltzis@gmx.de>
=item *
Bernhard Graf <augensalat@gmail.com>
=item *
Christian Walde <walde.christian@googlemail.com>
=item *
David Golden <dagolden@cpan.org>
=item *
David Steinbrunner <dsteinbrunner@pobox.com>
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
HIROSE Masaaki <hirose31@gmail.com>
=item *
James E Keenan <jkeenan@cpan.org>
=item *
Justin Hunter <justin.d.hunter@gmail.com>
=item *
Karen Etheridge <ether@cpan.org>
=item *
Kenichi Ishigaki <ishigaki@cpan.org>
=item *
kga <watrty@gmail.com>
=item *
Kris Matthews <kris@tigerlms.com>
=item *
Stefan Hornburg (Racke) <racke@linuxia.de>
=item *
William Blunn <zgpmax@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

152
database/perl/vendor/lib/Email/Sender/Failure.pm vendored Normal file
View File

@@ -0,0 +1,152 @@
package Email::Sender::Failure;
# ABSTRACT: a report of failure from an email sending transport
$Email::Sender::Failure::VERSION = '1.300035';
use Moo;
extends 'Throwable::Error';
use Carp ();
use MooX::Types::MooseLike::Base qw(ArrayRef);
#pod =attr message
#pod
#pod This method returns the failure message, which should describe the failure.
#pod Failures stringify to this message.
#pod
#pod =attr code
#pod
#pod This returns the numeric code of the failure, if any. This is mostly useful
#pod for network protocol transports like SMTP. This may be undefined.
#pod
#pod =cut
has code => (
is => 'ro',
);
#pod =attr recipients
#pod
#pod This returns a list of addresses to which the email could not be sent.
#pod
#pod =cut
has recipients => (
isa => ArrayRef,
default => sub { [] },
writer => '_set_recipients',
reader => '__get_recipients',
is => 'rw',
accessor => undef,
);
sub __recipients { @{$_[0]->__get_recipients} }
sub recipients {
my ($self) = @_;
return $self->__recipients if wantarray;
return if ! defined wantarray;
Carp::carp("recipients in scalar context is deprecated and WILL BE REMOVED");
return $self->__get_recipients;
}
#pod =method throw
#pod
#pod This method can be used to instantiate and throw an Email::Sender::Failure
#pod object at once.
#pod
#pod Email::Sender::Failure->throw(\%arg);
#pod
#pod Instead of a hashref of args, you can pass a single string argument which will
#pod be used as the C<message> of the new failure.
#pod
#pod =cut
sub BUILD {
my ($self) = @_;
Carp::confess("message must contain non-space characters")
unless $self->message =~ /\S/;
}
#pod =head1 SEE ALSO
#pod
#pod =over
#pod
#pod =item * L<Email::Sender::Permanent>
#pod
#pod =item * L<Email::Sender::Temporary>
#pod
#pod =item * L<Email::Sender::Multi>
#pod
#pod =back
#pod
#pod =cut
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Failure - a report of failure from an email sending transport
=head1 VERSION
version 1.300035
=head1 ATTRIBUTES
=head2 message
This method returns the failure message, which should describe the failure.
Failures stringify to this message.
=head2 code
This returns the numeric code of the failure, if any. This is mostly useful
for network protocol transports like SMTP. This may be undefined.
=head2 recipients
This returns a list of addresses to which the email could not be sent.
=head1 METHODS
=head2 throw
This method can be used to instantiate and throw an Email::Sender::Failure
object at once.
Email::Sender::Failure->throw(\%arg);
Instead of a hashref of args, you can pass a single string argument which will
be used as the C<message> of the new failure.
=head1 SEE ALSO
=over
=item * L<Email::Sender::Permanent>
=item * L<Email::Sender::Temporary>
=item * L<Email::Sender::Multi>
=back
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

119
database/perl/vendor/lib/Email/Sender/Failure/Multi.pm vendored Normal file
View File

@@ -0,0 +1,119 @@
package Email::Sender::Failure::Multi;
# ABSTRACT: an aggregate of multiple failures
$Email::Sender::Failure::Multi::VERSION = '1.300035';
use Moo;
extends 'Email::Sender::Failure';
use MooX::Types::MooseLike::Base qw(ArrayRef);
#pod =head1 DESCRIPTION
#pod
#pod A multiple failure report is raised when more than one failure is encountered
#pod when sending a single message, or when mixed states were encountered.
#pod
#pod =attr failures
#pod
#pod This method returns a list of other Email::Sender::Failure objects represented
#pod by this multi.
#pod
#pod =cut
has failures => (
is => 'ro',
isa => ArrayRef,
required => 1,
reader => '__get_failures',
);
sub __failures { @{$_[0]->__get_failures} }
sub failures {
my ($self) = @_;
return $self->__failures if wantarray;
return if ! defined wantarray;
Carp::carp("failures in scalar context is deprecated and WILL BE REMOVED");
return $self->__get_failures;
}
sub recipients {
my ($self) = @_;
my @rcpts = map { $_->recipients } $self->failures;
return @rcpts if wantarray;
return if ! defined wantarray;
Carp::carp("recipients in scalar context is deprecated and WILL BE REMOVED");
return \@rcpts;
}
#pod =method isa
#pod
#pod A multiple failure will report that it is a Permanent or Temporary if all of
#pod its contained failures are failures of that type.
#pod
#pod =cut
sub isa {
my ($self, $class) = @_;
if (
$class eq 'Email::Sender::Failure::Permanent'
or
$class eq 'Email::Sender::Failure::Temporary'
) {
my @failures = $self->failures;
return 1 if @failures == grep { $_->isa($class) } @failures;
}
return $self->SUPER::isa($class);
}
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Failure::Multi - an aggregate of multiple failures
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
A multiple failure report is raised when more than one failure is encountered
when sending a single message, or when mixed states were encountered.
=head1 ATTRIBUTES
=head2 failures
This method returns a list of other Email::Sender::Failure objects represented
by this multi.
=head1 METHODS
=head2 isa
A multiple failure will report that it is a Permanent or Temporary if all of
its contained failures are failures of that type.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

35
database/perl/vendor/lib/Email/Sender/Failure/Permanent.pm vendored Normal file
View File

@@ -0,0 +1,35 @@
package Email::Sender::Failure::Permanent;
# ABSTRACT: a permanent delivery failure
$Email::Sender::Failure::Permanent::VERSION = '1.300035';
use Moo;
extends 'Email::Sender::Failure';
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Failure::Permanent - a permanent delivery failure
=head1 VERSION
version 1.300035
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

35
database/perl/vendor/lib/Email/Sender/Failure/Temporary.pm vendored Normal file
View File

@@ -0,0 +1,35 @@
package Email::Sender::Failure::Temporary;
# ABSTRACT: a temporary delivery failure
$Email::Sender::Failure::Temporary::VERSION = '1.300035';
use Moo;
extends 'Email::Sender::Failure';
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Failure::Temporary - a temporary delivery failure
=head1 VERSION
version 1.300035
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

45
database/perl/vendor/lib/Email/Sender/Manual.pm vendored Normal file
View File

@@ -0,0 +1,45 @@
use strict;
use warnings;
package Email::Sender::Manual;
# ABSTRACT: table of contents for the Email::Sender manual
$Email::Sender::Manual::VERSION = '1.300035';
#pod =head1 THE MANUAL
#pod
#pod L<Email::Sender::Manual::QuickStart> tells you just what you need to know to
#pod start using Email::Sender.
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Manual - table of contents for the Email::Sender manual
=head1 VERSION
version 1.300035
=head1 THE MANUAL
L<Email::Sender::Manual::QuickStart> tells you just what you need to know to
start using Email::Sender.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

499
database/perl/vendor/lib/Email/Sender/Manual/QuickStart.pm vendored Normal file
View File

@@ -0,0 +1,499 @@
use strict;
use warnings;
package Email::Sender::Manual::QuickStart;
# ABSTRACT: how to start using Email::Sender right now
$Email::Sender::Manual::QuickStart::VERSION = '1.300035';
#pod =head1 QUICK START
#pod
#pod =head2 Let's Send Some Mail!
#pod
#pod No messing around, let's just send some mail.
#pod
#pod use strict;
#pod use Email::Sender::Simple qw(sendmail);
#pod use Email::MIME;
#pod
#pod # You can make an email object in lots of ways. Pick one you like!
#pod my $email = Email::MIME->create(...);
#pod
#pod sendmail($email);
#pod
#pod That's it. Your message goes out into the internet and tries to get delivered
#pod to C<x.ample@example.com>.
#pod
#pod In the example above, C<$email> could be an Email::MIME object, a MIME::Entity,
#pod a string containing an email message, or one of several other types of input.
#pod If C<Email::Abstract> can understand a value, it can be passed to
#pod Email::Sender::Simple. Email::Sender::Simple tries to make a good guess about
#pod how to send the message. It will usually try to use the F<sendmail> program on
#pod unix-like systems and to use SMTP on Windows. You can specify a transport, if
#pod you need to, but normally that shouldn't be an issue. (See L</Picking a
#pod Transport>, though, for more information.)
#pod
#pod Also note that we imported and used a C<sendmail> routine in the example above.
#pod This is exactly the same as saying:
#pod
#pod Email::Sender::Simple->send($email);
#pod
#pod ...but it's a lot easier to type. You can use either one.
#pod
#pod =head3 envelope information
#pod
#pod We didn't have to tell Email::Sender::Simple where to send the message. If you
#pod don't specify recipients, it will use all the email addresses it can find in
#pod the F<To> and F<Cc> headers by default. It will use L<Email::Address> to parse
#pod those fields. Similarly, if no sender is specified, it will use the first
#pod address found in the F<From> header.
#pod
#pod In most email transmission systems, though, the headers are not by necessity
#pod tied to the addresses used as the sender and recipients. For example, your
#pod message header might say "From: mailing-list@example.com" while your SMTP
#pod client says "MAIL FROM:E<lt>verp-1234@lists.example.comE<gt>". This is a
#pod powerful feature, and is necessary for many email application. Being able to
#pod set those distinctly is important, and Email::Sender::Simple lets you do this:
#pod
#pod sendmail($email, { to => [ $to_1, $to_2 ], from => $sender });
#pod
#pod =head3 in case of error
#pod
#pod When the message is sent successfully (at least on to its next hop),
#pod C<sendmail> will return a true value -- specifically, an
#pod L<Email::Sender::Success> object. This object only rarely has much use.
#pod What's more useful is what happens if the message can't be sent.
#pod
#pod If there is an error sending the message, an exception will be thrown. It will
#pod be an object belonging to the class L<Email::Sender::Failure>. This object
#pod will have a C<message> attribute describing the nature of the failure. There
#pod are several specialized forms of failure, like
#pod L<Email::Sender::Failure::Multi>, which is thrown when more than one error is
#pod encountered when trying to send. You don't need to know about these to use
#pod Email::Sender::Simple, though. All you need to know is that C<sendmail>
#pod returns true on success and dies on failure.
#pod
#pod If you'd rather not have to catch exceptions for failure to send mail, you can
#pod use the C<try_to_send> method, which can be imported as C<try_to_sendmail>.
#pod This method will return just false on failure to send mail.
#pod
#pod For example:
#pod
#pod Email::Sender::Simple->try_to_send($email, { ... });
#pod
#pod use Email::Sender::Simple qw(try_to_sendmail);
#pod try_to_sendmail($email, { ... });
#pod
#pod Some Email::Sender transports can signal success if some, but not all,
#pod recipients could be reached. Email::Sender::Simple does its best to ensure
#pod that this never happens. When you are using Email::Sender::Simple, mail should
#pod either be sent or not. Partial success should never occur.
#pod
#pod =head2 Picking a Transport
#pod
#pod =head3 passing in your own transport
#pod
#pod If Email::Sender::Simple doesn't pick the transport you want, or if you have
#pod more specific needs, you can specify a transport in several ways. The simplest
#pod is to build a transport object and pass it in. You can read more about
#pod transports elsewhere. For now, we'll just assume that you need to send mail
#pod via SMTP on an unusual port. You can send mail like this:
#pod
#pod my $transport = Email::Sender::Transport::SMTP->new({
#pod host => 'smtp.example.com',
#pod port => 2525,
#pod });
#pod
#pod sendmail($email, { transport => $transport });
#pod
#pod Now, instead of guessing at what transport to use, Email::Sender::Simple will
#pod use the one you provided. This transport will have to be specified for each
#pod call to C<sendmail>, so you might want to look at other options, which follow.
#pod
#pod =head3 specifying transport in the environment
#pod
#pod If you have a program that makes several calls to Email::Sender::Simple, and
#pod you need to run this program using a different mailserver, you can set
#pod environment variables to change the default. For example:
#pod
#pod $ export EMAIL_SENDER_TRANSPORT=SMTP
#pod $ export EMAIL_SENDER_TRANSPORT_host=smtp.example.com
#pod $ export EMAIL_SENDER_TRANSPORT_port=2525
#pod
#pod $ perl your-program
#pod
#pod It is important to note that if you have set the default transport by using the
#pod environment, I<< no subsequent C<transport> args to C<sendmail> will be
#pod respected >>. If you set the default transport via the environment, that's it.
#pod Everything will use that transport. (Also, note that while we gave the host and
#pod port arguments above in lower case, the casing of arguments in the environment
#pod is flattened to support systems where environment variables are of a fixed
#pod case. So, C<EMAIL_SENDER_TRANSPORT_PORT> would also work.
#pod
#pod This is extremely valuable behavior, as it allows you to audit every message
#pod that would be sent by a program by running something like this:
#pod
#pod $ export EMAIL_SENDER_TRANSPORT=Maildir
#pod $ perl your-program
#pod
#pod In that example, any message sent via Email::Sender::Simple would be delivered
#pod to a maildir in the current directory.
#pod
#pod =head3 subclassing to change the default transport
#pod
#pod If you want to use a library that will behave like Email::Sender::Simple but
#pod with a different default transport, you can subclass Email::Sender::Simple and
#pod replace the C<build_default_transport> method.
#pod
#pod =head2 Testing
#pod
#pod Email::Sender::Simple makes it very, very easy to test code that sends email.
#pod The simplest way is to do something like this:
#pod
#pod use Test::More;
#pod BEGIN { $ENV{EMAIL_SENDER_TRANSPORT} = 'Test' }
#pod use YourCode;
#pod
#pod YourCode->run;
#pod
#pod my @deliveries = Email::Sender::Simple->default_transport->deliveries;
#pod
#pod Now you've got an array containing every delivery performed through
#pod Email::Sender::Simple, in order. Because you set the transport via the
#pod environment, no other code will be able to force a different transport.
#pod
#pod When testing code that forks, L<Email::Sender::Transport::SQLite> can be used
#pod to allow every child process to deliver to a single, easy to inspect
#pod destination database.
#pod
#pod =head2 Hey, where's my Bcc support?
#pod
#pod A common question is "Why doesn't Email::Sender::Simple automatically respect
#pod my Bcc header?" This is often combined with, "Here is a patch to 'fix' it."
#pod This is not a bug or oversight. Bcc is being ignored intentionally for now
#pod because simply adding the Bcc addresses to the message recipients would not
#pod produce the usually-desired behavior.
#pod
#pod For example, here is a set of headers:
#pod
#pod From: sender@example.com
#pod To: to_rcpt@example.com
#pod Cc: cc_rcpt@example.com
#pod Bcc: the_boss@example.com
#pod
#pod In this case, we'd expect the message to be delivered to three people:
#pod to_rcpt, cc_rcpt, and the_boss. This is why it's often suggested that the
#pod Bcc header should be a source for envelope recipients. In fact, though, a
#pod message with a Bcc header should probably be delivered I<only> to the Bcc
#pod recipients. The "B" in Bcc means "blind." The other recipients should not
#pod see who has been Bcc'd. This means you want to send I<two> messages: one to
#pod to_rcpt and cc_rcpt, with no Bcc header present; and another to the_boss
#pod only, with the Bcc header. B<If you just pick up Bcc addresses as
#pod recipients, everyone will see who was Bcc'd.>
#pod
#pod Email::Sender::Simple promises to send messages atomically. That is: it
#pod won't deliver to only some of the recipients, and not to others. That means
#pod it can't automatically detect the Bcc header and make two deliveries. There
#pod would be a possibility for the second to fail after the first succeeded,
#pod which would break the promise of a pure failure or success.
#pod
#pod The other strategy for dealing with Bcc is to remove the Bcc header from the
#pod message and then inject the message with an envelope including the Bcc
#pod addresses. The envelope information will not be visible to the final
#pod recipients, so this is safe. Unfortunately, this requires modifying the
#pod message, and Email::Sender::Simple should not be altering the mutable email
#pod object passed to it. There is no C<clone> method on Email::Abstract, so it
#pod cannot just build a clone and modify that, either. When such a method
#pod exists, Bcc handling may be possible.
#pod
#pod =head3 Example Bcc Handling
#pod
#pod If you want to support the Bcc header now, it is up to you to deal with how
#pod you want to munge the mail and inject the (possibly) munged copies into your
#pod outbound mailflow. It is not reasonable to suggest that
#pod Email::Sender::Simple do this job.
#pod
#pod =head4 Example 1: Explicitly set the envelope recipients for Bcc recipients
#pod
#pod Create the email without a Bcc header, send it to the Bcc users explicitly
#pod and then send it to the To/Cc users implicitly.
#pod
#pod my $message = create_email_mime_msg; # <- whatever you do to get the message
#pod
#pod $message->header_set('bcc'); # delete the Bcc header before sending
#pod sendmail($message, { to => $rcpt }); # send to explicit Bcc address
#pod sendmail($message); # and then send as normal
#pod
#pod =head4 Example 2: Explicitly set the envelope recipients for all recipients
#pod
#pod You can make a single call to C<sendmail> by pulling all the recipient
#pod addresses from the headers yourself and specifying all the envelope
#pod recipients once. Again, delete the Bcc header before the message is sent.
#pod
#pod =head1 SEE ALSO
#pod
#pod =head2 This is awesome! Where can I learn more?
#pod
#pod Have a look at L<Email::Sender::Manual>, where all the manual's documents are
#pod listed. You can also look at the documentation for L<Email::Sender::Simple>
#pod and the various Email::Sender::Transport classes.
#pod
#pod =cut
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Manual::QuickStart - how to start using Email::Sender right now
=head1 VERSION
version 1.300035
=head1 QUICK START
=head2 Let's Send Some Mail!
No messing around, let's just send some mail.
use strict;
use Email::Sender::Simple qw(sendmail);
use Email::MIME;
# You can make an email object in lots of ways. Pick one you like!
my $email = Email::MIME->create(...);
sendmail($email);
That's it. Your message goes out into the internet and tries to get delivered
to C<x.ample@example.com>.
In the example above, C<$email> could be an Email::MIME object, a MIME::Entity,
a string containing an email message, or one of several other types of input.
If C<Email::Abstract> can understand a value, it can be passed to
Email::Sender::Simple. Email::Sender::Simple tries to make a good guess about
how to send the message. It will usually try to use the F<sendmail> program on
unix-like systems and to use SMTP on Windows. You can specify a transport, if
you need to, but normally that shouldn't be an issue. (See L</Picking a
Transport>, though, for more information.)
Also note that we imported and used a C<sendmail> routine in the example above.
This is exactly the same as saying:
Email::Sender::Simple->send($email);
...but it's a lot easier to type. You can use either one.
=head3 envelope information
We didn't have to tell Email::Sender::Simple where to send the message. If you
don't specify recipients, it will use all the email addresses it can find in
the F<To> and F<Cc> headers by default. It will use L<Email::Address> to parse
those fields. Similarly, if no sender is specified, it will use the first
address found in the F<From> header.
In most email transmission systems, though, the headers are not by necessity
tied to the addresses used as the sender and recipients. For example, your
message header might say "From: mailing-list@example.com" while your SMTP
client says "MAIL FROM:E<lt>verp-1234@lists.example.comE<gt>". This is a
powerful feature, and is necessary for many email application. Being able to
set those distinctly is important, and Email::Sender::Simple lets you do this:
sendmail($email, { to => [ $to_1, $to_2 ], from => $sender });
=head3 in case of error
When the message is sent successfully (at least on to its next hop),
C<sendmail> will return a true value -- specifically, an
L<Email::Sender::Success> object. This object only rarely has much use.
What's more useful is what happens if the message can't be sent.
If there is an error sending the message, an exception will be thrown. It will
be an object belonging to the class L<Email::Sender::Failure>. This object
will have a C<message> attribute describing the nature of the failure. There
are several specialized forms of failure, like
L<Email::Sender::Failure::Multi>, which is thrown when more than one error is
encountered when trying to send. You don't need to know about these to use
Email::Sender::Simple, though. All you need to know is that C<sendmail>
returns true on success and dies on failure.
If you'd rather not have to catch exceptions for failure to send mail, you can
use the C<try_to_send> method, which can be imported as C<try_to_sendmail>.
This method will return just false on failure to send mail.
For example:
Email::Sender::Simple->try_to_send($email, { ... });
use Email::Sender::Simple qw(try_to_sendmail);
try_to_sendmail($email, { ... });
Some Email::Sender transports can signal success if some, but not all,
recipients could be reached. Email::Sender::Simple does its best to ensure
that this never happens. When you are using Email::Sender::Simple, mail should
either be sent or not. Partial success should never occur.
=head2 Picking a Transport
=head3 passing in your own transport
If Email::Sender::Simple doesn't pick the transport you want, or if you have
more specific needs, you can specify a transport in several ways. The simplest
is to build a transport object and pass it in. You can read more about
transports elsewhere. For now, we'll just assume that you need to send mail
via SMTP on an unusual port. You can send mail like this:
my $transport = Email::Sender::Transport::SMTP->new({
host => 'smtp.example.com',
port => 2525,
});
sendmail($email, { transport => $transport });
Now, instead of guessing at what transport to use, Email::Sender::Simple will
use the one you provided. This transport will have to be specified for each
call to C<sendmail>, so you might want to look at other options, which follow.
=head3 specifying transport in the environment
If you have a program that makes several calls to Email::Sender::Simple, and
you need to run this program using a different mailserver, you can set
environment variables to change the default. For example:
$ export EMAIL_SENDER_TRANSPORT=SMTP
$ export EMAIL_SENDER_TRANSPORT_host=smtp.example.com
$ export EMAIL_SENDER_TRANSPORT_port=2525
$ perl your-program
It is important to note that if you have set the default transport by using the
environment, I<< no subsequent C<transport> args to C<sendmail> will be
respected >>. If you set the default transport via the environment, that's it.
Everything will use that transport. (Also, note that while we gave the host and
port arguments above in lower case, the casing of arguments in the environment
is flattened to support systems where environment variables are of a fixed
case. So, C<EMAIL_SENDER_TRANSPORT_PORT> would also work.
This is extremely valuable behavior, as it allows you to audit every message
that would be sent by a program by running something like this:
$ export EMAIL_SENDER_TRANSPORT=Maildir
$ perl your-program
In that example, any message sent via Email::Sender::Simple would be delivered
to a maildir in the current directory.
=head3 subclassing to change the default transport
If you want to use a library that will behave like Email::Sender::Simple but
with a different default transport, you can subclass Email::Sender::Simple and
replace the C<build_default_transport> method.
=head2 Testing
Email::Sender::Simple makes it very, very easy to test code that sends email.
The simplest way is to do something like this:
use Test::More;
BEGIN { $ENV{EMAIL_SENDER_TRANSPORT} = 'Test' }
use YourCode;
YourCode->run;
my @deliveries = Email::Sender::Simple->default_transport->deliveries;
Now you've got an array containing every delivery performed through
Email::Sender::Simple, in order. Because you set the transport via the
environment, no other code will be able to force a different transport.
When testing code that forks, L<Email::Sender::Transport::SQLite> can be used
to allow every child process to deliver to a single, easy to inspect
destination database.
=head2 Hey, where's my Bcc support?
A common question is "Why doesn't Email::Sender::Simple automatically respect
my Bcc header?" This is often combined with, "Here is a patch to 'fix' it."
This is not a bug or oversight. Bcc is being ignored intentionally for now
because simply adding the Bcc addresses to the message recipients would not
produce the usually-desired behavior.
For example, here is a set of headers:
From: sender@example.com
To: to_rcpt@example.com
Cc: cc_rcpt@example.com
Bcc: the_boss@example.com
In this case, we'd expect the message to be delivered to three people:
to_rcpt, cc_rcpt, and the_boss. This is why it's often suggested that the
Bcc header should be a source for envelope recipients. In fact, though, a
message with a Bcc header should probably be delivered I<only> to the Bcc
recipients. The "B" in Bcc means "blind." The other recipients should not
see who has been Bcc'd. This means you want to send I<two> messages: one to
to_rcpt and cc_rcpt, with no Bcc header present; and another to the_boss
only, with the Bcc header. B<If you just pick up Bcc addresses as
recipients, everyone will see who was Bcc'd.>
Email::Sender::Simple promises to send messages atomically. That is: it
won't deliver to only some of the recipients, and not to others. That means
it can't automatically detect the Bcc header and make two deliveries. There
would be a possibility for the second to fail after the first succeeded,
which would break the promise of a pure failure or success.
The other strategy for dealing with Bcc is to remove the Bcc header from the
message and then inject the message with an envelope including the Bcc
addresses. The envelope information will not be visible to the final
recipients, so this is safe. Unfortunately, this requires modifying the
message, and Email::Sender::Simple should not be altering the mutable email
object passed to it. There is no C<clone> method on Email::Abstract, so it
cannot just build a clone and modify that, either. When such a method
exists, Bcc handling may be possible.
=head3 Example Bcc Handling
If you want to support the Bcc header now, it is up to you to deal with how
you want to munge the mail and inject the (possibly) munged copies into your
outbound mailflow. It is not reasonable to suggest that
Email::Sender::Simple do this job.
=head4 Example 1: Explicitly set the envelope recipients for Bcc recipients
Create the email without a Bcc header, send it to the Bcc users explicitly
and then send it to the To/Cc users implicitly.
my $message = create_email_mime_msg; # <- whatever you do to get the message
$message->header_set('bcc'); # delete the Bcc header before sending
sendmail($message, { to => $rcpt }); # send to explicit Bcc address
sendmail($message); # and then send as normal
=head4 Example 2: Explicitly set the envelope recipients for all recipients
You can make a single call to C<sendmail> by pulling all the recipient
addresses from the headers yourself and specifying all the envelope
recipients once. Again, delete the Bcc header before the message is sent.
=head1 SEE ALSO
=head2 This is awesome! Where can I learn more?
Have a look at L<Email::Sender::Manual>, where all the manual's documents are
listed. You can also look at the documentation for L<Email::Sender::Simple>
and the various Email::Sender::Transport classes.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

184
database/perl/vendor/lib/Email/Sender/Role/CommonSending.pm vendored Normal file
View File

@@ -0,0 +1,184 @@
package Email::Sender::Role::CommonSending;
# ABSTRACT: the common sending tasks most Email::Sender classes will need
$Email::Sender::Role::CommonSending::VERSION = '1.300035';
use Moo::Role;
use Carp ();
use Email::Abstract 3.006;
use Email::Sender::Success;
use Email::Sender::Failure::Temporary;
use Email::Sender::Failure::Permanent;
use Scalar::Util ();
use Try::Tiny;
#pod =head1 DESCRIPTION
#pod
#pod Email::Sender::Role::CommonSending provides a number of features that should
#pod ease writing new classes that perform the L<Email::Sender> role. Instead of
#pod writing a C<send> method, implementors will need to write a smaller
#pod C<send_email> method, which will be passed an L<Email::Abstract> object and
#pod envelope containing C<from> and C<to> entries. The C<to> entry will be
#pod guaranteed to be an array reference.
#pod
#pod A C<success> method will also be provided as a shortcut for calling:
#pod
#pod Email::Sender::Success->new(...);
#pod
#pod A few other minor details are handled by CommonSending; for more information,
#pod consult the source.
#pod
#pod The methods documented here may be overridden to alter the behavior of the
#pod CommonSending role.
#pod
#pod =cut
with 'Email::Sender';
requires 'send_email';
sub send {
my ($self, $message, $env, @rest) = @_;
my $email = $self->prepare_email($message);
my $envelope = $self->prepare_envelope($env);
try {
return $self->send_email($email, $envelope, @rest);
} catch {
Carp::confess('unknown error') unless my $err = $_;
if (
try { $err->isa('Email::Sender::Failure') }
and ! (my @tmp = $err->recipients)
) {
$err->_set_recipients([ @{ $envelope->{to} } ]);
}
die $err;
}
}
#pod =method prepare_email
#pod
#pod This method is passed a scalar and is expected to return an Email::Abstract
#pod object. You probably shouldn't override it in most cases.
#pod
#pod =cut
sub prepare_email {
my ($self, $msg) = @_;
Carp::confess("no email passed in to sender") unless defined $msg;
# We check blessed because if someone would pass in a large message, in some
# perls calling isa on the string would create a package with the string as
# the name. If the message was (say) two megs, now you'd have a two meg hash
# key in the stash. Oops! -- rjbs, 2008-12-04
return $msg if Scalar::Util::blessed($msg) and eval { $msg->isa('Email::Abstract') };
return Email::Abstract->new($msg);
}
#pod =method prepare_envelope
#pod
#pod This method is passed a hashref and returns a new hashref that should be used
#pod as the envelope passed to the C<send_email> method. This method is responsible
#pod for ensuring that the F<to> entry is an array.
#pod
#pod =cut
sub prepare_envelope {
my ($self, $env) = @_;
my %new_env;
$new_env{to} = ref $env->{to} ? $env->{to} : [ grep {defined} $env->{to} ];
$new_env{from} = $env->{from};
return \%new_env;
}
#pod =method success
#pod
#pod ...
#pod return $self->success;
#pod
#pod This method returns a new Email::Sender::Success object. Arguments passed to
#pod this method are passed along to the Success's constructor. This is provided as
#pod a convenience for returning success from subclasses' C<send_email> methods.
#pod
#pod =cut
sub success {
my $self = shift;
my $success = Email::Sender::Success->new(@_);
}
no Moo::Role;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Role::CommonSending - the common sending tasks most Email::Sender classes will need
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
Email::Sender::Role::CommonSending provides a number of features that should
ease writing new classes that perform the L<Email::Sender> role. Instead of
writing a C<send> method, implementors will need to write a smaller
C<send_email> method, which will be passed an L<Email::Abstract> object and
envelope containing C<from> and C<to> entries. The C<to> entry will be
guaranteed to be an array reference.
A C<success> method will also be provided as a shortcut for calling:
Email::Sender::Success->new(...);
A few other minor details are handled by CommonSending; for more information,
consult the source.
The methods documented here may be overridden to alter the behavior of the
CommonSending role.
=head1 METHODS
=head2 prepare_email
This method is passed a scalar and is expected to return an Email::Abstract
object. You probably shouldn't override it in most cases.
=head2 prepare_envelope
This method is passed a hashref and returns a new hashref that should be used
as the envelope passed to the C<send_email> method. This method is responsible
for ensuring that the F<to> entry is an array.
=head2 success
...
return $self->success;
This method returns a new Email::Sender::Success object. Arguments passed to
this method are passed along to the Success's constructor. This is provided as
a convenience for returning success from subclasses' C<send_email> methods.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

51
database/perl/vendor/lib/Email/Sender/Role/HasMessage.pm vendored Normal file
View File

@@ -0,0 +1,51 @@
package Email::Sender::Role::HasMessage;
# ABSTRACT: an object that has a message
$Email::Sender::Role::HasMessage::VERSION = '1.300035';
use Moo::Role;
#pod =attr message
#pod
#pod This attribute is a message associated with the object.
#pod
#pod =cut
has message => (
is => 'ro',
required => 1,
);
no Moo::Role;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Role::HasMessage - an object that has a message
=head1 VERSION
version 1.300035
=head1 ATTRIBUTES
=head2 message
This attribute is a message associated with the object.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

200
database/perl/vendor/lib/Email/Sender/Simple.pm vendored Normal file
View File

@@ -0,0 +1,200 @@
package Email::Sender::Simple;
# ABSTRACT: the simple interface for sending mail with Sender
$Email::Sender::Simple::VERSION = '1.300035';
use Moo;
with 'Email::Sender::Role::CommonSending';
#pod =head1 SEE INSTEAD
#pod
#pod For now, the best documentation of this class is in
#pod L<Email::Sender::Manual::QuickStart>.
#pod
#pod =cut
use Sub::Exporter::Util ();
use Sub::Exporter -setup => {
exports => {
sendmail => Sub::Exporter::Util::curry_class('send'),
try_to_sendmail => Sub::Exporter::Util::curry_class('try_to_send'),
},
};
use Email::Address;
use Email::Sender::Transport;
use Email::Sender::Util;
use Try::Tiny;
{
my $DEFAULT_TRANSPORT;
my $DEFAULT_FROM_ENV;
sub _default_was_from_env {
my ($class) = @_;
$class->default_transport;
return $DEFAULT_FROM_ENV;
}
sub transport_from_env {
my ($class, $env_base) = @_;
$env_base ||= 'EMAIL_SENDER_TRANSPORT';
my $transport_class = $ENV{$env_base};
return unless defined $transport_class and length $transport_class;
my %arg;
for my $key (grep { /^\Q$env_base\E_[_0-9A-Za-z]+$/ } keys %ENV) {
(my $new_key = $key) =~ s/^\Q$env_base\E_//;
$arg{lc $new_key} = $ENV{$key};
}
return Email::Sender::Util->easy_transport($transport_class, \%arg);
}
sub default_transport {
return $DEFAULT_TRANSPORT if $DEFAULT_TRANSPORT;
my ($class) = @_;
my $transport = $class->transport_from_env;
if ($transport) {
$DEFAULT_FROM_ENV = 1;
$DEFAULT_TRANSPORT = $transport;
} else {
$DEFAULT_FROM_ENV = 0;
$DEFAULT_TRANSPORT = $class->build_default_transport;
}
return $DEFAULT_TRANSPORT;
}
sub build_default_transport {
require Email::Sender::Transport::Sendmail;
my $transport = eval { Email::Sender::Transport::Sendmail->new };
return $transport if $transport;
require Email::Sender::Transport::SMTP;
Email::Sender::Transport::SMTP->new;
}
sub reset_default_transport {
undef $DEFAULT_TRANSPORT;
undef $DEFAULT_FROM_ENV;
}
}
# Maybe this should be an around, but I'm just not excited about figuring out
# order at the moment. It just has to work. -- rjbs, 2009-06-05
around prepare_envelope => sub {
my ($orig, $class, $arg) = @_;
$arg ||= {};
my $env = $class->$orig($arg);
$env = {
%$arg,
%$env,
};
return $env;
};
sub send_email {
my ($class, $email, $arg) = @_;
my $transport = $class->default_transport;
if ($arg->{transport}) {
$arg = { %$arg }; # So we can delete transport without ill effects.
$transport = delete $arg->{transport} unless $class->_default_was_from_env;
}
Carp::confess("transport $transport not safe for use with Email::Sender::Simple")
unless $transport->is_simple;
my ($to, $from) = $class->_get_to_from($email, $arg);
Email::Sender::Failure::Permanent->throw("no recipients") if ! @$to;
Email::Sender::Failure::Permanent->throw("no sender") if ! defined $from;
return $transport->send(
$email,
{
to => $to,
from => $from,
},
);
}
sub try_to_send {
my ($class, $email, $arg) = @_;
try {
return $class->send($email, $arg);
} catch {
my $error = $_ || 'unknown error';
return if try { $error->isa('Email::Sender::Failure') };
die $error;
};
}
sub _get_to_from {
my ($class, $email, $arg) = @_;
my $to = $arg->{to};
unless (@$to) {
my @to_addrs =
map { $_->address }
grep { defined }
map { Email::Address->parse($_) }
map { $email->get_header($_) }
qw(to cc);
$to = \@to_addrs;
}
my $from = $arg->{from};
unless (defined $from) {
($from) =
map { $_->address }
grep { defined }
map { Email::Address->parse($_) }
map { $email->get_header($_) }
qw(from);
}
return ($to, $from);
}
no Moo;
"220 OK";
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Simple - the simple interface for sending mail with Sender
=head1 VERSION
version 1.300035
=head1 SEE INSTEAD
For now, the best documentation of this class is in
L<Email::Sender::Manual::QuickStart>.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

46
database/perl/vendor/lib/Email/Sender/Success.pm vendored Normal file
View File

@@ -0,0 +1,46 @@
package Email::Sender::Success;
# ABSTRACT: the result of successfully sending mail
$Email::Sender::Success::VERSION = '1.300035';
use Moo;
#pod =head1 DESCRIPTION
#pod
#pod An Email::Sender::Success object is just an indicator that an email message was
#pod successfully sent. Unless extended, it has no properties of its own.
#pod
#pod =cut
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Success - the result of successfully sending mail
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
An Email::Sender::Success object is just an indicator that an email message was
successfully sent. Unless extended, it has no properties of its own.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

59
database/perl/vendor/lib/Email/Sender/Success/Partial.pm vendored Normal file
View File

@@ -0,0 +1,59 @@
package Email::Sender::Success::Partial;
# ABSTRACT: a report of partial success when delivering
$Email::Sender::Success::Partial::VERSION = '1.300035';
use Moo;
extends 'Email::Sender::Success';
use MooX::Types::MooseLike::Base qw(InstanceOf);
#pod =head1 DESCRIPTION
#pod
#pod These objects indicate that some delivery was accepted for some recipients and
#pod not others. The success object's C<failure> attribute will return a
#pod L<Email::Sender::Failure::Multi> describing which parts of the delivery failed.
#pod
#pod =cut
use Email::Sender::Failure::Multi;
has failure => (
is => 'ro',
isa => InstanceOf['Email::Sender::Failure::Multi'],
required => 1,
);
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Success::Partial - a report of partial success when delivering
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
These objects indicate that some delivery was accepted for some recipients and
not others. The success object's C<failure> attribute will return a
L<Email::Sender::Failure::Multi> describing which parts of the delivery failed.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

90
database/perl/vendor/lib/Email/Sender/Transport.pm vendored Normal file
View File

@@ -0,0 +1,90 @@
package Email::Sender::Transport;
# ABSTRACT: a role for email transports
$Email::Sender::Transport::VERSION = '1.300035';
use Moo::Role;
#pod =head1 DESCRIPTION
#pod
#pod Email::Sender::Transport is a Moo role to aid in writing classes used to send
#pod mail. For the most part, its behavior comes entirely from the role
#pod L<Email::Sender::Role::CommonSending>, which it includes. The important
#pod difference is that Transports are often intended to be used by
#pod L<Email::Sender::Simple>, and they provide two methods related to that purpose.
#pod
#pod =for Pod::Coverage is_simple allow_partial_success
#pod
#pod First, they provide an C<allow_partial_success> method which returns true or
#pod false to indicate whether the transport will ever signal partial success.
#pod
#pod Second, they provide an C<is_simple> method, which returns true if the
#pod transport is suitable for use with Email::Sender::Simple. By default, this
#pod method returns the inverse of C<allow_partial_success>.
#pod
#pod It is B<imperative> that these methods be accurate to prevent
#pod Email::Sender::Simple users from sending partially successful transmissions.
#pod Partial success is a complex case that almost all users will wish to avoid at
#pod all times.
#pod
#pod =cut
with 'Email::Sender::Role::CommonSending';
sub is_simple {
my ($self) = @_;
return if $self->allow_partial_success;
return 1;
}
sub allow_partial_success { 0 }
no Moo::Role;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Transport - a role for email transports
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
Email::Sender::Transport is a Moo role to aid in writing classes used to send
mail. For the most part, its behavior comes entirely from the role
L<Email::Sender::Role::CommonSending>, which it includes. The important
difference is that Transports are often intended to be used by
L<Email::Sender::Simple>, and they provide two methods related to that purpose.
=for Pod::Coverage is_simple allow_partial_success
First, they provide an C<allow_partial_success> method which returns true or
false to indicate whether the transport will ever signal partial success.
Second, they provide an C<is_simple> method, which returns true if the
transport is suitable for use with Email::Sender::Simple. By default, this
method returns the inverse of C<allow_partial_success>.
It is B<imperative> that these methods be accurate to prevent
Email::Sender::Simple users from sending partially successful transmissions.
Partial success is a complex case that almost all users will wish to avoid at
all times.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

49
database/perl/vendor/lib/Email/Sender/Transport/DevNull.pm vendored Normal file
View File

@@ -0,0 +1,49 @@
package Email::Sender::Transport::DevNull;
# ABSTRACT: happily throw away your mail
$Email::Sender::Transport::DevNull::VERSION = '1.300035';
use Moo;
with 'Email::Sender::Transport';
#pod =head1 DESCRIPTION
#pod
#pod This class implements L<Email::Sender::Transport>. Any mail sent through a
#pod DevNull transport will be silently discarded.
#pod
#pod =cut
sub send_email { return $_[0]->success }
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Transport::DevNull - happily throw away your mail
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
This class implements L<Email::Sender::Transport>. Any mail sent through a
DevNull transport will be silently discarded.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

92
database/perl/vendor/lib/Email/Sender/Transport/Failable.pm vendored Normal file
View File

@@ -0,0 +1,92 @@
package Email::Sender::Transport::Failable;
# ABSTRACT: a wrapper to makes things fail predictably
$Email::Sender::Transport::Failable::VERSION = '1.300035';
use Moo;
extends 'Email::Sender::Transport::Wrapper';
use MooX::Types::MooseLike::Base qw(ArrayRef);
#pod =head1 DESCRIPTION
#pod
#pod This transport extends L<Email::Sender::Transport::Wrapper>, meaning that it
#pod must be created with a C<transport> attribute of another
#pod Email::Sender::Transport. It will proxy all email sending to that transport,
#pod but only after first deciding if it should fail.
#pod
#pod It does this by calling each coderef in its C<failure_conditions> attribute,
#pod which must be an arrayref of code references. Each coderef will be called and
#pod will be passed the Failable transport, the Email::Abstract object, the
#pod envelope, and a reference to an array containing the rest of the arguments to
#pod C<send>.
#pod
#pod If any coderef returns a true value, the value will be used to signal failure.
#pod
#pod =cut
has 'failure_conditions' => (
isa => ArrayRef,
default => sub { [] },
is => 'ro',
reader => '_failure_conditions',
);
sub failure_conditions { @{$_[0]->_failure_conditions} }
sub fail_if { push @{shift->_failure_conditions}, @_ }
sub clear_failure_conditions { @{$_[0]->{failure_conditions}} = () }
around send_email => sub {
my ($orig, $self, $email, $env, @rest) = @_;
for my $cond ($self->failure_conditions) {
my $reason = $cond->($self, $email, $env, \@rest);
next unless $reason;
die (ref $reason ? $reason : Email::Sender::Failure->new($reason));
}
return $self->$orig($email, $env, @rest);
};
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Transport::Failable - a wrapper to makes things fail predictably
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
This transport extends L<Email::Sender::Transport::Wrapper>, meaning that it
must be created with a C<transport> attribute of another
Email::Sender::Transport. It will proxy all email sending to that transport,
but only after first deciding if it should fail.
It does this by calling each coderef in its C<failure_conditions> attribute,
which must be an arrayref of code references. Each coderef will be called and
will be passed the Failable transport, the Email::Abstract object, the
envelope, and a reference to an array containing the rest of the arguments to
C<send>.
If any coderef returns a true value, the value will be used to signal failure.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

222
database/perl/vendor/lib/Email/Sender/Transport/Maildir.pm vendored Normal file
View File

@@ -0,0 +1,222 @@
package Email::Sender::Transport::Maildir;
# ABSTRACT: deliver mail to a maildir on disk
$Email::Sender::Transport::Maildir::VERSION = '1.300035';
use Moo;
with 'Email::Sender::Transport';
use Errno ();
use Fcntl;
use File::Path 2.06;
use File::Spec;
use Sys::Hostname;
use MooX::Types::MooseLike::Base qw(Bool);
#pod =head1 DESCRIPTION
#pod
#pod This transport delivers into a maildir. The maildir's location may be given as
#pod the F<dir> argument to the constructor, and defaults to F<Maildir> in the
#pod current directory (at the time of transport initialization).
#pod
#pod If the directory does not exist, it will be created.
#pod
#pod By default, three headers will be added:
#pod
#pod * X-Email-Sender-From - the envelope sender
#pod * X-Email-Sender-To - the envelope recipients (one header per rcpt)
#pod * Lines - the number of lines in the body
#pod
#pod These can be controlled with the C<add_lines_header> and
#pod C<add_envelope_headers> constructor arguments.
#pod
#pod The L<Email::Sender::Success> object returned on success has a C<filename>
#pod method that returns the filename to which the message was delivered.
#pod
#pod =cut
{
package
Email::Sender::Success::MaildirSuccess;
use Moo;
use MooX::Types::MooseLike::Base qw(Str);
extends 'Email::Sender::Success';
has filename => (
is => 'ro',
isa => Str,
required => 1,
);
no Moo;
}
my $HOSTNAME;
BEGIN { ($HOSTNAME = hostname) =~ s/\..*//; }
sub _hostname { $HOSTNAME }
my $MAILDIR_TIME = 0;
my $MAILDIR_COUNTER = 0;
has [ qw(add_lines_header add_envelope_headers) ] => (
is => 'ro',
isa => Bool,
default => sub { 1 },
);
has dir => (
is => 'ro',
required => 1,
default => sub { File::Spec->catdir(File::Spec->curdir, 'Maildir') },
);
sub send_email {
my ($self, $email, $env) = @_;
my $dupe = Email::Abstract->new(\do { $email->as_string });
if ($self->add_envelope_headers) {
$dupe->set_header('X-Email-Sender-From' =>
(defined $env->{from} ? $env->{from} : '-'),
);
my @to = grep {; defined } @{ $env->{to} };
$dupe->set_header('X-Email-Sender-To' => (@to ? @to : '-'));
}
$self->_ensure_maildir_exists;
$self->_add_lines_header($dupe) if $self->add_lines_header;
$self->_update_time;
my $fn = $self->_deliver_email($dupe);
return Email::Sender::Success::MaildirSuccess->new({
filename => $fn,
});
}
sub _ensure_maildir_exists {
my ($self) = @_;
for my $dir (qw(cur tmp new)) {
my $subdir = File::Spec->catdir($self->dir, $dir);
next if -d $subdir;
Email::Sender::Failure->throw("couldn't create $subdir: $!")
unless File::Path::make_path($subdir) || -d $subdir;
}
}
sub _add_lines_header {
my ($class, $email) = @_;
return if $email->get_header("Lines");
my $lines = $email->get_body =~ tr/\n/\n/;
$email->set_header("Lines", $lines);
}
sub _update_time {
my $time = time;
if ($MAILDIR_TIME != $time) {
$MAILDIR_TIME = $time;
$MAILDIR_COUNTER = 0;
} else {
$MAILDIR_COUNTER++;
}
}
sub _deliver_email {
my ($self, $email) = @_;
my ($tmp_filename, $tmp_fh) = $self->_delivery_fh;
# if (eval { $email->can('stream_to') }) {
# eval { $mail->stream_to($fh); 1 } or return;
#} else {
my $string = $email->as_string;
$string =~ s/\x0D\x0A/\x0A/g unless $^O eq 'MSWin32';
print $tmp_fh $string
or Email::Sender::Failure->throw("could not write to $tmp_filename: $!");
close $tmp_fh
or Email::Sender::Failure->throw("error closing $tmp_filename: $!");
my $target_name = File::Spec->catfile($self->dir, 'new', $tmp_filename);
my $ok = rename(
File::Spec->catfile($self->dir, 'tmp', $tmp_filename),
$target_name,
);
Email::Sender::Failure->throw("could not move $tmp_filename from tmp to new")
unless $ok;
return $target_name;
}
sub _delivery_fh {
my ($self) = @_;
my $hostname = $self->_hostname;
my ($filename, $fh);
until ($fh) {
$filename = join q{.}, $MAILDIR_TIME, $$, ++$MAILDIR_COUNTER, $hostname;
my $filespec = File::Spec->catfile($self->dir, 'tmp', $filename);
sysopen $fh, $filespec, O_CREAT|O_EXCL|O_WRONLY;
binmode $fh;
Email::Sender::Failure->throw("cannot create $filespec for delivery: $!")
unless $fh or $!{EEXIST};
}
return ($filename, $fh);
}
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Transport::Maildir - deliver mail to a maildir on disk
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
This transport delivers into a maildir. The maildir's location may be given as
the F<dir> argument to the constructor, and defaults to F<Maildir> in the
current directory (at the time of transport initialization).
If the directory does not exist, it will be created.
By default, three headers will be added:
* X-Email-Sender-From - the envelope sender
* X-Email-Sender-To - the envelope recipients (one header per rcpt)
* Lines - the number of lines in the body
These can be controlled with the C<add_lines_header> and
C<add_envelope_headers> constructor arguments.
The L<Email::Sender::Success> object returned on success has a C<filename>
method that returns the filename to which the message was delivered.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

150
database/perl/vendor/lib/Email/Sender/Transport/Mbox.pm vendored Normal file
View File

@@ -0,0 +1,150 @@
package Email::Sender::Transport::Mbox;
# ABSTRACT: deliver mail to an mbox on disk
$Email::Sender::Transport::Mbox::VERSION = '1.300035';
use Moo;
with 'Email::Sender::Transport';
use Carp;
use File::Path;
use File::Basename;
use IO::File 1.11; # binmode
use Email::Simple 1.998; # needed for ->header_obj
use Fcntl ':flock';
#pod =head1 DESCRIPTION
#pod
#pod This transport delivers into an mbox. The mbox file may be given by the
#pod F<filename> argument to the constructor, and defaults to F<mbox>.
#pod
#pod The transport I<currently> assumes that the mbox is in F<mboxo> format, but
#pod this may change or be configurable in the future.
#pod
#pod =cut
has 'filename' => (is => 'ro', default => sub { 'mbox' }, required => 1);
sub send_email {
my ($self, $email, $env) = @_;
my $filename = $self->filename;
my $fh = $self->_open_fh($filename);
my $ok = eval {
if ($fh->tell > 0) {
$fh->print("\n") or Carp::confess("couldn't write to $filename: $!");
}
$fh->print($self->_from_line($email, $env))
or Carp::confess("couldn't write to $filename: $!");
$fh->print($self->_escape_from_body($email))
or Carp::confess("couldn't write to $filename: $!");
# This will make streaming a bit more annoying. -- rjbs, 2007-05-25
$fh->print("\n")
or Carp::confess("couldn't write to $filename: $!")
unless $email->as_string =~ /\n$/;
$self->_close_fh($fh)
or Carp::confess "couldn't close file $filename: $!";
1;
};
die unless $ok;
# Email::Sender::Failure->throw($@ || 'unknown error') unless $ok;
return $self->success;
}
sub _open_fh {
my ($class, $file) = @_;
my $dir = dirname($file);
Carp::confess "couldn't make path $dir: $!" if not -d $dir or mkpath($dir);
my $fh = IO::File->new($file, '>>')
or Carp::confess "couldn't open $file for appending: $!";
$fh->binmode(':raw');
$class->_getlock($fh, $file);
$fh->seek(0, 2);
return $fh;
}
sub _close_fh {
my ($class, $fh, $file) = @_;
$class->_unlock($fh);
return $fh->close;
}
sub _escape_from_body {
my ($class, $email) = @_;
my $body = $email->get_body;
$body =~ s/^(From )/>$1/gm;
my $simple = $email->cast('Email::Simple');
return $simple->header_obj->as_string . $simple->crlf . $body;
}
sub _from_line {
my ($class, $email, $envelope) = @_;
my $fromtime = localtime;
$fromtime =~ s/(:\d\d) \S+ (\d{4})$/$1 $2/; # strip timezone.
return "From $envelope->{from} $fromtime\n";
}
sub _getlock {
my ($class, $fh, $fn) = @_;
for (1 .. 10) {
return 1 if flock($fh, LOCK_EX | LOCK_NB);
sleep $_;
}
Carp::confess "couldn't lock file $fn";
}
sub _unlock {
my ($class, $fh) = @_;
flock($fh, LOCK_UN);
}
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Transport::Mbox - deliver mail to an mbox on disk
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
This transport delivers into an mbox. The mbox file may be given by the
F<filename> argument to the constructor, and defaults to F<mbox>.
The transport I<currently> assumes that the mbox is in F<mboxo> format, but
this may change or be configurable in the future.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

75
database/perl/vendor/lib/Email/Sender/Transport/Print.pm vendored Normal file
View File

@@ -0,0 +1,75 @@
package Email::Sender::Transport::Print;
# ABSTRACT: print email to a filehandle (like stdout)
$Email::Sender::Transport::Print::VERSION = '1.300035';
use Moo;
with 'Email::Sender::Transport';
#pod =head1 DESCRIPTION
#pod
#pod When this transport is handed mail, it prints it to a filehandle. By default,
#pod it will print to STDOUT, but it can be given any L<IO::Handle> object to print
#pod to as its C<fh> attribute.
#pod
#pod =cut
use IO::Handle;
use MooX::Types::MooseLike::Base qw(InstanceOf);
has 'fh' => (
is => 'ro',
isa => InstanceOf['IO::Handle'],
required => 1,
default => sub { IO::Handle->new_from_fd(fileno(STDOUT), 'w') },
);
sub send_email {
my ($self, $email, $env) = @_;
my $fh = $self->fh;
$fh->printf("ENVELOPE TO : %s\n", join(q{, }, @{ $env->{to} }) || '-');
$fh->printf("ENVELOPE FROM: %s\n", defined $env->{from} ? $env->{from} : '-');
$fh->print(q{-} x 10 . " begin message\n");
$fh->print( $email->as_string );
$fh->print(q{-} x 10 . " end message\n");
return $self->success;
}
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Transport::Print - print email to a filehandle (like stdout)
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
When this transport is handed mail, it prints it to a filehandle. By default,
it will print to STDOUT, but it can be given any L<IO::Handle> object to print
to as its C<fh> attribute.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

413
database/perl/vendor/lib/Email/Sender/Transport/SMTP.pm vendored Normal file
View File

@@ -0,0 +1,413 @@
package Email::Sender::Transport::SMTP;
# ABSTRACT: send email over SMTP
$Email::Sender::Transport::SMTP::VERSION = '1.300035';
use Moo;
use Email::Sender::Failure::Multi;
use Email::Sender::Success::Partial;
use Email::Sender::Role::HasMessage ();
use Email::Sender::Util;
use MooX::Types::MooseLike::Base qw(Bool Int Str HashRef);
use Net::SMTP 3.07; # SSL support, fixed datasend
use utf8 (); # See below. -- rjbs, 2015-05-14
#pod =head1 DESCRIPTION
#pod
#pod This transport is used to send email over SMTP, either with or without secure
#pod sockets (SSL/TLS). It is one of the most complex transports available, capable
#pod of partial success.
#pod
#pod For a potentially more efficient version of this transport, see
#pod L<Email::Sender::Transport::SMTP::Persistent>.
#pod
#pod =head1 ATTRIBUTES
#pod
#pod The following attributes may be passed to the constructor:
#pod
#pod =over 4
#pod
#pod =item C<hosts>: an arrayref of names of the host to try, in order; defaults to a single element array containing C<localhost>
#pod
#pod The attribute C<host> may be given, instead, which contains a single hostname.
#pod
#pod =item C<ssl>: if 'starttls', use STARTTLS; if 'ssl' (or 1), connect securely;
#pod otherwise, no security
#pod
#pod =item C<ssl_options>: passed to Net::SMTP constructor for 'ssl' connections or
#pod to starttls for 'starttls' connections; should contain extra options for
#pod IO::Socket::SSL
#pod
#pod =item C<port>: port to connect to; defaults to 25 for non-SSL, 465 for 'ssl',
#pod 587 for 'starttls'
#pod
#pod =item C<timeout>: maximum time in secs to wait for server; default is 120
#pod
#pod =cut
sub BUILD {
my ($self) = @_;
Carp::croak("do not pass port number to SMTP transport in host, use port parameter")
if grep {; /:/ } $self->hosts;
}
sub BUILDARGS {
my ($self, @rest) = @_;
my $arg = $self->SUPER::BUILDARGS(@rest);
if (exists $arg->{host}) {
Carp::croak("can't pass both host and hosts to constructor")
if exists $arg->{hosts};
$arg->{hosts} = [ delete $arg->{host} ];
}
return $arg;
}
has ssl => (is => 'ro', isa => Str, default => sub { 0 });
has _hosts => (
is => 'ro',
isa => sub {
die "invalid hosts in Email::Sender::Transport::SMTP constructor"
unless defined $_[0]
&& (ref $_[0] eq 'ARRAY')
&& (grep {; length } @{ $_[0] }) > 0;
},
default => sub { [ 'localhost' ] },
init_arg => 'hosts',
);
sub hosts { @{ $_[0]->_hosts } }
sub host { $_[0]->_hosts->[0] }
has _security => (
is => 'ro',
lazy => 1,
init_arg => undef,
default => sub {
my $ssl = $_[0]->ssl;
return '' unless $ssl;
$ssl = lc $ssl;
return 'starttls' if 'starttls' eq $ssl;
return 'ssl' if $ssl eq 1 or $ssl eq 'ssl';
Carp::cluck(qq{true "ssl" argument to Email::Sender::Transport::SMTP should be 'ssl' or 'startls' or '1' but got '$ssl'});
return 1;
},
);
has ssl_options => (is => 'ro', isa => HashRef, default => sub { {} });
has port => (
is => 'ro',
isa => Int,
lazy => 1,
default => sub {
return $_[0]->_security eq 'starttls' ? 587
: $_[0]->_security eq 'ssl' ? 465
: 25
},
);
has timeout => (is => 'ro', isa => Int, default => sub { 120 });
#pod =item C<sasl_username>: the username to use for auth; optional
#pod
#pod =item C<sasl_password>: the password to use for auth; required if C<sasl_username> is provided
#pod
#pod =item C<allow_partial_success>: if true, will send data even if some recipients were rejected; defaults to false
#pod
#pod =cut
has sasl_username => (is => 'ro', isa => Str);
has sasl_password => (is => 'ro', isa => Str);
has allow_partial_success => (is => 'ro', isa => Bool, default => sub { 0 });
#pod =item C<helo>: what to say when saying HELO; no default
#pod
#pod =item C<localaddr>: local address from which to connect
#pod
#pod =item C<localport>: local port from which to connect
#pod
#pod =cut
has helo => (is => 'ro', isa => Str);
has localaddr => (is => 'ro');
has localport => (is => 'ro', isa => Int);
#pod =item C<debug>: if true, put the L<Net::SMTP> object in debug mode
#pod
#pod =back
#pod
#pod =cut
has debug => (is => 'ro', isa => Bool, default => sub { 0 });
# I am basically -sure- that this is wrong, but sending hundreds of millions of
# messages has shown that it is right enough. I will try to make it textbook
# later. -- rjbs, 2008-12-05
sub _quoteaddr {
my $addr = shift;
my @localparts = split /\@/, $addr;
my $domain = pop @localparts;
my $localpart = join q{@}, @localparts;
return $addr # The first regex here is RFC 821 "specials" excepting dot.
unless $localpart =~ /[\x00-\x1F\x7F<>\(\)\[\]\\,;:@"]/
or $localpart =~ /^\./
or $localpart =~ /\.$/;
return join q{@}, qq("$localpart"), $domain;
}
sub _smtp_client {
my ($self) = @_;
my $class = "Net::SMTP";
my $smtp = $class->new( $self->_net_smtp_args );
unless ($smtp) {
$self->_throw(
sprintf "unable to establish SMTP connection to (%s) port %s",
(join q{, }, $self->hosts),
$self->port,
);
}
if ($self->_security eq 'starttls') {
$self->_throw("can't STARTTLS: " . $smtp->message)
unless $smtp->starttls(%{ $self->ssl_options });
}
if ($self->sasl_username) {
$self->_throw("sasl_username but no sasl_password")
unless defined $self->sasl_password;
unless ($smtp->auth($self->sasl_username, $self->sasl_password)) {
if ($smtp->message =~ /MIME::Base64|Authen::SASL/) {
Carp::confess("SMTP auth requires MIME::Base64 and Authen::SASL");
}
$self->_throw('failed AUTH', $smtp);
}
}
return $smtp;
}
sub _net_smtp_args {
my ($self) = @_;
return (
[ $self->hosts ],
Port => $self->port,
Timeout => $self->timeout,
Debug => $self->debug,
(($self->_security eq 'ssl')
? (SSL => 1, %{ $self->ssl_options })
: ()),
defined $self->helo ? (Hello => $self->helo) : (),
defined $self->localaddr ? (LocalAddr => $self->localaddr) : (),
defined $self->localport ? (LocalPort => $self->localport) : (),
);
}
sub _throw {
my ($self, @rest) = @_;
Email::Sender::Util->_failure(@rest)->throw;
}
sub send_email {
my ($self, $email, $env) = @_;
Email::Sender::Failure->throw("no valid addresses in recipient list")
unless my @to = grep { defined and length } @{ $env->{to} };
my $smtp = $self->_smtp_client;
my $FAULT = sub { $self->_throw($_[0], $smtp); };
$smtp->mail(_quoteaddr($env->{from}))
or $FAULT->("$env->{from} failed after MAIL FROM");
my @failures;
my @ok_rcpts;
for my $addr (@to) {
if ($smtp->to(_quoteaddr($addr))) {
push @ok_rcpts, $addr;
} else {
# my ($self, $error, $smtp, $error_class, @rest) = @_;
push @failures, Email::Sender::Util->_failure(
undef,
$smtp,
recipients => [ $addr ],
);
}
}
# This logic used to include: or (@ok_rcpts == 1 and $ok_rcpts[0] eq '0')
# because if called without SkipBad, $smtp->to can return 1 or 0. This
# should not happen because we now always pass SkipBad and do the counting
# ourselves. Still, I've put this comment here (a) in memory of the
# suffering it caused to have to find that problem and (b) in case the
# original problem is more insidious than I thought! -- rjbs, 2008-12-05
if (
@failures
and ((@ok_rcpts == 0) or (! $self->allow_partial_success))
) {
$failures[0]->throw if @failures == 1;
my $message = sprintf '%s recipients were rejected during RCPT',
@ok_rcpts ? 'some' : 'all';
Email::Sender::Failure::Multi->throw(
message => $message,
failures => \@failures,
);
}
# restore Pobox's support for streaming, code-based messages, and arrays here
# -- rjbs, 2008-12-04
$smtp->data or $FAULT->("error at DATA start");
my $msg_string = $email->as_string;
my $hunk_size = $self->_hunk_size;
while (length $msg_string) {
my $next_hunk = substr $msg_string, 0, $hunk_size, '';
$smtp->datasend($next_hunk) or $FAULT->("error at during DATA");
}
$smtp->dataend or $FAULT->("error at after DATA");
my $message = $smtp->message;
$self->_message_complete($smtp);
# We must report partial success (failures) if applicable.
return $self->success({ message => $message }) unless @failures;
return $self->partial_success({
message => $message,
failure => Email::Sender::Failure::Multi->new({
message => 'some recipients were rejected during RCPT',
failures => \@failures
}),
});
}
sub _hunk_size { 2**20 } # send messages to DATA in hunks of 1 mebibyte
sub success {
my $self = shift;
my $success = Moo::Role->create_class_with_roles('Email::Sender::Success', 'Email::Sender::Role::HasMessage')->new(@_);
}
sub partial_success {
my $self = shift;
my $partial_success = Moo::Role->create_class_with_roles('Email::Sender::Success::Partial', 'Email::Sender::Role::HasMessage')->new(@_);
}
sub _message_complete { $_[1]->quit; }
#pod =head1 PARTIAL SUCCESS
#pod
#pod If C<allow_partial_success> was set when creating the transport, the transport
#pod may return L<Email::Sender::Success::Partial> objects. Consult that module's
#pod documentation.
#pod
#pod =cut
with 'Email::Sender::Transport';
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Transport::SMTP - send email over SMTP
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
This transport is used to send email over SMTP, either with or without secure
sockets (SSL/TLS). It is one of the most complex transports available, capable
of partial success.
For a potentially more efficient version of this transport, see
L<Email::Sender::Transport::SMTP::Persistent>.
=head1 ATTRIBUTES
The following attributes may be passed to the constructor:
=over 4
=item C<hosts>: an arrayref of names of the host to try, in order; defaults to a single element array containing C<localhost>
The attribute C<host> may be given, instead, which contains a single hostname.
=item C<ssl>: if 'starttls', use STARTTLS; if 'ssl' (or 1), connect securely;
otherwise, no security
=item C<ssl_options>: passed to Net::SMTP constructor for 'ssl' connections or
to starttls for 'starttls' connections; should contain extra options for
IO::Socket::SSL
=item C<port>: port to connect to; defaults to 25 for non-SSL, 465 for 'ssl',
587 for 'starttls'
=item C<timeout>: maximum time in secs to wait for server; default is 120
=item C<sasl_username>: the username to use for auth; optional
=item C<sasl_password>: the password to use for auth; required if C<sasl_username> is provided
=item C<allow_partial_success>: if true, will send data even if some recipients were rejected; defaults to false
=item C<helo>: what to say when saying HELO; no default
=item C<localaddr>: local address from which to connect
=item C<localport>: local port from which to connect
=item C<debug>: if true, put the L<Net::SMTP> object in debug mode
=back
=head1 PARTIAL SUCCESS
If C<allow_partial_success> was set when creating the transport, the transport
may return L<Email::Sender::Success::Partial> objects. Consult that module's
documentation.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

99
database/perl/vendor/lib/Email/Sender/Transport/SMTP/Persistent.pm vendored Normal file
View File

@@ -0,0 +1,99 @@
package Email::Sender::Transport::SMTP::Persistent;
# ABSTRACT: an SMTP client that stays online
$Email::Sender::Transport::SMTP::Persistent::VERSION = '1.300035';
use Moo;
extends 'Email::Sender::Transport::SMTP';
#pod =head1 DESCRIPTION
#pod
#pod The stock L<Email::Sender::Transport::SMTP> reconnects each time it sends a
#pod message. This transport only reconnects when the existing connection fails.
#pod
#pod =cut
use Net::SMTP;
has _cached_client => (
is => 'rw',
);
sub _smtp_client {
my ($self) = @_;
if (my $client = $self->_cached_client) {
return $client if eval { $client->reset; $client->ok; };
my $error = $@
|| 'error resetting cached SMTP connection: ' . $client->message;
Carp::carp($error);
}
my $client = $self->SUPER::_smtp_client;
$self->_cached_client($client);
return $client;
}
sub _message_complete { }
#pod =method disconnect
#pod
#pod $transport->disconnect;
#pod
#pod This method sends an SMTP QUIT command and destroys the SMTP client, if on
#pod exists and is connected.
#pod
#pod =cut
sub disconnect {
my ($self) = @_;
return unless $self->_cached_client;
$self->_cached_client->quit;
$self->_cached_client(undef);
}
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Transport::SMTP::Persistent - an SMTP client that stays online
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
The stock L<Email::Sender::Transport::SMTP> reconnects each time it sends a
message. This transport only reconnects when the existing connection fails.
=head1 METHODS
=head2 disconnect
$transport->disconnect;
This method sends an SMTP QUIT command and destroys the SMTP client, if on
exists and is connected.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

139
database/perl/vendor/lib/Email/Sender/Transport/Sendmail.pm vendored Normal file
View File

@@ -0,0 +1,139 @@
package Email::Sender::Transport::Sendmail;
# ABSTRACT: send mail via sendmail(1)
$Email::Sender::Transport::Sendmail::VERSION = '1.300035';
use Moo;
with 'Email::Sender::Transport';
use MooX::Types::MooseLike::Base qw(Str);
#pod =head2 DESCRIPTION
#pod
#pod This transport sends mail by piping it to the F<sendmail> command. If the
#pod location of the F<sendmail> command is not provided in the constructor (see
#pod below) then the library will look for an executable file called F<sendmail> in
#pod the path.
#pod
#pod To specify the location of sendmail:
#pod
#pod my $sender = Email::Sender::Transport::Sendmail->new({ sendmail => $path });
#pod
#pod =cut
use File::Spec ();
has 'sendmail' => (
is => 'ro',
isa => Str,
required => 1,
lazy => 1,
default => sub {
# This should not have to be lazy, but Moose has a bug(?) that prevents the
# instance or partial-instance from being passed in to the default sub.
# Laziness doesn't hurt much, though, because (ugh) of the BUILD below.
# -- rjbs, 2008-12-04
# return $ENV{PERL_SENDMAIL_PATH} if $ENV{PERL_SENDMAIL_PATH}; # ???
return $_[0]->_find_sendmail('sendmail');
},
);
sub BUILD {
$_[0]->sendmail; # force population -- rjbs, 2009-06-08
}
sub _find_sendmail {
my ($self, $program_name) = @_;
$program_name ||= 'sendmail';
my @path = File::Spec->path;
if ($program_name eq 'sendmail') {
# for 'real' sendmail we will look in common locations -- rjbs, 2009-07-12
push @path, (
File::Spec->catfile('', qw(usr sbin)),
File::Spec->catfile('', qw(usr lib)),
);
}
for my $dir (@path) {
my $sendmail = File::Spec->catfile($dir, $program_name);
return $sendmail if ($^O eq 'MSWin32') ? -f $sendmail : -x $sendmail;
}
Carp::confess("couldn't find a sendmail executable");
}
sub _sendmail_pipe {
my ($self, $envelope) = @_;
my $prog = $self->sendmail;
my ($first, @args) = $^O eq 'MSWin32'
? qq(| "$prog" -i -f $envelope->{from} @{$envelope->{to}})
: (q{|-}, $prog, '-i', '-f', $envelope->{from}, '--', @{$envelope->{to}});
no warnings 'exec'; ## no critic
my $pipe;
Email::Sender::Failure->throw("couldn't open pipe to sendmail ($prog): $!")
unless open($pipe, $first, @args);
return $pipe;
}
sub send_email {
my ($self, $email, $envelope) = @_;
my $pipe = $self->_sendmail_pipe($envelope);
my $string = $email->as_string;
$string =~ s/\x0D\x0A/\x0A/g unless $^O eq 'MSWin32';
print $pipe $string
or Email::Sender::Failure->throw("couldn't send message to sendmail: $!");
close $pipe
or Email::Sender::Failure->throw("error when closing pipe to sendmail: $!");
return $self->success;
}
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Transport::Sendmail - send mail via sendmail(1)
=head1 VERSION
version 1.300035
=head2 DESCRIPTION
This transport sends mail by piping it to the F<sendmail> command. If the
location of the F<sendmail> command is not provided in the constructor (see
below) then the library will look for an executable file called F<sendmail> in
the path.
To specify the location of sendmail:
my $sender = Email::Sender::Transport::Sendmail->new({ sendmail => $path });
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

219
database/perl/vendor/lib/Email/Sender/Transport/Test.pm vendored Normal file
View File

@@ -0,0 +1,219 @@
package Email::Sender::Transport::Test;
# ABSTRACT: deliver mail in memory for testing
$Email::Sender::Transport::Test::VERSION = '1.300035';
use Moo;
use Email::Sender::Failure::Multi;
use Email::Sender::Success::Partial;
use MooX::Types::MooseLike::Base qw(ArrayRef Bool);
#pod =head1 DESCRIPTION
#pod
#pod This transport is meant for testing email deliveries in memory. It will store
#pod a record of any delivery made so that they can be inspected afterward.
#pod
#pod =for Pod::Coverage recipient_failure delivery_failure
#pod
#pod By default, the Test transport will not allow partial success and will always
#pod succeed. It can be made to fail predictably, however, if it is extended and
#pod its C<recipient_failure> or C<delivery_failure> methods are overridden. These
#pod methods are called as follows:
#pod
#pod $self->delivery_failure($email, $envelope);
#pod
#pod $self->recipient_failure($to);
#pod
#pod If they return true, the sending will fail. If the transport was created with
#pod a true C<allow_partial_success> attribute, recipient failures can cause partial
#pod success to be returned.
#pod
#pod For more flexible failure modes, you can override more aggressively or can use
#pod L<Email::Sender::Transport::Failable>.
#pod
#pod =attr deliveries
#pod
#pod =for Pod::Coverage clear_deliveries
#pod
#pod This attribute stores an arrayref of all the deliveries made via the transport.
#pod The C<clear_deliveries> method returns a list of them.
#pod
#pod Each delivery is a hashref, in the following format:
#pod
#pod {
#pod email => $email,
#pod envelope => $envelope,
#pod successes => \@ok_rcpts,
#pod failures => \@failures,
#pod }
#pod
#pod Both successful and failed deliveries are stored.
#pod
#pod A number of methods related to this attribute are provided:
#pod
#pod =for :list
#pod * delivery_count
#pod * clear_deliveries
#pod * shift_deliveries
#pod
#pod =cut
has allow_partial_success => (is => 'ro', isa => Bool, default => sub { 0 });
sub recipient_failure { }
sub delivery_failure { }
has deliveries => (
isa => ArrayRef,
init_arg => undef,
default => sub { [] },
is => 'ro',
reader => '_deliveries',
);
sub delivery_count { scalar @{ $_[0]->_deliveries } }
sub record_delivery { push @{ shift->_deliveries }, @_ }
sub deliveries { @{ $_[0]->_deliveries } }
sub shift_deliveries { shift @{ $_[0]->_deliveries } }
sub clear_deliveries { @{ $_[0]->_deliveries } = () }
sub send_email {
my ($self, $email, $envelope) = @_;
my @failures;
my @ok_rcpts;
if (my $failure = $self->delivery_failure($email, $envelope)) {
$failure->throw;
}
for my $to (@{ $envelope->{to} }) {
if (my $failure = $self->recipient_failure($to)) {
push @failures, $failure;
} else {
push @ok_rcpts, $to;
}
}
if (
@failures
and ((@ok_rcpts == 0) or (! $self->allow_partial_success))
) {
$failures[0]->throw if @failures == 1 and @ok_rcpts == 0;
my $message = sprintf '%s recipients were rejected',
@ok_rcpts ? 'some' : 'all';
Email::Sender::Failure::Multi->throw(
message => $message,
failures => \@failures,
);
}
$self->record_delivery({
email => $email,
envelope => $envelope,
successes => \@ok_rcpts,
failures => \@failures,
});
# XXX: We must report partial success (failures) if applicable.
return $self->success unless @failures;
return Email::Sender::Success::Partial->new({
failure => Email::Sender::Failure::Multi->new({
message => 'some recipients were rejected',
failures => \@failures
}),
});
}
with 'Email::Sender::Transport';
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Transport::Test - deliver mail in memory for testing
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
This transport is meant for testing email deliveries in memory. It will store
a record of any delivery made so that they can be inspected afterward.
=head1 ATTRIBUTES
=head2 deliveries
=for Pod::Coverage recipient_failure delivery_failure
By default, the Test transport will not allow partial success and will always
succeed. It can be made to fail predictably, however, if it is extended and
its C<recipient_failure> or C<delivery_failure> methods are overridden. These
methods are called as follows:
$self->delivery_failure($email, $envelope);
$self->recipient_failure($to);
If they return true, the sending will fail. If the transport was created with
a true C<allow_partial_success> attribute, recipient failures can cause partial
success to be returned.
For more flexible failure modes, you can override more aggressively or can use
L<Email::Sender::Transport::Failable>.
=for Pod::Coverage clear_deliveries
This attribute stores an arrayref of all the deliveries made via the transport.
The C<clear_deliveries> method returns a list of them.
Each delivery is a hashref, in the following format:
{
email => $email,
envelope => $envelope,
successes => \@ok_rcpts,
failures => \@failures,
}
Both successful and failed deliveries are stored.
A number of methods related to this attribute are provided:
=over 4
=item *
delivery_count
=item *
clear_deliveries
=item *
shift_deliveries
=back
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

90
database/perl/vendor/lib/Email/Sender/Transport/Wrapper.pm vendored Normal file
View File

@@ -0,0 +1,90 @@
package Email::Sender::Transport::Wrapper;
# ABSTRACT: a mailer to wrap a mailer for mailing mail
$Email::Sender::Transport::Wrapper::VERSION = '1.300035';
use Moo;
with 'Email::Sender::Transport';
use Email::Sender::Util;
#pod =head1 DESCRIPTION
#pod
#pod Email::Sender::Transport::Wrapper wraps a transport, provided as the
#pod C<transport> argument to the constructor. It is provided as a simple way to
#pod use method modifiers to create wrapping classes.
#pod
#pod =cut
has transport => (
is => 'ro',
does => 'Email::Sender::Transport',
required => 1,
);
sub send_email {
my $self = shift;
$self->transport->send_email(@_);
}
sub is_simple {
return $_[0]->transport->is_simple;
}
sub allow_partial_success {
return $_[0]->transport->allow_partial_success;
}
sub BUILDARGS {
my $self = shift;
my $href = $self->SUPER::BUILDARGS(@_);
if (my $class = delete $href->{transport_class}) {
Carp::confess("given both a transport and transport_class")
if $href->{transport};
my %arg;
for my $key (map {; /^transport_arg_(.+)$/ ? "$1" : () } keys %$href) {
$arg{$key} = delete $href->{"transport_arg_$key"};
}
$href->{transport} = Email::Sender::Util->easy_transport($class, \%arg);
}
return $href;
}
no Moo;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Transport::Wrapper - a mailer to wrap a mailer for mailing mail
=head1 VERSION
version 1.300035
=head1 DESCRIPTION
Email::Sender::Transport::Wrapper wraps a transport, provided as the
C<transport> argument to the constructor. It is provided as a simple way to
use method modifiers to create wrapping classes.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

141
database/perl/vendor/lib/Email/Sender/Util.pm vendored Normal file
View File

@@ -0,0 +1,141 @@
use strict;
use warnings;
package Email::Sender::Util;
# ABSTRACT: random stuff that makes Email::Sender go
$Email::Sender::Util::VERSION = '1.300035';
use Email::Address;
use Email::Sender::Failure;
use Email::Sender::Failure::Permanent;
use Email::Sender::Failure::Temporary;
use List::Util 1.45 ();
use Module::Runtime qw(require_module);
# This code will be used by Email::Sender::Simple. -- rjbs, 2008-12-04
sub _recipients_from_email {
my ($self, $email) = @_;
my @to = List::Util::uniq(
map { $_->address }
map { Email::Address->parse($_) }
map { $email->get_header($_) }
qw(to cc bcc));
return \@to;
}
sub _sender_from_email {
my ($self, $email) = @_;
my ($sender) = map { $_->address }
map { Email::Address->parse($_) }
scalar $email->get_header('from');
return $sender;
}
# It's probably reasonable to make this code publicker at some point, but for
# now I don't want to deal with making a sane set of args. -- rjbs, 2008-12-09
sub _failure {
my ($self, $error, $smtp, @rest) = @_;
my ($code, $message);
if ($smtp) {
$code = $smtp->code;
$message = $smtp->message;
$message = ! defined $message ? "(no SMTP error message)"
: ! length $message ? "(empty SMTP error message)"
: $message;
$message = defined $error && length $error
? "$error: $message"
: $message;
} else {
$message = $error;
$message = "(no error given)" unless defined $message;
$message = "(empty error string)" unless length $message;
}
my $error_class = ! $code ? 'Email::Sender::Failure'
: $code =~ /^4/ ? 'Email::Sender::Failure::Temporary'
: $code =~ /^5/ ? 'Email::Sender::Failure::Permanent'
: 'Email::Sender::Failure';
$error_class->new({
message => $message,
code => $code,
@rest,
});
}
#pod =method easy_transport
#pod
#pod my $transport = Email::Sender::Util->easy_transport($class => \%arg);
#pod
#pod This takes the name of a transport class and a set of args to new. It returns
#pod an Email::Sender::Transport object of that class.
#pod
#pod C<$class> is rewritten to C<Email::Sender::Transport::$class> unless it starts
#pod with an equals sign (C<=>) or contains a colon. The equals sign, if present,
#pod will be removed.
#pod
#pod =cut
sub _rewrite_class {
my $transport_class = $_[1];
if ($transport_class !~ s/^=// and $transport_class !~ m{:}) {
$transport_class = "Email::Sender::Transport::$transport_class";
}
return $transport_class;
}
sub easy_transport {
my ($self, $transport_class, $arg) = @_;
$transport_class = $self->_rewrite_class($transport_class);
require_module($transport_class);
return $transport_class->new($arg);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Sender::Util - random stuff that makes Email::Sender go
=head1 VERSION
version 1.300035
=head1 METHODS
=head2 easy_transport
my $transport = Email::Sender::Util->easy_transport($class => \%arg);
This takes the name of a transport class and a set of args to new. It returns
an Email::Sender::Transport object of that class.
C<$class> is rewritten to C<Email::Sender::Transport::$class> unless it starts
with an equals sign (C<=>) or contains a colon. The equals sign, if present,
will be removed.
=head1 AUTHOR
Ricardo Signes <rjbs@semiotic.systems>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2020 by Ricardo Signes.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

600
database/perl/vendor/lib/Email/Simple.pm vendored Normal file
View File

@@ -0,0 +1,600 @@
use 5.008;
use strict;
use warnings;
package Email::Simple;
# ABSTRACT: simple parsing of RFC2822 message format and headers
$Email::Simple::VERSION = '2.216';
use Carp ();
use Email::Simple::Creator;
use Email::Simple::Header;
our $GROUCHY = 0;
# We are liberal in what we accept.
sub __crlf_re { qr/\x0a\x0d|\x0d\x0a|\x0a|\x0d/; }
#pod =head1 SYNOPSIS
#pod
#pod use Email::Simple;
#pod my $email = Email::Simple->new($text);
#pod
#pod my $from_header = $email->header("From");
#pod my @received = $email->header("Received");
#pod
#pod $email->header_set("From", 'Simon Cozens <simon@cpan.org>');
#pod
#pod my $old_body = $email->body;
#pod $email->body_set("Hello world\nSimon");
#pod
#pod print $email->as_string;
#pod
#pod ...or, to create a message from scratch...
#pod
#pod my $email = Email::Simple->create(
#pod header => [
#pod From => 'casey@geeknest.com',
#pod To => 'drain@example.com',
#pod Subject => 'Message in a bottle',
#pod ],
#pod body => '...',
#pod );
#pod
#pod $email->header_set( 'X-Content-Container' => 'bottle/glass' );
#pod
#pod print $email->as_string;
#pod
#pod =head1 DESCRIPTION
#pod
#pod The Email:: namespace was begun as a reaction against the increasing complexity
#pod and bugginess of Perl's existing email modules. C<Email::*> modules are meant
#pod to be simple to use and to maintain, pared to the bone, fast, minimal in their
#pod external dependencies, and correct.
#pod
#pod =method new
#pod
#pod my $email = Email::Simple->new($message, \%arg);
#pod
#pod This method parses an email from a scalar containing an RFC2822 formatted
#pod message and returns an object. C<$message> may be a reference to a message
#pod string, in which case the string will be altered in place. This can result in
#pod significant memory savings.
#pod
#pod If you want to create a message from scratch, you should use the C<L</create>>
#pod method.
#pod
#pod Valid arguments are:
#pod
#pod header_class - the class used to create new header objects
#pod The named module is not 'require'-ed by Email::Simple!
#pod
#pod =cut
sub new {
my ($class, $text, $arg) = @_;
$arg ||= {};
Carp::croak 'Unable to parse undefined message' if ! defined $text;
my $text_ref = (ref $text || '' eq 'SCALAR') ? $text : \$text;
my ($pos, $mycrlf) = $class->_split_head_from_body($text_ref);
my $self = bless { mycrlf => $mycrlf } => $class;
my $head;
if (defined $pos) {
$head = substr $$text_ref, 0, $pos, '';
substr($head, -(length $mycrlf)) = '';
} else {
$head = $$text_ref;
$text_ref = \'';
}
my $header_class = $arg->{header_class} || $self->default_header_class;
$self->header_obj_set(
$header_class->new(\$head, { crlf => $self->crlf })
);
$self->body_set($text_ref);
return $self;
}
# Given the text of an email, return ($pos, $crlf) where $pos is the position
# at which the body text begins and $crlf is the type of newline used in the
# message.
sub _split_head_from_body {
my ($self, $text_ref) = @_;
# For body/header division, see RFC 2822, section 2.1
#
# Honestly, are we *ever* going to have LFCR messages?? -- rjbs, 2015-10-11
my $re = qr{\x0a\x0d\x0a\x0d|\x0d\x0a\x0d\x0a|\x0d\x0d|\x0a\x0a};
if ($$text_ref =~ /($re)/gsm) {
my $crlf = substr $1, 0, length($1)/2;
return (pos($$text_ref), $crlf);
} else {
# The body is, of course, optional.
my $re = $self->__crlf_re;
$$text_ref =~ /($re)/gsm;
return (undef, ($1 || "\n"));
}
}
#pod =method create
#pod
#pod my $email = Email::Simple->create(header => [ @headers ], body => '...');
#pod
#pod This method is a constructor that creates an Email::Simple object
#pod from a set of named parameters. The C<header> parameter's value is a
#pod list reference containing a set of headers to be created. The C<body>
#pod parameter's value is a scalar value holding the contents of the message
#pod body. Line endings in the body will normalized to CRLF.
#pod
#pod If no C<Date> header is specified, one will be provided for you based on the
#pod C<gmtime> of the local machine. This is because the C<Date> field is a required
#pod header and is a pain in the neck to create manually for every message. The
#pod C<From> field is also a required header, but it is I<not> provided for you.
#pod
#pod =cut
our $CREATOR = 'Email::Simple::Creator';
sub create {
my ($class, %args) = @_;
# We default it in here as well as below because by having it here, then we
# know that if there are no other headers, we'll get the proper CRLF.
# Otherwise, we get a message with incorrect CRLF. -- rjbs, 2007-07-13
my $headers = $args{header} || [ Date => $CREATOR->_date_header ];
my $body = $args{body} || '';
my $empty = q{};
my $header = \$empty;
for my $idx (map { $_ * 2 } 0 .. @$headers / 2 - 1) {
my ($key, $value) = @$headers[ $idx, $idx + 1 ];
$CREATOR->_add_to_header($header, $key, $value);
}
$CREATOR->_finalize_header($header);
my $email = $class->new($header);
$email->header_raw_set(Date => $CREATOR->_date_header)
unless defined $email->header_raw('Date');
$body = (join $CREATOR->_crlf, split /\x0d\x0a|\x0a\x0d|\x0a|\x0d/, $body)
. $CREATOR->_crlf;
$email->body_set($body);
return $email;
}
#pod =method header_obj
#pod
#pod my $header = $email->header_obj;
#pod
#pod This method returns the object representing the email's header. For the
#pod interface for this object, see L<Email::Simple::Header>.
#pod
#pod =cut
sub header_obj {
my ($self) = @_;
return $self->{header};
}
# Probably needs to exist in perpetuity for modules released during the "__head
# is tentative" phase, until we have a way to force modules below us on the
# dependency tree to upgrade. i.e., never and/or in Perl 6 -- rjbs, 2006-11-28
BEGIN { *__head = \&header_obj }
#pod =method header_obj_set
#pod
#pod $email->header_obj_set($new_header_obj);
#pod
#pod This method substitutes the given new header object for the email's existing
#pod header object.
#pod
#pod =cut
sub header_obj_set {
my ($self, $obj) = @_;
$self->{header} = $obj;
}
#pod =method header
#pod
#pod my @values = $email->header($header_name);
#pod my $first = $email->header($header_name);
#pod my $value = $email->header($header_name, $index);
#pod
#pod In list context, this returns every value for the named header. In scalar
#pod context, it returns the I<first> value for the named header. If second
#pod parameter is specified then instead I<first> value it returns value at
#pod position C<$index> (negative C<$index> is from the end).
#pod
#pod =method header_set
#pod
#pod $email->header_set($field, $line1, $line2, ...);
#pod
#pod Sets the header to contain the given data. If you pass multiple lines
#pod in, you get multiple headers, and order is retained. If no values are given to
#pod set, the header will be removed from to the message entirely.
#pod
#pod =method header_raw
#pod
#pod This is another name (and the preferred one) for C<header>.
#pod
#pod =method header_raw_set
#pod
#pod This is another name (and the preferred one) for C<header_set>.
#pod
#pod =method header_raw_prepend
#pod
#pod $email->header_raw_prepend($field => $value);
#pod
#pod This method adds a new instance of the name field as the first field in the
#pod header.
#pod
#pod =method header_names
#pod
#pod my @header_names = $email->header_names;
#pod
#pod This method returns the list of header names currently in the email object.
#pod These names can be passed to the C<header> method one-at-a-time to get header
#pod values. You are guaranteed to get a set of headers that are unique. You are not
#pod guaranteed to get the headers in any order at all.
#pod
#pod For backwards compatibility, this method can also be called as B<headers>.
#pod
#pod =method header_pairs
#pod
#pod my @headers = $email->header_pairs;
#pod
#pod This method returns a list of pairs describing the contents of the header.
#pod Every other value, starting with and including zeroth, is a header name and the
#pod value following it is the header value.
#pod
#pod =method header_raw_pairs
#pod
#pod This is another name (and the preferred one) for C<header_pairs>.
#pod
#pod =cut
BEGIN {
no strict 'refs';
for my $method (qw(
header_raw header
header_raw_set header_set
header_raw_prepend
header_raw_pairs header_pairs
header_names
)) {
*$method = sub { (shift)->header_obj->$method(@_) };
}
*headers = \&header_names;
}
#pod =method body
#pod
#pod Returns the body text of the mail.
#pod
#pod =cut
sub body {
my ($self) = @_;
return (defined ${ $self->{body} }) ? ${ $self->{body} } : '';
}
#pod =method body_set
#pod
#pod Sets the body text of the mail.
#pod
#pod =cut
sub body_set {
my ($self, $text) = @_;
my $text_ref = ref $text ? $text : \$text;
$self->{body} = $text_ref;
return;
}
#pod =method as_string
#pod
#pod Returns the mail as a string, reconstructing the headers.
#pod
#pod =cut
sub as_string {
my $self = shift;
return $self->header_obj->as_string . $self->crlf . $self->body;
}
#pod =method crlf
#pod
#pod This method returns the type of newline used in the email. It is an accessor
#pod only.
#pod
#pod =cut
sub crlf { $_[0]->{mycrlf} }
#pod =method default_header_class
#pod
#pod This returns the class used, by default, for header objects, and is provided
#pod for subclassing. The default default is Email::Simple::Header.
#pod
#pod =cut
sub default_header_class { 'Email::Simple::Header' }
1;
=pod
=encoding UTF-8
=head1 NAME
Email::Simple - simple parsing of RFC2822 message format and headers
=head1 VERSION
version 2.216
=head1 SYNOPSIS
use Email::Simple;
my $email = Email::Simple->new($text);
my $from_header = $email->header("From");
my @received = $email->header("Received");
$email->header_set("From", 'Simon Cozens <simon@cpan.org>');
my $old_body = $email->body;
$email->body_set("Hello world\nSimon");
print $email->as_string;
...or, to create a message from scratch...
my $email = Email::Simple->create(
header => [
From => 'casey@geeknest.com',
To => 'drain@example.com',
Subject => 'Message in a bottle',
],
body => '...',
);
$email->header_set( 'X-Content-Container' => 'bottle/glass' );
print $email->as_string;
=head1 DESCRIPTION
The Email:: namespace was begun as a reaction against the increasing complexity
and bugginess of Perl's existing email modules. C<Email::*> modules are meant
to be simple to use and to maintain, pared to the bone, fast, minimal in their
external dependencies, and correct.
=head1 METHODS
=head2 new
my $email = Email::Simple->new($message, \%arg);
This method parses an email from a scalar containing an RFC2822 formatted
message and returns an object. C<$message> may be a reference to a message
string, in which case the string will be altered in place. This can result in
significant memory savings.
If you want to create a message from scratch, you should use the C<L</create>>
method.
Valid arguments are:
header_class - the class used to create new header objects
The named module is not 'require'-ed by Email::Simple!
=head2 create
my $email = Email::Simple->create(header => [ @headers ], body => '...');
This method is a constructor that creates an Email::Simple object
from a set of named parameters. The C<header> parameter's value is a
list reference containing a set of headers to be created. The C<body>
parameter's value is a scalar value holding the contents of the message
body. Line endings in the body will normalized to CRLF.
If no C<Date> header is specified, one will be provided for you based on the
C<gmtime> of the local machine. This is because the C<Date> field is a required
header and is a pain in the neck to create manually for every message. The
C<From> field is also a required header, but it is I<not> provided for you.
=head2 header_obj
my $header = $email->header_obj;
This method returns the object representing the email's header. For the
interface for this object, see L<Email::Simple::Header>.
=head2 header_obj_set
$email->header_obj_set($new_header_obj);
This method substitutes the given new header object for the email's existing
header object.
=head2 header
my @values = $email->header($header_name);
my $first = $email->header($header_name);
my $value = $email->header($header_name, $index);
In list context, this returns every value for the named header. In scalar
context, it returns the I<first> value for the named header. If second
parameter is specified then instead I<first> value it returns value at
position C<$index> (negative C<$index> is from the end).
=head2 header_set
$email->header_set($field, $line1, $line2, ...);
Sets the header to contain the given data. If you pass multiple lines
in, you get multiple headers, and order is retained. If no values are given to
set, the header will be removed from to the message entirely.
=head2 header_raw
This is another name (and the preferred one) for C<header>.
=head2 header_raw_set
This is another name (and the preferred one) for C<header_set>.
=head2 header_raw_prepend
$email->header_raw_prepend($field => $value);
This method adds a new instance of the name field as the first field in the
header.
=head2 header_names
my @header_names = $email->header_names;
This method returns the list of header names currently in the email object.
These names can be passed to the C<header> method one-at-a-time to get header
values. You are guaranteed to get a set of headers that are unique. You are not
guaranteed to get the headers in any order at all.
For backwards compatibility, this method can also be called as B<headers>.
=head2 header_pairs
my @headers = $email->header_pairs;
This method returns a list of pairs describing the contents of the header.
Every other value, starting with and including zeroth, is a header name and the
value following it is the header value.
=head2 header_raw_pairs
This is another name (and the preferred one) for C<header_pairs>.
=head2 body
Returns the body text of the mail.
=head2 body_set
Sets the body text of the mail.
=head2 as_string
Returns the mail as a string, reconstructing the headers.
=head2 crlf
This method returns the type of newline used in the email. It is an accessor
only.
=head2 default_header_class
This returns the class used, by default, for header objects, and is provided
for subclassing. The default default is Email::Simple::Header.
=head1 CAVEATS
Email::Simple handles only RFC2822 formatted messages. This means you cannot
expect it to cope well as the only parser between you and the outside world,
say for example when writing a mail filter for invocation from a .forward file
(for this we recommend you use L<Email::Filter> anyway).
=head1 AUTHORS
=over 4
=item *
Simon Cozens
=item *
Casey West
=item *
Ricardo SIGNES
=back
=head1 CONTRIBUTORS
=for stopwords Brian Cassidy Christian Walde Marc Bradshaw Michael Stevens Pali Ricardo SIGNES Ronald F. Guilmette William Yardley
=over 4
=item *
Brian Cassidy <bricas@cpan.org>
=item *
Christian Walde <walde.christian@googlemail.com>
=item *
Marc Bradshaw <marc@marcbradshaw.net>
=item *
Michael Stevens <mstevens@etla.org>
=item *
Pali <pali@cpan.org>
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Ronald F. Guilmette <rfg@tristatelogic.com>
=item *
William Yardley <pep@veggiechinese.net>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2003 by Simon Cozens.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
#pod =head1 CAVEATS
#pod
#pod Email::Simple handles only RFC2822 formatted messages. This means you cannot
#pod expect it to cope well as the only parser between you and the outside world,
#pod say for example when writing a mail filter for invocation from a .forward file
#pod (for this we recommend you use L<Email::Filter> anyway).
#pod
#pod =cut

74
database/perl/vendor/lib/Email/Simple/Creator.pm vendored Normal file
View File

@@ -0,0 +1,74 @@
use strict;
use warnings;
package Email::Simple::Creator;
# ABSTRACT: private helper for building Email::Simple objects
$Email::Simple::Creator::VERSION = '2.216';
sub _crlf {
"\x0d\x0a";
}
sub _date_header {
require Email::Date::Format;
Email::Date::Format::email_date();
}
our @CARP_NOT = qw(Email::Simple Email::MIME);
sub _add_to_header {
my ($class, $header, $key, $value) = @_;
$value = '' unless defined $value;
if ($value =~ s/[\x0a\x0b\x0c\x0d\x85\x{2028}\x{2029}]+/ /g) {
Carp::carp("replaced vertical whitespace in $key header with space; this will become fatal in a future version");
}
$$header .= Email::Simple::Header->__fold_objless("$key: $value", 78, q{ }, $class->_crlf);
}
sub _finalize_header {
my ($class, $header) = @_;
$$header .= $class->_crlf;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Simple::Creator - private helper for building Email::Simple objects
=head1 VERSION
version 2.216
=head1 AUTHORS
=over 4
=item *
Simon Cozens
=item *
Casey West
=item *
Ricardo SIGNES
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2003 by Simon Cozens.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

538
database/perl/vendor/lib/Email/Simple/Header.pm vendored Normal file
View File

@@ -0,0 +1,538 @@
use strict;
use warnings;
package Email::Simple::Header;
# ABSTRACT: the header of an Email::Simple message
$Email::Simple::Header::VERSION = '2.216';
use Carp ();
require Email::Simple;
#pod =head1 SYNOPSIS
#pod
#pod my $email = Email::Simple->new($text);
#pod
#pod my $header = $email->header_obj;
#pod print $header->as_string;
#pod
#pod =head1 DESCRIPTION
#pod
#pod This method implements the headers of an Email::Simple object. It is a very
#pod minimal interface, and is mostly for private consumption at the moment.
#pod
#pod =method new
#pod
#pod my $header = Email::Simple::Header->new($head, \%arg);
#pod
#pod C<$head> is a string containing a valid email header, or a reference to such a
#pod string. If a reference is passed in, don't expect that it won't be altered.
#pod
#pod Valid arguments are:
#pod
#pod crlf - the header's newline; defaults to CRLF
#pod
#pod =cut
# We need to be able to:
# * get all values by lc name
# * produce all pairs, with case intact
sub new {
my ($class, $head, $arg) = @_;
my $head_ref = ref $head ? $head : \$head;
my $self = { mycrlf => $arg->{crlf} || "\x0d\x0a", };
my $headers = $class->_header_to_list($head_ref, $self->{mycrlf});
# for my $header (@$headers) {
# push @{ $self->{order} }, $header->[0];
# push @{ $self->{head}{ $header->[0] } }, $header->[1];
# }
#
# $self->{header_names} = { map { lc $_ => $_ } keys %{ $self->{head} } };
$self->{headers} = $headers;
bless $self => $class;
}
sub _header_to_list {
my ($self, $head, $mycrlf) = @_;
my @headers;
my $crlf = Email::Simple->__crlf_re;
while ($$head =~ m/\G(.+?)$crlf/go) {
local $_ = $1;
if (/^\s+/ or not /^([^:]+):\s*(.*)/) {
# This is a continuation line. We fold it onto the end of
# the previous header.
next if !@headers; # Well, that sucks. We're continuing nothing?
(my $trimmed = $_) =~ s/^\s+//;
$headers[-1][0] .= $headers[-1][0] =~ /\S/ ? " $trimmed" : $trimmed;
$headers[-1][1] .= "$mycrlf$_";
} else {
push @headers, $1, [ $2, $_ ];
}
}
return \@headers;
}
#pod =method as_string
#pod
#pod my $string = $header->as_string(\%arg);
#pod
#pod This returns a stringified version of the header.
#pod
#pod =cut
# RFC 2822, 3.6:
# ...for the purposes of this standard, header fields SHOULD NOT be reordered
# when a message is transported or transformed. More importantly, the trace
# header fields and resent header fields MUST NOT be reordered, and SHOULD be
# kept in blocks prepended to the message.
sub as_string {
my ($self, $arg) = @_;
$arg ||= {};
my $header_str = '';
my $headers = $self->{headers};
my $fold_arg = {
# at => (exists $arg->{fold_at} ? $arg->{fold_at} : $self->default_fold_at),
# indent => (exists $arg->{fold_indent} ? $arg->{fold_indent} : $self->default_fold_indent),
at => $self->_default_fold_at,
indent => $self->_default_fold_indent,
};
for (my $i = 0; $i < @$headers; $i += 2) {
if (ref $headers->[ $i + 1 ]) {
$header_str .= $headers->[ $i + 1 ][1] . $self->crlf;
} else {
my $header = "$headers->[$i]: $headers->[$i + 1]";
$header_str .= $self->_fold($header, $fold_arg);
}
}
return $header_str;
}
#pod =method header_names
#pod
#pod This method returns a list of the unique header names found in this header, in
#pod no particular order.
#pod
#pod =cut
sub header_names {
my $headers = $_[0]->{headers};
my %seen;
grep { !$seen{ lc $_ }++ }
map { $headers->[ $_ * 2 ] } 0 .. @$headers / 2 - 1;
}
#pod =method header_raw_pairs
#pod
#pod my @pairs = $header->header_raw_pairs;
#pod my $first_name = $pairs[0];
#pod my $first_value = $pairs[1];
#pod
#pod This method returns a list of all the field/value pairs in the header, in the
#pod order that they appear in the header. (Remember: don't try assigning that to a
#pod hash. Some fields may appear more than once!)
#pod
#pod =method header_pairs
#pod
#pod L<header_pairs> is another name for L<header_raw_pairs>, which was the original
#pod name for the method and which you'll see most often. In general, though, it's
#pod better to be explicit and use L<header_raw_pairs>. (In Email::MIME,
#pod L<header_str_pairs> exists for letting the library do the header decoding for
#pod you.)
#pod
#pod =cut
sub header_raw_pairs {
my ($self) = @_;
my @pairs = map {; _str_value($_) } @{ $self->{headers} };
return @pairs;
}
sub header_pairs {
my ($self) = @_;
$self->header_raw_pairs;
}
#pod =method header_raw
#pod
#pod my $first_value = $header->header_raw($field);
#pod my $nth_value = $header->header_raw($field, $index);
#pod my @all_values = $header->header_raw($field);
#pod
#pod This method returns the value or values of the given header field. If the
#pod named field does not appear in the header, this method returns false.
#pod
#pod =method header
#pod
#pod This method just calls C<header_raw>. It's the older name for C<header_raw>,
#pod but it can be a problem because L<Email::MIME>, a subclass of Email::Simple,
#pod makes C<header> return the header's decoded value.
#pod
#pod =cut
sub _str_value { return ref $_[0] ? $_[0][0] : $_[0] }
sub header_raw {
my ($self, $field, $index) = @_;
my $headers = $self->{headers};
my $lc_field = lc $field;
if (wantarray and not defined $index) {
return map { _str_value($headers->[ $_ * 2 + 1 ]) }
grep { lc $headers->[ $_ * 2 ] eq $lc_field } 0 .. @$headers / 2 - 1;
} else {
$index = 0 unless defined $index;
my $max = @$headers / 2 - 1;
my @indexes = $index >= 0 ? (0 .. $max) : reverse(0 .. $max);
$index = -1-$index if $index < 0;
for (@indexes) {
next unless lc $headers->[ $_ * 2 ] eq $lc_field;
return _str_value($headers->[ $_ * 2 + 1 ]) if $index-- == 0;
}
return undef;
}
}
*header = \&header_raw;
#pod =method header_raw_set
#pod
#pod $header->header_raw_set($field => @values);
#pod
#pod This method updates the value of the given header. Existing headers have their
#pod values set in place. Additional headers are added at the end. If no values
#pod are given to set, the header will be removed from to the message entirely.
#pod
#pod =method header_set
#pod
#pod L<header_set> is another name for L<header_raw_set>, which was the original
#pod name for the method and which you'll see most often. In general, though, it's
#pod better to be explicit and use L<header_raw_set>. (In Email::MIME,
#pod L<header_str_set> exists for letting the library do the header encoding for
#pod you.)
#pod
#pod =cut
# Header fields are lines composed of a field name, followed by a colon (":"),
# followed by a field body, and terminated by CRLF. A field name MUST be
# composed of printable US-ASCII characters (i.e., characters that have values
# between 33 and 126, inclusive), except colon. A field body may be composed
# of any US-ASCII characters, except for CR and LF.
# However, a field body may contain CRLF when used in header "folding" and
# "unfolding" as described in section 2.2.3.
sub header_raw_set {
my ($self, $field, @data) = @_;
# I hate this block. -- rjbs, 2006-10-06
if ($Email::Simple::GROUCHY) {
Carp::croak "field name contains illegal characters"
unless $field =~ /^[\x21-\x39\x3b-\x7e]+$/;
Carp::carp "field name is not limited to hyphens and alphanumerics"
unless $field =~ /^[\w-]+$/;
}
my $headers = $self->{headers};
my $lc_field = lc $field;
my @indices = grep { lc $headers->[$_] eq $lc_field }
map { $_ * 2 } 0 .. @$headers / 2 - 1;
if (@indices > @data) {
my $overage = @indices - @data;
splice @{$headers}, $_, 2 for reverse @indices[ -$overage .. -1 ];
pop @indices for (1 .. $overage);
} elsif (@data > @indices) {
my $underage = @data - @indices;
for (1 .. $underage) {
push @$headers, $field, undef; # temporary value
push @indices, $#$headers - 1;
}
}
for (0 .. $#indices) {
$headers->[ $indices[$_] + 1 ] = $data[$_];
}
return wantarray ? @data : $data[0];
}
sub header_set {
my ($self, $field, @data) = @_;
$self->header_raw_set($field, @data);
}
#pod =method header_raw_prepend
#pod
#pod $header->header_raw_prepend($field => $value);
#pod
#pod This method adds a new instance of the name field as the first field in the
#pod header.
#pod
#pod =cut
sub header_raw_prepend {
my ($self, $field, $value) = @_;
Carp::confess("tried to prepend raw header with undefined field name")
unless defined $field;
Carp::confess(qq{tried to prepend raw header "$field" with undefined value})
unless defined $value;
unshift @{ $self->{headers} }, $field => $value;
return;
}
#pod =method crlf
#pod
#pod This method returns the newline string used in the header.
#pod
#pod =cut
sub crlf { $_[0]->{mycrlf} }
# =method fold
#
# my $folded = $header->fold($line, \%arg);
#
# Given a header string, this method returns a folded version, if the string is
# long enough to warrant folding. This method is used internally.
#
# Valid arguments are:
#
# at - fold lines to be no longer than this length, if possible
# if given and false, never fold headers
# indent - indent lines with this string
# =cut
sub _fold {
my ($self, $line, $arg) = @_;
$arg ||= {};
$arg->{at} = $self->_default_fold_at unless exists $arg->{at};
$arg->{indent} = $self->_default_fold_indent unless exists $arg->{indent};
my $indent = $arg->{indent} || $self->_default_fold_indent;
# We will not folder headers if...
# * the header has vertical whitespace
# * all vertical whitespace is followed by horizontal whitespace or END
if ($line =~ /\n/) {
if ($line =~ s/\n([^\s\t])/\n$indent$1/g) {
Carp::carp("bad space in header: newline followed by non-space: $line");
} else {
$line .= $self->crlf unless $line =~ /\n$/;
return $line;
}
}
return $line . $self->crlf unless $arg->{at} and $arg->{at} > 0;
my $limit = ($arg->{at} || $self->_default_fold_at) - 1;
return $line . $self->crlf if length $line <= $limit;
return $self->__fold_objless($line, $limit, $indent, $self->crlf);
}
sub __fold_objless {
my ($self, $line, $limit, $indent, $crlf) = @_;
# We know it will not contain any new lines at present
my $folded = "";
while (length $line) {
if ($line =~ s/^(.{0,$limit})(\s|\z)//) {
$folded .= $1 . $crlf;
$folded .= $indent if length $line;
} else {
# Basically nothing we can do. :(
$folded .= $line . $crlf;
last;
}
}
return $folded;
}
# =method default_fold_at
#
# This method (provided for subclassing) returns the default length at which to
# try to fold header lines. The default default is 78.
#
# =cut
sub _default_fold_at { 78 }
# =method default_fold_indent
#
# This method (provided for subclassing) returns the default string used to
# indent folded headers. The default default is a single space.
#
# =cut
sub _default_fold_indent { " " }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Simple::Header - the header of an Email::Simple message
=head1 VERSION
version 2.216
=head1 SYNOPSIS
my $email = Email::Simple->new($text);
my $header = $email->header_obj;
print $header->as_string;
=head1 DESCRIPTION
This method implements the headers of an Email::Simple object. It is a very
minimal interface, and is mostly for private consumption at the moment.
=head1 METHODS
=head2 new
my $header = Email::Simple::Header->new($head, \%arg);
C<$head> is a string containing a valid email header, or a reference to such a
string. If a reference is passed in, don't expect that it won't be altered.
Valid arguments are:
crlf - the header's newline; defaults to CRLF
=head2 as_string
my $string = $header->as_string(\%arg);
This returns a stringified version of the header.
=head2 header_names
This method returns a list of the unique header names found in this header, in
no particular order.
=head2 header_raw_pairs
my @pairs = $header->header_raw_pairs;
my $first_name = $pairs[0];
my $first_value = $pairs[1];
This method returns a list of all the field/value pairs in the header, in the
order that they appear in the header. (Remember: don't try assigning that to a
hash. Some fields may appear more than once!)
=head2 header_pairs
L<header_pairs> is another name for L<header_raw_pairs>, which was the original
name for the method and which you'll see most often. In general, though, it's
better to be explicit and use L<header_raw_pairs>. (In Email::MIME,
L<header_str_pairs> exists for letting the library do the header decoding for
you.)
=head2 header_raw
my $first_value = $header->header_raw($field);
my $nth_value = $header->header_raw($field, $index);
my @all_values = $header->header_raw($field);
This method returns the value or values of the given header field. If the
named field does not appear in the header, this method returns false.
=head2 header
This method just calls C<header_raw>. It's the older name for C<header_raw>,
but it can be a problem because L<Email::MIME>, a subclass of Email::Simple,
makes C<header> return the header's decoded value.
=head2 header_raw_set
$header->header_raw_set($field => @values);
This method updates the value of the given header. Existing headers have their
values set in place. Additional headers are added at the end. If no values
are given to set, the header will be removed from to the message entirely.
=head2 header_set
L<header_set> is another name for L<header_raw_set>, which was the original
name for the method and which you'll see most often. In general, though, it's
better to be explicit and use L<header_raw_set>. (In Email::MIME,
L<header_str_set> exists for letting the library do the header encoding for
you.)
=head2 header_raw_prepend
$header->header_raw_prepend($field => $value);
This method adds a new instance of the name field as the first field in the
header.
=head2 crlf
This method returns the newline string used in the header.
=head1 AUTHORS
=over 4
=item *
Simon Cozens
=item *
Casey West
=item *
Ricardo SIGNES
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2003 by Simon Cozens.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

1285
database/perl/vendor/lib/Email/Stuffer.pm vendored Normal file
View File

File diff suppressed because it is too large Load Diff

998
database/perl/vendor/lib/Email/Valid.pm vendored Normal file
View File

@@ -0,0 +1,998 @@
require 5.006;
use strict;
use warnings;
package Email::Valid;
$Email::Valid::VERSION = '1.202';
# ABSTRACT: Check validity of Internet email addresses
our (
$RFC822PAT,
$Details, $Resolver, $Nslookup_Path,
$Debug,
);
use Carp;
use IO::File;
use Mail::Address;
use File::Spec;
use Scalar::Util 'blessed';
our %AUTOLOAD = (
allow_ip => 1,
fqdn => 1,
fudge => 1,
mxcheck => 1,
tldcheck => 1,
local_rules => 1,
localpart => 1,
);
our $NSLOOKUP_PAT = 'preference|serial|expire|mail\s+exchanger';
our @NSLOOKUP_PATHS = File::Spec->path();
# initialize if already loaded, better in prefork mod_perl environment
our $DNS_Method = defined $Net::DNS::VERSION ? 'Net::DNS' : '';
unless ($DNS_Method) {
__PACKAGE__->_select_dns_method;
}
# initialize $Resolver if necessary
if ($DNS_Method eq 'Net::DNS') {
unless (defined $Resolver) {
$Resolver = Net::DNS::Resolver->new;
}
}
sub new {
my $class = shift;
$class = ref $class || $class;
bless my $self = {}, $class;
$self->_initialize;
%$self = $self->_rearrange([ keys %AUTOLOAD ], \@_);
return $self;
}
sub _initialize {
my $self = shift;
$self->{mxcheck} = 0;
$self->{tldcheck} = 0;
$self->{fudge} = 0;
$self->{fqdn} = 1;
$self->{allow_ip} = 1;
$self->{local_rules} = 0;
$self->{localpart} = 1;
$self->{details} = $Details = undef;
}
# Pupose: handles named parameter calling style
sub _rearrange {
my $self = shift;
my(@names) = @{ shift() };
my(@params) = @{ shift() };
my(%args);
ref $self ? %args = %$self : _initialize( \%args );
return %args unless @params;
unless (@params > 1 and $params[0] =~ /^-/) {
while(@params) {
croak 'unexpected number of parameters' unless @names;
$args{ lc shift @names } = shift @params;
}
return %args;
}
while(@params) {
my $param = lc substr(shift @params, 1);
$args{ $param } = shift @params;
}
%args;
}
# Purpose: determine why an address failed a check
sub details {
my $self = shift;
return (ref $self ? $self->{details} : $Details) unless @_;
$Details = shift;
$self->{details} = $Details if ref $self;
return undef;
}
# Purpose: Check whether address conforms to RFC 822 syntax.
sub rfc822 {
my $self = shift;
my %args = $self->_rearrange([qw( address )], \@_);
my $addr = $args{address} or return $self->details('rfc822');
$addr = $addr->address if (blessed($addr) && $addr->isa('Mail::Address'));
return $self->details('rfc822')
if $addr =~ /\P{ASCII}/ or $addr !~ m/^$RFC822PAT$/o;
return 1;
}
# Purpose: attempt to locate the nslookup utility
sub _find_nslookup {
my $self = shift;
my $ns = 'nslookup';
foreach my $path (@NSLOOKUP_PATHS) {
my $file = File::Spec->catfile($path, $ns);
return "$file.exe" if ($^O eq 'MSWin32') and -x "$file.exe" and !-d _;
return $file if -x $file and !-d _;
}
return undef;
}
sub _select_dns_method {
# Configure a global resolver object for DNS queries
# if Net::DNS is available
eval { require Net::DNS };
return $DNS_Method = 'Net::DNS' unless $@;
$DNS_Method = 'nslookup';
}
# Purpose: perform DNS query using the Net::DNS module
sub _net_dns_query {
my $self = shift;
my $host = shift;
$Resolver = Net::DNS::Resolver->new unless defined $Resolver;
my @mx_entries = Net::DNS::mx($Resolver, $host);
# Check for valid MX records for $host
if (@mx_entries) {
foreach my $mx (@mx_entries) {
my $mxhost = $mx->exchange;
my $query = $Resolver->search($mxhost);
next unless ($query);
foreach my $a_rr ($query->answer) {
return 1 unless $a_rr->type ne 'A';
}
}
}
# Check for A record for $host
my $ans = $Resolver->query($host, 'A');
my @a_rrs = $ans ? $ans->answer : ();
if (@a_rrs) {
foreach my $a_rr (@a_rrs) {
return 1 unless $a_rr->type ne 'A';
}
}
# MX Check failed
return $self->details('mx');
}
# Purpose: perform DNS query using the nslookup utility
sub _nslookup_query {
my $self = shift;
my $host = shift;
local($/, *OLDERR);
unless ($Nslookup_Path) {
$Nslookup_Path = $self->_find_nslookup
or croak 'unable to locate nslookup';
}
# Check for an A record
return 1 if gethostbyname $host;
# Check for an MX record
if ($^O eq 'MSWin32' or $^O eq 'Cygwin') {
# Oh no, we're on Windows!
require IO::CaptureOutput;
my $response = IO::CaptureOutput::capture_exec(
$Nslookup_Path, '-query=mx', $host
);
croak "unable to execute nslookup '$Nslookup_Path': exit $?" if $?;
print STDERR $response if $Debug;
$response =~ /$NSLOOKUP_PAT/io or return $self->details('mx');
return 1;
} else {
# phew, we're not on Windows!
if (my $fh = IO::File->new('-|')) {
my $response = <$fh>;
print STDERR $response if $Debug;
close $fh;
$response =~ /$NSLOOKUP_PAT/io or return $self->details('mx');
return 1;
} else {
open OLDERR, '>&STDERR' or croak "cannot dup stderr: $!";
open STDERR, '>&STDOUT' or croak "cannot redirect stderr to stdout: $!";
{
exec $Nslookup_Path, '-query=mx', $host;
}
open STDERR, ">&OLDERR";
croak "unable to execute nslookup '$Nslookup_Path': $!";
}
}
}
# Purpose: Check whether a top level domain is valid for a domain.
sub tld {
my $self = shift;
my %args = $self->_rearrange([qw( address )], \@_);
unless (eval {require Net::Domain::TLD; Net::Domain::TLD->VERSION(1.65); 1}) {
die "Net::Domain::TLD not available";
}
my $host = $self->_host( $args{address} or return $self->details('tld') );
my ($tld) = $host =~ m#\.(\w+)$#;
my %invalid_tlds = map { $_ => 1 } qw(invalid test example localhost);
return defined $invalid_tlds{$tld} ? 0 : Net::Domain::TLD::tld_exists($tld);
}
# Purpose: Check whether a DNS record (A or MX) exists for a domain.
sub mx {
my $self = shift;
my %args = $self->_rearrange([qw( address )], \@_);
my $host = $self->_host($args{address}) or return $self->details('mx');
$self->_select_dns_method unless $DNS_Method;
if ($DNS_Method eq 'Net::DNS') {
print STDERR "using Net::DNS for dns query\n" if $Debug;
return $self->_net_dns_query( $host );
} elsif ($DNS_Method eq 'nslookup') {
print STDERR "using nslookup for dns query\n" if $Debug;
return $self->_nslookup_query( $host );
} else {
croak "unknown DNS method '$DNS_Method'";
}
}
# Purpose: convert address to host
# Returns: host
sub _host {
my $self = shift;
my $addr = shift;
$addr = $addr->address if (blessed($addr) && $addr->isa('Mail::Address'));
my $host = ($addr =~ /^.*@(.*)$/ ? $1 : $addr);
$host =~ s/\s+//g;
# REMOVE BRACKETS IF IT'S A DOMAIN-LITERAL
# RFC822 3.4.6
# Square brackets ("[" and "]") are used to indicate the
# presence of a domain-literal, which the appropriate
# name-domain is to use directly, bypassing normal
# name-resolution mechanisms.
$host =~ s/(^\[)|(\]$)//g;
$host;
}
# Purpose: Fix common addressing errors
# Returns: Possibly modified address
sub _fudge {
my $self = shift;
my $addr = shift;
$addr =~ s/\s+//g if $addr =~ /aol\.com$/i;
$addr =~ s/,/./g if $addr =~ /compuserve\.com$/i;
$addr;
}
# Purpose: Special address restrictions on a per-domain basis.
# Caveats: These organizations may change their rules at any time.
sub _local_rules {
my $self = shift;
my($user, $host) = @_;
1;
}
sub _valid_local_part {
my ($self, $localpart) = @_;
return 0 unless defined $localpart and length $localpart <= 64;
return 1;
}
sub _valid_domain_parts {
my ($self, $string) = @_;
return unless $string and length $string <= 255;
return if $string =~ /\.\./;
my @labels = split /\./, $string;
for my $label (@labels) {
return 0 unless $self->_is_domain_label($label);
}
return scalar @labels;
}
sub _is_domain_label {
my ($self, $string) = @_;
return unless $string =~ /\A
[A-Z0-9] # must start with an alnum
(?:
[-A-Z0-9]* # then maybe a dash or alnum
[A-Z0-9] # finally ending with an alnum
)? # lather, rinse, repeat
\z/ix;
return 1;
}
# Purpose: Put an address through a series of checks to determine
# whether it should be considered valid.
sub address {
my $self = shift;
my %args = $self->_rearrange([qw( address fudge mxcheck tldcheck fqdn
local_rules )], \@_);
my $addr = $args{address} or return $self->details('rfc822');
$addr = $addr->address if (blessed($addr) && $addr->isa('Mail::Address'));
$addr = $self->_fudge( $addr ) if $args{fudge};
$self->rfc822( -address => $addr ) or return undef;
($addr) = Mail::Address->parse( $addr );
$addr or return $self->details('rfc822'); # This should never happen
if (length($addr->address) > 254) {
return $self->details('address_too_long');
}
if ($args{local_rules}) {
$self->_local_rules( $addr->user, $addr->host )
or return $self->details('local_rules');
}
if ($args{localpart}) {
$self->_valid_local_part($addr->user) > 0
or return $self->details('localpart');
}
my $ip_ok = $args{allow_ip} && $addr->host =~ /\A\[
(?:[0-9]{1,3}\.){3}[0-9]{1,3}
/x;
if (! $ip_ok && $args{fqdn}) {
my $domain_parts = $self->_valid_domain_parts($addr->host);
return $self->details('fqdn')
unless $ip_ok || ($domain_parts && $domain_parts > 1);
}
if (! $ip_ok && $args{tldcheck}) {
$self->tld( $addr->host ) or return $self->details('tldcheck');
}
if ($args{mxcheck}) {
# I'm not sure this ->details call is needed, but I'll test for it later.
# The whole ->details thing is... weird. -- rjbs, 2006-06-08
$self->mx( $addr->host ) or return $self->details('mxcheck');
}
return (wantarray ? ($addr->address, $addr) : $addr->address);
}
sub AUTOLOAD {
my $self = shift;
my $type = ref($self) || die "$self is not an object";
my $name = our $AUTOLOAD;
$name =~ s/.*://;
return if $name eq 'DESTROY';
die "unknown autoload name '$name'" unless $AUTOLOAD{$name};
return (@_ ? $self->{$name} = shift : $self->{$name});
}
# Regular expression built using Jeffrey Friedl's example in
# _Mastering Regular Expressions_ (http://www.ora.com/catalog/regexp/).
$RFC822PAT = <<'EOF';
[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\
xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xf
f\n\015()]*)*\)[\040\t]*)*(?:(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\x
ff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|"[^\\\x80-\xff\n\015
"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[\040\t]*(?:\([^\\\x80-\
xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80
-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*
)*(?:\.[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\
\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\
x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x8
0-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|"[^\\\x80-\xff\n
\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[\040\t]*(?:\([^\\\x
80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^
\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040
\t]*)*)*@[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([
^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\
\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\
x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-
\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()
]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\
x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\04
0\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\
n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\
015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?!
[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\
]]|\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\
x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\01
5()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)*|(?:[^(\040)<>@,;:".
\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]
)|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[^
()<>@,;:".\\\[\]\x80-\xff\000-\010\012-\037]*(?:(?:\([^\\\x80-\xff\n\0
15()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][
^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)|"[^\\\x80-\xff\
n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[^()<>@,;:".\\\[\]\
x80-\xff\000-\010\012-\037]*)*<[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?
:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-
\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:@[\040\t]*
(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015
()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()
]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\0
40)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\
[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\
xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*
)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80
-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x
80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t
]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\
\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])
*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x
80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80
-\xff\n\015()]*)*\)[\040\t]*)*)*(?:,[\040\t]*(?:\([^\\\x80-\xff\n\015(
)]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\
\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*@[\040\t
]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\0
15()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015
()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(
\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|
\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80
-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()
]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x
80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^
\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040
\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".
\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff
])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\
\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x
80-\xff\n\015()]*)*\)[\040\t]*)*)*)*:[\040\t]*(?:\([^\\\x80-\xff\n\015
()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\
\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)?(?:[^
(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-
\037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\
n\015"]*)*")[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|
\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))
[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80-\xff
\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\x
ff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(
?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\
000-\037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\
xff\n\015"]*)*")[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\x
ff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)
*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)*@[\040\t]*(?:\([^\\\x80-\x
ff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-
\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)
*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\
]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\]
)[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-
\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\x
ff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(
?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80
-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<
>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x8
0-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\040\t]*(?:
\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]
*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)
*\)[\040\t]*)*)*>)
EOF
$RFC822PAT =~ s/\n//g;
1;
#pod =head1 SYNOPSIS
#pod
#pod use Email::Valid;
#pod my $address = Email::Valid->address('maurice@hevanet.com');
#pod print ($address ? 'yes' : 'no');
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module determines whether an email address is well-formed, and
#pod optionally, whether a mail host exists for the domain.
#pod
#pod Please note that there is no way to determine whether an
#pod address is deliverable without attempting delivery
#pod (for details, see L<perlfaq 9|http://perldoc.perl.org/perlfaq9.html#How-do-I-check-a-valid-mail-address>).
#pod
#pod =head1 PREREQUISITES
#pod
#pod This module requires perl 5.004 or later and the L<Mail::Address> module.
#pod Either the L<Net::DNS> module or the nslookup utility is required
#pod for DNS checks. The L<Net::Domain::TLD> module is required to check the
#pod validity of top level domains.
#pod
#pod =head1 METHODS
#pod
#pod Every method which accepts an C<< <ADDRESS> >> parameter may
#pod be passed either a string or an instance of the Mail::Address
#pod class. All errors raise an exception.
#pod
#pod =over 4
#pod
#pod =item new ( [PARAMS] )
#pod
#pod This method is used to construct an Email::Valid object.
#pod It accepts an optional list of named parameters to
#pod control the behavior of the object at instantiation.
#pod
#pod The following named parameters are allowed. See the
#pod individual methods below for details.
#pod
#pod -mxcheck
#pod -tldcheck
#pod -fudge
#pod -fqdn
#pod -allow_ip
#pod -local_rules
#pod
#pod =item mx ( <ADDRESS>|<DOMAIN> )
#pod
#pod This method accepts an email address or domain name and determines
#pod whether a DNS record (A or MX) exists for it.
#pod
#pod The method returns true if a record is found and undef if not.
#pod
#pod Either the Net::DNS module or the nslookup utility is required for
#pod DNS checks. Using Net::DNS is the preferred method since error
#pod handling is improved. If Net::DNS is available, you can modify
#pod the behavior of the resolver (e.g. change the default tcp_timeout
#pod value) by manipulating the global L<Net::DNS::Resolver> instance stored in
#pod C<$Email::Valid::Resolver>.
#pod
#pod =item rfc822 ( <ADDRESS> )
#pod
#pod This method determines whether an address conforms to the RFC822
#pod specification (except for nested comments). It returns true if it
#pod conforms and undef if not.
#pod
#pod =item fudge ( <TRUE>|<FALSE> )
#pod
#pod Specifies whether calls to address() should attempt to correct
#pod common addressing errors. Currently, this results in the removal of
#pod spaces in AOL addresses, and the conversion of commas to periods in
#pod Compuserve addresses. The default is false.
#pod
#pod =item allow_ip ( <TRUE>|<FALSE> )
#pod
#pod Specifies whether a "domain literal" is acceptable as the domain part. That
#pod means addresses like: C<rjbs@[1.2.3.4]>
#pod
#pod The checking for the domain literal is stricter than the RFC and looser than
#pod checking for a valid IP address, I<but this is subject to change>.
#pod
#pod The default is true.
#pod
#pod =item fqdn ( <TRUE>|<FALSE> )
#pod
#pod Specifies whether addresses passed to address() must contain a fully
#pod qualified domain name (FQDN). The default is true.
#pod
#pod B<Please note!> FQDN checks only occur for non-domain-literals. In other
#pod words, if you have set C<allow_ip> and the address ends in a bracketed IP
#pod address, the FQDN check will not occur.
#pod
#pod =item tld ( <ADDRESS> )
#pod
#pod This method determines whether the domain part of an address is in a
#pod recognized top-level domain.
#pod
#pod B<Please note!> TLD checks only occur for non-domain-literals. In other
#pod words, if you have set C<allow_ip> and the address ends in a bracketed IP
#pod address, the TLD check will not occur.
#pod
#pod =item local_rules ( <TRUE>|<FALSE> )
#pod
#pod Specifies whether addresses passed to address() should be tested
#pod for domain specific restrictions. Currently, this is limited to
#pod certain AOL restrictions that I'm aware of. The default is false.
#pod
#pod =item mxcheck ( <TRUE>|<FALSE> )
#pod
#pod Specifies whether addresses passed to address() should be checked
#pod for a valid DNS entry. The default is false.
#pod
#pod =item tldcheck ( <TRUE>|<FALSE> )
#pod
#pod Specifies whether addresses passed to address() should be checked
#pod for a valid top level domains. The default is false.
#pod
#pod =item address ( <ADDRESS> )
#pod
#pod This is the primary method which determines whether an email
#pod address is valid. Its behavior is modified by the values of
#pod mxcheck(), tldcheck(), local_rules(), fqdn(), and fudge(). If the address
#pod passes all checks, the (possibly modified) address is returned as
#pod a string. Otherwise, undef is returned.
#pod In a list context, the method also returns an instance of the
#pod Mail::Address class representing the email address.
#pod
#pod =item details ()
#pod
#pod If the last call to address() returned undef, you can call this
#pod method to determine why it failed. Possible values are:
#pod
#pod rfc822
#pod localpart
#pod local_rules
#pod fqdn
#pod mxcheck
#pod tldcheck
#pod
#pod If the class is not instantiated, you can get the same information
#pod from the global C<$Email::Valid::Details>.
#pod
#pod =back
#pod
#pod =head1 EXAMPLES
#pod
#pod Let's see if the address 'maurice@hevanet.com' conforms to the
#pod RFC822 specification:
#pod
#pod print (Email::Valid->address('maurice@hevanet.com') ? 'yes' : 'no');
#pod
#pod Additionally, let's make sure there's a mail host for it:
#pod
#pod print (Email::Valid->address( -address => 'maurice@hevanet.com',
#pod -mxcheck => 1 ) ? 'yes' : 'no');
#pod
#pod Let's see an example of how the address may be modified:
#pod
#pod $addr = Email::Valid->address('Alfred Neuman <Neuman @ foo.bar>');
#pod print "$addr\n"; # prints Neuman@foo.bar
#pod
#pod Now let's add the check for top level domains:
#pod
#pod $addr = Email::Valid->address( -address => 'Neuman@foo.bar',
#pod -tldcheck => 1 );
#pod print "$addr\n"; # doesn't print anything
#pod
#pod Need to determine why an address failed?
#pod
#pod unless(Email::Valid->address('maurice@hevanet')) {
#pod print "address failed $Email::Valid::Details check.\n";
#pod }
#pod
#pod If an error is encountered, an exception is raised. This is really
#pod only possible when performing DNS queries. Trap any exceptions by
#pod wrapping the call in an eval block:
#pod
#pod eval {
#pod $addr = Email::Valid->address( -address => 'maurice@hevanet.com',
#pod -mxcheck => 1 );
#pod };
#pod warn "an error was encountered: $@" if $@;
#pod
#pod =head1 CREDITS
#pod
#pod Significant portions of this module are based on the ckaddr program
#pod written by Tom Christiansen and the RFC822 address pattern developed
#pod by Jeffrey Friedl. Neither were involved in the construction of this
#pod module; all errors are mine.
#pod
#pod Thanks very much to the following people for their suggestions and
#pod bug fixes:
#pod
#pod Otis Gospodnetic <otis@DOMINIS.com>
#pod Kim Ryan <kimaryan@ozemail.com.au>
#pod Pete Ehlke <pde@listserv.music.sony.com>
#pod Lupe Christoph
#pod David Birnbaum
#pod Achim
#pod Elizabeth Mattijsen (liz@dijkmat.nl)
#pod
#pod =head1 SEE ALSO
#pod
#pod L<Mail::Address>, L<Net::DNS>, L<Net::Domain::TLD>, L<perlfaq9|https://metacpan.org/pod/distribution/perlfaq/lib/perlfaq9.pod>
#pod
#pod L<RFC822|https://www.ietf.org/rfc/rfc0822.txt> -
#pod standard for the format of ARPA internet text messages.
#pod Superseded by L<RFC2822|https://www.ietf.org/rfc/rfc2822.txt>.
#pod
#pod =cut
__END__
=pod
=encoding UTF-8
=head1 NAME
Email::Valid - Check validity of Internet email addresses
=head1 VERSION
version 1.202
=head1 SYNOPSIS
use Email::Valid;
my $address = Email::Valid->address('maurice@hevanet.com');
print ($address ? 'yes' : 'no');
=head1 DESCRIPTION
This module determines whether an email address is well-formed, and
optionally, whether a mail host exists for the domain.
Please note that there is no way to determine whether an
address is deliverable without attempting delivery
(for details, see L<perlfaq 9|http://perldoc.perl.org/perlfaq9.html#How-do-I-check-a-valid-mail-address>).
=head1 PREREQUISITES
This module requires perl 5.004 or later and the L<Mail::Address> module.
Either the L<Net::DNS> module or the nslookup utility is required
for DNS checks. The L<Net::Domain::TLD> module is required to check the
validity of top level domains.
=head1 METHODS
Every method which accepts an C<< <ADDRESS> >> parameter may
be passed either a string or an instance of the Mail::Address
class. All errors raise an exception.
=over 4
=item new ( [PARAMS] )
This method is used to construct an Email::Valid object.
It accepts an optional list of named parameters to
control the behavior of the object at instantiation.
The following named parameters are allowed. See the
individual methods below for details.
-mxcheck
-tldcheck
-fudge
-fqdn
-allow_ip
-local_rules
=item mx ( <ADDRESS>|<DOMAIN> )
This method accepts an email address or domain name and determines
whether a DNS record (A or MX) exists for it.
The method returns true if a record is found and undef if not.
Either the Net::DNS module or the nslookup utility is required for
DNS checks. Using Net::DNS is the preferred method since error
handling is improved. If Net::DNS is available, you can modify
the behavior of the resolver (e.g. change the default tcp_timeout
value) by manipulating the global L<Net::DNS::Resolver> instance stored in
C<$Email::Valid::Resolver>.
=item rfc822 ( <ADDRESS> )
This method determines whether an address conforms to the RFC822
specification (except for nested comments). It returns true if it
conforms and undef if not.
=item fudge ( <TRUE>|<FALSE> )
Specifies whether calls to address() should attempt to correct
common addressing errors. Currently, this results in the removal of
spaces in AOL addresses, and the conversion of commas to periods in
Compuserve addresses. The default is false.
=item allow_ip ( <TRUE>|<FALSE> )
Specifies whether a "domain literal" is acceptable as the domain part. That
means addresses like: C<rjbs@[1.2.3.4]>
The checking for the domain literal is stricter than the RFC and looser than
checking for a valid IP address, I<but this is subject to change>.
The default is true.
=item fqdn ( <TRUE>|<FALSE> )
Specifies whether addresses passed to address() must contain a fully
qualified domain name (FQDN). The default is true.
B<Please note!> FQDN checks only occur for non-domain-literals. In other
words, if you have set C<allow_ip> and the address ends in a bracketed IP
address, the FQDN check will not occur.
=item tld ( <ADDRESS> )
This method determines whether the domain part of an address is in a
recognized top-level domain.
B<Please note!> TLD checks only occur for non-domain-literals. In other
words, if you have set C<allow_ip> and the address ends in a bracketed IP
address, the TLD check will not occur.
=item local_rules ( <TRUE>|<FALSE> )
Specifies whether addresses passed to address() should be tested
for domain specific restrictions. Currently, this is limited to
certain AOL restrictions that I'm aware of. The default is false.
=item mxcheck ( <TRUE>|<FALSE> )
Specifies whether addresses passed to address() should be checked
for a valid DNS entry. The default is false.
=item tldcheck ( <TRUE>|<FALSE> )
Specifies whether addresses passed to address() should be checked
for a valid top level domains. The default is false.
=item address ( <ADDRESS> )
This is the primary method which determines whether an email
address is valid. Its behavior is modified by the values of
mxcheck(), tldcheck(), local_rules(), fqdn(), and fudge(). If the address
passes all checks, the (possibly modified) address is returned as
a string. Otherwise, undef is returned.
In a list context, the method also returns an instance of the
Mail::Address class representing the email address.
=item details ()
If the last call to address() returned undef, you can call this
method to determine why it failed. Possible values are:
rfc822
localpart
local_rules
fqdn
mxcheck
tldcheck
If the class is not instantiated, you can get the same information
from the global C<$Email::Valid::Details>.
=back
=head1 EXAMPLES
Let's see if the address 'maurice@hevanet.com' conforms to the
RFC822 specification:
print (Email::Valid->address('maurice@hevanet.com') ? 'yes' : 'no');
Additionally, let's make sure there's a mail host for it:
print (Email::Valid->address( -address => 'maurice@hevanet.com',
-mxcheck => 1 ) ? 'yes' : 'no');
Let's see an example of how the address may be modified:
$addr = Email::Valid->address('Alfred Neuman <Neuman @ foo.bar>');
print "$addr\n"; # prints Neuman@foo.bar
Now let's add the check for top level domains:
$addr = Email::Valid->address( -address => 'Neuman@foo.bar',
-tldcheck => 1 );
print "$addr\n"; # doesn't print anything
Need to determine why an address failed?
unless(Email::Valid->address('maurice@hevanet')) {
print "address failed $Email::Valid::Details check.\n";
}
If an error is encountered, an exception is raised. This is really
only possible when performing DNS queries. Trap any exceptions by
wrapping the call in an eval block:
eval {
$addr = Email::Valid->address( -address => 'maurice@hevanet.com',
-mxcheck => 1 );
};
warn "an error was encountered: $@" if $@;
=head1 CREDITS
Significant portions of this module are based on the ckaddr program
written by Tom Christiansen and the RFC822 address pattern developed
by Jeffrey Friedl. Neither were involved in the construction of this
module; all errors are mine.
Thanks very much to the following people for their suggestions and
bug fixes:
Otis Gospodnetic <otis@DOMINIS.com>
Kim Ryan <kimaryan@ozemail.com.au>
Pete Ehlke <pde@listserv.music.sony.com>
Lupe Christoph
David Birnbaum
Achim
Elizabeth Mattijsen (liz@dijkmat.nl)
=head1 SEE ALSO
L<Mail::Address>, L<Net::DNS>, L<Net::Domain::TLD>, L<perlfaq9|https://metacpan.org/pod/distribution/perlfaq/lib/perlfaq9.pod>
L<RFC822|https://www.ietf.org/rfc/rfc0822.txt> -
standard for the format of ARPA internet text messages.
Superseded by L<RFC2822|https://www.ietf.org/rfc/rfc2822.txt>.
=head1 AUTHOR
Maurice Aubrey <maurice@hevanet.com>
=head1 CONTRIBUTORS
=for stopwords Alexandr Ciornii Karel Miko McA Michael Schout Mohammad S Anwar Neil Bowers Ricardo SIGNES Steve Bertrand Svetlana Troy Morehouse
=over 4
=item *
Alexandr Ciornii <alexchorny@gmail.com>
=item *
Karel Miko <karel.miko@gmail.com>
=item *
McA <McA@github.com>
=item *
Michael Schout <mschout@gkg.net>
=item *
Mohammad S Anwar <mohammad.anwar@yahoo.com>
=item *
Neil Bowers <neil@bowers.com>
=item *
Ricardo SIGNES <rjbs@cpan.org>
=item *
Steve Bertrand <steveb@cpan.org>
=item *
Svetlana <svetlana.wiczer@gmail.com>
=item *
Troy Morehouse <troymore@nbnet.nb.ca>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 1998 by Maurice Aubrey.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut