/usr/share/perl5/Email/MIME/Attachment/Stripper.pm is in libemail-mime-attachment-stripper-perl 1.317-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | use strict;
use warnings;
package Email::MIME::Attachment::Stripper;
{
$Email::MIME::Attachment::Stripper::VERSION = '1.317';
}
# ABSTRACT: strip the attachments from an email
use Email::MIME 1.861; # new(\$str)
use Email::MIME::ContentType 1.016; # type/subtype
use Carp;
sub new {
my ($class, $email, %attr) = @_;
$email = Email::MIME->new($email) if (ref($email) || 'SCALAR') eq 'SCALAR';
croak "Need a message" unless ref($email) || do {
require Email::Abstract;
$email = Email::Abstract->cast($email, 'Email::MIME');
};
bless { message => $email, attr => \%attr }, $class;
}
sub message {
my ($self) = @_;
$self->_detach_all unless exists $self->{attach};
return $self->{message};
}
sub attachments {
my $self = shift;
$self->_detach_all unless exists $self->{attach};
return $self->{attach} ? @{ $self->{attach} } : ();
}
sub _detach_all {
my ($self, $part) = @_;
$part ||= $self->{message};
return if $part->parts == 1;
my @attach = ();
my @keep = ();
foreach ( $part->parts ) {
my $ct = $_->content_type || 'text/plain';
my $dp = $_->header('Content-Disposition') || 'inline';
push(@keep, $_) and next
if $ct =~ m[text/plain]i && $dp =~ /inline/i;
push @attach, $_;
if ($_->parts > 1) {
my @kept=$self->_detach_all($_);
push(@keep,@kept) if @kept;
}
}
$part->parts_set(\@keep);
push @{$self->{attach}}, map {;
my $content_type = parse_content_type($_->content_type);
{
content_type => join('/', @{$content_type}{qw[type subtype]}),
payload => $_->body,
filename => $self->{attr}->{force_filename}
? $_->filename(1)
: ($_->filename || ''),
}
} @attach;
return @keep;
}
1;
__END__
=pod
=head1 NAME
Email::MIME::Attachment::Stripper - strip the attachments from an email
=head1 VERSION
version 1.317
=head1 SYNOPSIS
my $stripper = Email::MIME::Attachment::Stripper->new($mail);
my $msg = $stripper->message;
my @attachments = $stripper->attachments;
=head1 DESCRIPTION
Given a Email::MIME object, detach all attachments from the message and make
them available separately.
The message you're left with might still be multipart, but it should only be
multipart/alternative or multipart/related.
Given this message:
+ multipart/mixed
- text/plain
- application/pdf; disposition=attachment
The PDF will be stripped. Whether the returned message is a single text/plain
part or a multipart/mixed message with only the text/plain part remaining in it
is not yet guaranteed one way or the other.
=head1 METHODS
=head2 new
my $stripper = Email::MIME::Attachment::Stripper->new($email, %args);
The constructor may be passed an Email::MIME object, a reference to a string,
or any other value that Email::Abstract (if available) can cast to an
Email::MIME object.
Valid arguments include:
force_filename - try harder to get a filename, making one up if necessary
=head2 message
my $email_mime = $stripper->message;
This returns the message with all the attachments detached. This will alter
both the body and the header of the message.
=head2 attachments
my @attachments = $stripper->attachments;
This returns a list of all the attachments we found in the message, as a hash
of { filename, content_type, payload }.
This may contain parts that might not normally be considered attachments, like
text/html or multipart/alternative.
=head1 ATTENTION!
This module's behavior has never been very clearly spelled out, and it has led
to misunderstandings and bug reports, which may or may not be actual bugs. I
plan to take some significant action to address this. To read more or comment,
please see L<https://github.com/rjbs/Email-MIME-Attachment-Stripper/issues/2>
=head1 CREDITS AND LICENSE
This module is incredibly closely derived from Tony Bowden's
L<Mail::Message::Attachment::Stripper>; this derivation was done by Simon
Cozens (C<simon@cpan.org>), and you receive this under the same terms as Tony's
original module.
=head1 AUTHOR
Simon Cozens
=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
|