142 lines
3.6 KiB
Perl
142 lines
3.6 KiB
Perl
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
|