Initial Commit
This commit is contained in:
Riley Schneider
391
database/perl/vendor/lib/Email/MIME/Kit/Assembler/Standard.pm
vendored
Normal file
391
database/perl/vendor/lib/Email/MIME/Kit/Assembler/Standard.pm
vendored
Normal 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
|
||||
Reference in New Issue
Block a user