Initial class construction
This commit is contained in:
672
Git/usr/share/perl5/vendor_perl/MIME/Body.pm
Normal file
672
Git/usr/share/perl5/vendor_perl/MIME/Body.pm
Normal file
@ -0,0 +1,672 @@
|
||||
package MIME::Body;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Body - the body of a MIME message
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Before reading further, you should see L<MIME::Tools> to make sure that
|
||||
you understand where this module fits into the grand scheme of things.
|
||||
Go on, do it now. I'll wait.
|
||||
|
||||
Ready? Ok...
|
||||
|
||||
|
||||
=head2 Obtaining bodies
|
||||
|
||||
### Get the bodyhandle of a MIME::Entity object:
|
||||
$body = $entity->bodyhandle;
|
||||
|
||||
### Create a body which stores data in a disk file:
|
||||
$body = new MIME::Body::File "/path/to/file";
|
||||
|
||||
### Create a body which stores data in an in-core array:
|
||||
$body = new MIME::Body::InCore \@strings;
|
||||
|
||||
|
||||
=head2 Opening, closing, and using IO handles
|
||||
|
||||
### Write data to the body:
|
||||
$IO = $body->open("w") || die "open body: $!";
|
||||
$IO->print($message);
|
||||
$IO->close || die "close I/O handle: $!";
|
||||
|
||||
### Read data from the body (in this case, line by line):
|
||||
$IO = $body->open("r") || die "open body: $!";
|
||||
while (defined($_ = $IO->getline)) {
|
||||
### do stuff
|
||||
}
|
||||
$IO->close || die "close I/O handle: $!";
|
||||
|
||||
|
||||
=head2 Other I/O
|
||||
|
||||
### Dump the ENCODED body data to a filehandle:
|
||||
$body->print(\*STDOUT);
|
||||
|
||||
### Slurp all the UNENCODED data in, and put it in a scalar:
|
||||
$string = $body->as_string;
|
||||
|
||||
### Slurp all the UNENCODED data in, and put it in an array of lines:
|
||||
@lines = $body->as_lines;
|
||||
|
||||
|
||||
=head2 Working directly with paths to underlying files
|
||||
|
||||
### Where's the data?
|
||||
if (defined($body->path)) { ### data is on disk:
|
||||
print "data is stored externally, in ", $body->path;
|
||||
}
|
||||
else { ### data is in core:
|
||||
print "data is already in core, and is...\n", $body->as_string;
|
||||
}
|
||||
|
||||
### Get rid of anything on disk:
|
||||
$body->purge;
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
MIME messages can be very long (e.g., tar files, MPEGs, etc.) or very
|
||||
short (short textual notes, as in ordinary mail). Long messages
|
||||
are best stored in files, while short ones are perhaps best stored
|
||||
in core.
|
||||
|
||||
This class is an attempt to define a common interface for objects
|
||||
which contain message data, regardless of how the data is
|
||||
physically stored. The lifespan of a "body" object
|
||||
usually looks like this:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1.
|
||||
|
||||
B<Body object is created by a MIME::Parser during parsing.>
|
||||
It's at this point that the actual MIME::Body subclass is chosen,
|
||||
and new() is invoked. (For example: if the body data is going to
|
||||
a file, then it is at this point that the class MIME::Body::File,
|
||||
and the filename, is chosen).
|
||||
|
||||
=item 2.
|
||||
|
||||
B<Data is written to the body> (usually by the MIME parser) like this:
|
||||
The body is opened for writing, via C<open("w")>. This will trash any
|
||||
previous contents, and return an "I/O handle" opened for writing.
|
||||
Data is written to this I/O handle, via print().
|
||||
Then the I/O handle is closed, via close().
|
||||
|
||||
=item 3.
|
||||
|
||||
B<Data is read from the body> (usually by the user application) like this:
|
||||
The body is opened for reading by a user application, via C<open("r")>.
|
||||
This will return an "I/O handle" opened for reading.
|
||||
Data is read from the I/O handle, via read(), getline(), or getlines().
|
||||
Then the I/O handle is closed, via close().
|
||||
|
||||
=item 4.
|
||||
|
||||
B<Body object is destructed.>
|
||||
|
||||
=back
|
||||
|
||||
You can write your own subclasses, as long as they follow the
|
||||
interface described below. Implementers of subclasses should assume
|
||||
that steps 2 and 3 may be repeated any number of times, and in
|
||||
different orders (e.g., 1-2-2-3-2-3-3-3-3-3-2-4).
|
||||
|
||||
In any case, once a MIME::Body has been created, you ask to open it
|
||||
for reading or writing, which gets you an "i/o handle": you then use
|
||||
the same mechanisms for reading from or writing to that handle, no matter
|
||||
what class it is.
|
||||
|
||||
Beware: unless you know for certain what kind of body you have, you
|
||||
should I<not> assume that the body has an underlying filehandle.
|
||||
|
||||
|
||||
=head1 PUBLIC INTERFACE
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
### Pragmas:
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
|
||||
### System modules:
|
||||
use Carp;
|
||||
use IO::File;
|
||||
|
||||
### The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item new ARGS...
|
||||
|
||||
I<Class method, constructor.>
|
||||
Create a new body. Any ARGS are sent to init().
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $self = bless {}, shift;
|
||||
$self->init(@_);
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item init ARGS...
|
||||
|
||||
I<Instance method, abstract, initiallizer.>
|
||||
This is called automatically by C<new()>, with the arguments given
|
||||
to C<new()>. The arguments are optional, and entirely up to the
|
||||
subclass. The default method does nothing,
|
||||
|
||||
=cut
|
||||
|
||||
sub init { 1 }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item as_lines
|
||||
|
||||
I<Instance method.>
|
||||
Return the contents of the body as an array of lines (each terminated
|
||||
by a newline, with the possible exception of the final one).
|
||||
Returns empty on failure (NB: indistinguishable from an empty body!).
|
||||
|
||||
Note: the default method gets the data via
|
||||
repeated getline() calls; your subclass might wish to override this.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_lines {
|
||||
my $self = shift;
|
||||
my @lines;
|
||||
my $io = $self->open("r") || return ();
|
||||
local $_;
|
||||
push @lines, $_ while (defined($_ = $io->getline()));
|
||||
$io->close;
|
||||
@lines;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item as_string
|
||||
|
||||
I<Instance method.>
|
||||
Return the body data as a string (slurping it into core if necessary).
|
||||
Best not to do this unless you're I<sure> that the body is reasonably small!
|
||||
Returns empty string for an empty body, and undef on failure.
|
||||
|
||||
Note: the default method uses print(), which gets the data via
|
||||
repeated read() calls; your subclass might wish to override this.
|
||||
|
||||
=cut
|
||||
|
||||
sub as_string {
|
||||
my $self = shift;
|
||||
my $str = '';
|
||||
my $fh = IO::File->new(\$str, '>:') or croak("Cannot open in-memory file: $!");
|
||||
$self->print($fh);
|
||||
close($fh);
|
||||
return $str;
|
||||
}
|
||||
*data = \&as_string; ### silently invoke preferred usage
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item binmode [ONOFF]
|
||||
|
||||
I<Instance method.>
|
||||
With argument, flags whether or not open() should return an I/O handle
|
||||
which has binmode() activated. With no argument, just returns the
|
||||
current value.
|
||||
|
||||
=cut
|
||||
|
||||
sub binmode {
|
||||
my ($self, $onoff) = @_;
|
||||
$self->{MB_Binmode} = $onoff if (@_ > 1);
|
||||
$self->{MB_Binmode};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item is_encoded [ONOFF]
|
||||
|
||||
I<Instance method.>
|
||||
If set to yes, no decoding is applied on output. This flag is set
|
||||
by MIME::Parser, if the parser runs in decode_bodies(0) mode, so the
|
||||
content is handled unmodified.
|
||||
|
||||
=cut
|
||||
|
||||
sub is_encoded {
|
||||
my ($self, $yesno) = @_;
|
||||
$self->{MB_IsEncoded} = $yesno if (@_ > 1);
|
||||
$self->{MB_IsEncoded};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item dup
|
||||
|
||||
I<Instance method.>
|
||||
Duplicate the bodyhandle.
|
||||
|
||||
I<Beware:> external data in bodyhandles is I<not> copied to new files!
|
||||
Changing the data in one body's data file, or purging that body,
|
||||
I<will> affect its duplicate. Bodies with in-core data probably need
|
||||
not worry.
|
||||
|
||||
=cut
|
||||
|
||||
sub dup {
|
||||
my $self = shift;
|
||||
bless { %$self }, ref($self); ### shallow copy ok for ::File and ::Scalar
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item open READWRITE
|
||||
|
||||
I<Instance method, abstract.>
|
||||
This should do whatever is necessary to open the body for either
|
||||
writing (if READWRITE is "w") or reading (if mode is "r").
|
||||
|
||||
This method is expected to return an "I/O handle" object on success,
|
||||
and undef on error. An I/O handle can be any object that supports a
|
||||
small set of standard methods for reading/writing data.
|
||||
See the IO::Handle class for an example.
|
||||
|
||||
=cut
|
||||
|
||||
sub open {
|
||||
undef;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item path [PATH]
|
||||
|
||||
I<Instance method.>
|
||||
If you're storing the body data externally (e.g., in a disk file), you'll
|
||||
want to give applications the ability to get at that data, for cleanup.
|
||||
This method should return the path to the data, or undef if there is none.
|
||||
|
||||
Where appropriate, the path I<should> be a simple string, like a filename.
|
||||
With argument, sets the PATH, which should be undef if there is none.
|
||||
|
||||
=cut
|
||||
|
||||
sub path {
|
||||
my $self = shift;
|
||||
$self->{MB_Path} = shift if @_;
|
||||
$self->{MB_Path};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item print FILEHANDLE
|
||||
|
||||
I<Instance method.>
|
||||
Output the body data to the given filehandle, or to the currently-selected
|
||||
one if none is given.
|
||||
|
||||
=cut
|
||||
|
||||
sub print {
|
||||
my ($self, $fh) = @_;
|
||||
my $nread;
|
||||
|
||||
### Get output filehandle, and ensure that it's a printable object:
|
||||
$fh ||= select;
|
||||
|
||||
### Write it:
|
||||
my $buf = '';
|
||||
my $io = $self->open("r") || return undef;
|
||||
$fh->print($buf) while ($nread = $io->read($buf, 8192));
|
||||
$io->close;
|
||||
return defined($nread); ### how'd we do?
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item purge
|
||||
|
||||
I<Instance method, abstract.>
|
||||
Remove any data which resides external to the program (e.g., in disk files).
|
||||
Immediately after a purge(), the path() should return undef to indicate
|
||||
that the external data is no longer available.
|
||||
|
||||
=cut
|
||||
|
||||
sub purge {
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=head1 SUBCLASSES
|
||||
|
||||
The following built-in classes are provided:
|
||||
|
||||
Body Stores body When open()ed,
|
||||
class: data in: returns:
|
||||
--------------------------------------------------------
|
||||
MIME::Body::File disk file IO::Handle
|
||||
MIME::Body::Scalar scalar IO::Handle
|
||||
MIME::Body::InCore scalar array IO::Handle
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#------------------------------------------------------------
|
||||
package MIME::Body::File;
|
||||
#------------------------------------------------------------
|
||||
|
||||
=head2 MIME::Body::File
|
||||
|
||||
A body class that stores the data in a disk file. Invoke the
|
||||
constructor as:
|
||||
|
||||
$body = new MIME::Body::File "/path/to/file";
|
||||
|
||||
In this case, the C<path()> method would return the given path,
|
||||
so you I<could> say:
|
||||
|
||||
if (defined($body->path)) {
|
||||
open BODY, $body->path or die "open: $!";
|
||||
while (<BODY>) {
|
||||
### do stuff
|
||||
}
|
||||
close BODY;
|
||||
}
|
||||
|
||||
But you're best off not doing this.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
### Pragmas:
|
||||
use vars qw(@ISA);
|
||||
use strict;
|
||||
|
||||
### System modules:
|
||||
use IO::File;
|
||||
|
||||
### Kit modules:
|
||||
use MIME::Tools qw(whine);
|
||||
|
||||
@ISA = qw(MIME::Body);
|
||||
|
||||
|
||||
#------------------------------
|
||||
# init PATH
|
||||
#------------------------------
|
||||
sub init {
|
||||
my ($self, $path) = @_;
|
||||
$self->path($path); ### use it as-is
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# open READWRITE
|
||||
#------------------------------
|
||||
sub open {
|
||||
my ($self, $mode) = @_;
|
||||
|
||||
my $path = $self->path;
|
||||
|
||||
if( $mode ne 'r' && $mode ne 'w' ) {
|
||||
die "bad mode: '$mode'";
|
||||
}
|
||||
|
||||
my $IO = IO::File->new($path, $mode) || die "MIME::Body::File->open $path: $!";
|
||||
|
||||
$IO->binmode() if $self->binmode;
|
||||
|
||||
return $IO;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# purge
|
||||
#------------------------------
|
||||
# Unlink the path (and undefine it).
|
||||
#
|
||||
sub purge {
|
||||
my $self = shift;
|
||||
if (defined($self->path)) {
|
||||
unlink $self->path or whine "couldn't unlink ".$self->path.": $!";
|
||||
$self->path(undef);
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
#------------------------------------------------------------
|
||||
package MIME::Body::Scalar;
|
||||
#------------------------------------------------------------
|
||||
|
||||
=head2 MIME::Body::Scalar
|
||||
|
||||
A body class that stores the data in-core, in a simple scalar.
|
||||
Invoke the constructor as:
|
||||
|
||||
$body = new MIME::Body::Scalar \$string;
|
||||
|
||||
A single scalar argument sets the body to that value, exactly as though
|
||||
you'd opened for the body for writing, written the value,
|
||||
and closed the body again:
|
||||
|
||||
$body = new MIME::Body::Scalar "Line 1\nLine 2\nLine 3";
|
||||
|
||||
A single array reference sets the body to the result of joining all the
|
||||
elements of that array together:
|
||||
|
||||
$body = new MIME::Body::Scalar ["Line 1\n",
|
||||
"Line 2\n",
|
||||
"Line 3"];
|
||||
|
||||
=cut
|
||||
|
||||
use vars qw(@ISA);
|
||||
use strict;
|
||||
|
||||
use Carp;
|
||||
|
||||
@ISA = qw(MIME::Body);
|
||||
|
||||
|
||||
#------------------------------
|
||||
# init DATA
|
||||
#------------------------------
|
||||
sub init {
|
||||
my ($self, $data) = @_;
|
||||
$data = join('', @$data) if (ref($data) && (ref($data) eq 'ARRAY'));
|
||||
$self->{MBS_Data} = (defined($data) ? $data : '');
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# as_string
|
||||
#------------------------------
|
||||
sub as_string {
|
||||
shift->{MBS_Data};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
# open READWRITE
|
||||
#------------------------------
|
||||
sub open {
|
||||
my ($self, $mode) = @_;
|
||||
$self->{MBS_Data} = '' if ($mode eq 'w'); ### writing
|
||||
|
||||
if ($mode eq 'w') {
|
||||
$mode = '>:';
|
||||
} elsif ($mode eq 'r') {
|
||||
$mode = '<:';
|
||||
} else {
|
||||
die "bad mode: $mode";
|
||||
}
|
||||
|
||||
return IO::File->new(\ $self->{MBS_Data}, $mode);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#------------------------------------------------------------
|
||||
package MIME::Body::InCore;
|
||||
#------------------------------------------------------------
|
||||
|
||||
=head2 MIME::Body::InCore
|
||||
|
||||
A body class that stores the data in-core.
|
||||
Invoke the constructor as:
|
||||
|
||||
$body = new MIME::Body::InCore \$string;
|
||||
$body = new MIME::Body::InCore $string;
|
||||
$body = new MIME::Body::InCore \@stringarray
|
||||
|
||||
A simple scalar argument sets the body to that value, exactly as though
|
||||
you'd opened for the body for writing, written the value,
|
||||
and closed the body again:
|
||||
|
||||
$body = new MIME::Body::InCore "Line 1\nLine 2\nLine 3";
|
||||
|
||||
A single array reference sets the body to the concatenation of all
|
||||
scalars that it holds:
|
||||
|
||||
$body = new MIME::Body::InCore ["Line 1\n",
|
||||
"Line 2\n",
|
||||
"Line 3"];
|
||||
|
||||
=cut
|
||||
|
||||
use vars qw(@ISA);
|
||||
use strict;
|
||||
|
||||
use Carp;
|
||||
|
||||
@ISA = qw(MIME::Body::Scalar);
|
||||
|
||||
|
||||
#------------------------------
|
||||
# init DATA
|
||||
#------------------------------
|
||||
sub init {
|
||||
my ($self, $data) = @_;
|
||||
if (!defined($data)) { ### nothing
|
||||
$self->{MBS_Data} = '';
|
||||
}
|
||||
elsif (!ref($data)) { ### simple scalar
|
||||
$self->{MBS_Data} = $data;
|
||||
}
|
||||
elsif (ref($data) eq 'SCALAR') {
|
||||
$self->{MBS_Data} = $$data;
|
||||
}
|
||||
elsif (ref($data) eq 'ARRAY') {
|
||||
$self->{MBS_Data} = join('', @$data);
|
||||
}
|
||||
else {
|
||||
croak "I can't handle DATA which is a ".ref($data)."\n";
|
||||
}
|
||||
$self;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=head2 Defining your own subclasses
|
||||
|
||||
So you're not happy with files and scalar-arrays?
|
||||
No problem: just define your own MIME::Body subclass, and make a subclass
|
||||
of MIME::Parser or MIME::ParserBase which returns an instance of your
|
||||
body class whenever appropriate in the C<new_body_for(head)> method.
|
||||
|
||||
Your "body" class must inherit from MIME::Body (or some subclass of it),
|
||||
and it must either provide (or inherit the default for) the following
|
||||
methods...
|
||||
|
||||
The default inherited method I<should suffice> for all these:
|
||||
|
||||
new
|
||||
binmode [ONOFF]
|
||||
path
|
||||
|
||||
The default inherited method I<may suffice> for these, but perhaps
|
||||
there's a better implementation for your subclass.
|
||||
|
||||
init ARGS...
|
||||
as_lines
|
||||
as_string
|
||||
dup
|
||||
print
|
||||
purge
|
||||
|
||||
The default inherited method I<will probably not suffice> for these:
|
||||
|
||||
open
|
||||
|
||||
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
One reason I didn't just use IO::Handle objects for message bodies was
|
||||
that I wanted a "body" object to be a form of completely encapsulated
|
||||
program-persistent storage; that is, I wanted users to be able to write
|
||||
code like this...
|
||||
|
||||
### Get body handle from this MIME message, and read its data:
|
||||
$body = $entity->bodyhandle;
|
||||
$IO = $body->open("r");
|
||||
while (defined($_ = $IO->getline)) {
|
||||
print STDOUT $_;
|
||||
}
|
||||
$IO->close;
|
||||
|
||||
...without requiring that they know anything more about how the
|
||||
$body object is actually storing its data (disk file, scalar variable,
|
||||
array variable, or whatever).
|
||||
|
||||
Storing the body of each MIME message in a persistently-open
|
||||
IO::Handle was a possibility, but it seemed like a bad idea,
|
||||
considering that a single multipart MIME message could easily suck up
|
||||
all the available file descriptors on some systems. This risk increases
|
||||
if the user application is processing more than one MIME entity at a time.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Tools>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
David F. Skoll (dfs@roaringpenguin.com) http://www.roaringpenguin.com
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
Thanks to Achim Bohnet for suggesting that MIME::Parser not be restricted
|
||||
to the use of FileHandles.
|
||||
|
||||
#------------------------------
|
||||
1;
|
||||
|
661
Git/usr/share/perl5/vendor_perl/MIME/Decoder.pm
Normal file
661
Git/usr/share/perl5/vendor_perl/MIME/Decoder.pm
Normal file
@ -0,0 +1,661 @@
|
||||
package MIME::Decoder;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Decoder - an object for decoding the body part of a MIME stream
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Before reading further, you should see L<MIME::Tools> to make sure that
|
||||
you understand where this module fits into the grand scheme of things.
|
||||
Go on, do it now. I'll wait.
|
||||
|
||||
Ready? Ok...
|
||||
|
||||
|
||||
=head2 Decoding a data stream
|
||||
|
||||
Here's a simple filter program to read quoted-printable data from STDIN
|
||||
(until EOF) and write the decoded data to STDOUT:
|
||||
|
||||
use MIME::Decoder;
|
||||
|
||||
$decoder = new MIME::Decoder 'quoted-printable' or die "unsupported";
|
||||
$decoder->decode(\*STDIN, \*STDOUT);
|
||||
|
||||
|
||||
=head2 Encoding a data stream
|
||||
|
||||
Here's a simple filter program to read binary data from STDIN
|
||||
(until EOF) and write base64-encoded data to STDOUT:
|
||||
|
||||
use MIME::Decoder;
|
||||
|
||||
$decoder = new MIME::Decoder 'base64' or die "unsupported";
|
||||
$decoder->encode(\*STDIN, \*STDOUT);
|
||||
|
||||
|
||||
=head2 Non-standard encodings
|
||||
|
||||
You can B<write and install> your own decoders so that
|
||||
MIME::Decoder will know about them:
|
||||
|
||||
use MyBase64Decoder;
|
||||
|
||||
install MyBase64Decoder 'base64';
|
||||
|
||||
You can also B<test> if a given encoding is supported:
|
||||
|
||||
if (supported MIME::Decoder 'x-uuencode') {
|
||||
### we can uuencode!
|
||||
}
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This abstract class, and its private concrete subclasses (see below)
|
||||
provide an OO front end to the actions of...
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Decoding a MIME-encoded stream
|
||||
|
||||
=item *
|
||||
|
||||
Encoding a raw data stream into a MIME-encoded stream.
|
||||
|
||||
=back
|
||||
|
||||
The constructor for MIME::Decoder takes the name of an encoding
|
||||
(C<base64>, C<7bit>, etc.), and returns an instance of a I<subclass>
|
||||
of MIME::Decoder whose C<decode()> method will perform the appropriate
|
||||
decoding action, and whose C<encode()> method will perform the appropriate
|
||||
encoding action.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
### Pragmas:
|
||||
use strict;
|
||||
use vars qw($VERSION %DecoderFor);
|
||||
|
||||
### System modules:
|
||||
use IPC::Open2;
|
||||
use IO::Select;
|
||||
use FileHandle;
|
||||
|
||||
### Kit modules:
|
||||
use MIME::Tools qw(:config :msgs);
|
||||
use Carp;
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# Globals
|
||||
#
|
||||
#------------------------------
|
||||
|
||||
### The stream decoders:
|
||||
%DecoderFor = (
|
||||
|
||||
### Standard...
|
||||
'7bit' => 'MIME::Decoder::NBit',
|
||||
'8bit' => 'MIME::Decoder::NBit',
|
||||
'base64' => 'MIME::Decoder::Base64',
|
||||
'binary' => 'MIME::Decoder::Binary',
|
||||
'none' => 'MIME::Decoder::Binary',
|
||||
'quoted-printable' => 'MIME::Decoder::QuotedPrint',
|
||||
|
||||
### Non-standard...
|
||||
'binhex' => 'MIME::Decoder::BinHex',
|
||||
'binhex40' => 'MIME::Decoder::BinHex',
|
||||
'mac-binhex40' => 'MIME::Decoder::BinHex',
|
||||
'mac-binhex' => 'MIME::Decoder::BinHex',
|
||||
'x-uu' => 'MIME::Decoder::UU',
|
||||
'x-uuencode' => 'MIME::Decoder::UU',
|
||||
|
||||
### This was removed, since I fear that x-gzip != x-gzip64...
|
||||
### 'x-gzip' => 'MIME::Decoder::Gzip64',
|
||||
|
||||
### This is no longer installed by default, since not all folks have gzip:
|
||||
### 'x-gzip64' => 'MIME::Decoder::Gzip64',
|
||||
);
|
||||
|
||||
### The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
### Me:
|
||||
my $ME = 'MIME::Decoder';
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=head1 PUBLIC INTERFACE
|
||||
|
||||
=head2 Standard interface
|
||||
|
||||
If all you are doing is I<using> this class, here's all you'll need...
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item new ENCODING
|
||||
|
||||
I<Class method, constructor.>
|
||||
Create and return a new decoder object which can handle the
|
||||
given ENCODING.
|
||||
|
||||
my $decoder = new MIME::Decoder "7bit";
|
||||
|
||||
Returns the undefined value if no known decoders are appropriate.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class, @args) = @_;
|
||||
my ($encoding) = @args;
|
||||
|
||||
### Coerce the type to be legit:
|
||||
$encoding = lc($encoding || '');
|
||||
|
||||
### Get the class:
|
||||
my $concrete_name = $DecoderFor{$encoding};
|
||||
|
||||
if( ! $concrete_name ) {
|
||||
carp "no decoder for $encoding";
|
||||
return undef;
|
||||
}
|
||||
|
||||
### Create the new object (if we can):
|
||||
my $self = { MD_Encoding => lc($encoding) };
|
||||
unless (eval "require $concrete_name;") {
|
||||
carp $@;
|
||||
return undef;
|
||||
}
|
||||
bless $self, $concrete_name;
|
||||
$self->init(@args);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item best ENCODING
|
||||
|
||||
I<Class method, constructor.>
|
||||
Exactly like new(), except that this defaults any unsupported encoding to
|
||||
"binary", after raising a suitable warning (it's a fatal error if there's
|
||||
no binary decoder).
|
||||
|
||||
my $decoder = best MIME::Decoder "x-gzip64";
|
||||
|
||||
Will either return a decoder, or a raise a fatal exception.
|
||||
|
||||
=cut
|
||||
|
||||
sub best {
|
||||
my ($class, $enc, @args) = @_;
|
||||
my $self = $class->new($enc, @args);
|
||||
if (!$self) {
|
||||
usage "unsupported encoding '$enc': using 'binary'";
|
||||
$self = $class->new('binary') || croak "ack! no binary decoder!";
|
||||
}
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item decode INSTREAM,OUTSTREAM
|
||||
|
||||
I<Instance method.>
|
||||
Decode the document waiting in the input handle INSTREAM,
|
||||
writing the decoded information to the output handle OUTSTREAM.
|
||||
|
||||
Read the section in this document on I/O handles for more information
|
||||
about the arguments. Note that you can still supply old-style
|
||||
unblessed filehandles for INSTREAM and OUTSTREAM.
|
||||
|
||||
Returns true on success, throws exception on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub decode {
|
||||
my ($self, $in, $out) = @_;
|
||||
|
||||
### Set up the default input record separator to be CRLF:
|
||||
### $in->input_record_separator("\012\015");
|
||||
|
||||
### Invoke back-end method to do the work:
|
||||
$self->decode_it($in, $out) ||
|
||||
die "$ME: ".$self->encoding." decoding failed\n";
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item encode INSTREAM,OUTSTREAM
|
||||
|
||||
I<Instance method.>
|
||||
Encode the document waiting in the input filehandle INSTREAM,
|
||||
writing the encoded information to the output stream OUTSTREAM.
|
||||
|
||||
Read the section in this document on I/O handles for more information
|
||||
about the arguments. Note that you can still supply old-style
|
||||
unblessed filehandles for INSTREAM and OUTSTREAM.
|
||||
|
||||
Returns true on success, throws exception on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub encode {
|
||||
my ($self, $in, $out, $textual_type) = @_;
|
||||
|
||||
### Invoke back-end method to do the work:
|
||||
$self->encode_it($in, $out, $self->encoding eq 'quoted-printable' ? ($textual_type) : ()) ||
|
||||
die "$ME: ".$self->encoding." encoding failed\n";
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item encoding
|
||||
|
||||
I<Instance method.>
|
||||
Return the encoding that this object was created to handle,
|
||||
coerced to all lowercase (e.g., C<"base64">).
|
||||
|
||||
=cut
|
||||
|
||||
sub encoding {
|
||||
shift->{MD_Encoding};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item head [HEAD]
|
||||
|
||||
I<Instance method.>
|
||||
Completely optional: some decoders need to know a little about the file
|
||||
they are encoding/decoding; e.g., x-uu likes to have the filename.
|
||||
The HEAD is any object which responds to messages like:
|
||||
|
||||
$head->mime_attr('content-disposition.filename');
|
||||
|
||||
=cut
|
||||
|
||||
sub head {
|
||||
my ($self, $head) = @_;
|
||||
$self->{MD_Head} = $head if @_ > 1;
|
||||
$self->{MD_Head};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item supported [ENCODING]
|
||||
|
||||
I<Class method.>
|
||||
With one arg (an ENCODING name), returns truth if that encoding
|
||||
is currently handled, and falsity otherwise. The ENCODING will
|
||||
be automatically coerced to lowercase:
|
||||
|
||||
if (supported MIME::Decoder '7BIT') {
|
||||
### yes, we can handle it...
|
||||
}
|
||||
else {
|
||||
### drop back six and punt...
|
||||
}
|
||||
|
||||
With no args, returns a reference to a hash of all available decoders,
|
||||
where the key is the encoding name (all lowercase, like '7bit'),
|
||||
and the value is true (it happens to be the name of the class
|
||||
that handles the decoding, but you probably shouldn't rely on that).
|
||||
You may safely modify this hash; it will I<not> change the way the
|
||||
module performs its lookups. Only C<install> can do that.
|
||||
|
||||
I<Thanks to Achim Bohnet for suggesting this method.>
|
||||
|
||||
=cut
|
||||
|
||||
sub supported {
|
||||
my ($class, $decoder) = @_;
|
||||
defined($decoder) ? $DecoderFor{lc($decoder)}: { %DecoderFor };
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=back
|
||||
|
||||
=head2 Subclass interface
|
||||
|
||||
If you are writing (or installing) a new decoder subclass, there
|
||||
are some other methods you'll need to know about:
|
||||
|
||||
=over 4
|
||||
|
||||
=item decode_it INSTREAM,OUTSTREAM
|
||||
|
||||
I<Abstract instance method.>
|
||||
The back-end of the B<decode> method. It takes an input handle
|
||||
opened for reading (INSTREAM), and an output handle opened for
|
||||
writing (OUTSTREAM).
|
||||
|
||||
If you are writing your own decoder subclass, you must override this
|
||||
method in your class. Your method should read from the input
|
||||
handle via C<getline()> or C<read()>, decode this input, and print the
|
||||
decoded data to the output handle via C<print()>. You may do this
|
||||
however you see fit, so long as the end result is the same.
|
||||
|
||||
Note that unblessed references and globrefs are automatically turned
|
||||
into I/O handles for you by C<decode()>, so you don't need to worry
|
||||
about it.
|
||||
|
||||
Your method must return either C<undef> (to indicate failure),
|
||||
or C<1> (to indicate success).
|
||||
It may also throw an exception to indicate failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub decode_it {
|
||||
die "attempted to use abstract 'decode_it' method!";
|
||||
}
|
||||
|
||||
=item encode_it INSTREAM,OUTSTREAM
|
||||
|
||||
I<Abstract instance method.>
|
||||
The back-end of the B<encode> method. It takes an input handle
|
||||
opened for reading (INSTREAM), and an output handle opened for
|
||||
writing (OUTSTREAM).
|
||||
|
||||
If you are writing your own decoder subclass, you must override this
|
||||
method in your class. Your method should read from the input
|
||||
handle via C<getline()> or C<read()>, encode this input, and print the
|
||||
encoded data to the output handle via C<print()>. You may do this
|
||||
however you see fit, so long as the end result is the same.
|
||||
|
||||
Note that unblessed references and globrefs are automatically turned
|
||||
into I/O handles for you by C<encode()>, so you don't need to worry
|
||||
about it.
|
||||
|
||||
Your method must return either C<undef> (to indicate failure),
|
||||
or C<1> (to indicate success).
|
||||
It may also throw an exception to indicate failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub encode_it {
|
||||
die "attempted to use abstract 'encode_it' method!";
|
||||
}
|
||||
|
||||
=item filter IN, OUT, COMMAND...
|
||||
|
||||
I<Class method, utility.>
|
||||
If your decoder involves an external program, you can invoke
|
||||
them easily through this method. The command must be a "filter": a
|
||||
command that reads input from its STDIN (which will come from the IN argument)
|
||||
and writes output to its STDOUT (which will go to the OUT argument).
|
||||
|
||||
For example, here's a decoder that un-gzips its data:
|
||||
|
||||
sub decode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
$self->filter($in, $out, "gzip -d -");
|
||||
}
|
||||
|
||||
The usage is similar to IPC::Open2::open2 (which it uses internally),
|
||||
so you can specify COMMAND as a single argument or as an array.
|
||||
|
||||
=cut
|
||||
|
||||
sub filter
|
||||
{
|
||||
my ($self, $in, $out, @cmd) = @_;
|
||||
my $buf = '';
|
||||
|
||||
### Open pipe:
|
||||
STDOUT->flush; ### very important, or else we get duplicate output!
|
||||
|
||||
my $kidpid = open2(my $child_out, my $child_in, @cmd) || die "@cmd: open2 failed: $!";
|
||||
|
||||
### We have to use select() for doing both reading and writing.
|
||||
my $rsel = IO::Select->new( $child_out );
|
||||
my $wsel = IO::Select->new( $child_in );
|
||||
|
||||
while (1) {
|
||||
|
||||
### Wait for one hour; if that fails, it's too bad.
|
||||
my ($read, $write) = IO::Select->select( $rsel, $wsel, undef, 3600);
|
||||
|
||||
if( !defined $read && !defined $write ) {
|
||||
kill 1, $kidpid;
|
||||
waitpid $kidpid, 0;
|
||||
die "@cmd: select failed: $!";
|
||||
}
|
||||
|
||||
### If can read from child:
|
||||
if( my $fh = shift @$read ) {
|
||||
if( $fh->sysread(my $buf, 1024) ) {
|
||||
$out->print($buf);
|
||||
} else {
|
||||
$rsel->remove($fh);
|
||||
$fh->close();
|
||||
}
|
||||
}
|
||||
|
||||
### If can write to child:
|
||||
if( my $fh = shift @$write ) {
|
||||
if($in->read(my $buf, 1024)) {
|
||||
local $SIG{PIPE} = sub {
|
||||
warn "got SIGPIPE from @cmd";
|
||||
$wsel->remove($fh);
|
||||
$fh->close();
|
||||
};
|
||||
$fh->syswrite( $buf );
|
||||
} else {
|
||||
$wsel->remove($fh);
|
||||
$fh->close();
|
||||
}
|
||||
}
|
||||
|
||||
### If both $child_out and $child_in are done:
|
||||
last unless ($rsel->count() || $wsel->count());
|
||||
}
|
||||
|
||||
### Wait for it:
|
||||
waitpid($kidpid, 0) == $kidpid or die "@cmd: couldn't reap child $kidpid";
|
||||
### Check if it failed:
|
||||
$? == 0 or die "@cmd: bad exit status: \$? = $?";
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item init ARGS...
|
||||
|
||||
I<Instance method.>
|
||||
Do any necessary initialization of the new instance,
|
||||
taking whatever arguments were given to C<new()>.
|
||||
Should return the self object on success, undef on failure.
|
||||
|
||||
=cut
|
||||
|
||||
sub init {
|
||||
$_[0];
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item install ENCODINGS...
|
||||
|
||||
I<Class method>.
|
||||
Install this class so that each encoding in ENCODINGS is handled by it:
|
||||
|
||||
install MyBase64Decoder 'base64', 'x-base64super';
|
||||
|
||||
You should not override this method.
|
||||
|
||||
=cut
|
||||
|
||||
sub install {
|
||||
my $class = shift;
|
||||
$DecoderFor{lc(shift @_)} = $class while (@_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item uninstall ENCODINGS...
|
||||
|
||||
I<Class method>.
|
||||
Uninstall support for encodings. This is a way to turn off the decoding
|
||||
of "experimental" encodings. For safety, always use MIME::Decoder directly:
|
||||
|
||||
uninstall MIME::Decoder 'x-uu', 'x-uuencode';
|
||||
|
||||
You should not override this method.
|
||||
|
||||
=cut
|
||||
|
||||
sub uninstall {
|
||||
shift;
|
||||
$DecoderFor{lc(shift @_)} = undef while (@_);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
#------------------------------
|
||||
|
||||
=back
|
||||
|
||||
=head1 DECODER SUBCLASSES
|
||||
|
||||
You don't need to C<"use"> any other Perl modules; the
|
||||
following "standard" subclasses are included as part of MIME::Decoder:
|
||||
|
||||
Class: Handles encodings:
|
||||
------------------------------------------------------------
|
||||
MIME::Decoder::Binary binary
|
||||
MIME::Decoder::NBit 7bit, 8bit
|
||||
MIME::Decoder::Base64 base64
|
||||
MIME::Decoder::QuotedPrint quoted-printable
|
||||
|
||||
The following "non-standard" subclasses are also included:
|
||||
|
||||
Class: Handles encodings:
|
||||
------------------------------------------------------------
|
||||
MIME::Decoder::UU x-uu, x-uuencode
|
||||
MIME::Decoder::Gzip64 x-gzip64 ** requires gzip!
|
||||
|
||||
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
=head2 Input/Output handles
|
||||
|
||||
As of MIME-tools 2.0, this class has to play nice with the new MIME::Body
|
||||
class... which means that input and output routines cannot just assume that
|
||||
they are dealing with filehandles.
|
||||
|
||||
Therefore, all that MIME::Decoder and its subclasses require (and, thus,
|
||||
all that they can assume) is that INSTREAMs and OUTSTREAMs are objects
|
||||
which respond to a subset of the messages defined in the IO::Handle
|
||||
interface; minimally:
|
||||
|
||||
print
|
||||
getline
|
||||
read(BUF,NBYTES)
|
||||
|
||||
I<Thanks to Achim Bohnet for suggesting this more-generic I/O model.>
|
||||
|
||||
|
||||
=head2 Writing a decoder
|
||||
|
||||
If you're experimenting with your own encodings, you'll probably want
|
||||
to write a decoder. Here are the basics:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1.
|
||||
|
||||
Create a module, like "MyDecoder::", for your decoder.
|
||||
Declare it to be a subclass of MIME::Decoder.
|
||||
|
||||
=item 2.
|
||||
|
||||
Create the following instance methods in your class, as described above:
|
||||
|
||||
decode_it
|
||||
encode_it
|
||||
init
|
||||
|
||||
=item 3.
|
||||
|
||||
In your application program, activate your decoder for one or
|
||||
more encodings like this:
|
||||
|
||||
require MyDecoder;
|
||||
|
||||
install MyDecoder "7bit"; ### use MyDecoder to decode "7bit"
|
||||
install MyDecoder "x-foo"; ### also use MyDecoder to decode "x-foo"
|
||||
|
||||
=back
|
||||
|
||||
To illustrate, here's a custom decoder class for the C<quoted-printable>
|
||||
encoding:
|
||||
|
||||
package MyQPDecoder;
|
||||
|
||||
@ISA = qw(MIME::Decoder);
|
||||
use MIME::Decoder;
|
||||
use MIME::QuotedPrint;
|
||||
|
||||
### decode_it - the private decoding method
|
||||
sub decode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
local $_;
|
||||
while (defined($_ = $in->getline)) {
|
||||
my $decoded = decode_qp($_);
|
||||
$out->print($decoded);
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
### encode_it - the private encoding method
|
||||
sub encode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
|
||||
my ($buf, $nread) = ('', 0);
|
||||
while ($in->read($buf, 60)) {
|
||||
my $encoded = encode_qp($buf);
|
||||
$out->print($encoded);
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
That's it. The task was pretty simple because the C<"quoted-printable">
|
||||
encoding can easily be converted line-by-line... as can
|
||||
even C<"7bit"> and C<"8bit"> (since all these encodings guarantee
|
||||
short lines, with a max of 1000 characters).
|
||||
The good news is: it is very likely that it will be similarly-easy to
|
||||
write a MIME::Decoder for any future standard encodings.
|
||||
|
||||
The C<"binary"> decoder, however, really required block reads and writes:
|
||||
see L<"MIME::Decoder::Binary"> for details.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Tools>, other MIME::Decoder subclasses.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
1;
|
137
Git/usr/share/perl5/vendor_perl/MIME/Decoder/Base64.pm
Normal file
137
Git/usr/share/perl5/vendor_perl/MIME/Decoder/Base64.pm
Normal file
@ -0,0 +1,137 @@
|
||||
package MIME::Decoder::Base64;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Decoder::Base64 - encode/decode a "base64" stream
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
A generic decoder object; see L<MIME::Decoder> for usage.
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A L<MIME::Decoder> subclass for the C<"base64"> encoding.
|
||||
The name was chosen to jibe with the pre-existing MIME::Base64
|
||||
utility package, which this class actually uses to translate each chunk.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
When B<decoding>, the input is read one line at a time.
|
||||
The input accumulates in an internal buffer, which is decoded in
|
||||
multiple-of-4-sized chunks (plus a possible "leftover" input chunk,
|
||||
of course).
|
||||
|
||||
=item *
|
||||
|
||||
When B<encoding>, the input is read 45 bytes at a time: this ensures
|
||||
that the output lines are not too long. We chose 45 since it is
|
||||
a multiple of 3 and produces lines under 76 characters, as RFC 2045
|
||||
specifies:
|
||||
The encoded output stream must be represented in lines of no more
|
||||
than 76 characters each.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Decoder>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
use vars qw(@ISA $VERSION);
|
||||
use MIME::Decoder;
|
||||
use MIME::Base64 2.04;
|
||||
use MIME::Tools qw(debug);
|
||||
|
||||
@ISA = qw(MIME::Decoder);
|
||||
|
||||
### The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
### How many bytes to encode at a time (must be a multiple of 3, and
|
||||
### less than (76 * 0.75)!
|
||||
my $EncodeChunkLength = 45;
|
||||
|
||||
### How many bytes to decode at a time?
|
||||
my $DecodeChunkLength = 32 * 1024;
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# decode_it IN, OUT
|
||||
#
|
||||
sub decode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
my $len_4xN;
|
||||
|
||||
### Create a suitable buffer:
|
||||
my $buffer = ' ' x (120 + $DecodeChunkLength); $buffer = '';
|
||||
debug "in = $in; out = $out";
|
||||
|
||||
### Get chunks until done:
|
||||
local($_) = ' ' x $DecodeChunkLength;
|
||||
while ($in->read($_, $DecodeChunkLength)) {
|
||||
tr{A-Za-z0-9+/}{}cd; ### get rid of non-base64 chars
|
||||
|
||||
### Concat any new input onto any leftover from the last round:
|
||||
$buffer .= $_;
|
||||
length($buffer) >= $DecodeChunkLength or next;
|
||||
|
||||
### Extract substring with highest multiple of 4 bytes:
|
||||
### 0 means not enough to work with... get more data!
|
||||
$len_4xN = length($buffer) & ~3;
|
||||
|
||||
### Partition into largest-multiple-of-4 (which we decode),
|
||||
### and the remainder (which gets handled next time around):
|
||||
$out->print(decode_base64(substr($buffer, 0, $len_4xN)));
|
||||
$buffer = substr($buffer, $len_4xN);
|
||||
}
|
||||
|
||||
### No more input remains. Dispose of anything left in buffer:
|
||||
if (length($buffer)) {
|
||||
|
||||
### Pad to 4-byte multiple, and decode:
|
||||
$buffer .= "==="; ### need no more than 3 pad chars
|
||||
$len_4xN = length($buffer) & ~3;
|
||||
|
||||
### Decode it!
|
||||
$out->print(decode_base64(substr($buffer, 0, $len_4xN)));
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# encode_it IN, OUT
|
||||
#
|
||||
sub encode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
my $encoded;
|
||||
|
||||
my $nread;
|
||||
my $buf = '';
|
||||
my $nl = $MIME::Entity::BOUNDARY_DELIMITER || "\n";
|
||||
while ($nread = $in->read($buf, $EncodeChunkLength)) {
|
||||
$encoded = encode_base64($buf, $nl);
|
||||
$encoded .= $nl unless ($encoded =~ /$nl\Z/); ### ensure newline!
|
||||
$out->print($encoded);
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
1;
|
||||
|
183
Git/usr/share/perl5/vendor_perl/MIME/Decoder/BinHex.pm
Normal file
183
Git/usr/share/perl5/vendor_perl/MIME/Decoder/BinHex.pm
Normal file
@ -0,0 +1,183 @@
|
||||
package MIME::Decoder::BinHex;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Decoder::BinHex - decode a "binhex" stream
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
A generic decoder object; see L<MIME::Decoder> for usage.
|
||||
|
||||
Also supports a preamble() method to recover text before
|
||||
the binhexed portion of the stream.
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A MIME::Decoder subclass for a nonstandard encoding whereby
|
||||
data are binhex-encoded. Common non-standard MIME encodings for this:
|
||||
|
||||
x-uu
|
||||
x-uuencode
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Decoder>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Julian Field (F<mailscanner@ecs.soton.ac.uk>).
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
require 5.002;
|
||||
use vars qw(@ISA $VERSION);
|
||||
use MIME::Decoder;
|
||||
use MIME::Tools qw(whine);
|
||||
use Convert::BinHex;
|
||||
|
||||
@ISA = qw(MIME::Decoder);
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# decode_it IN, OUT
|
||||
#
|
||||
sub decode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
my ($mode, $file);
|
||||
my (@preamble, @data);
|
||||
my $H2B = Convert::BinHex->hex2bin;
|
||||
my $line;
|
||||
|
||||
$self->{MDU_Preamble} = \@preamble;
|
||||
$self->{MDU_Mode} = '600';
|
||||
$self->{MDU_File} = undef;
|
||||
|
||||
### Find beginning...
|
||||
local $_;
|
||||
while (defined($_ = $in->getline)) {
|
||||
if (/^\(This file must be converted/) {
|
||||
$_ = $in->getline;
|
||||
last if /^:/;
|
||||
}
|
||||
push @preamble, $_;
|
||||
}
|
||||
die("binhex decoding: fell off end of file\n") if !defined($_);
|
||||
|
||||
### Decode:
|
||||
my $data;
|
||||
$data = $H2B->next($_); # or whine("Next error is $@ $!\n");
|
||||
my $len = unpack("C", $data);
|
||||
while ($len > length($data)+21 && defined($line = $in->getline)) {
|
||||
$data .= $H2B->next($line);
|
||||
}
|
||||
if (length($data) >= 22+$len) {
|
||||
$data = substr($data, 22+$len);
|
||||
} else {
|
||||
$data = '';
|
||||
}
|
||||
|
||||
$out->print($data);
|
||||
while (defined($_ = $in->getline)) {
|
||||
$line = $_;
|
||||
$data = $H2B->next($line);
|
||||
$out->print($data);
|
||||
last if $line =~ /:$/;
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# encode_it IN, OUT
|
||||
#
|
||||
sub encode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
my $line;
|
||||
my $buf = '';
|
||||
my $fname = (($self->head &&
|
||||
$self->head->mime_attr('content-disposition.filename')) ||
|
||||
'');
|
||||
my $B2H = Convert::BinHex->bin2hex;
|
||||
$out->print("(This file must be converted with BinHex 4.0)\n");
|
||||
|
||||
# Sigh... get length of file
|
||||
$in->seek(0, 2);
|
||||
my $datalen = $in->tell();
|
||||
$in->seek(0, 0);
|
||||
|
||||
# Build header in core:
|
||||
my @hdrs;
|
||||
my $flen = length($fname);
|
||||
push @hdrs, pack("C", $flen);
|
||||
push @hdrs, pack("a$flen", $fname);
|
||||
push @hdrs, pack('C', 4);
|
||||
push @hdrs, pack('a4', '????');
|
||||
push @hdrs, pack('a4', '????');
|
||||
push @hdrs, pack('n', 0);
|
||||
push @hdrs, pack('N', $datalen);
|
||||
push @hdrs, pack('N', 0); # Resource length
|
||||
my $hdr = join '', @hdrs;
|
||||
|
||||
# Compute the header CRC:
|
||||
my $crc = Convert::BinHex::binhex_crc("\000\000",
|
||||
Convert::BinHex::binhex_crc($hdr, 0));
|
||||
|
||||
# Output the header (plus its CRC):
|
||||
$out->print($B2H->next($hdr . pack('n', $crc)));
|
||||
|
||||
while ($in->read($buf, 1000)) {
|
||||
$out->print($B2H->next($buf));
|
||||
}
|
||||
$out->print($B2H->done);
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# last_preamble
|
||||
#
|
||||
# Return the last preamble as ref to array of lines.
|
||||
# Gets reset by decode_it().
|
||||
#
|
||||
sub last_preamble {
|
||||
my $self = shift;
|
||||
return $self->{MDU_Preamble} || [];
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# last_mode
|
||||
#
|
||||
# Return the last mode.
|
||||
# Gets reset to undef by decode_it().
|
||||
#
|
||||
sub last_mode {
|
||||
shift->{MDU_Mode};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# last_filename
|
||||
#
|
||||
# Return the last filename.
|
||||
# Gets reset by decode_it().
|
||||
#
|
||||
sub last_filename {
|
||||
shift->{MDU_File} || undef; #[];
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
1;
|
86
Git/usr/share/perl5/vendor_perl/MIME/Decoder/Binary.pm
Normal file
86
Git/usr/share/perl5/vendor_perl/MIME/Decoder/Binary.pm
Normal file
@ -0,0 +1,86 @@
|
||||
package MIME::Decoder::Binary;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Decoder::Binary - perform no encoding/decoding
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
A generic decoder object; see L<MIME::Decoder> for usage.
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A MIME::Decoder subclass for the C<"binary"> encoding (in other words,
|
||||
no encoding).
|
||||
|
||||
The C<"binary"> decoder is a special case, since it's ill-advised
|
||||
to read the input line-by-line: after all, an uncompressed image file might
|
||||
conceivably have loooooooooong stretches of bytes without a C<"\n"> among
|
||||
them, and we don't want to risk blowing out our core. So, we
|
||||
read-and-write fixed-size chunks.
|
||||
|
||||
Both the B<encoder> and B<decoder> do a simple pass-through of the data
|
||||
from input to output.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Decoder>
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
use MIME::Decoder;
|
||||
use vars qw(@ISA $VERSION);
|
||||
|
||||
@ISA = qw(MIME::Decoder);
|
||||
|
||||
### The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
### Buffer length:
|
||||
my $BUFLEN = 8192;
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# decode_it IN, OUT
|
||||
#
|
||||
sub decode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
|
||||
my ($buf, $nread) = ('', 0);
|
||||
while ($nread = $in->read($buf, $BUFLEN)) {
|
||||
$out->print($buf);
|
||||
}
|
||||
defined($nread) or return undef; ### check for error
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# encode_it IN, OUT
|
||||
#
|
||||
sub encode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
|
||||
my ($buf, $nread) = ('', 0);
|
||||
while ($nread = $in->read($buf, $BUFLEN)) {
|
||||
$out->print($buf);
|
||||
}
|
||||
defined($nread) or return undef; ### check for error
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
1;
|
111
Git/usr/share/perl5/vendor_perl/MIME/Decoder/Gzip64.pm
Normal file
111
Git/usr/share/perl5/vendor_perl/MIME/Decoder/Gzip64.pm
Normal file
@ -0,0 +1,111 @@
|
||||
package MIME::Decoder::Gzip64;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Decoder::Gzip64 - decode a "base64" gzip stream
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
A generic decoder object; see L<MIME::Decoder> for usage.
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A MIME::Decoder::Base64 subclass for a nonstandard encoding whereby
|
||||
data are gzipped, then the gzipped file is base64-encoded.
|
||||
Common non-standard MIME encodings for this:
|
||||
|
||||
x-gzip64
|
||||
|
||||
Since this class relies on external programs which may not
|
||||
exist on your machine, MIME-tools does not "install" it by default.
|
||||
To use it, you need to say in your main program:
|
||||
|
||||
install MIME::Decoder::Gzip64 'x-gzip64';
|
||||
|
||||
Note: if this class isn't working for you, you may need to change the
|
||||
commands it runs. In your main program, you can do so by setting up
|
||||
the two commands which handle the compression/decompression.
|
||||
|
||||
use MIME::Decoder::Gzip64;
|
||||
|
||||
$MIME::Decoder::Gzip64::GZIP = 'gzip -c';
|
||||
$MIME::Decoder::Gzip64::GUNZIP = 'gzip -d -c';
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Decoder>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
require 5.002;
|
||||
use strict;
|
||||
use vars qw(@ISA $VERSION $GZIP $GUNZIP);
|
||||
use MIME::Decoder;
|
||||
use MIME::Base64;
|
||||
use MIME::Decoder::Base64;
|
||||
use MIME::Tools qw(tmpopen whine);
|
||||
|
||||
# Inheritance:
|
||||
@ISA = qw(MIME::Decoder::Base64);
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
# How to compress stdin to stdout:
|
||||
$GZIP = "gzip -c";
|
||||
|
||||
# How to UNcompress stdin to stdout:
|
||||
$GUNZIP = "gzip -d -c";
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# decode_it IN, OUT
|
||||
#
|
||||
sub decode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
|
||||
# Open a temp file (assume the worst, that this is a big stream):
|
||||
my $tmp = tmpopen() || die "can't get temp file";
|
||||
|
||||
# Stage 1: decode the base64'd stream into zipped data:
|
||||
$self->SUPER::decode_it($in, $tmp) or die "base64 decoding failed!";
|
||||
|
||||
# Stage 2: un-zip the zipped data:
|
||||
$tmp->seek(0, 0);
|
||||
$self->filter($tmp, $out, $GUNZIP) or die "gzip decoding failed!";
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# encode_it IN, OUT
|
||||
#
|
||||
sub encode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
whine "Encoding ", $self->encoding, " is not standard MIME!";
|
||||
|
||||
# Open a temp file (assume the worst, that this is a big stream):
|
||||
my $tmp = tmpopen() || die "can't get temp file";
|
||||
|
||||
# Stage 1: zip the raw data:
|
||||
$self->filter($in, $tmp, $GZIP) or die "gzip encoding failed!";
|
||||
|
||||
# Stage 2: encode the zipped data via base64:
|
||||
$tmp->seek(0, 0);
|
||||
$self->SUPER::encode_it($tmp, $out) or die "base64 encoding failed!";
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
1;
|
160
Git/usr/share/perl5/vendor_perl/MIME/Decoder/NBit.pm
Normal file
160
Git/usr/share/perl5/vendor_perl/MIME/Decoder/NBit.pm
Normal file
@ -0,0 +1,160 @@
|
||||
package MIME::Decoder::NBit;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Decoder::NBit - encode/decode a "7bit" or "8bit" stream
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
A generic decoder object; see L<MIME::Decoder> for usage.
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a MIME::Decoder subclass for the C<7bit> and C<8bit> content
|
||||
transfer encodings. These are not "encodings" per se: rather, they
|
||||
are simply assertions of the content of the message.
|
||||
From RFC-2045 Section 6.2.:
|
||||
|
||||
Three transformations are currently defined: identity, the "quoted-
|
||||
printable" encoding, and the "base64" encoding. The domains are
|
||||
"binary", "8bit" and "7bit".
|
||||
|
||||
The Content-Transfer-Encoding values "7bit", "8bit", and "binary" all
|
||||
mean that the identity (i.e. NO) encoding transformation has been
|
||||
performed. As such, they serve simply as indicators of the domain of
|
||||
the body data, and provide useful information about the sort of
|
||||
encoding that might be needed for transmission in a given transport
|
||||
system.
|
||||
|
||||
In keeping with this: as of MIME-tools 4.x,
|
||||
I<this class does no modification of its input when encoding;>
|
||||
all it does is attempt to I<detect violations> of the 7bit/8bit assertion,
|
||||
and issue a warning (one per message) if any are found.
|
||||
|
||||
|
||||
=head2 Legal 7bit data
|
||||
|
||||
RFC-2045 Section 2.7 defines legal C<7bit> data:
|
||||
|
||||
"7bit data" refers to data that is all represented as relatively
|
||||
short lines with 998 octets or less between CRLF line separation
|
||||
sequences [RFC-821]. No octets with decimal values greater than 127
|
||||
are allowed and neither are NULs (octets with decimal value 0). CR
|
||||
(decimal value 13) and LF (decimal value 10) octets only occur as
|
||||
part of CRLF line separation sequences.
|
||||
|
||||
|
||||
=head2 Legal 8bit data
|
||||
|
||||
RFC-2045 Section 2.8 defines legal C<8bit> data:
|
||||
|
||||
"8bit data" refers to data that is all represented as relatively
|
||||
short lines with 998 octets or less between CRLF line separation
|
||||
sequences [RFC-821]), but octets with decimal values greater than 127
|
||||
may be used. As with "7bit data" CR and LF octets only occur as part
|
||||
of CRLF line separation sequences and no NULs are allowed.
|
||||
|
||||
|
||||
=head2 How decoding is done
|
||||
|
||||
The B<decoder> does a line-by-line pass-through from input to output,
|
||||
leaving the data unchanged I<except> that an end-of-line sequence of
|
||||
CRLF is converted to a newline "\n". Given the line-oriented nature
|
||||
of 7bit and 8bit, this seems relatively sensible.
|
||||
|
||||
|
||||
=head2 How encoding is done
|
||||
|
||||
The B<encoder> does a line-by-line pass-through from input to output,
|
||||
and simply attempts to I<detect> violations of the C<7bit>/C<8bit>
|
||||
domain. The default action is to warn once per encoding if violations
|
||||
are detected; the warnings may be silenced with the QUIET configuration
|
||||
of L<MIME::Tools>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Decoder>
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
use vars qw(@ISA $VERSION);
|
||||
|
||||
use MIME::Decoder;
|
||||
use MIME::Tools qw(:msgs);
|
||||
|
||||
@ISA = qw(MIME::Decoder);
|
||||
|
||||
### The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
### How many bytes to decode at a time?
|
||||
my $DecodeChunkLength = 8 * 1024;
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# decode_it IN, OUT
|
||||
#
|
||||
sub decode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
my $and_also;
|
||||
|
||||
### Allocate a buffer suitable for a chunk and a line:
|
||||
local $_ = (' ' x ($DecodeChunkLength + 1024)); $_ = '';
|
||||
|
||||
### Get chunks until done:
|
||||
while ($in->read($_, $DecodeChunkLength)) {
|
||||
$and_also = $in->getline;
|
||||
$_ .= $and_also if defined($and_also);
|
||||
|
||||
### Just got a chunk ending in a line.
|
||||
s/\015\012$/\n/g;
|
||||
$out->print($_);
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# encode_it IN, OUT
|
||||
#
|
||||
sub encode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
my $saw_8bit = 0; ### warn them ONCE PER ENCODING if 8-bit data exists
|
||||
my $saw_long = 0; ### warn them ONCE PER ENCODING if long lines exist
|
||||
my $seven_bit = ($self->encoding eq '7bit'); ### 7bit?
|
||||
|
||||
my $line;
|
||||
while (defined($line = $in->getline)) {
|
||||
|
||||
### Whine if encoding is 7bit and it has 8-bit data:
|
||||
if ($seven_bit && ($line =~ /[\200-\377]/)) { ### oops! saw 8-bit data!
|
||||
whine "saw 8-bit data while encoding 7bit" unless $saw_8bit++;
|
||||
}
|
||||
|
||||
### Whine if long lines detected:
|
||||
if (length($line) > 998) {
|
||||
whine "saw long line while encoding 7bit/8bit" unless $saw_long++;
|
||||
}
|
||||
|
||||
### Output!
|
||||
$out->print($line);
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
159
Git/usr/share/perl5/vendor_perl/MIME/Decoder/QuotedPrint.pm
Normal file
159
Git/usr/share/perl5/vendor_perl/MIME/Decoder/QuotedPrint.pm
Normal file
@ -0,0 +1,159 @@
|
||||
package MIME::Decoder::QuotedPrint;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Decoder::QuotedPrint - encode/decode a "quoted-printable" stream
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
A generic decoder object; see L<MIME::Decoder> for usage.
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A MIME::Decoder subclass for the C<"quoted-printable"> encoding.
|
||||
The name was chosen to jibe with the pre-existing MIME::QuotedPrint
|
||||
utility package, which this class actually uses to translate each line.
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
The B<decoder> does a line-by-line translation from input to output.
|
||||
|
||||
=item *
|
||||
|
||||
The B<encoder> does a line-by-line translation, breaking lines
|
||||
so that they fall under the standard 76-character limit for this
|
||||
encoding.
|
||||
|
||||
=back
|
||||
|
||||
|
||||
B<Note:> just like MIME::QuotedPrint, we currently use the
|
||||
native C<"\n"> for line breaks, and not C<CRLF>. This may
|
||||
need to change in future versions.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Decoder>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
use vars qw(@ISA $VERSION);
|
||||
use MIME::Decoder;
|
||||
use MIME::QuotedPrint;
|
||||
|
||||
@ISA = qw(MIME::Decoder);
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
#------------------------------
|
||||
# If we have MIME::QuotedPrint 3.03 or later, use the three-argument
|
||||
# version. If we have an earlier version of MIME::QuotedPrint, we
|
||||
# may get the wrong results. However, on some systems (RH Linux,
|
||||
# for example), MIME::QuotedPrint is part of the Perl package and
|
||||
# upgrading it separately breaks their magic auto-update tools.
|
||||
# We are supporting older versions of MIME::QuotedPrint even though
|
||||
# they may give incorrect results simply because it's too painful
|
||||
# for many people to upgrade.
|
||||
|
||||
# The following code is horrible. I know. Beat me up. --dfs
|
||||
BEGIN {
|
||||
if (!defined(&encode_qp_threearg)) {
|
||||
if ($::MIME::QuotedPrint::VERSION >= 3.03) {
|
||||
eval 'sub encode_qp_threearg ( $$$ ) { encode_qp(shift, shift, shift); }';
|
||||
} else {
|
||||
eval 'sub encode_qp_threearg ( $$$ ) { encode_qp(shift); }';
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# encode_qp_really STRING TEXTUAL_TYPE_FLAG
|
||||
#
|
||||
# Encode QP, and then follow guideline 8 from RFC 2049 (thanks to Denis
|
||||
# N. Antonioli) whereby we make things a little safer for the transport
|
||||
# and storage of messages. WARNING: we can only do this if the line won't
|
||||
# grow beyond 76 characters!
|
||||
#
|
||||
sub encode_qp_really {
|
||||
my $enc = encode_qp_threearg(shift, undef, not shift);
|
||||
if (length($enc) < 74) {
|
||||
$enc =~ s/^\.\n/=2E\n/g; # force encoding of /^\.$/
|
||||
$enc =~ s/^From /=46rom /g; # force encoding of /^From /
|
||||
}
|
||||
$enc;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# decode_it IN, OUT
|
||||
#
|
||||
sub decode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
my $init = 0;
|
||||
my $badpdf = 0;
|
||||
|
||||
local $_;
|
||||
while (defined($_ = $in->getline)) {
|
||||
#
|
||||
# Dirty hack to fix QP-Encoded PDFs from MS-Outlook.
|
||||
#
|
||||
# Check if we have a PDF file and if it has been encoded
|
||||
# on Windows. Unix encoded files are fine. If we have
|
||||
# one encoded CR after the PDF init string but are missing
|
||||
# an encoded CR before the newline this means the PDF is broken.
|
||||
#
|
||||
if (!$init) {
|
||||
$init = 1;
|
||||
if ($_ =~ /^%PDF-[0-9\.]+=0D/ && $_ !~ /=0D\n$/) {
|
||||
$badpdf = 1;
|
||||
}
|
||||
}
|
||||
#
|
||||
# Decode everything with decode_qp() except corrupted PDFs.
|
||||
#
|
||||
if ($badpdf) {
|
||||
my $output = $_;
|
||||
$output =~ s/[ \t]+?(\r?\n)/$1/g;
|
||||
$output =~ s/=\r?\n//g;
|
||||
$output =~ s/(^|[^\r])\n\Z/$1\r\n/;
|
||||
$output =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge;
|
||||
$out->print($output);
|
||||
} else {
|
||||
$out->print(decode_qp($_));
|
||||
}
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# encode_it IN, OUT
|
||||
#
|
||||
sub encode_it {
|
||||
my ($self, $in, $out, $textual_type) = @_;
|
||||
|
||||
local $_;
|
||||
while (defined($_ = $in->getline)) {
|
||||
$out->print(encode_qp_really($_, $textual_type));
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
1;
|
151
Git/usr/share/perl5/vendor_perl/MIME/Decoder/UU.pm
Normal file
151
Git/usr/share/perl5/vendor_perl/MIME/Decoder/UU.pm
Normal file
@ -0,0 +1,151 @@
|
||||
package MIME::Decoder::UU;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Decoder::UU - decode a "uuencoded" stream
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
A generic decoder object; see L<MIME::Decoder> for usage.
|
||||
|
||||
Also supports a preamble() method to recover text before
|
||||
the uuencoded portion of the stream.
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A MIME::Decoder subclass for a nonstandard encoding whereby
|
||||
data are uuencoded. Common non-standard MIME encodings for this:
|
||||
|
||||
x-uu
|
||||
x-uuencode
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Decoder>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
UU-decoding code lifted from "uuexplode", a Perl script by an
|
||||
unknown author...
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
require 5.002;
|
||||
use vars qw(@ISA $VERSION);
|
||||
use MIME::Decoder;
|
||||
use MIME::Tools qw(whine);
|
||||
|
||||
@ISA = qw(MIME::Decoder);
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# decode_it IN, OUT
|
||||
#
|
||||
sub decode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
my ($mode, $file);
|
||||
my @preamble;
|
||||
|
||||
### Init:
|
||||
$self->{MDU_Preamble} = \@preamble;
|
||||
$self->{MDU_Mode} = undef;
|
||||
$self->{MDU_File} = undef;
|
||||
|
||||
### Find beginning...
|
||||
local $_;
|
||||
while (defined($_ = $in->getline)) {
|
||||
if (/^begin(.*)/) { ### found it: now decode it...
|
||||
my $modefile = $1;
|
||||
if ($modefile =~ /^(\s+(\d+))?(\s+(.*?\S))?\s*\Z/) {
|
||||
($mode, $file) = ($2, $4);
|
||||
}
|
||||
last; ### decoded or not, we're done
|
||||
}
|
||||
push @preamble, $_;
|
||||
}
|
||||
die("uu decoding: no begin found\n") if !defined($_); # hit eof!
|
||||
|
||||
### Store info:
|
||||
$self->{MDU_Mode} = $mode;
|
||||
$self->{MDU_File} = $file;
|
||||
|
||||
### Decode:
|
||||
while (defined($_ = $in->getline)) {
|
||||
last if /^end/;
|
||||
next if /[a-z]/;
|
||||
next unless int((((ord() - 32) & 077) + 2) / 3) == int(length() / 4);
|
||||
$out->print(unpack('u', $_));
|
||||
}
|
||||
### chmod oct($mode), $file; # sheeyeah... right...
|
||||
whine "file incomplete, no end found\n" if !defined($_); # eof
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# encode_it IN, OUT
|
||||
#
|
||||
sub encode_it {
|
||||
my ($self, $in, $out) = @_;
|
||||
my $buf = '';
|
||||
|
||||
my $fname = (($self->head &&
|
||||
$self->head->mime_attr('content-disposition.filename')) ||
|
||||
'');
|
||||
my $nl = $MIME::Entity::BOUNDARY_DELIMITER || "\n";
|
||||
$out->print("begin 644 $fname$nl");
|
||||
while ($in->read($buf, 45)) { $out->print(pack('u', $buf)) }
|
||||
$out->print("end$nl");
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# last_preamble
|
||||
#
|
||||
# Return the last preamble as ref to array of lines.
|
||||
# Gets reset by decode_it().
|
||||
#
|
||||
sub last_preamble {
|
||||
my $self = shift;
|
||||
return $self->{MDU_Preamble} || [];
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# last_mode
|
||||
#
|
||||
# Return the last mode.
|
||||
# Gets reset to undef by decode_it().
|
||||
#
|
||||
sub last_mode {
|
||||
shift->{MDU_Mode};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# last_filename
|
||||
#
|
||||
# Return the last filename.
|
||||
# Gets reset by decode_it().
|
||||
#
|
||||
sub last_filename {
|
||||
shift->{MDU_File} || [];
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
1;
|
2272
Git/usr/share/perl5/vendor_perl/MIME/Entity.pm
Normal file
2272
Git/usr/share/perl5/vendor_perl/MIME/Entity.pm
Normal file
File diff suppressed because it is too large
Load Diff
63
Git/usr/share/perl5/vendor_perl/MIME/Field/ConTraEnc.pm
Normal file
63
Git/usr/share/perl5/vendor_perl/MIME/Field/ConTraEnc.pm
Normal file
@ -0,0 +1,63 @@
|
||||
package MIME::Field::ConTraEnc;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Field::ConTraEnc - a "Content-transfer-encoding" field
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A subclass of Mail::Field.
|
||||
|
||||
I<Don't use this class directly... its name may change in the future!>
|
||||
Instead, ask Mail::Field for new instances based on the field name!
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mail::Field;
|
||||
use MIME::Head;
|
||||
|
||||
# Create an instance from some text:
|
||||
$field = Mail::Field->new('Content-transfer-encoding', '7bit');
|
||||
|
||||
# Get the encoding.
|
||||
# Possible values: 'binary', '7bit', '8bit', 'quoted-printable',
|
||||
# 'base64' and '' (unspecified). Note that there can't be a
|
||||
# single default for this, since it depends on the content type!
|
||||
$encoding = $field->encoding;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Field::ParamVal>, L<Mail::Field>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
Dianne Skoll (dfs@roaringpenguin.com) http://www.roaringpenguin.com
|
||||
|
||||
=cut
|
||||
|
||||
require 5.001;
|
||||
use strict;
|
||||
use MIME::Field::ParamVal;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
@ISA = qw(MIME::Field::ParamVal);
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
# Install it:
|
||||
bless([])->register('Content-transfer-encoding');
|
||||
|
||||
#------------------------------
|
||||
|
||||
sub encoding {
|
||||
shift->paramstr('_', @_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
1;
|
||||
|
68
Git/usr/share/perl5/vendor_perl/MIME/Field/ContDisp.pm
Normal file
68
Git/usr/share/perl5/vendor_perl/MIME/Field/ContDisp.pm
Normal file
@ -0,0 +1,68 @@
|
||||
package MIME::Field::ContDisp;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Field::ContDisp - a "Content-disposition" field
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A subclass of Mail::Field.
|
||||
|
||||
I<Don't use this class directly... its name may change in the future!>
|
||||
Instead, ask Mail::Field for new instances based on the field name!
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mail::Field;
|
||||
use MIME::Head;
|
||||
|
||||
# Create an instance from some text:
|
||||
$field = Mail::Field->new('Content-disposition', $text);
|
||||
|
||||
# Inline or attachment?
|
||||
$type = $field->type;
|
||||
|
||||
# Recommended filename?
|
||||
$filename = $field->filename;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Field::ParamVal>, L<Mail::Field>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
Dianne Skoll (dfs@roaringpenguin.com) http://www.roaringpenguin.com
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
require 5.001;
|
||||
use strict;
|
||||
use MIME::Field::ParamVal;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
@ISA = qw(MIME::Field::ParamVal);
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
# Install it:
|
||||
bless([])->register('Content-disposition');
|
||||
|
||||
#------------------------------
|
||||
|
||||
sub filename {
|
||||
shift->paramstr('filename', @_);
|
||||
}
|
||||
|
||||
sub type {
|
||||
shift->paramstr('_', @_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
1;
|
||||
|
196
Git/usr/share/perl5/vendor_perl/MIME/Field/ContType.pm
Normal file
196
Git/usr/share/perl5/vendor_perl/MIME/Field/ContType.pm
Normal file
@ -0,0 +1,196 @@
|
||||
package MIME::Field::ContType;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Field::ContType - a "Content-type" field
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A subclass of Mail::Field.
|
||||
|
||||
I<Don't use this class directly... its name may change in the future!>
|
||||
Instead, ask Mail::Field for new instances based on the field name!
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mail::Field;
|
||||
use MIME::Head;
|
||||
|
||||
# Create an instance from some text:
|
||||
$field = Mail::Field->new('Content-type',
|
||||
'text/HTML; charset="US-ASCII"');
|
||||
|
||||
# Get the MIME type, like 'text/plain' or 'x-foobar'.
|
||||
# Returns 'text/plain' as default, as per RFC 2045:
|
||||
my ($type, $subtype) = split('/', $field->type);
|
||||
|
||||
# Get generic information:
|
||||
print $field->name;
|
||||
|
||||
# Get information related to "message" type:
|
||||
if ($type eq 'message') {
|
||||
print $field->id;
|
||||
print $field->number;
|
||||
print $field->total;
|
||||
}
|
||||
|
||||
# Get information related to "multipart" type:
|
||||
if ($type eq 'multipart') {
|
||||
print $field->boundary; # the basic value, fixed up
|
||||
print $field->multipart_boundary; # empty if not a multipart message!
|
||||
}
|
||||
|
||||
# Get information related to "text" type:
|
||||
if ($type eq 'text') {
|
||||
print $field->charset; # returns 'us-ascii' as default
|
||||
}
|
||||
|
||||
|
||||
=head1 PUBLIC INTERFACE
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
require 5.001;
|
||||
use strict;
|
||||
use MIME::Field::ParamVal;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
@ISA = qw(MIME::Field::ParamVal);
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
# Install it:
|
||||
bless([])->register('Content-type');
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# Basic access/storage methods...
|
||||
#
|
||||
sub charset {
|
||||
lc(shift->paramstr('charset', @_)) || 'us-ascii'; # RFC 2045
|
||||
}
|
||||
sub id {
|
||||
shift->paramstr('id', @_);
|
||||
}
|
||||
sub name {
|
||||
shift->paramstr('name', @_);
|
||||
}
|
||||
sub number {
|
||||
shift->paramstr('number', @_);
|
||||
}
|
||||
sub total {
|
||||
shift->paramstr('total', @_);
|
||||
}
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item boundary
|
||||
|
||||
Return the boundary field. The boundary is returned exactly
|
||||
as given in the C<Content-type:> field; that is, the leading
|
||||
double-hyphen (C<-->) is I<not> prepended.
|
||||
|
||||
(Well, I<almost> exactly... from RFC 2046:
|
||||
|
||||
(If a boundary appears to end with white space, the white space
|
||||
must be presumed to have been added by a gateway, and must be deleted.)
|
||||
|
||||
so we oblige and remove any trailing spaces.)
|
||||
|
||||
Returns the empty string if there is no boundary, or if the boundary is
|
||||
illegal (e.g., if it is empty after all trailing whitespace has been
|
||||
removed).
|
||||
|
||||
=cut
|
||||
|
||||
sub boundary {
|
||||
my $value = shift->param('boundary', @_);
|
||||
defined($value) || return '';
|
||||
$value =~ s/\s+$//; # kill trailing white, per RFC 2046
|
||||
$value;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item multipart_boundary
|
||||
|
||||
Like C<boundary()>, except that this will also return the empty
|
||||
string if the message is not a multipart message. In other words,
|
||||
there's an automatic sanity check.
|
||||
|
||||
=cut
|
||||
|
||||
sub multipart_boundary {
|
||||
my $self = shift;
|
||||
my ($type) = split('/', $self->type);
|
||||
return '' if ($type ne 'multipart'); # not multipart!
|
||||
$self->boundary; # okay, return the boundary
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item type
|
||||
|
||||
Try real hard to determine the content type (e.g., C<"text/plain">,
|
||||
C<"image/gif">, C<"x-weird-type">, which is returned
|
||||
in all-lowercase.
|
||||
|
||||
A happy thing: the following code will work just as you would want,
|
||||
even if there's no subtype (as in C<"x-weird-type">)... in such a case,
|
||||
the $subtype would simply be the empty string:
|
||||
|
||||
($type, $subtype) = split('/', $head->mime_type);
|
||||
|
||||
If the content-type information is missing, it defaults to C<"text/plain">,
|
||||
as per RFC 2045:
|
||||
|
||||
Default RFC 2822 messages are typed by this protocol as plain text in
|
||||
the US-ASCII character set, which can be explicitly specified as
|
||||
"Content-type: text/plain; charset=us-ascii". If no Content-Type is
|
||||
specified, this default is assumed.
|
||||
|
||||
B<Note:> under the "be liberal in what we accept" principle, this routine
|
||||
no longer syntax-checks the content type. If it ain't empty,
|
||||
just downcase and return it.
|
||||
|
||||
=cut
|
||||
|
||||
sub type {
|
||||
lc(shift->paramstr('_', @_)) || 'text/plain'; # RFC 2045
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=back
|
||||
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
Since nearly all (if not all) parameters must have non-empty values
|
||||
to be considered valid, we just return the empty string to signify
|
||||
missing fields. If you need to get the I<real> underlying value,
|
||||
use the inherited C<param()> method (which returns undef if the
|
||||
parameter is missing).
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Field::ParamVal>, L<Mail::Field>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
Dianne Skoll (dfs@roaringpenguin.com) http://www.roaringpenguin.com
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
||||
|
||||
|
416
Git/usr/share/perl5/vendor_perl/MIME/Field/ParamVal.pm
Normal file
416
Git/usr/share/perl5/vendor_perl/MIME/Field/ParamVal.pm
Normal file
@ -0,0 +1,416 @@
|
||||
package MIME::Field::ParamVal;
|
||||
|
||||
use MIME::Words;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Field::ParamVal - subclass of Mail::Field, for structured MIME fields
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Create an object for a content-type field:
|
||||
$field = new Mail::Field 'Content-type';
|
||||
|
||||
# Set some attributes:
|
||||
$field->param('_' => 'text/html');
|
||||
$field->param('charset' => 'us-ascii');
|
||||
$field->param('boundary' => '---ABC---');
|
||||
|
||||
# Same:
|
||||
$field->set('_' => 'text/html',
|
||||
'charset' => 'us-ascii',
|
||||
'boundary' => '---ABC---');
|
||||
|
||||
# Get an attribute, or undefined if not present:
|
||||
print "no id!" if defined($field->param('id'));
|
||||
|
||||
# Same, but use empty string for missing values:
|
||||
print "no id!" if ($field->paramstr('id') eq '');
|
||||
|
||||
# Output as string:
|
||||
print $field->stringify, "\n";
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is an abstract superclass of most MIME fields. It handles
|
||||
fields with a general syntax like this:
|
||||
|
||||
Content-Type: Message/Partial;
|
||||
number=2; total=3;
|
||||
id="oc=jpbe0M2Yt4s@thumper.bellcore.com"
|
||||
|
||||
Comments are supported I<between> items, like this:
|
||||
|
||||
Content-Type: Message/Partial; (a comment)
|
||||
number=2 (another comment) ; (yet another comment) total=3;
|
||||
id="oc=jpbe0M2Yt4s@thumper.bellcore.com"
|
||||
|
||||
|
||||
=head1 PUBLIC INTERFACE
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
|
||||
require 5.001;
|
||||
|
||||
# Pragmas:
|
||||
use strict;
|
||||
use re 'taint';
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
|
||||
# Other modules:
|
||||
use Mail::Field;
|
||||
|
||||
# Kit modules:
|
||||
use MIME::Tools qw(:config :msgs);
|
||||
|
||||
@ISA = qw(Mail::Field);
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# Public globals...
|
||||
#
|
||||
#------------------------------
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# Private globals...
|
||||
#
|
||||
#------------------------------
|
||||
|
||||
# Pattern to match parameter names (like fieldnames, but = not allowed):
|
||||
my $PARAMNAME = '[^\x00-\x1f\x80-\xff :=]+';
|
||||
|
||||
# Pattern to match the first value on the line:
|
||||
my $FIRST = '[^\s\;\x00-\x1f\x80-\xff]*';
|
||||
|
||||
# Pattern to match an RFC 2045 token:
|
||||
#
|
||||
# token = 1*<any (ASCII) CHAR except SPACE, CTLs, or tspecials>
|
||||
#
|
||||
my $TSPECIAL = '()<>@,;:\</[]?="';
|
||||
|
||||
#" Fix emacs highlighting...
|
||||
|
||||
my $TOKEN = '[^ \x00-\x1f\x80-\xff' . "\Q$TSPECIAL\E" . ']+';
|
||||
|
||||
my $QUOTED_STRING = '"([^\\\\"]*(?:\\\\.(?:[^\\\\"]*))*)"';
|
||||
|
||||
# Encoded token:
|
||||
my $ENCTOKEN = "=\\?[^?]*\\?[A-Za-z]\\?[^?]+\\?=";
|
||||
|
||||
# Pattern to match spaces or comments:
|
||||
my $SPCZ = '(?:\s|\([^\)]*\))*';
|
||||
|
||||
# Pattern to match non-semicolon as fallback for broken MIME
|
||||
# produced by some viruses
|
||||
my $BADTOKEN = '[^;]+';
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# Class init...
|
||||
#
|
||||
#------------------------------
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item set [\%PARAMHASH | KEY=>VAL,...,KEY=>VAL]
|
||||
|
||||
I<Instance method.> Set this field.
|
||||
The paramhash should contain parameter names
|
||||
in I<all lowercase>, with the special C<"_"> parameter name
|
||||
signifying the "default" (unnamed) parameter for the field:
|
||||
|
||||
# Set up to be...
|
||||
#
|
||||
# Content-type: Message/Partial; number=2; total=3; id="ocj=pbe0M2"
|
||||
#
|
||||
$conttype->set('_' => 'Message/Partial',
|
||||
'number' => 2,
|
||||
'total' => 3,
|
||||
'id' => "ocj=pbe0M2");
|
||||
|
||||
Note that a single argument is taken to be a I<reference> to
|
||||
a paramhash, while multiple args are taken to be the elements
|
||||
of the paramhash themselves.
|
||||
|
||||
Supplying undef for a hashref, or an empty set of values, effectively
|
||||
clears the object.
|
||||
|
||||
The self object is returned.
|
||||
|
||||
=cut
|
||||
|
||||
sub set {
|
||||
my $self = shift;
|
||||
my $params = ((@_ == 1) ? (shift || {}) : {@_});
|
||||
%$self = %$params; # set 'em
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item parse_params STRING
|
||||
|
||||
I<Class/instance utility method.>
|
||||
Extract parameter info from a structured field, and return
|
||||
it as a hash reference. For example, here is a field with parameters:
|
||||
|
||||
Content-Type: Message/Partial;
|
||||
number=2; total=3;
|
||||
id="oc=jpbe0M2Yt4s@thumper.bellcore.com"
|
||||
|
||||
Here is how you'd extract them:
|
||||
|
||||
$params = $class->parse_params('content-type');
|
||||
if ($$params{'_'} eq 'message/partial') {
|
||||
$number = $$params{'number'};
|
||||
$total = $$params{'total'};
|
||||
$id = $$params{'id'};
|
||||
}
|
||||
|
||||
Like field names, parameter names are coerced to lowercase.
|
||||
The special '_' parameter means the default parameter for the
|
||||
field.
|
||||
|
||||
B<NOTE:> This has been provided as a public method to support backwards
|
||||
compatibility, but you probably shouldn't use it.
|
||||
|
||||
=cut
|
||||
|
||||
sub rfc2231decode {
|
||||
my($val) = @_;
|
||||
my($enc, $lang, $rest);
|
||||
|
||||
local($1,$2,$3);
|
||||
if ($val =~ m/^([^']*)'([^']*)'(.*)\z/s) {
|
||||
$enc = $1;
|
||||
$lang = $2;
|
||||
$rest = $3;
|
||||
} elsif ($val =~ m/^([^']*)'([^']*)\z/s) {
|
||||
$enc = $1;
|
||||
$rest = $2;
|
||||
} else {
|
||||
$rest = $val;
|
||||
# $enc remains undefined when charset/language info is missing
|
||||
}
|
||||
return ($enc, $lang, $rest);
|
||||
}
|
||||
|
||||
sub rfc2231percent {
|
||||
# Do percent-substitution
|
||||
my($str) = @_;
|
||||
local $1;
|
||||
$str =~ s/%([0-9a-fA-F]{2})/pack("C", hex($1))/ge;
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub parse_params {
|
||||
my ($self, $raw) = @_;
|
||||
my %params;
|
||||
my %rfc2231params;
|
||||
my %rfc2231encoding_is_used;
|
||||
my $param;
|
||||
my $val;
|
||||
my $part;
|
||||
|
||||
# Get raw field, and unfold it:
|
||||
defined($raw) or $raw = '';
|
||||
$raw =~ s/\n//g;
|
||||
$raw =~ s/\s+\z//; # Strip trailing whitespace
|
||||
|
||||
local($1,$2,$3,$4,$5);
|
||||
# Extract special first parameter:
|
||||
$raw =~ m/\A$SPCZ($FIRST)$SPCZ/og or return {}; # nada!
|
||||
$params{'_'} = $1;
|
||||
|
||||
# Extract subsequent parameters.
|
||||
# No, we can't just "split" on semicolons: they're legal in quoted strings!
|
||||
while (1) { # keep chopping away until done...
|
||||
$raw =~ m/\G[^;]*(\;$SPCZ)+/og or last; # skip leading separator
|
||||
$raw =~ m/\G($PARAMNAME)\s*=\s*/og or last; # give up if not a param
|
||||
$param = lc($1);
|
||||
$raw =~ m/\G(?:$QUOTED_STRING|($ENCTOKEN)|($TOKEN)|($BADTOKEN))/g or last; # give up if no value"
|
||||
my ($qstr, $enctoken, $token, $badtoken) = ($1, $2, $3, $4, $5);
|
||||
if (defined($qstr)) {
|
||||
# unescape
|
||||
$qstr =~ s/\\(.)/$1/g;
|
||||
}
|
||||
if (defined($badtoken)) {
|
||||
# Strip leading/trailing whitespace from badtoken
|
||||
$badtoken =~ s/^\s+//;
|
||||
$badtoken =~ s/\s+\z//;
|
||||
|
||||
# Only keep token parameters in badtoken;
|
||||
# cut it off at the first non-token char. CPAN RT #105455
|
||||
$badtoken =~ /^($TOKEN)*/;
|
||||
$badtoken = $1;
|
||||
# Cut it off at first whitespace too
|
||||
$badtoken =~ s/\s.*//;
|
||||
}
|
||||
$val = defined($qstr) ? $qstr :
|
||||
(defined($enctoken) ? $enctoken :
|
||||
(defined($badtoken) ? $badtoken : $token));
|
||||
|
||||
# Do RFC 2231 processing
|
||||
# Pick out the parts of the parameter
|
||||
if ($param =~ /\*/ &&
|
||||
$param =~ /^ ([^*]+) (?: \* ([^*]+) )? (\*)? \z/xs) {
|
||||
# We have param*number* or param*number or param*
|
||||
my($name, $num) = ($1, $2||0);
|
||||
if (defined($3)) {
|
||||
# We have param*number* or param*
|
||||
# RFC 2231: Asterisks ("*") are reused to provide the
|
||||
# indicator that language and character set information
|
||||
# is present and encoding is being used
|
||||
$val = rfc2231percent($val);
|
||||
$rfc2231encoding_is_used{$name} = 1;
|
||||
}
|
||||
$rfc2231params{$name}{$num} .= $val;
|
||||
} else {
|
||||
# Assign non-rfc2231 value directly. If we
|
||||
# did get a mix of rfc2231 and non-rfc2231 values,
|
||||
# the non-rfc2231 will be blown away in the
|
||||
# "extract reconstructed parameters" loop.
|
||||
$params{$param} = $val;
|
||||
}
|
||||
}
|
||||
|
||||
# Extract reconstructed parameters
|
||||
foreach $param (keys %rfc2231params) {
|
||||
# If we got any rfc-2231 parameters, then
|
||||
# blow away any potential non-rfc-2231 parameter.
|
||||
$params{$param} = '';
|
||||
foreach $part (sort { $a <=> $b } keys %{$rfc2231params{$param}}) {
|
||||
$params{$param} .= $rfc2231params{$param}{$part};
|
||||
}
|
||||
if ($rfc2231encoding_is_used{$param}) {
|
||||
my($enc, $lang, $val) = rfc2231decode($params{$param});
|
||||
if (defined $enc) {
|
||||
# re-encode as QP, preserving charset and language info
|
||||
$val =~ s{([=?_\x00-\x1F\x7F-\xFF])}
|
||||
{sprintf("=%02X", ord($1))}eg;
|
||||
$val =~ tr/ /_/;
|
||||
# RFC 2231 section 5: Language specification in Encoded Words
|
||||
$enc .= '*' . $lang if defined $lang && $lang ne '';
|
||||
$params{$param} = '=?' . $enc . '?Q?' . $val . '?=';
|
||||
}
|
||||
}
|
||||
debug " field param <$param> = <$params{$param}>";
|
||||
}
|
||||
|
||||
# Done:
|
||||
\%params;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item parse STRING
|
||||
|
||||
I<Class/instance method.>
|
||||
Parse the string into the instance. Any previous information is wiped.
|
||||
The self object is returned.
|
||||
|
||||
May also be used as a constructor.
|
||||
|
||||
=cut
|
||||
|
||||
sub parse {
|
||||
my ($self, $string) = @_;
|
||||
|
||||
# Allow use as constructor, for MIME::Head:
|
||||
ref($self) or $self = bless({}, $self);
|
||||
|
||||
# Get params, and stuff them into the self object:
|
||||
$self->set($self->parse_params($string));
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item param PARAMNAME,[VALUE]
|
||||
|
||||
I<Instance method.>
|
||||
Return the given parameter, or undef if it isn't there.
|
||||
With argument, set the parameter to that VALUE.
|
||||
The PARAMNAME is case-insensitive. A "_" refers to the "default" parameter.
|
||||
|
||||
=cut
|
||||
|
||||
sub param {
|
||||
my ($self, $paramname, $value) = @_;
|
||||
$paramname = lc($paramname);
|
||||
$self->{$paramname} = $value if (@_ > 2);
|
||||
$self->{$paramname}
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item paramstr PARAMNAME,[VALUE]
|
||||
|
||||
I<Instance method.>
|
||||
Like param(): return the given parameter, or I<empty> if it isn't there.
|
||||
With argument, set the parameter to that VALUE.
|
||||
The PARAMNAME is case-insensitive. A "_" refers to the "default" parameter.
|
||||
|
||||
=cut
|
||||
|
||||
sub paramstr {
|
||||
my $val = shift->param(@_);
|
||||
(defined($val) ? $val : '');
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item stringify
|
||||
|
||||
I<Instance method.>
|
||||
Convert the field to a string, and return it.
|
||||
|
||||
=cut
|
||||
|
||||
sub stringify {
|
||||
my $self = shift;
|
||||
my ($key, $val);
|
||||
|
||||
my $str = $self->{'_'}; # default subfield
|
||||
foreach $key (sort keys %$self) {
|
||||
next if ($key !~ /^[a-z][a-z-_0-9]*$/); # only lowercase ones!
|
||||
defined($val = $self->{$key}) or next;
|
||||
$val =~ s/(["\\])/\\$1/g;
|
||||
$str .= qq{; $key="$val"};
|
||||
}
|
||||
$str;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item tag
|
||||
|
||||
I<Instance method, abstract.>
|
||||
Return the tag for this field.
|
||||
|
||||
=cut
|
||||
|
||||
sub tag { '' }
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mail::Field>
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
1;
|
930
Git/usr/share/perl5/vendor_perl/MIME/Head.pm
Normal file
930
Git/usr/share/perl5/vendor_perl/MIME/Head.pm
Normal file
@ -0,0 +1,930 @@
|
||||
package MIME::Head;
|
||||
|
||||
use MIME::WordDecoder;
|
||||
=head1 NAME
|
||||
|
||||
MIME::Head - MIME message header (a subclass of Mail::Header)
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Before reading further, you should see L<MIME::Tools> to make sure that
|
||||
you understand where this module fits into the grand scheme of things.
|
||||
Go on, do it now. I'll wait.
|
||||
|
||||
Ready? Ok...
|
||||
|
||||
=head2 Construction
|
||||
|
||||
### Create a new, empty header, and populate it manually:
|
||||
$head = MIME::Head->new;
|
||||
$head->replace('content-type', 'text/plain; charset=US-ASCII');
|
||||
$head->replace('content-length', $len);
|
||||
|
||||
### Parse a new header from a filehandle:
|
||||
$head = MIME::Head->read(\*STDIN);
|
||||
|
||||
### Parse a new header from a file, or a readable pipe:
|
||||
$testhead = MIME::Head->from_file("/tmp/test.hdr");
|
||||
$a_b_head = MIME::Head->from_file("cat a.hdr b.hdr |");
|
||||
|
||||
|
||||
=head2 Output
|
||||
|
||||
### Output to filehandle:
|
||||
$head->print(\*STDOUT);
|
||||
|
||||
### Output as string:
|
||||
print STDOUT $head->as_string;
|
||||
print STDOUT $head->stringify;
|
||||
|
||||
|
||||
=head2 Getting field contents
|
||||
|
||||
### Is this a reply?
|
||||
$is_reply = 1 if ($head->get('Subject') =~ /^Re: /);
|
||||
|
||||
### Get receipt information:
|
||||
print "Last received from: ", $head->get('Received', 0);
|
||||
@all_received = $head->get('Received');
|
||||
|
||||
### Print the subject, or the empty string if none:
|
||||
print "Subject: ", $head->get('Subject',0);
|
||||
|
||||
### Too many hops? Count 'em and see!
|
||||
if ($head->count('Received') > 5) { ...
|
||||
|
||||
### Test whether a given field exists
|
||||
warn "missing subject!" if (! $head->count('subject'));
|
||||
|
||||
|
||||
=head2 Setting field contents
|
||||
|
||||
### Declare this to be an HTML header:
|
||||
$head->replace('Content-type', 'text/html');
|
||||
|
||||
|
||||
=head2 Manipulating field contents
|
||||
|
||||
### Get rid of internal newlines in fields:
|
||||
$head->unfold;
|
||||
|
||||
### Decode any Q- or B-encoded-text in fields (DEPRECATED):
|
||||
$head->decode;
|
||||
|
||||
|
||||
=head2 Getting high-level MIME information
|
||||
|
||||
### Get/set a given MIME attribute:
|
||||
unless ($charset = $head->mime_attr('content-type.charset')) {
|
||||
$head->mime_attr("content-type.charset" => "US-ASCII");
|
||||
}
|
||||
|
||||
### The content type (e.g., "text/html"):
|
||||
$mime_type = $head->mime_type;
|
||||
|
||||
### The content transfer encoding (e.g., "quoted-printable"):
|
||||
$mime_encoding = $head->mime_encoding;
|
||||
|
||||
### The recommended name when extracted:
|
||||
$file_name = $head->recommended_filename;
|
||||
|
||||
### The boundary text, for multipart messages:
|
||||
$boundary = $head->multipart_boundary;
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A class for parsing in and manipulating RFC-822 message headers, with
|
||||
some methods geared towards standard (and not so standard) MIME fields
|
||||
as specified in the various I<Multipurpose Internet Mail Extensions>
|
||||
RFCs (starting with RFC 2045)
|
||||
|
||||
|
||||
=head1 PUBLIC INTERFACE
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
|
||||
require 5.002;
|
||||
|
||||
### Pragmas:
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA @EXPORT_OK);
|
||||
|
||||
### System modules:
|
||||
use IO::File;
|
||||
|
||||
### Other modules:
|
||||
use Mail::Header 1.09 ();
|
||||
use Mail::Field 1.05 ();
|
||||
|
||||
### Kit modules:
|
||||
use MIME::Words qw(:all);
|
||||
use MIME::Tools qw(:config :msgs);
|
||||
use MIME::Field::ParamVal;
|
||||
use MIME::Field::ConTraEnc;
|
||||
use MIME::Field::ContDisp;
|
||||
use MIME::Field::ContType;
|
||||
|
||||
@ISA = qw(Mail::Header);
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# Public globals...
|
||||
#
|
||||
#------------------------------
|
||||
|
||||
### The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
### Sanity (we put this test after our own version, for CPAN::):
|
||||
use Mail::Header 1.06 ();
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=head2 Creation, input, and output
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item new [ARG],[OPTIONS]
|
||||
|
||||
I<Class method, inherited.>
|
||||
Creates a new header object. Arguments are the same as those in the
|
||||
superclass.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
bless Mail::Header->new(@_), $class;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item from_file EXPR,OPTIONS
|
||||
|
||||
I<Class or instance method>.
|
||||
For convenience, you can use this to parse a header object in from EXPR,
|
||||
which may actually be any expression that can be sent to open() so as to
|
||||
return a readable filehandle. The "file" will be opened, read, and then
|
||||
closed:
|
||||
|
||||
### Create a new header by parsing in a file:
|
||||
my $head = MIME::Head->from_file("/tmp/test.hdr");
|
||||
|
||||
Since this method can function as either a class constructor I<or>
|
||||
an instance initializer, the above is exactly equivalent to:
|
||||
|
||||
### Create a new header by parsing in a file:
|
||||
my $head = MIME::Head->new->from_file("/tmp/test.hdr");
|
||||
|
||||
On success, the object will be returned; on failure, the undefined value.
|
||||
|
||||
The OPTIONS are the same as in new(), and are passed into new()
|
||||
if this is invoked as a class method.
|
||||
|
||||
B<Note:> This is really just a convenience front-end onto C<read()>,
|
||||
provided mostly for backwards-compatibility with MIME-parser 1.0.
|
||||
|
||||
=cut
|
||||
|
||||
sub from_file {
|
||||
my ($self, $file, @opts) = @_; ### at this point, $self is inst. or class!
|
||||
my $class = ref($self) ? ref($self) : $self;
|
||||
|
||||
### Parse:
|
||||
my $fh = IO::File->new($file, '<') or return error("open $file: $!");
|
||||
$fh->binmode() or return error("binmode $file: $!"); # we expect to have \r\n at line ends, and want to keep 'em.
|
||||
$self = $class->new($fh, @opts); ### now, $self is instance or undef
|
||||
$fh->close or return error("close $file: $!");
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item read FILEHANDLE
|
||||
|
||||
I<Instance (or class) method.>
|
||||
This initializes a header object by reading it in from a FILEHANDLE,
|
||||
until the terminating blank line is encountered.
|
||||
A syntax error or end-of-stream will also halt processing.
|
||||
|
||||
Supply this routine with a reference to a filehandle glob; e.g., C<\*STDIN>:
|
||||
|
||||
### Create a new header by parsing in STDIN:
|
||||
$head->read(\*STDIN);
|
||||
|
||||
On success, the self object will be returned; on failure, a false value.
|
||||
|
||||
B<Note:> in the MIME world, it is perfectly legal for a header to be
|
||||
empty, consisting of nothing but the terminating blank line. Thus,
|
||||
we can't just use the formula that "no tags equals error".
|
||||
|
||||
B<Warning:> as of the time of this writing, Mail::Header::read did not flag
|
||||
either syntax errors or unexpected end-of-file conditions (an EOF
|
||||
before the terminating blank line). MIME::ParserBase takes this
|
||||
into account.
|
||||
|
||||
=cut
|
||||
|
||||
sub read {
|
||||
my $self = shift; ### either instance or class!
|
||||
ref($self) or $self = $self->new; ### if used as class method, make new
|
||||
$self->SUPER::read(@_);
|
||||
}
|
||||
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=back
|
||||
|
||||
=head2 Getting/setting fields
|
||||
|
||||
The following are methods related to retrieving and modifying the header
|
||||
fields. Some are inherited from Mail::Header, but I've kept the
|
||||
documentation around for convenience.
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item add TAG,TEXT,[INDEX]
|
||||
|
||||
I<Instance method, inherited.>
|
||||
Add a new occurrence of the field named TAG, given by TEXT:
|
||||
|
||||
### Add the trace information:
|
||||
$head->add('Received',
|
||||
'from eryq.pr.mcs.net by gonzo.net with smtp');
|
||||
|
||||
Normally, the new occurrence will be I<appended> to the existing
|
||||
occurrences. However, if the optional INDEX argument is 0, then the
|
||||
new occurrence will be I<prepended>. If you want to be I<explicit>
|
||||
about appending, specify an INDEX of -1.
|
||||
|
||||
B<Warning>: this method always adds new occurrences; it doesn't overwrite
|
||||
any existing occurrences... so if you just want to I<change> the value
|
||||
of a field (creating it if necessary), then you probably B<don't> want to use
|
||||
this method: consider using C<replace()> instead.
|
||||
|
||||
=cut
|
||||
|
||||
### Inherited.
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# copy
|
||||
#
|
||||
# Instance method, DEPRECATED.
|
||||
# Duplicate the object.
|
||||
#
|
||||
sub copy {
|
||||
usage "deprecated: use dup() instead.";
|
||||
shift->dup(@_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item count TAG
|
||||
|
||||
I<Instance method, inherited.>
|
||||
Returns the number of occurrences of a field; in a boolean context, this
|
||||
tells you whether a given field exists:
|
||||
|
||||
### Was a "Subject:" field given?
|
||||
$subject_was_given = $head->count('subject');
|
||||
|
||||
The TAG is treated in a case-insensitive manner.
|
||||
This method returns some false value if the field doesn't exist,
|
||||
and some true value if it does.
|
||||
|
||||
=cut
|
||||
|
||||
### Inherited.
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item decode [FORCE]
|
||||
|
||||
I<Instance method, DEPRECATED.>
|
||||
Go through all the header fields, looking for RFC 1522 / RFC 2047 style
|
||||
"Q" (quoted-printable, sort of) or "B" (base64) encoding, and decode
|
||||
them in-place. Fellow Americans, you probably don't know what the hell
|
||||
I'm talking about. Europeans, Russians, et al, you probably do.
|
||||
C<:-)>.
|
||||
|
||||
B<This method has been deprecated.>
|
||||
See L<MIME::Parser/decode_headers> for the full reasons.
|
||||
If you absolutely must use it and don't like the warning, then
|
||||
provide a FORCE:
|
||||
|
||||
"I_NEED_TO_FIX_THIS"
|
||||
Just shut up and do it. Not recommended.
|
||||
Provided only for those who need to keep old scripts functioning.
|
||||
|
||||
"I_KNOW_WHAT_I_AM_DOING"
|
||||
Just shut up and do it. Not recommended.
|
||||
Provided for those who REALLY know what they are doing.
|
||||
|
||||
B<What this method does.>
|
||||
For an example, let's consider a valid email header you might get:
|
||||
|
||||
From: =?US-ASCII?Q?Keith_Moore?= <moore@cs.utk.edu>
|
||||
To: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk>
|
||||
CC: =?ISO-8859-1?Q?Andr=E9_?= Pirard <PIRARD@vm1.ulg.ac.be>
|
||||
Subject: =?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?=
|
||||
=?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?=
|
||||
=?US-ASCII?Q?.._cool!?=
|
||||
|
||||
That basically decodes to (sorry, I can only approximate the
|
||||
Latin characters with 7 bit sequences /o and 'e):
|
||||
|
||||
From: Keith Moore <moore@cs.utk.edu>
|
||||
To: Keld J/orn Simonsen <keld@dkuug.dk>
|
||||
CC: Andr'e Pirard <PIRARD@vm1.ulg.ac.be>
|
||||
Subject: If you can read this you understand the example... cool!
|
||||
|
||||
B<Note:> currently, the decodings are done without regard to the
|
||||
character set: thus, the Q-encoding C<=F8> is simply translated to the
|
||||
octet (hexadecimal C<F8>), period. For piece-by-piece decoding
|
||||
of a given field, you want the array context of
|
||||
C<MIME::Words::decode_mimewords()>.
|
||||
|
||||
B<Warning:> the CRLF+SPACE separator that splits up long encoded words
|
||||
into shorter sequences (see the Subject: example above) gets lost
|
||||
when the field is unfolded, and so decoding after unfolding causes
|
||||
a spurious space to be left in the field.
|
||||
I<THEREFORE: if you're going to decode, do so BEFORE unfolding!>
|
||||
|
||||
This method returns the self object.
|
||||
|
||||
I<Thanks to Kent Boortz for providing the idea, and the baseline
|
||||
RFC-1522-decoding code.>
|
||||
|
||||
=cut
|
||||
|
||||
sub decode {
|
||||
my $self = shift;
|
||||
|
||||
### Warn if necessary:
|
||||
my $force = shift || 0;
|
||||
unless (($force eq "I_NEED_TO_FIX_THIS") ||
|
||||
($force eq "I_KNOW_WHAT_I_AM_DOING")) {
|
||||
usage "decode is deprecated for safety";
|
||||
}
|
||||
|
||||
my ($tag, $i, @decoded);
|
||||
foreach $tag ($self->tags) {
|
||||
@decoded = map { scalar(decode_mimewords($_, Field=>$tag))
|
||||
} $self->get_all($tag);
|
||||
for ($i = 0; $i < @decoded; $i++) {
|
||||
$self->replace($tag, $decoded[$i], $i);
|
||||
}
|
||||
}
|
||||
$self->{MH_Decoded} = 1;
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item delete TAG,[INDEX]
|
||||
|
||||
I<Instance method, inherited.>
|
||||
Delete all occurrences of the field named TAG.
|
||||
|
||||
### Remove some MIME information:
|
||||
$head->delete('MIME-Version');
|
||||
$head->delete('Content-type');
|
||||
|
||||
=cut
|
||||
|
||||
### Inherited
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# exists
|
||||
#
|
||||
sub exists {
|
||||
usage "deprecated; use count() instead";
|
||||
shift->count(@_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# fields
|
||||
#
|
||||
sub fields {
|
||||
usage "deprecated: use tags() instead",
|
||||
shift->tags(@_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item get TAG,[INDEX]
|
||||
|
||||
I<Instance method, inherited.>
|
||||
Get the contents of field TAG.
|
||||
|
||||
If a B<numeric INDEX> is given, returns the occurrence at that index,
|
||||
or undef if not present:
|
||||
|
||||
### Print the first and last 'Received:' entries (explicitly):
|
||||
print "First, or most recent: ", $head->get('received', 0);
|
||||
print "Last, or least recent: ", $head->get('received',-1);
|
||||
|
||||
If B<no INDEX> is given, but invoked in a B<scalar> context, then
|
||||
INDEX simply defaults to 0:
|
||||
|
||||
### Get the first 'Received:' entry (implicitly):
|
||||
my $most_recent = $head->get('received');
|
||||
|
||||
If B<no INDEX> is given, and invoked in an B<array> context, then
|
||||
I<all> occurrences of the field are returned:
|
||||
|
||||
### Get all 'Received:' entries:
|
||||
my @all_received = $head->get('received');
|
||||
|
||||
B<NOTE>: The header(s) returned may end with a newline. If you don't
|
||||
want this, then B<chomp> the return value.
|
||||
|
||||
=cut
|
||||
|
||||
### Inherited.
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item get_all FIELD
|
||||
|
||||
I<Instance method.>
|
||||
Returns the list of I<all> occurrences of the field, or the
|
||||
empty list if the field is not present:
|
||||
|
||||
### How did it get here?
|
||||
@history = $head->get_all('Received');
|
||||
|
||||
B<Note:> I had originally experimented with having C<get()> return all
|
||||
occurrences when invoked in an array context... but that causes a lot of
|
||||
accidents when you get careless and do stuff like this:
|
||||
|
||||
print "\u$field: ", $head->get($field);
|
||||
|
||||
It also made the intuitive behaviour unclear if the INDEX argument
|
||||
was given in an array context. So I opted for an explicit approach
|
||||
to asking for all occurrences.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_all {
|
||||
my ($self, $tag) = @_;
|
||||
$self->count($tag) or return (); ### empty if doesn't exist
|
||||
($self->get($tag));
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# original_text
|
||||
#
|
||||
# Instance method, DEPRECATED.
|
||||
# Return an approximation of the original text.
|
||||
#
|
||||
sub original_text {
|
||||
usage "deprecated: use stringify() instead";
|
||||
shift->stringify(@_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item print [OUTSTREAM]
|
||||
|
||||
I<Instance method, override.>
|
||||
Print the header out to the given OUTSTREAM, or the currently-selected
|
||||
filehandle if none. The OUTSTREAM may be a filehandle, or any object
|
||||
that responds to a print() message.
|
||||
|
||||
The override actually lets you print to any object that responds to
|
||||
a print() method. This is vital for outputting MIME entities to scalars.
|
||||
|
||||
Also, it defaults to the I<currently-selected> filehandle if none is given
|
||||
(not STDOUT!), so I<please> supply a filehandle to prevent confusion.
|
||||
|
||||
=cut
|
||||
|
||||
sub print {
|
||||
my ($self, $fh) = @_;
|
||||
$fh ||= select;
|
||||
$fh->print($self->as_string);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# set TAG,TEXT
|
||||
#
|
||||
# Instance method, DEPRECATED.
|
||||
# Set the field named TAG to [the single occurrence given by the TEXT.
|
||||
#
|
||||
sub set {
|
||||
my $self = shift;
|
||||
usage "deprecated: use the replace() method instead.";
|
||||
$self->replace(@_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item stringify
|
||||
|
||||
I<Instance method.>
|
||||
Return the header as a string. You can also invoke it as C<as_string>.
|
||||
|
||||
If you set the variable $MIME::Entity::BOUNDARY_DELIMITER to a string,
|
||||
that string will be used as line-end delimiter. If it is not set,
|
||||
the line ending will be a newline character (\n)
|
||||
|
||||
=cut
|
||||
|
||||
sub stringify {
|
||||
my $self = shift; ### build clean header, and output...
|
||||
my @header = grep {defined($_) ? $_ : ()} @{$self->header};
|
||||
my $header_delimiter = $MIME::Entity::BOUNDARY_DELIMITER || "\n";
|
||||
join "", map { /\n$/ ? substr($_, 0, -1) . $header_delimiter : $_ . $header_delimiter } @header;
|
||||
}
|
||||
sub as_string { shift->stringify(@_) }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item unfold [FIELD]
|
||||
|
||||
I<Instance method, inherited.>
|
||||
Unfold (remove newlines in) the text of all occurrences of the given FIELD.
|
||||
If the FIELD is omitted, I<all> fields are unfolded.
|
||||
Returns the "self" object.
|
||||
|
||||
=cut
|
||||
|
||||
### Inherited
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=back
|
||||
|
||||
=head2 MIME-specific methods
|
||||
|
||||
All of the following methods extract information from the following fields:
|
||||
|
||||
Content-type
|
||||
Content-transfer-encoding
|
||||
Content-disposition
|
||||
|
||||
Be aware that they do not just return the raw contents of those fields,
|
||||
and in some cases they will fill in sensible (I hope) default values.
|
||||
Use C<get()> or C<mime_attr()> if you need to grab and process the
|
||||
raw field text.
|
||||
|
||||
B<Note:> some of these methods are provided both as a convenience and
|
||||
for backwards-compatibility only, while others (like
|
||||
recommended_filename()) I<really do have to be in MIME::Head to work
|
||||
properly,> since they look for their value in more than one field.
|
||||
However, if you know that a value is restricted to a single
|
||||
field, you should really use the Mail::Field interface to get it.
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# params TAG
|
||||
#
|
||||
# Instance method, DEPRECATED.
|
||||
# Extract parameter info from a structured field, and return
|
||||
# it as a hash reference. Provided for 1.0 compatibility only!
|
||||
# Use the new MIME::Field interface classes (subclasses of Mail::Field).
|
||||
|
||||
sub params {
|
||||
my ($self, $tag) = @_;
|
||||
usage "deprecated: use the MIME::Field interface classes from now on!";
|
||||
return MIME::Field::ParamVal->parse_params($self->get($tag,0));
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item mime_attr ATTR,[VALUE]
|
||||
|
||||
A quick-and-easy interface to set/get the attributes in structured
|
||||
MIME fields:
|
||||
|
||||
$head->mime_attr("content-type" => "text/html");
|
||||
$head->mime_attr("content-type.charset" => "US-ASCII");
|
||||
$head->mime_attr("content-type.name" => "homepage.html");
|
||||
|
||||
This would cause the final output to look something like this:
|
||||
|
||||
Content-type: text/html; charset=US-ASCII; name="homepage.html"
|
||||
|
||||
Note that the special empty sub-field tag indicates the anonymous
|
||||
first sub-field.
|
||||
|
||||
B<Giving VALUE as undefined> will cause the contents of the named subfield
|
||||
to be deleted:
|
||||
|
||||
$head->mime_attr("content-type.charset" => undef);
|
||||
|
||||
B<Supplying no VALUE argument> just returns the attribute's value,
|
||||
or undefined if it isn't there:
|
||||
|
||||
$type = $head->mime_attr("content-type"); ### text/html
|
||||
$name = $head->mime_attr("content-type.name"); ### homepage.html
|
||||
|
||||
In all cases, the new/current value is returned.
|
||||
|
||||
=cut
|
||||
|
||||
sub mime_attr {
|
||||
my ($self, $attr, $value) = @_;
|
||||
|
||||
### Break attribute name up:
|
||||
my ($tag, $subtag) = split /\./, $attr;
|
||||
$subtag ||= '_';
|
||||
|
||||
### Set or get?
|
||||
my $field = MIME::Field::ParamVal->parse($self->get($tag, 0));
|
||||
if (@_ > 2) { ### set it:
|
||||
$field->param($subtag, $value); ### set subfield
|
||||
$self->replace($tag, $field->stringify); ### replace!
|
||||
return $value;
|
||||
}
|
||||
else { ### get it:
|
||||
return $field->param($subtag);
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item mime_encoding
|
||||
|
||||
I<Instance method.>
|
||||
Try I<real hard> to determine the content transfer encoding
|
||||
(e.g., C<"base64">, C<"binary">), which is returned in all-lowercase.
|
||||
|
||||
If no encoding could be found, the default of C<"7bit"> is returned
|
||||
I quote from RFC 2045 section 6.1:
|
||||
|
||||
This is the default value -- that is, "Content-Transfer-Encoding: 7BIT"
|
||||
is assumed if the Content-Transfer-Encoding header field is not present.
|
||||
|
||||
I do one other form of fixup: "7_bit", "7-bit", and "7 bit" are
|
||||
corrected to "7bit"; likewise for "8bit".
|
||||
|
||||
=cut
|
||||
|
||||
sub mime_encoding {
|
||||
my $self = shift;
|
||||
my $enc = lc($self->mime_attr('content-transfer-encoding') || '7bit');
|
||||
$enc =~ s{^([78])[ _-]bit\Z}{$1bit};
|
||||
$enc;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item mime_type [DEFAULT]
|
||||
|
||||
I<Instance method.>
|
||||
Try C<real hard> to determine the content type (e.g., C<"text/plain">,
|
||||
C<"image/gif">, C<"x-weird-type">, which is returned in all-lowercase.
|
||||
"Real hard" means that if no content type could be found, the default
|
||||
(usually C<"text/plain">) is returned. From RFC 2045 section 5.2:
|
||||
|
||||
Default RFC 822 messages without a MIME Content-Type header are
|
||||
taken by this protocol to be plain text in the US-ASCII character
|
||||
set, which can be explicitly specified as:
|
||||
|
||||
Content-type: text/plain; charset=us-ascii
|
||||
|
||||
This default is assumed if no Content-Type header field is specified.
|
||||
|
||||
Unless this is a part of a "multipart/digest", in which case
|
||||
"message/rfc822" is the default. Note that you can also I<set> the
|
||||
default, but you shouldn't: normally only the MIME parser uses this
|
||||
feature.
|
||||
|
||||
=cut
|
||||
|
||||
sub mime_type {
|
||||
my ($self, $default) = @_;
|
||||
$self->{MIH_DefaultType} = $default if @_ > 1;
|
||||
my $s = $self->mime_attr('content-type') ||
|
||||
$self->{MIH_DefaultType} ||
|
||||
'text/plain';
|
||||
# avoid [perl #87336] bug, lc laundering tainted data
|
||||
return lc($s) if $] <= 5.008 || $] >= 5.014;
|
||||
$s =~ tr/A-Z/a-z/;
|
||||
$s;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item multipart_boundary
|
||||
|
||||
I<Instance method.>
|
||||
If this is a header for a multipart message, return the
|
||||
"encapsulation boundary" used to separate the parts. The boundary
|
||||
is returned exactly as given in the C<Content-type:> field; that
|
||||
is, the leading double-hyphen (C<-->) is I<not> prepended.
|
||||
|
||||
Well, I<almost> exactly... this passage from RFC 2046 dictates
|
||||
that we remove any trailing spaces:
|
||||
|
||||
If a boundary appears to end with white space, the white space
|
||||
must be presumed to have been added by a gateway, and must be deleted.
|
||||
|
||||
Returns undef (B<not> the empty string) if either the message is not
|
||||
multipart or if there is no specified boundary.
|
||||
|
||||
=cut
|
||||
|
||||
sub multipart_boundary {
|
||||
my $self = shift;
|
||||
my $value = $self->mime_attr('content-type.boundary');
|
||||
(!defined($value)) ? undef : $value;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item recommended_filename
|
||||
|
||||
I<Instance method.>
|
||||
Return the recommended external filename. This is used when
|
||||
extracting the data from the MIME stream. The filename is always
|
||||
returned as a string in Perl's internal format (the UTF8 flag may be on!)
|
||||
|
||||
Returns undef if no filename could be suggested.
|
||||
|
||||
=cut
|
||||
|
||||
sub recommended_filename
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
# Try these headers in order, taking the first defined,
|
||||
# non-blank one we find.
|
||||
my $wd = supported MIME::WordDecoder 'UTF-8';
|
||||
foreach my $attr_name ( qw( content-disposition.filename content-type.name ) ) {
|
||||
my $value = $self->mime_attr( $attr_name );
|
||||
if ( defined $value
|
||||
&& $value ne ''
|
||||
&& $value =~ /\S/ ) {
|
||||
return $wd->decode($value);
|
||||
}
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# tweak_FROM_parsing
|
||||
#
|
||||
# DEPRECATED. Use the inherited mail_from() class method now.
|
||||
|
||||
sub tweak_FROM_parsing {
|
||||
my $self = shift;
|
||||
usage "deprecated. Use mail_from() instead.";
|
||||
$self->mail_from(@_);
|
||||
}
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
#------------------------------
|
||||
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
=over 4
|
||||
|
||||
=item Why have separate objects for the entity, head, and body?
|
||||
|
||||
See the documentation for the MIME-tools distribution
|
||||
for the rationale behind this decision.
|
||||
|
||||
|
||||
=item Why assume that MIME headers are email headers?
|
||||
|
||||
I quote from Achim Bohnet, who gave feedback on v.1.9 (I think
|
||||
he's using the word "header" where I would use "field"; e.g.,
|
||||
to refer to "Subject:", "Content-type:", etc.):
|
||||
|
||||
There is also IMHO no requirement [for] MIME::Heads to look
|
||||
like [email] headers; so to speak, the MIME::Head [simply stores]
|
||||
the attributes of a complex object, e.g.:
|
||||
|
||||
new MIME::Head type => "text/plain",
|
||||
charset => ...,
|
||||
disposition => ..., ... ;
|
||||
|
||||
I agree in principle, but (alas and dammit) RFC 2045 says otherwise.
|
||||
RFC 2045 [MIME] headers are a syntactic subset of RFC-822 [email] headers.
|
||||
|
||||
In my mind's eye, I see an abstract class, call it MIME::Attrs, which does
|
||||
what Achim suggests... so you could say:
|
||||
|
||||
my $attrs = new MIME::Attrs type => "text/plain",
|
||||
charset => ...,
|
||||
disposition => ..., ... ;
|
||||
|
||||
We could even make it a superclass of MIME::Head: that way, MIME::Head
|
||||
would have to implement its interface, I<and> allow itself to be
|
||||
initialized from a MIME::Attrs object.
|
||||
|
||||
However, when you read RFC 2045, you begin to see how much MIME information
|
||||
is organized by its presence in particular fields. I imagine that we'd
|
||||
begin to mirror the structure of RFC 2045 fields and subfields to such
|
||||
a degree that this might not give us a tremendous gain over just
|
||||
having MIME::Head.
|
||||
|
||||
|
||||
=item Why all this "occurrence" and "index" jazz? Isn't every field unique?
|
||||
|
||||
Aaaaaaaaaahh....no.
|
||||
|
||||
Looking at a typical mail message header, it is sooooooo tempting to just
|
||||
store the fields as a hash of strings, one string per hash entry.
|
||||
Unfortunately, there's the little matter of the C<Received:> field,
|
||||
which (unlike C<From:>, C<To:>, etc.) will often have multiple
|
||||
occurrences; e.g.:
|
||||
|
||||
Received: from gsfc.nasa.gov by eryq.pr.mcs.net with smtp
|
||||
(Linux Smail3.1.28.1 #5) id m0tStZ7-0007X4C;
|
||||
Thu, 21 Dec 95 16:34 CST
|
||||
Received: from rhine.gsfc.nasa.gov by gsfc.nasa.gov
|
||||
(5.65/Ultrix3.0-C) id AA13596;
|
||||
Thu, 21 Dec 95 17:20:38 -0500
|
||||
Received: (from eryq@localhost) by rhine.gsfc.nasa.gov
|
||||
(8.6.12/8.6.12) id RAA28069;
|
||||
Thu, 21 Dec 1995 17:27:54 -0500
|
||||
Date: Thu, 21 Dec 1995 17:27:54 -0500
|
||||
From: Eryq <eryq@rhine.gsfc.nasa.gov>
|
||||
Message-Id: <199512212227.RAA28069@rhine.gsfc.nasa.gov>
|
||||
To: eryq@eryq.pr.mcs.net
|
||||
Subject: Stuff and things
|
||||
|
||||
The C<Received:> field is used for tracing message routes, and although
|
||||
it's not generally used for anything other than human debugging, I
|
||||
didn't want to inconvenience anyone who actually wanted to get at that
|
||||
information.
|
||||
|
||||
I also didn't want to make this a special case; after all, who
|
||||
knows what other fields could have multiple occurrences in the
|
||||
future? So, clearly, multiple entries had to somehow be stored
|
||||
multiple times... and the different occurrences had to be retrievable.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mail::Header>, L<Mail::Field>, L<MIME::Words>, L<MIME::Tools>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
Dianne Skoll (dfs@roaringpenguin.com) http://www.roaringpenguin.com
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The more-comprehensive filename extraction is courtesy of
|
||||
Lee E. Brotzman, Advanced Data Solutions.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
2009
Git/usr/share/perl5/vendor_perl/MIME/Parser.pm
Normal file
2009
Git/usr/share/perl5/vendor_perl/MIME/Parser.pm
Normal file
File diff suppressed because it is too large
Load Diff
940
Git/usr/share/perl5/vendor_perl/MIME/Parser/Filer.pm
Normal file
940
Git/usr/share/perl5/vendor_perl/MIME/Parser/Filer.pm
Normal file
@ -0,0 +1,940 @@
|
||||
package MIME::Parser::Filer;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Parser::Filer - manage file-output of the parser
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Before reading further, you should see L<MIME::Parser> to make sure that
|
||||
you understand where this module fits into the grand scheme of things.
|
||||
Go on, do it now. I'll wait.
|
||||
|
||||
Ready? Ok... now read L<"DESCRIPTION"> below, and everything else
|
||||
should make sense.
|
||||
|
||||
|
||||
=head2 Public interface
|
||||
|
||||
### Create a "filer" of the desired class:
|
||||
my $filer = MIME::Parser::FileInto->new($dir);
|
||||
my $filer = MIME::Parser::FileUnder->new($basedir);
|
||||
...
|
||||
|
||||
### Want added security? Don't let outsiders name your files:
|
||||
$filer->ignore_filename(1);
|
||||
|
||||
### Prepare for the parsing of a new top-level message:
|
||||
$filer->init_parse;
|
||||
|
||||
### Return the path where this message's data should be placed:
|
||||
$path = $filer->output_path($head);
|
||||
|
||||
|
||||
=head2 Semi-public interface
|
||||
|
||||
These methods might be overridden or ignored in some subclasses,
|
||||
so they don't all make sense in all circumstances:
|
||||
|
||||
### Tweak the mapping from content-type to extension:
|
||||
$emap = $filer->output_extension_map;
|
||||
$emap->{"text/html"} = ".htm";
|
||||
|
||||
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
|
||||
=head2 How this class is used when parsing
|
||||
|
||||
When a MIME::Parser decides that it wants to output a file to disk,
|
||||
it uses its "Filer" object -- an instance of a MIME::Parser::Filer
|
||||
subclass -- to determine where to put the file.
|
||||
|
||||
Every parser has a single Filer object, which it uses for all
|
||||
parsing. You can get the Filer for a given $parser like this:
|
||||
|
||||
$filer = $parser->filer;
|
||||
|
||||
At the beginning of each C<parse()>, the filer's internal state
|
||||
is reset by the parser:
|
||||
|
||||
$parser->filer->init_parse;
|
||||
|
||||
The parser can then get a path for each entity in the message
|
||||
by handing that entity's header (a MIME::Head) to the filer
|
||||
and having it do the work, like this:
|
||||
|
||||
$new_file = $parser->filer->output_path($head);
|
||||
|
||||
Since it's nice to be able to clean up after a parse (especially
|
||||
a failed parse), the parser tells the filer when it has actually
|
||||
used a path:
|
||||
|
||||
$parser->filer->purgeable($new_file);
|
||||
|
||||
Then, if you want to clean up the files which were created for a
|
||||
particular parse (and also any directories that the Filer created),
|
||||
you would do this:
|
||||
|
||||
$parser->filer->purge;
|
||||
|
||||
|
||||
|
||||
=head2 Writing your own subclasses
|
||||
|
||||
There are two standard "Filer" subclasses (see below):
|
||||
B<MIME::Parser::FileInto>, which throws all files from all parses
|
||||
into the same directory, and B<MIME::Parser::FileUnder> (preferred), which
|
||||
creates a subdirectory for each message. Hopefully, these will be
|
||||
sufficient for most uses, but just in case...
|
||||
|
||||
The only method you have to override is L<output_path()|/output_path>:
|
||||
|
||||
$filer->output_path($head);
|
||||
|
||||
This method is invoked by MIME::Parser when it wants to put a
|
||||
decoded message body in an output file. The method should return a
|
||||
path to the file to create. Failure is indicated by throwing an
|
||||
exception.
|
||||
|
||||
The path returned by C<output_path()> should be "ready for open()":
|
||||
any necessary parent directories need to exist at that point.
|
||||
These directories can be created by the Filer, if course, and they
|
||||
should be marked as B<purgeable()> if a purge should delete them.
|
||||
|
||||
Actually, if your issue is more I<where> the files go than
|
||||
what they're named, you can use the default L<output_path()|/output_path>
|
||||
method and just override one of its components:
|
||||
|
||||
$dir = $filer->output_dir($head);
|
||||
$name = $filer->output_filename($head);
|
||||
...
|
||||
|
||||
|
||||
|
||||
=head1 PUBLIC INTERFACE
|
||||
|
||||
|
||||
=head2 MIME::Parser::Filer
|
||||
|
||||
This is the abstract superclass of all "filer" objects.
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
|
||||
### Kit modules:
|
||||
use MIME::Tools qw(:msgtypes);
|
||||
use File::Spec;
|
||||
use File::Path qw(rmtree);
|
||||
use MIME::WordDecoder;
|
||||
|
||||
### Output path uniquifiers:
|
||||
my $GFileNo = 0;
|
||||
my $GSubdirNo = 0;
|
||||
|
||||
### Map content-type to extension.
|
||||
### If we can't map "major/minor", we try "major/*", then use "*/*".
|
||||
my %DefaultTypeToExt =
|
||||
qw(
|
||||
|
||||
application/andrew-inset .ez
|
||||
application/octet-stream .bin
|
||||
application/oda .oda
|
||||
application/pdf .pdf
|
||||
application/pgp .pgp
|
||||
application/postscript .ps
|
||||
application/rtf .rtf
|
||||
application/x-bcpio .bcpio
|
||||
application/x-chess-pgn .pgn
|
||||
application/x-cpio .cpio
|
||||
application/x-csh .csh
|
||||
application/x-dvi .dvi
|
||||
application/x-gtar .gtar
|
||||
application/x-gunzip .gz
|
||||
application/x-hdf .hdf
|
||||
application/x-latex .latex
|
||||
application/x-mif .mif
|
||||
application/x-netcdf .cdf
|
||||
application/x-netcdf .nc
|
||||
application/x-sh .sh
|
||||
application/x-shar .shar
|
||||
application/x-sv4cpio .sv4cpio
|
||||
application/x-sv4crc .sv4crc
|
||||
application/x-tar .tar
|
||||
application/x-tcl .tcl
|
||||
application/x-tex .tex
|
||||
application/x-texinfo .texi
|
||||
application/x-troff .roff
|
||||
application/x-troff .tr
|
||||
application/x-troff-man .man
|
||||
application/x-troff-me .me
|
||||
application/x-troff-ms .ms
|
||||
application/x-ustar .ustar
|
||||
application/x-wais-source .src
|
||||
application/zip .zip
|
||||
|
||||
audio/basic .snd
|
||||
audio/ulaw .au
|
||||
audio/x-aiff .aiff
|
||||
audio/x-wav .wav
|
||||
|
||||
image/gif .gif
|
||||
image/ief .ief
|
||||
image/jpeg .jpg
|
||||
image/png .png
|
||||
image/xbm .xbm
|
||||
image/tiff .tif
|
||||
image/x-cmu-raster .ras
|
||||
image/x-portable-anymap .pnm
|
||||
image/x-portable-bitmap .pbm
|
||||
image/x-portable-graymap .pgm
|
||||
image/x-portable-pixmap .ppm
|
||||
image/x-rgb .rgb
|
||||
image/x-xbitmap .xbm
|
||||
image/x-xpixmap .xpm
|
||||
image/x-xwindowdump .xwd
|
||||
|
||||
text/* .txt
|
||||
text/html .html
|
||||
text/plain .txt
|
||||
text/richtext .rtx
|
||||
text/tab-separated-values .tsv
|
||||
text/x-setext .etx
|
||||
text/x-vcard .vcf
|
||||
|
||||
video/mpeg .mpg
|
||||
video/quicktime .mov
|
||||
video/x-msvideo .avi
|
||||
video/x-sgi-movie .movie
|
||||
|
||||
message/* .msg
|
||||
|
||||
*/* .dat
|
||||
|
||||
);
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item new INITARGS...
|
||||
|
||||
I<Class method, constructor.>
|
||||
Create a new outputter for the given parser.
|
||||
Any subsequent arguments are given to init(), which subclasses should
|
||||
override for their own use (the default init does nothing).
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class, @initargs) = @_;
|
||||
my $self = bless {
|
||||
MPF_Prefix => "msg",
|
||||
MPF_Dir => ".",
|
||||
MPF_Ext => { %DefaultTypeToExt },
|
||||
MPF_Purgeable => [], ### files created by the last parse
|
||||
|
||||
MPF_MaxName => 80, ### max filename before treated as evil
|
||||
MPF_TrimRoot => 14, ### trim root to this length
|
||||
MPF_TrimExt => 3, ### trim extension to this length
|
||||
}, $class;
|
||||
$self->init(@initargs);
|
||||
$self;
|
||||
}
|
||||
|
||||
sub init {
|
||||
### no-op
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# cleanup_dir
|
||||
#
|
||||
# Instance method, private.
|
||||
# Cleanup a directory, defaulting empty to "."
|
||||
#
|
||||
sub cleanup_dir {
|
||||
my ($self, $dir) = @_;
|
||||
$dir = '.' if (!defined($dir) || ($dir eq '')); # coerce empty to "."
|
||||
$dir = '/.' if ($dir eq '/'); # coerce "/" so "$dir/$filename" works
|
||||
$dir =~ s|/$||; # be nice: get rid of any trailing "/"
|
||||
$dir;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item results RESULTS
|
||||
|
||||
I<Instance method.>
|
||||
Link this filer to a MIME::Parser::Results object which will
|
||||
tally the messages. Notice that we avoid linking it to the
|
||||
parser to avoid circular reference!
|
||||
|
||||
=cut
|
||||
|
||||
sub results {
|
||||
my ($self, $results) = @_;
|
||||
$self->{MPF_Results} = $results if (@_ > 1);
|
||||
$self->{MPF_Results};
|
||||
}
|
||||
|
||||
### Log debug messages:
|
||||
sub debug {
|
||||
my $self = shift;
|
||||
if (MIME::Tools->debugging()) {
|
||||
if ($self->{MPF_Results}) {
|
||||
unshift @_, $self->{MPF_Results}->indent;
|
||||
$self->{MPF_Results}->msg($M_DEBUG, @_);
|
||||
}
|
||||
MIME::Tools::debug(@_);
|
||||
}
|
||||
}
|
||||
|
||||
### Log warning messages:
|
||||
sub whine {
|
||||
my $self = shift;
|
||||
if ($self->{MPF_Results}) {
|
||||
unshift @_, $self->{MPF_Results}->indent;
|
||||
$self->{MPF_Results}->msg($M_WARNING, @_);
|
||||
}
|
||||
MIME::Tools::whine(@_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item init_parse
|
||||
|
||||
I<Instance method.>
|
||||
Prepare to start parsing a new message.
|
||||
Subclasses should always be sure to invoke the inherited method.
|
||||
|
||||
=cut
|
||||
|
||||
sub init_parse {
|
||||
my $self = shift;
|
||||
$self->{MPF_Purgeable} = [];
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item evil_filename FILENAME
|
||||
|
||||
I<Instance method.>
|
||||
Is this an evil filename; i.e., one which should not be used
|
||||
in generating a disk file name? It is if any of these are true:
|
||||
|
||||
* it is empty or entirely whitespace
|
||||
* it contains leading or trailing whitespace
|
||||
* it is a string of dots: ".", "..", etc.
|
||||
* it contains characters not in the set: "A" - "Z", "a" - "z",
|
||||
"0" - "9", "-", "_", "+", "=", ".", ",", "@", "#",
|
||||
"$", and " ".
|
||||
* it is too long
|
||||
|
||||
If you just want to change this behavior, you should override
|
||||
this method in the subclass of MIME::Parser::Filer that you use.
|
||||
|
||||
B<Warning:> at the time this method is invoked, the FILENAME has
|
||||
already been unmime'd into the local character set.
|
||||
If you're using any character set other than ASCII, ISO-8859-*,
|
||||
or UTF-8, the interpretation of the "path" characters might be
|
||||
very different, and you will probably need to override this method.
|
||||
See L<MIME::WordDecoder/unmime> for more details.
|
||||
|
||||
B<Note:> subclasses of MIME::Parser::Filer which override
|
||||
output_path() might not consult this method; note, however, that
|
||||
the built-in subclasses do consult it.
|
||||
|
||||
I<Thanks to Andrew Pimlott for finding a real dumb bug in the original
|
||||
version. Thanks to Nickolay Saukh for noting that evil is in the
|
||||
eye of the beholder.>
|
||||
|
||||
=cut
|
||||
|
||||
sub evil_filename {
|
||||
my ($self, $name) = @_;
|
||||
|
||||
$self->debug("is this evil? '$name'");
|
||||
|
||||
return 1 if (!defined($name) or ($name eq '')); ### empty
|
||||
return 1 if ($name =~ m{(^\s)|(\s+\Z)}); ### leading/trailing whitespace
|
||||
return 1 if ($name =~ m{^\.+\Z}); ### dots
|
||||
return 1 if ($name =~ /[^-A-Z0-9_+=.,@\#\$\% ]/i); # Only allow good chars
|
||||
return 1 if ($self->{MPF_MaxName} and
|
||||
(length($name) > $self->{MPF_MaxName}));
|
||||
$self->debug("it's ok");
|
||||
0;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item exorcise_filename FILENAME
|
||||
|
||||
I<Instance method.>
|
||||
If a given filename is evil (see L</evil_filename>) we try to
|
||||
rescue it by performing some basic operations: shortening it,
|
||||
removing bad characters, etc., and checking each against
|
||||
evil_filename().
|
||||
|
||||
Returns the exorcised filename (which is guaranteed to not
|
||||
be evil), or undef if it could not be salvaged.
|
||||
|
||||
B<Warning:> at the time this method is invoked, the FILENAME has
|
||||
already been unmime'd into the local character set.
|
||||
If you're using anything character set other than ASCII, ISO-8859-*,
|
||||
or UTF-8, the interpretation of the "path" characters might be very
|
||||
very different, and you will probably need to override this method.
|
||||
See L<MIME::WordDecoder/unmime> for more details.
|
||||
|
||||
=cut
|
||||
|
||||
sub exorcise_filename {
|
||||
my ($self, $fname) = @_;
|
||||
|
||||
### Isolate to last path element:
|
||||
my $last = $fname;
|
||||
|
||||
### Path separators are / or \
|
||||
$last =~ s{^.*[/\\]}{};
|
||||
|
||||
### Convert semi-evil characters to underscores
|
||||
$last =~ s/[\/\\\[\]:]/_/g;
|
||||
if ($last and !$self->evil_filename($last)) {
|
||||
$self->debug("looks like I can use the last path element");
|
||||
return $last;
|
||||
}
|
||||
|
||||
### Break last element into root and extension, and truncate:
|
||||
my ($root, $ext) = (($last =~ /^(.*)\.([^\.]+)\Z/)
|
||||
? ($1, $2)
|
||||
: ($last, ''));
|
||||
### Delete leading and trailing whitespace
|
||||
$root =~ s/^\s+//;
|
||||
$ext =~ s/\s+$//;
|
||||
$root = substr($root, 0, ($self->{MPF_TrimRoot} || 14));
|
||||
$ext = substr($ext, 0, ($self->{MPF_TrimExt} || 3));
|
||||
$ext =~ /^\w+$/ or $ext = "dat";
|
||||
my $trunc = $root . ($ext ? ".$ext" : '');
|
||||
if (!$self->evil_filename($trunc)) {
|
||||
$self->debug("looks like I can use the truncated last path element");
|
||||
return $trunc;
|
||||
}
|
||||
|
||||
### Remove all bad characters
|
||||
$trunc =~ s/([^-A-Z0-9_+=.,@\#\$ ])/sprintf("%%%02X", unpack("C", $1))/ige;
|
||||
if (!$self->evil_filename($trunc)) {
|
||||
$self->debug("looks like I can use a munged version of the truncated last path element");
|
||||
return $trunc;
|
||||
}
|
||||
|
||||
### Hope that works:
|
||||
undef;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item find_unused_path DIR, FILENAME
|
||||
|
||||
I<Instance method, subclasses only.>
|
||||
We have decided on an output directory and tentative filename,
|
||||
but there is a chance that it might already exist. Keep
|
||||
adding a numeric suffix "-1", "-2", etc. to the filename
|
||||
until an unused path is found, and then return that path.
|
||||
|
||||
The suffix is actually added before the first "." in the filename
|
||||
is there is one; for example:
|
||||
|
||||
picture.gif archive.tar.gz readme
|
||||
picture-1.gif archive-1.tar.gz readme-1
|
||||
picture-2.gif archive-2.tar.gz readme-2
|
||||
... ... ...
|
||||
picture-10.gif
|
||||
...
|
||||
|
||||
This can be a costly operation, and risky if you don't want files
|
||||
renamed, so it is in your best interest to minimize situations
|
||||
where these kinds of collisions occur. Unfortunately, if
|
||||
a multipart message gives all of its parts the same recommended
|
||||
filename, and you are placing them all in the same directory,
|
||||
this method might be unavoidable.
|
||||
|
||||
=cut
|
||||
|
||||
sub find_unused_path {
|
||||
my ($self, $dir, $fname) = @_;
|
||||
my $i = 0;
|
||||
while (1) {
|
||||
|
||||
### Create suffixed name (from filename), and see if we can use it:
|
||||
my $suffix = ($i ? "-$i" : "");
|
||||
my $sname = $fname; $sname =~ s/^(.*?)(\.|\Z)/$1$suffix$2/;
|
||||
my $path = File::Spec->catfile($dir, $sname);
|
||||
if (! -e $path) { ### it's good!
|
||||
$i and $self->whine("collision with $fname in $dir: using $path");
|
||||
return $path;
|
||||
}
|
||||
$self->debug("$path already taken");
|
||||
} continue { ++$i; }
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item ignore_filename [YESNO]
|
||||
|
||||
I<Instance method.>
|
||||
Return true if we should always ignore recommended filenames in
|
||||
messages, choosing instead to always generate our own filenames.
|
||||
With argument, sets this value.
|
||||
|
||||
B<Note:> subclasses of MIME::Parser::Filer which override
|
||||
output_path() might not honor this setting; note, however, that
|
||||
the built-in subclasses honor it.
|
||||
|
||||
=cut
|
||||
|
||||
sub ignore_filename {
|
||||
my $self = shift;
|
||||
$self->{MPF_IgnoreFilename} = $_[0] if @_;
|
||||
$self->{MPF_IgnoreFilename};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item output_dir HEAD
|
||||
|
||||
I<Instance method.>
|
||||
Return the output directory for the given header.
|
||||
The default method returns ".".
|
||||
|
||||
=cut
|
||||
|
||||
sub output_dir {
|
||||
my ($self, $head) = @_;
|
||||
return ".";
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item output_filename HEAD
|
||||
|
||||
I<Instance method, subclasses only.>
|
||||
A given recommended filename was either not given, or it was judged
|
||||
to be evil. Return a fake name, possibly using information in the
|
||||
message HEADer. Note that this is just the filename, not the full path.
|
||||
|
||||
Used by L<output_path()|/output_path>.
|
||||
If you're using the default C<output_path()>, you probably don't
|
||||
need to worry about avoiding collisions with existing files;
|
||||
we take care of that in L<find_unused_path()|/find_unused_path>.
|
||||
|
||||
=cut
|
||||
|
||||
sub output_filename {
|
||||
my ($self, $head) = @_;
|
||||
|
||||
### Get the recommended name:
|
||||
my $recommended = $head->recommended_filename;
|
||||
|
||||
### Get content type:
|
||||
my ($type, $subtype) = split m{/}, $head->mime_type; $subtype ||= '';
|
||||
|
||||
### Get recommended extension, being quite conservative:
|
||||
my $recommended_ext = (($recommended and ($recommended =~ m{(\.\w+)\Z}))
|
||||
? $1
|
||||
: undef);
|
||||
|
||||
### Try and get an extension, honoring a given one first:
|
||||
my $ext = ($recommended_ext ||
|
||||
$self->{MPF_Ext}{"$type/$subtype"} ||
|
||||
$self->{MPF_Ext}{"$type/*"} ||
|
||||
$self->{MPF_Ext}{"*/*"} ||
|
||||
".dat");
|
||||
|
||||
### Get a prefix:
|
||||
++$GFileNo;
|
||||
return ($self->output_prefix . "-$$-$GFileNo$ext");
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item output_prefix [PREFIX]
|
||||
|
||||
I<Instance method.>
|
||||
Get the short string that all filenames for extracted body-parts
|
||||
will begin with (assuming that there is no better "recommended filename").
|
||||
The default is F<"msg">.
|
||||
|
||||
If PREFIX I<is not> given, the current output prefix is returned.
|
||||
If PREFIX I<is> given, the output prefix is set to the new value,
|
||||
and the previous value is returned.
|
||||
|
||||
Used by L<output_filename()|/output_filename>.
|
||||
|
||||
B<Note:> subclasses of MIME::Parser::Filer which override
|
||||
output_path() or output_filename() might not honor this setting;
|
||||
note, however, that the built-in subclasses honor it.
|
||||
|
||||
=cut
|
||||
|
||||
sub output_prefix {
|
||||
my ($self, $prefix) = @_;
|
||||
$self->{MPF_Prefix} = $prefix if (@_ > 1);
|
||||
$self->{MPF_Prefix};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item output_type_ext
|
||||
|
||||
I<Instance method.>
|
||||
Return a reference to the hash used by the default
|
||||
L<output_filename()|/output_filename> for mapping from content-types
|
||||
to extensions when there is no default extension to use.
|
||||
|
||||
$emap = $filer->output_typemap;
|
||||
$emap->{'text/plain'} = '.txt';
|
||||
$emap->{'text/html'} = '.html';
|
||||
$emap->{'text/*'} = '.txt';
|
||||
$emap->{'*/*'} = '.dat';
|
||||
|
||||
B<Note:> subclasses of MIME::Parser::Filer which override
|
||||
output_path() or output_filename() might not consult this hash;
|
||||
note, however, that the built-in subclasses consult it.
|
||||
|
||||
=cut
|
||||
|
||||
sub output_type_ext {
|
||||
my $self = shift;
|
||||
return $self->{MPF_Ext};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item output_path HEAD
|
||||
|
||||
I<Instance method, subclasses only.>
|
||||
Given a MIME head for a file to be extracted, come up with a good
|
||||
output pathname for the extracted file. This is the only method
|
||||
you need to worry about if you are building a custom filer.
|
||||
|
||||
The default implementation does a lot of work; subclass
|
||||
implementers I<really> should try to just override its components
|
||||
instead of the whole thing. It works basically as follows:
|
||||
|
||||
$directory = $self->output_dir($head);
|
||||
|
||||
$filename = $head->recommended_filename();
|
||||
if (!$filename or
|
||||
$self->ignore_filename() or
|
||||
$self->evil_filename($filename)) {
|
||||
$filename = $self->output_filename($head);
|
||||
}
|
||||
|
||||
return $self->find_unused_path($directory, $filename);
|
||||
|
||||
B<Note:> There are many, many, many ways you might want to control
|
||||
the naming of files, based on your application. If you don't like
|
||||
the behavior of this function, you can easily define your own subclass
|
||||
of MIME::Parser::Filer and override it there.
|
||||
|
||||
B<Note:> Nickolay Saukh pointed out that, given the subjective nature of
|
||||
what is "evil", this function really shouldn't I<warn> about an evil
|
||||
filename, but maybe just issue a I<debug> message. I considered that,
|
||||
but then I thought: if debugging were off, people wouldn't know why
|
||||
(or even if) a given filename had been ignored. In mail robots
|
||||
that depend on externally-provided filenames, this could cause
|
||||
hard-to-diagnose problems. So, the message is still a warning.
|
||||
|
||||
I<Thanks to Laurent Amon for pointing out problems with the original
|
||||
implementation, and for making some good suggestions. Thanks also to
|
||||
Achim Bohnet for pointing out that there should be a hookless, OO way of
|
||||
overriding the output path.>
|
||||
|
||||
=cut
|
||||
|
||||
sub output_path {
|
||||
my ($self, $head) = @_;
|
||||
|
||||
### Get the output directory:
|
||||
my $dir = $self->output_dir($head);
|
||||
|
||||
### Get the output filename as UTF-8
|
||||
my $fname = $head->recommended_filename;
|
||||
|
||||
### Can we use it:
|
||||
if (!defined($fname)) {
|
||||
$self->debug("no filename recommended: synthesizing our own");
|
||||
$fname = $self->output_filename($head);
|
||||
}
|
||||
elsif ($self->ignore_filename) {
|
||||
$self->debug("ignoring all external filenames: synthesizing our own");
|
||||
$fname = $self->output_filename($head);
|
||||
}
|
||||
elsif ($self->evil_filename($fname)) {
|
||||
|
||||
### Can we save it by just taking the last element?
|
||||
my $ex = $self->exorcise_filename($fname);
|
||||
if (defined($ex) and !$self->evil_filename($ex)) {
|
||||
$self->whine("Provided filename '$fname' is regarded as evil, ",
|
||||
"but I was able to exorcise it and get something ",
|
||||
"usable.");
|
||||
$fname = $ex;
|
||||
}
|
||||
else {
|
||||
$self->whine("Provided filename '$fname' is regarded as evil; ",
|
||||
"I'm ignoring it and supplying my own.");
|
||||
$fname = $self->output_filename($head);
|
||||
}
|
||||
}
|
||||
$self->debug("planning to use '$fname'");
|
||||
|
||||
### Resolve collisions and return final path:
|
||||
return $self->find_unused_path($dir, $fname);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item purge
|
||||
|
||||
I<Instance method, final.>
|
||||
Purge all files/directories created by the last parse.
|
||||
This method simply goes through the purgeable list in reverse order
|
||||
(see L</purgeable>) and removes all existing files/directories in it.
|
||||
You should not need to override this method.
|
||||
|
||||
=cut
|
||||
|
||||
sub purge {
|
||||
my ($self) = @_;
|
||||
foreach my $path (reverse @{$self->{MPF_Purgeable}}) {
|
||||
(-e $path) or next; ### must check: might delete DIR before DIR/FILE
|
||||
rmtree($path, 0, 1);
|
||||
(-e $path) and $self->whine("unable to purge: $path");
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item purgeable [FILE]
|
||||
|
||||
I<Instance method, final.>
|
||||
Add FILE to the list of "purgeable" files/directories (those which
|
||||
will be removed if you do a C<purge()>).
|
||||
You should not need to override this method.
|
||||
|
||||
If FILE is not given, the "purgeable" list is returned.
|
||||
This may be used for more-sophisticated purging.
|
||||
|
||||
As a special case, invoking this method with a FILE that is an
|
||||
arrayref will replace the purgeable list with a copy of the
|
||||
array's contents, so [] may be used to clear the list.
|
||||
|
||||
Note that the "purgeable" list is cleared when a parser begins a
|
||||
new parse; therefore, if you want to use purge() to do cleanup,
|
||||
you I<must> do so I<before> starting a new parse!
|
||||
|
||||
=cut
|
||||
|
||||
sub purgeable {
|
||||
my ($self, $path) = @_;
|
||||
return @{$self->{MPF_Purgeable}} if (@_ == 1);
|
||||
|
||||
if (ref($path)) { $self->{MPF_Purgeable} = [ @$path ]; }
|
||||
else { push @{$self->{MPF_Purgeable}}, $path; }
|
||||
1;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#------------------------------------------------------------
|
||||
#------------------------------------------------------------
|
||||
|
||||
=head2 MIME::Parser::FileInto
|
||||
|
||||
This concrete subclass of MIME::Parser::Filer supports filing
|
||||
into a given directory.
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
package MIME::Parser::FileInto;
|
||||
|
||||
use strict;
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(MIME::Parser::Filer);
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item init DIRECTORY
|
||||
|
||||
I<Instance method, initiallizer.>
|
||||
Set the directory where all files will go.
|
||||
|
||||
=cut
|
||||
|
||||
sub init {
|
||||
my ($self, $dir) = @_;
|
||||
$self->{MPFI_Dir} = $self->cleanup_dir($dir);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# output_dir HEAD
|
||||
#
|
||||
# I<Instance method, concrete override.>
|
||||
# Return the output directory where the files go.
|
||||
#
|
||||
sub output_dir {
|
||||
shift->{MPFI_Dir};
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
|
||||
#------------------------------------------------------------
|
||||
#------------------------------------------------------------
|
||||
|
||||
=head2 MIME::Parser::FileUnder
|
||||
|
||||
This concrete subclass of MIME::Parser::Filer supports filing under
|
||||
a given directory, using one subdirectory per message, but with
|
||||
all message parts in the same directory.
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
package MIME::Parser::FileUnder;
|
||||
|
||||
use strict;
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(MIME::Parser::Filer);
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item init BASEDIR, OPTSHASH...
|
||||
|
||||
I<Instance method, initiallizer.>
|
||||
Set the base directory which will contain the message directories.
|
||||
If used, then each parse of begins by creating a new subdirectory
|
||||
of BASEDIR where the actual parts of the message are placed.
|
||||
OPTSHASH can contain the following:
|
||||
|
||||
=over 4
|
||||
|
||||
=item DirName
|
||||
|
||||
Explicitly set the name of the subdirectory which is created.
|
||||
The default is to use the time, process id, and a sequence number,
|
||||
but you might want a predictable directory.
|
||||
|
||||
=item Purge
|
||||
|
||||
Automatically purge the contents of the directory (including all
|
||||
subdirectories) before each parse. This is really only needed if
|
||||
using an explicit DirName, and is provided as a convenience only.
|
||||
Currently we use the 1-arg form of File::Path::rmtree; you should
|
||||
familiarize yourself with the caveats therein.
|
||||
|
||||
=back
|
||||
|
||||
The output_dir() will return the path to this message-specific directory
|
||||
until the next parse is begun, so you can do this:
|
||||
|
||||
use File::Path;
|
||||
|
||||
$parser->output_under("/tmp");
|
||||
$ent = eval { $parser->parse_open($msg); }; ### parse
|
||||
if (!$ent) { ### parse failed
|
||||
rmtree($parser->output_dir);
|
||||
die "parse failed: $@";
|
||||
}
|
||||
else { ### parse succeeded
|
||||
...do stuff...
|
||||
}
|
||||
|
||||
=cut
|
||||
|
||||
sub init {
|
||||
my ($self, $basedir, %opts) = @_;
|
||||
|
||||
$self->{MPFU_Base} = $self->cleanup_dir($basedir);
|
||||
$self->{MPFU_DirName} = $opts{DirName};
|
||||
$self->{MPFU_Purge} = $opts{Purge};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# init_parse
|
||||
#
|
||||
# I<Instance method, override.>
|
||||
# Prepare to start parsing a new message.
|
||||
#
|
||||
sub init_parse {
|
||||
my $self = shift;
|
||||
|
||||
### Invoke inherited method first!
|
||||
$self->SUPER::init_parse;
|
||||
|
||||
### Determine the subdirectory of their base to use:
|
||||
my $subdir = (defined($self->{MPFU_DirName})
|
||||
? $self->{MPFU_DirName}
|
||||
: ("msg-".scalar(time)."-$$-".$GSubdirNo++));
|
||||
$self->debug("subdir = $subdir");
|
||||
|
||||
### Determine full path to the per-message output directory:
|
||||
$self->{MPFU_Dir} = File::Spec->catfile($self->{MPFU_Base}, $subdir);
|
||||
|
||||
### Remove and re-create the per-message output directory:
|
||||
rmtree $self->output_dir if $self->{MPFU_Purge};
|
||||
(-d $self->output_dir) or
|
||||
mkdir $self->output_dir, 0700 or
|
||||
die "mkdir ".$self->output_dir.": $!\n";
|
||||
|
||||
### Add the per-message output directory to the puregables:
|
||||
$self->purgeable($self->output_dir);
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# output_dir HEAD
|
||||
#
|
||||
# I<Instance method, concrete override.>
|
||||
# Return the output directory that we used for the last parse.
|
||||
#
|
||||
sub output_dir {
|
||||
shift->{MPFU_Dir};
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Tools>, L<MIME::Parser>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
328
Git/usr/share/perl5/vendor_perl/MIME/Parser/Reader.pm
Normal file
328
Git/usr/share/perl5/vendor_perl/MIME/Parser/Reader.pm
Normal file
@ -0,0 +1,328 @@
|
||||
package MIME::Parser::Reader;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Parser::Reader - a line-oriented reader for a MIME::Parser
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
This module is used internally by MIME::Parser; you probably
|
||||
don't need to be looking at it at all. But just in case...
|
||||
|
||||
### Create a top-level reader, where chunks end at EOF:
|
||||
$rdr = MIME::Parser::Reader->new();
|
||||
|
||||
### Spawn a child reader, where chunks also end at a boundary:
|
||||
$subrdr = $rdr->spawn->add_boundary($bound);
|
||||
|
||||
### Spawn a child reader, where chunks also end at a given string:
|
||||
$subrdr = $rdr->spawn->add_terminator($string);
|
||||
|
||||
### Read until boundary or terminator:
|
||||
$subrdr->read_chunk($in, $out);
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A line-oriented reader which can deal with virtual end-of-stream
|
||||
defined by a collection of boundaries.
|
||||
|
||||
B<Warning:> this is a private class solely for use by MIME::Parser.
|
||||
This class has no official public interface
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
|
||||
### All possible end-of-line sequences.
|
||||
### Note that "" is included because last line of stream may have no newline!
|
||||
my @EOLs = ("", "\r", "\n", "\r\n", "\n\r");
|
||||
|
||||
### Long line:
|
||||
my $LONGLINE = ' ' x 1000;
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# new
|
||||
#
|
||||
# I<Class method.>
|
||||
# Construct an empty (top-level) reader.
|
||||
#
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $eos;
|
||||
return bless {
|
||||
Bounds => [],
|
||||
BH => {},
|
||||
TH => {},
|
||||
EOS => \$eos,
|
||||
}, $class;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# spawn
|
||||
#
|
||||
# I<Instance method.>
|
||||
# Return a reader which is mostly a duplicate, except that the EOS
|
||||
# accumulator is shared.
|
||||
#
|
||||
sub spawn {
|
||||
my $self = shift;
|
||||
my $dup = bless {}, ref($self);
|
||||
$dup->{Bounds} = [ @{$self->{Bounds}} ]; ### deep copy
|
||||
$dup->{BH} = { %{$self->{BH}} }; ### deep copy
|
||||
$dup->{TH} = { %{$self->{TH}} }; ### deep copy
|
||||
$dup->{EOS} = $self->{EOS}; ### shallow copy; same ref!
|
||||
$dup;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# add_boundary BOUND
|
||||
#
|
||||
# I<Instance method.>
|
||||
# Let BOUND be the new innermost boundary. Returns self.
|
||||
#
|
||||
sub add_boundary {
|
||||
my ($self, $bound) = @_;
|
||||
unshift @{$self->{Bounds}}, $bound; ### now at index 0
|
||||
$self->{BH}{"--$bound"} = "DELIM $bound";
|
||||
$self->{BH}{"--$bound--"} = "CLOSE $bound";
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# add_terminator LINE
|
||||
#
|
||||
# I<Instance method.>
|
||||
# Let LINE be another terminator. Returns self.
|
||||
#
|
||||
sub add_terminator {
|
||||
my ($self, $line) = @_;
|
||||
foreach (@EOLs) {
|
||||
$self->{TH}{"$line$_"} = "DONE $line";
|
||||
}
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# has_bounds
|
||||
#
|
||||
# I<Instance method.>
|
||||
# Are there boundaries to contend with?
|
||||
#
|
||||
sub has_bounds {
|
||||
scalar(@{shift->{Bounds}});
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# depth
|
||||
#
|
||||
# I<Instance method.>
|
||||
# How many levels are there?
|
||||
#
|
||||
sub depth {
|
||||
scalar(@{shift->{Bounds}});
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# eos [EOS]
|
||||
#
|
||||
# I<Instance method.>
|
||||
# Return the last end-of-stream token seen.
|
||||
# See read_chunk() for what these might be.
|
||||
#
|
||||
sub eos {
|
||||
my $self = shift;
|
||||
${$self->{EOS}} = $_[0] if @_;
|
||||
${$self->{EOS}};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# eos_type [EOSTOKEN]
|
||||
#
|
||||
# I<Instance method.>
|
||||
# Return the high-level type of the given token (defaults to our token).
|
||||
#
|
||||
# DELIM saw an innermost boundary like --xyz
|
||||
# CLOSE saw an innermost boundary like --xyz--
|
||||
# DONE callback returned false
|
||||
# EOF end of file
|
||||
# EXT saw boundary of some higher-level
|
||||
#
|
||||
sub eos_type {
|
||||
my ($self, $eos) = @_;
|
||||
$eos = $self->eos if (@_ == 1);
|
||||
|
||||
if ($eos =~ /^(DONE|EOF)/) {
|
||||
return $1;
|
||||
}
|
||||
elsif ($eos =~ /^(DELIM|CLOSE) (.*)$/) {
|
||||
return (($2 eq $self->{Bounds}[0]) ? $1 : 'EXT');
|
||||
}
|
||||
else {
|
||||
die("internal error: unable to classify boundary token ($eos)");
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# native_handle HANDLE
|
||||
#
|
||||
# I<Function.>
|
||||
# Can we do native i/o on HANDLE? If true, returns the handle
|
||||
# that will respond to native I/O calls; else, returns undef.
|
||||
#
|
||||
sub native_handle {
|
||||
my $fh = shift;
|
||||
return $fh if ($fh->isa('IO::File') || $fh->isa('IO::Handle'));
|
||||
return $fh if (ref $fh eq 'GLOB');
|
||||
undef;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# read_chunk INHANDLE, OUTHANDLE
|
||||
#
|
||||
# I<Instance method.>
|
||||
# Get lines until end-of-stream.
|
||||
# Returns the terminating-condition token:
|
||||
#
|
||||
# DELIM xyz saw boundary line "--xyz"
|
||||
# CLOSE xyz saw boundary line "--xyz--"
|
||||
# DONE xyz saw terminator line "xyz"
|
||||
# EOF end of file
|
||||
|
||||
# Parse up to (and including) the boundary, and dump output.
|
||||
# Follows the RFC 2046 specification, that the CRLF immediately preceding
|
||||
# the boundary is part of the boundary, NOT part of the input!
|
||||
#
|
||||
# NOTE: while parsing bodies, we take care to remember the EXACT end-of-line
|
||||
# sequence. This is because we *may* be handling 'binary' encoded data, and
|
||||
# in that case we can't just massage \r\n into \n! Don't worry... if the
|
||||
# data is styled as '7bit' or '8bit', the "decoder" will massage the CRLF
|
||||
# for us. For now, we're just trying to chop up the data stream.
|
||||
|
||||
# NBK - Oct 12, 1999
|
||||
# The CRLF at the end of the current line is considered part
|
||||
# of the boundary. I buffer the current line and output the
|
||||
# last. I strip the last CRLF when I hit the boundary.
|
||||
|
||||
sub read_chunk {
|
||||
my ($self, $in, $out, $keep_newline, $normalize_newlines) = @_;
|
||||
|
||||
# If we're parsing a preamble or epilogue, we need to keep the blank line
|
||||
# that precedes the boundary line.
|
||||
$keep_newline ||= 0;
|
||||
|
||||
$normalize_newlines ||= 0;
|
||||
### Init:
|
||||
my %bh = %{$self->{BH}};
|
||||
my %th = %{$self->{TH}}; my $thx = keys %th;
|
||||
local $_ = $LONGLINE;
|
||||
my $maybe;
|
||||
my $last = '';
|
||||
my $eos = '';
|
||||
|
||||
### Determine types:
|
||||
my $n_in = native_handle($in);
|
||||
my $n_out = native_handle($out);
|
||||
|
||||
### Handle efficiently by type:
|
||||
if ($n_in) {
|
||||
if ($n_out) { ### native input, native output [fastest]
|
||||
while (<$n_in>) {
|
||||
# Normalize line ending
|
||||
$_ =~ s/(?:\n\r|\r\n|\r)$/\n/ if $normalize_newlines;
|
||||
if (substr($_, 0, 2) eq '--') {
|
||||
($maybe = $_) =~ s/[ \t\r\n]+\Z//;
|
||||
$bh{$maybe} and do { $eos = $bh{$maybe}; last };
|
||||
}
|
||||
$thx and $th{$_} and do { $eos = $th{$_}; last };
|
||||
print $n_out $last; $last = $_;
|
||||
}
|
||||
}
|
||||
else { ### native input, OO output [slower]
|
||||
while (<$n_in>) {
|
||||
# Normalize line ending
|
||||
$_ =~ s/(?:\n\r|\r\n|\r)$/\n/ if $normalize_newlines;
|
||||
if (substr($_, 0, 2) eq '--') {
|
||||
($maybe = $_) =~ s/[ \t\r\n]+\Z//;
|
||||
$bh{$maybe} and do { $eos = $bh{$maybe}; last };
|
||||
}
|
||||
$thx and $th{$_} and do { $eos = $th{$_}; last };
|
||||
$out->print($last); $last = $_;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ($n_out) { ### OO input, native output [even slower]
|
||||
while (defined($_ = $in->getline)) {
|
||||
# Normalize line ending
|
||||
$_ =~ s/(?:\n\r|\r\n|\r)$/\n/ if $normalize_newlines;
|
||||
if (substr($_, 0, 2) eq '--') {
|
||||
($maybe = $_) =~ s/[ \t\r\n]+\Z//;
|
||||
$bh{$maybe} and do { $eos = $bh{$maybe}; last };
|
||||
}
|
||||
$thx and $th{$_} and do { $eos = $th{$_}; last };
|
||||
print $n_out $last; $last = $_;
|
||||
}
|
||||
}
|
||||
else { ### OO input, OO output [slowest]
|
||||
while (defined($_ = $in->getline)) {
|
||||
# Normalize line ending
|
||||
$_ =~ s/(?:\n\r|\r\n|\r)$/\n/ if $normalize_newlines;
|
||||
if (substr($_, 0, 2) eq '--') {
|
||||
($maybe = $_) =~ s/[ \t\r\n]+\Z//;
|
||||
$bh{$maybe} and do { $eos = $bh{$maybe}; last };
|
||||
}
|
||||
$thx and $th{$_} and do { $eos = $th{$_}; last };
|
||||
$out->print($last); $last = $_;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Write out last held line, removing terminating CRLF if ended on bound,
|
||||
# unless the line consists only of CRLF and we're wanting to keep the
|
||||
# preceding blank line (as when parsing a preamble)
|
||||
$last =~ s/[\r\n]+\Z// if ($eos =~ /^(DELIM|CLOSE)/ && !($keep_newline && $last =~ m/^[\r\n]\z/));
|
||||
$out->print($last);
|
||||
|
||||
### Save and return what we finished on:
|
||||
${$self->{EOS}} = ($eos || 'EOF');
|
||||
1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# read_lines INHANDLE, \@OUTLINES
|
||||
#
|
||||
# I<Instance method.>
|
||||
# Read lines into the given array.
|
||||
#
|
||||
sub read_lines {
|
||||
my ($self, $in, $outlines) = @_;
|
||||
|
||||
my $data = '';
|
||||
open(my $fh, '>', \$data) or die $!;
|
||||
$self->read_chunk($in, $fh);
|
||||
@$outlines = split(/^/, $data);
|
||||
close $fh;
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Tools>, L<MIME::Parser>
|
186
Git/usr/share/perl5/vendor_perl/MIME/Parser/Results.pm
Normal file
186
Git/usr/share/perl5/vendor_perl/MIME/Parser/Results.pm
Normal file
@ -0,0 +1,186 @@
|
||||
package MIME::Parser::Results;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Parser::Results - results of the last entity parsed
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Before reading further, you should see L<MIME::Parser> to make sure that
|
||||
you understand where this module fits into the grand scheme of things.
|
||||
Go on, do it now. I'll wait.
|
||||
|
||||
Ready? Ok...
|
||||
|
||||
### Do parse, get results:
|
||||
my $entity = eval { $parser->parse(\*STDIN); };
|
||||
my $results = $parser->results;
|
||||
|
||||
### Get all messages logged:
|
||||
@msgs = $results->msgs;
|
||||
|
||||
### Get messages of specific types (also tests if there were problems):
|
||||
$had_errors = $results->errors;
|
||||
$had_warnings = $results->warnings;
|
||||
|
||||
### Get outermost header:
|
||||
$top_head = $results->top_head;
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Results from the last MIME::Parser parse.
|
||||
|
||||
|
||||
=head1 PUBLIC INTERFACE
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
|
||||
### Kit modules:
|
||||
use MIME::Tools qw(:msgs);
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item new
|
||||
|
||||
I<Constructor.>
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
bless {
|
||||
MPI_ID => 'MIME-parser',
|
||||
MPI_Msgs => [],
|
||||
MPI_Level => 0,
|
||||
MPI_TopHead => undef,
|
||||
}, shift;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item msgs
|
||||
|
||||
I<Instance method.>
|
||||
Return all messages that we logged, in order.
|
||||
Every message is a string beginning with its type followed by C<": ">;
|
||||
the current types are C<debug>, C<warning>, and C<error>.
|
||||
|
||||
=cut
|
||||
|
||||
sub msgs {
|
||||
@{shift->{MPI_Msgs}};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item errors
|
||||
|
||||
I<Instance method.>
|
||||
Return all error messages that we logged, in order.
|
||||
A convenience front-end onto msgs().
|
||||
|
||||
=cut
|
||||
|
||||
sub errors {
|
||||
grep /^error: /, @{shift->{MPI_Msgs}};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item warnings
|
||||
|
||||
I<Instance method.>
|
||||
Return all warning messages that we logged, in order.
|
||||
A convenience front-end onto msgs().
|
||||
|
||||
=cut
|
||||
|
||||
sub warnings {
|
||||
grep /^warning: /, @{shift->{MPI_Msgs}};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item top_head
|
||||
|
||||
I<Instance method.>
|
||||
Return the topmost header, if we were able to read it.
|
||||
This may be useful if the parse fails.
|
||||
|
||||
=cut
|
||||
|
||||
sub top_head {
|
||||
my ($self, $head) = @_;
|
||||
$self->{MPI_TopHead} = $head if @_ > 1;
|
||||
$self->{MPI_TopHead};
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# PRIVATE: FOR USE DURING PARSING ONLY!
|
||||
#
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# msg TYPE, MESSAGE...
|
||||
#
|
||||
# Take a message.
|
||||
#
|
||||
sub msg {
|
||||
my $self = shift;
|
||||
my $type = shift;
|
||||
my @args = map { defined($_) ? $_ : '<<undef>>' } @_;
|
||||
|
||||
push @{$self->{MPI_Msgs}}, ($type.": ".join('', @args)."\n");
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# level [+1|-1]
|
||||
#
|
||||
# Return current parsing level.
|
||||
#
|
||||
sub level {
|
||||
my ($self, $lvl) = @_;
|
||||
$self->{MPI_Level} += $lvl if @_ > 1;
|
||||
$self->{MPI_Level};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# indent
|
||||
#
|
||||
# Return indent for current parsing level.
|
||||
#
|
||||
sub indent {
|
||||
my ($self) = @_;
|
||||
' ' x $self->{MPI_Level};
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Tools>, L<MIME::Parser>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
1046
Git/usr/share/perl5/vendor_perl/MIME/Tools.pm
Normal file
1046
Git/usr/share/perl5/vendor_perl/MIME/Tools.pm
Normal file
File diff suppressed because it is too large
Load Diff
682
Git/usr/share/perl5/vendor_perl/MIME/WordDecoder.pm
Normal file
682
Git/usr/share/perl5/vendor_perl/MIME/WordDecoder.pm
Normal file
@ -0,0 +1,682 @@
|
||||
package MIME::WordDecoder;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::WordDecoder - decode RFC 2047 encoded words to a local representation
|
||||
|
||||
WARNING: Most of this module is deprecated and may disappear. The only
|
||||
function you should use for MIME decoding is "mime_to_perl_string".
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
See L<MIME::Words> for the basics of encoded words.
|
||||
See L<"DESCRIPTION"> for how this class works.
|
||||
|
||||
use MIME::WordDecoder;
|
||||
|
||||
|
||||
### Get the default word-decoder (used by unmime()):
|
||||
$wd = default MIME::WordDecoder;
|
||||
|
||||
### Get a word-decoder which maps to ISO-8859-1 (Latin1):
|
||||
$wd = supported MIME::WordDecoder "ISO-8859-1";
|
||||
|
||||
|
||||
### Decode a MIME string (e.g., into Latin1) via the default decoder:
|
||||
$str = $wd->decode('To: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld>');
|
||||
|
||||
### Decode a string using the default decoder, non-OO style:
|
||||
$str = unmime('To: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld>');
|
||||
|
||||
### Decode a string to an internal Perl string, non-OO style
|
||||
### The result is likely to have the UTF8 flag ON.
|
||||
$str = mime_to_perl_string('To: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld>');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
WARNING: Most of this module is deprecated and may disappear. It
|
||||
duplicates (badly) the function of the standard 'Encode' module. The
|
||||
only function you should rely on is mime_to_perl_string.
|
||||
|
||||
A MIME::WordDecoder consists, fundamentally, of a hash which maps
|
||||
a character set name (US-ASCII, ISO-8859-1, etc.) to a subroutine which
|
||||
knows how to take bytes in that character set and turn them into
|
||||
the target string representation. Ideally, this target representation
|
||||
would be Unicode, but we don't want to overspecify the translation
|
||||
that takes place: if you want to convert MIME strings directly to Big5,
|
||||
that's your own decision.
|
||||
|
||||
The subroutine will be invoked with two arguments: DATA (the data in
|
||||
the given character set), and CHARSET (the upcased character set name).
|
||||
|
||||
For example:
|
||||
|
||||
### Keep 7-bit characters as-is, convert 8-bit characters to '#':
|
||||
sub keep7bit {
|
||||
local $_ = shift;
|
||||
tr/\x00-\x7F/#/c;
|
||||
$_;
|
||||
}
|
||||
|
||||
Here's a decoder which uses that:
|
||||
|
||||
### Construct a decoder:
|
||||
$wd = MIME::WordDecoder->new({'US-ASCII' => "KEEP", ### sub { $_[0] }
|
||||
'ISO-8859-1' => \&keep7bit,
|
||||
'ISO-8859-2' => \&keep7bit,
|
||||
'Big5' => "WARN",
|
||||
'*' => "DIE"});
|
||||
|
||||
### Convert some MIME text to a pure ASCII string...
|
||||
$ascii = $wd->decode('To: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld>');
|
||||
|
||||
### ...which will now hold: "To: Keld J#rn Simonsen <keld>"
|
||||
|
||||
The UTF-8 built-in decoder decodes everything into Perl's internal
|
||||
string format, possibly turning on the internal UTF8 flag. Use it like
|
||||
this:
|
||||
|
||||
$wd = supported MIME::WordDecoder 'UTF-8';
|
||||
$perl_string = $wd->decode('To: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld>');
|
||||
# perl_string will be a valid UTF-8 string with the "UTF8" flag set.
|
||||
|
||||
Generally, you should use the UTF-8 decoder in preference to "unmime".
|
||||
|
||||
=head1 PUBLIC INTERFACE
|
||||
|
||||
=over
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use Carp qw( carp croak );
|
||||
use MIME::Words qw(decode_mimewords);
|
||||
use Exporter;
|
||||
use vars qw(@ISA @EXPORT);
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw( unmime mime_to_perl_string );
|
||||
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# Globals
|
||||
#
|
||||
#------------------------------
|
||||
|
||||
### Decoders.
|
||||
my %DecoderFor = ();
|
||||
|
||||
### Standard handlers.
|
||||
my %Handler =
|
||||
(
|
||||
KEEP => sub {$_[0]},
|
||||
IGNORE => sub {''},
|
||||
WARN => sub { carp "ignoring text in character set `$_[1]'\n" },
|
||||
DIE => sub { croak "can't handle text in character set `$_[1]'\n" },
|
||||
);
|
||||
|
||||
### Global default decoder. We init it below.
|
||||
my $Default;
|
||||
|
||||
### Global UTF8 decoder.
|
||||
my $DefaultUTF8;
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item default [DECODER]
|
||||
|
||||
I<Class method.>
|
||||
Get/set the default DECODER object.
|
||||
|
||||
=cut
|
||||
|
||||
sub default {
|
||||
my $class = shift;
|
||||
if (@_) {
|
||||
$Default = shift;
|
||||
}
|
||||
$Default;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item supported CHARSET, [DECODER]
|
||||
|
||||
I<Class method.>
|
||||
If just CHARSET is given, returns a decoder object which maps
|
||||
data into that character set (the character set is forced to
|
||||
all-uppercase).
|
||||
|
||||
$wd = supported MIME::WordDecoder "ISO-8859-1";
|
||||
|
||||
If DECODER is given, installs such an object:
|
||||
|
||||
MIME::WordDecoder->supported("ISO-8859-1" =>
|
||||
(new MIME::WordDecoder::ISO_8859 "1"));
|
||||
|
||||
You should not override this method.
|
||||
|
||||
=cut
|
||||
|
||||
sub supported {
|
||||
my ($class, $charset, $decoder) = @_;
|
||||
$DecoderFor{uc($charset)} = $decoder if (@_ > 2);
|
||||
$DecoderFor{uc($charset)};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item new [\@HANDLERS]
|
||||
|
||||
I<Class method, constructor.>
|
||||
If \@HANDLERS is given, then @HANDLERS is passed to handler()
|
||||
to initialize the internal map.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class, $h) = @_;
|
||||
my $self = bless { MWD_Map=>{} }, $class;
|
||||
|
||||
### Init the map:
|
||||
$self->handler(@$h);
|
||||
|
||||
### Add fallbacks:
|
||||
$self->{MWD_Map}{'*'} ||= $Handler{WARN};
|
||||
$self->{MWD_Map}{'raw'} ||= $self->{MWD_Map}{'US-ASCII'};
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item handler CHARSET=>\&SUBREF, ...
|
||||
|
||||
I<Instance method.>
|
||||
Set the handler SUBREF for a given CHARSET, for as many pairs
|
||||
as you care to supply.
|
||||
|
||||
When performing the translation of a MIME-encoded string, a
|
||||
given SUBREF will be invoked when translating a block of text
|
||||
in character set CHARSET. The subroutine will be invoked with
|
||||
the following arguments:
|
||||
|
||||
DATA - the data in the given character set.
|
||||
CHARSET - the upcased character set name, which may prove useful
|
||||
if you are using the same SUBREF for multiple CHARSETs.
|
||||
DECODER - the decoder itself, if it contains configuration information
|
||||
that your handler function needs.
|
||||
|
||||
For example:
|
||||
|
||||
$wd = new MIME::WordDecoder;
|
||||
$wd->handler('US-ASCII' => "KEEP");
|
||||
$wd->handler('ISO-8859-1' => \&handle_latin1,
|
||||
'ISO-8859-2' => \&handle_latin1,
|
||||
'*' => "DIE");
|
||||
|
||||
Notice that, much as with %SIG, the SUBREF can also be taken from
|
||||
a set of special keywords:
|
||||
|
||||
KEEP Pass data through unchanged.
|
||||
IGNORE Ignore data in this character set, without warning.
|
||||
WARN Ignore data in this character set, with warning.
|
||||
DIE Fatal exception with "can't handle character set" message.
|
||||
|
||||
The subroutine for the special CHARSET of 'raw' is used for raw
|
||||
(non-MIME-encoded) text, which is supposed to be US-ASCII.
|
||||
The handler for 'raw' defaults to whatever was specified for 'US-ASCII'
|
||||
at the time of construction.
|
||||
|
||||
The subroutine for the special CHARSET of '*' is used for any
|
||||
unrecognized character set. The default action for '*' is WARN.
|
||||
|
||||
=cut
|
||||
|
||||
sub handler {
|
||||
my $self = shift;
|
||||
|
||||
### Copy the hash, and edit it:
|
||||
while (@_) {
|
||||
my $c = shift;
|
||||
my $sub = shift;
|
||||
$self->{MWD_Map}{$c} = $self->real_handler($sub);
|
||||
}
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item decode STRING
|
||||
|
||||
I<Instance method.>
|
||||
Decode a STRING which might contain MIME-encoded components into a
|
||||
local representation (e.g., UTF-8, etc.).
|
||||
|
||||
=cut
|
||||
|
||||
sub decode {
|
||||
my ($self, $str) = @_;
|
||||
defined($str) or return undef;
|
||||
join('', map {
|
||||
### Get the data and (upcased) charset:
|
||||
my $data = $_->[0];
|
||||
my $charset = (defined($_->[1]) ? uc($_->[1]) : 'raw');
|
||||
$charset =~ s/\*\w+\Z//; ### RFC2184 language suffix
|
||||
|
||||
### Get the handler; guess if never seen before:
|
||||
defined($self->{MWD_Map}{$charset}) or
|
||||
$self->{MWD_Map}{$charset} =
|
||||
($self->real_handler($self->guess_handler($charset)) || 0);
|
||||
my $subr = $self->{MWD_Map}{$charset} || $self->{MWD_Map}{'*'};
|
||||
|
||||
### Map this chunk:
|
||||
&$subr($data, $charset, $self);
|
||||
} decode_mimewords($str));
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# guess_handler CHARSET
|
||||
#
|
||||
# Instance method.
|
||||
# An unrecognized charset has been seen. Guess a handler subref
|
||||
# for the given charset, returning false if there is none.
|
||||
# Successful mappings will be cached in the main map.
|
||||
#
|
||||
sub guess_handler {
|
||||
undef;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# real_handler HANDLER
|
||||
#
|
||||
# Instance method.
|
||||
# Translate the given handler, which might be a subref or a string.
|
||||
#
|
||||
sub real_handler {
|
||||
my ($self, $sub) = @_;
|
||||
(!$sub) or
|
||||
(ref($sub) eq 'CODE') or
|
||||
$sub = ($Handler{$sub} || croak "bad named handler: $sub\n");
|
||||
$sub;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item unmime STRING
|
||||
|
||||
I<Function, exported.>
|
||||
Decode the given STRING using the default() decoder.
|
||||
See L<default()|/default>.
|
||||
|
||||
You should consider using the UTF-8 decoder instead. It decodes
|
||||
MIME strings into Perl's internal string format.
|
||||
|
||||
=cut
|
||||
|
||||
sub unmime($) {
|
||||
my $str = shift;
|
||||
$Default->decode($str);
|
||||
}
|
||||
|
||||
=item mime_to_perl_string
|
||||
|
||||
I<Function, exported.>
|
||||
Decode the given STRING into an internal Perl Unicode string.
|
||||
You should use this function in preference to all others.
|
||||
|
||||
The result of mime_to_perl_string is likely to have Perl's
|
||||
UTF8 flag set.
|
||||
|
||||
=cut
|
||||
|
||||
sub mime_to_perl_string($) {
|
||||
my $str = shift;
|
||||
$DecoderFor{'UTF-8'}->decode($str);
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
=head1 SUBCLASSES
|
||||
|
||||
=over
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------------------------------------
|
||||
#------------------------------------------------------------
|
||||
|
||||
=item MIME::WordDecoder::ISO_8859
|
||||
|
||||
A simple decoder which keeps US-ASCII and the 7-bit characters
|
||||
of ISO-8859 character sets and UTF8, and also keeps 8-bit
|
||||
characters from the indicated character set.
|
||||
|
||||
### Construct:
|
||||
$wd = new MIME::WordDecoder::ISO_8859 2; ### ISO-8859-2
|
||||
|
||||
### What to translate unknown characters to (can also use empty):
|
||||
### Default is "?".
|
||||
$wd->unknown("?");
|
||||
|
||||
### Collapse runs of unknown characters to a single unknown()?
|
||||
### Default is false.
|
||||
$wd->collapse(1);
|
||||
|
||||
|
||||
According to B<http://czyborra.com/charsets/iso8859.html>
|
||||
(ca. November 2000):
|
||||
|
||||
ISO 8859 is a full series of 10 (and soon even more) standardized
|
||||
multilingual single-byte coded (8bit) graphic character sets for
|
||||
writing in alphabetic languages:
|
||||
|
||||
1. Latin1 (West European)
|
||||
2. Latin2 (East European)
|
||||
3. Latin3 (South European)
|
||||
4. Latin4 (North European)
|
||||
5. Cyrillic
|
||||
6. Arabic
|
||||
7. Greek
|
||||
8. Hebrew
|
||||
9. Latin5 (Turkish)
|
||||
10. Latin6 (Nordic)
|
||||
|
||||
The ISO 8859 charsets are not even remotely as complete as the truly
|
||||
great Unicode but they have been around and usable for quite a while
|
||||
(first registered Internet charsets for use with MIME) and have
|
||||
already offered a major improvement over the plain 7bit US-ASCII.
|
||||
|
||||
Characters 0 to 127 are always identical with US-ASCII and the
|
||||
positions 128 to 159 hold some less used control characters: the
|
||||
so-called C1 set from ISO 6429.
|
||||
|
||||
=cut
|
||||
|
||||
package MIME::WordDecoder::ISO_8859;
|
||||
|
||||
use strict;
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw( MIME::WordDecoder );
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# HANDLERS
|
||||
#
|
||||
#------------------------------
|
||||
|
||||
### Keep 7bit characters.
|
||||
### Turn all else to the special \x00.
|
||||
sub h_keep7bit {
|
||||
local $_ = $_[0];
|
||||
# my $unknown = $_[2]->{MWDI_Unknown};
|
||||
|
||||
s{[\x80-\xFF]}{\x00}g;
|
||||
$_;
|
||||
}
|
||||
|
||||
### Note: should use Unicode::String, converting/manipulating
|
||||
### everything into full Unicode form.
|
||||
|
||||
### Keep 7bit UTF8 characters (ASCII).
|
||||
### Keep ISO-8859-1 if this decoder is for Latin-1.
|
||||
### Turn all else to the special \x00.
|
||||
sub h_utf8 {
|
||||
local $_ = $_[0];
|
||||
# my $unknown = $_[2]->{MWDI_Unknown};
|
||||
my $latin1 = ($_[2]->{MWDI_Num} == 1);
|
||||
#print STDERR "UTF8 in: <$_>\n";
|
||||
|
||||
local($1,$2,$3);
|
||||
my $tgt = '';
|
||||
while (m{\G(
|
||||
([\x00-\x7F]) | # 0xxxxxxx
|
||||
([\xC0-\xDF] [\x80-\xBF]) | # 110yyyyy 10xxxxxx
|
||||
([\xE0-\xEF] [\x80-\xBF]{2}) | # 1110zzzz 10yyyyyy 10xxxxxx
|
||||
([\xF0-\xF7] [\x80-\xBF]{3}) | # 11110uuu 10uuzzzz 10yyyyyy 10xxxxxx
|
||||
. # error; synch
|
||||
)}gcsx and ($1 ne '')) {
|
||||
|
||||
if (defined($2)) { $tgt .= $2 }
|
||||
elsif (defined($3) && $latin1) { $tgt .= "\x00" }
|
||||
else { $tgt .= "\x00" }
|
||||
}
|
||||
|
||||
#print STDERR "UTF8 out: <$tgt>\n";
|
||||
$tgt;
|
||||
}
|
||||
|
||||
### Keep characters which are 7bit in UTF8 (ASCII).
|
||||
### Keep ISO-8859-1 if this decoder is for Latin-1.
|
||||
### Turn all else to the special \x00.
|
||||
sub h_utf16 {
|
||||
local $_ = $_[0];
|
||||
# my $unknown = $_[2]->{MWDI_Unknown};
|
||||
my $latin1 = ($_[2]->{MWDI_Num} == 1);
|
||||
#print STDERR "UTF16 in: <$_>\n";
|
||||
|
||||
local($1,$2,$3,$4,$5);
|
||||
my $tgt = '';
|
||||
while (m{\G(
|
||||
( \x00 ([\x00-\x7F])) | # 00000000 0xxxxxxx
|
||||
( \x00 ([\x80-\xFF])) | # 00000000 1xxxxxxx
|
||||
( [^\x00] [\x00-\xFF]) | # etc
|
||||
)
|
||||
}gcsx and ($1 ne '')) {
|
||||
|
||||
if (defined($2)) { $tgt .= $3 }
|
||||
elsif (defined($4) && $latin1) { $tgt .= $5 }
|
||||
else { $tgt .= "\x00" }
|
||||
}
|
||||
|
||||
#print STDERR "UTF16 out: <$tgt>\n";
|
||||
$tgt;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# PUBLIC INTERFACE
|
||||
#
|
||||
#------------------------------
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# new NUMBER
|
||||
#
|
||||
sub new {
|
||||
my ($class, $num) = @_;
|
||||
|
||||
my $self = $class->SUPER::new();
|
||||
$self->handler('raw' => 'KEEP',
|
||||
'US-ASCII' => 'KEEP');
|
||||
|
||||
$self->{MWDI_Num} = $num;
|
||||
$self->{MWDI_Unknown} = "?";
|
||||
$self->{MWDI_Collapse} = 0;
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# guess_handler CHARSET
|
||||
#
|
||||
sub guess_handler {
|
||||
my ($self, $charset) = @_;
|
||||
return 'KEEP' if (($charset =~ /^ISO[-_]?8859[-_](\d+)$/) &&
|
||||
($1 eq $self->{MWDI_Num}));
|
||||
return \&h_keep7bit if ($charset =~ /^ISO[-_]?8859/);
|
||||
return \&h_utf8 if ($charset =~ /^UTF[-_]?8$/);
|
||||
return \&h_utf16 if ($charset =~ /^UTF[-_]?16$/);
|
||||
undef;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# unknown [REPLACEMENT]
|
||||
#
|
||||
sub unknown {
|
||||
my $self = shift;
|
||||
$self->{MWDI_Unknown} = shift if @_;
|
||||
$self->{MWDI_Unknown};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# collapse [YESNO]
|
||||
#
|
||||
sub collapse {
|
||||
my $self = shift;
|
||||
$self->{MWDI_Collapse} = shift if @_;
|
||||
$self->{MWDI_Collapse};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# decode STRING
|
||||
#
|
||||
sub decode {
|
||||
my $self = shift;
|
||||
|
||||
### Do inherited action:
|
||||
my $basic = $self->SUPER::decode(@_);
|
||||
defined($basic) or return undef;
|
||||
|
||||
### Translate/consolidate illegal characters:
|
||||
$basic =~ tr{\x00}{\x00}c if $self->{MWDI_Collapse};
|
||||
$basic =~ s{\x00}{$self->{MWDI_Unknown}}g;
|
||||
$basic;
|
||||
}
|
||||
|
||||
#------------------------------------------------------------
|
||||
#------------------------------------------------------------
|
||||
|
||||
=item MIME::WordDecoder::US_ASCII
|
||||
|
||||
A subclass of the ISO-8859-1 decoder which discards 8-bit characters.
|
||||
You're probably better off using ISO-8859-1.
|
||||
|
||||
=cut
|
||||
|
||||
package MIME::WordDecoder::US_ASCII;
|
||||
|
||||
use strict;
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw( MIME::WordDecoder::ISO_8859 );
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
return $class->SUPER::new("1");
|
||||
}
|
||||
|
||||
sub decode {
|
||||
my $self = shift;
|
||||
|
||||
### Do inherited action:
|
||||
my $basic = $self->SUPER::decode(@_);
|
||||
defined($basic) or return undef;
|
||||
|
||||
### Translate/consolidate 8-bit characters:
|
||||
$basic =~ tr{\x80-\xFF}{}c if $self->{MWDI_Collapse};
|
||||
$basic =~ s{[\x80-\xFF]}{$self->{MWDI_Unknown}}g;
|
||||
$basic;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
package MIME::WordDecoder::UTF_8;
|
||||
use strict;
|
||||
use Encode qw();
|
||||
use Carp qw( carp );
|
||||
use vars qw(@ISA);
|
||||
|
||||
@ISA = qw( MIME::WordDecoder );
|
||||
|
||||
sub h_convert_to_utf8
|
||||
{
|
||||
my ($data, $charset, $decoder) = @_;
|
||||
$charset = 'US-ASCII' if ($charset eq 'raw');
|
||||
my $enc = Encode::find_encoding($charset);
|
||||
if (!$enc) {
|
||||
carp "Unable to convert text in character set `$charset' to UTF-8... ignoring\n";
|
||||
return '';
|
||||
}
|
||||
my $ans = $enc->decode($data, Encode::FB_PERLQQ);
|
||||
return $ans;
|
||||
}
|
||||
|
||||
sub new {
|
||||
my ($class) = @_;
|
||||
my $self = $class->SUPER::new();
|
||||
$self->handler('*' => \&h_convert_to_utf8);
|
||||
}
|
||||
|
||||
|
||||
#------------------------------------------------------------
|
||||
#------------------------------------------------------------
|
||||
|
||||
package MIME::WordDecoder;
|
||||
|
||||
### Now we can init the default handler.
|
||||
$Default = (MIME::WordDecoder::ISO_8859->new('1'));
|
||||
|
||||
|
||||
### Add US-ASCII handler:
|
||||
$DecoderFor{"US-ASCII"} = MIME::WordDecoder::US_ASCII->new;
|
||||
|
||||
### Add ISO-8859-{1..15} handlers:
|
||||
for (1..15) {
|
||||
$DecoderFor{"ISO-8859-$_"} = MIME::WordDecoder::ISO_8859->new($_);
|
||||
}
|
||||
|
||||
### UTF-8
|
||||
$DecoderFor{'UTF-8'} = MIME::WordDecoder::UTF_8->new();
|
||||
|
||||
1; # end the module
|
||||
__END__
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Tools>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
Dianne Skoll (dfs@roaringpenguin.com) http://www.roaringpenguin.com
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
BEGIN { unshift @INC, ".", "./etc", "./lib" };
|
||||
import MIME::WordDecoder;
|
||||
|
||||
### Decode a MIME string (e.g., into Latin1) via the default decoder:
|
||||
my $charset = $ARGV[0] || 'ISO-8859-1';
|
||||
my $wd = MIME::WordDecoder->supported($charset) || die "unsupported charset: $charset\n";
|
||||
|
||||
$wd->unknown('#');
|
||||
my @encs = (
|
||||
'ASCII: =?US-ASCII?Q?Keith_Moore?= <moore@cs.utk.edu>',
|
||||
'Latin1: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk>',
|
||||
'Latin1: =?ISO-8859-1?Q?Andr=E9_?= Pirard <PIRARD@vm1.ulg.ac.be>',
|
||||
'Latin1: =?ISO-8859-1?Q?Andr=E9_?=Pirard <PIRARD@vm1.ulg.ac.be>',
|
||||
' UTF-8: =?UTF-8?Q?Andr=E9_?=Pirard <PIRARD@vm1.ulg.ac.be>',
|
||||
'UTF-16: =?UTF-16?Q?=00A=00n=00d=00r=00=E9?= Pirard <PIRARD@vm1.ulg.ac.be>',
|
||||
('=?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?='.
|
||||
'=?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?='.
|
||||
'=?US-ASCII?Q?.._cool!?='));
|
||||
$str = $wd->decode(join "\n", @encs);
|
||||
print "$str\n";
|
||||
1;
|
353
Git/usr/share/perl5/vendor_perl/MIME/Words.pm
Normal file
353
Git/usr/share/perl5/vendor_perl/MIME/Words.pm
Normal file
@ -0,0 +1,353 @@
|
||||
package MIME::Words;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
MIME::Words - deal with RFC 2047 encoded words
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Before reading further, you should see L<MIME::Tools> to make sure that
|
||||
you understand where this module fits into the grand scheme of things.
|
||||
Go on, do it now. I'll wait.
|
||||
|
||||
Ready? Ok...
|
||||
|
||||
|
||||
use MIME::Words qw(:all);
|
||||
|
||||
### Decode the string into another string, forgetting the charsets:
|
||||
$decoded = decode_mimewords(
|
||||
'To: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk>',
|
||||
);
|
||||
|
||||
### Split string into array of decoded [DATA,CHARSET] pairs:
|
||||
@decoded = decode_mimewords(
|
||||
'To: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk>',
|
||||
);
|
||||
|
||||
### Encode a single unsafe word:
|
||||
$encoded = encode_mimeword("\xABFran\xE7ois\xBB");
|
||||
|
||||
### Encode a string, trying to find the unsafe words inside it:
|
||||
$encoded = encode_mimewords("Me and \xABFran\xE7ois\xBB in town");
|
||||
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Fellow Americans, you probably won't know what the hell this module
|
||||
is for. Europeans, Russians, et al, you probably do. C<:-)>.
|
||||
|
||||
For example, here's a valid MIME header you might get:
|
||||
|
||||
From: =?US-ASCII?Q?Keith_Moore?= <moore@cs.utk.edu>
|
||||
To: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk>
|
||||
CC: =?ISO-8859-1?Q?Andr=E9_?= Pirard <PIRARD@vm1.ulg.ac.be>
|
||||
Subject: =?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?=
|
||||
=?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?=
|
||||
=?US-ASCII?Q?.._cool!?=
|
||||
|
||||
The fields basically decode to (sorry, I can only approximate the
|
||||
Latin characters with 7 bit sequences /o and 'e):
|
||||
|
||||
From: Keith Moore <moore@cs.utk.edu>
|
||||
To: Keld J/orn Simonsen <keld@dkuug.dk>
|
||||
CC: Andr'e Pirard <PIRARD@vm1.ulg.ac.be>
|
||||
Subject: If you can read this you understand the example... cool!
|
||||
|
||||
|
||||
=head1 PUBLIC INTERFACE
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
require 5.001;
|
||||
|
||||
### Pragmas:
|
||||
use strict;
|
||||
use re 'taint';
|
||||
use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @ISA);
|
||||
|
||||
### Exporting:
|
||||
use Exporter;
|
||||
%EXPORT_TAGS = (all => [qw(decode_mimewords
|
||||
encode_mimeword
|
||||
encode_mimewords
|
||||
)]);
|
||||
Exporter::export_ok_tags('all');
|
||||
|
||||
### Inheritance:
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
### Other modules:
|
||||
use MIME::Base64;
|
||||
use MIME::QuotedPrint;
|
||||
|
||||
|
||||
|
||||
#------------------------------
|
||||
#
|
||||
# Globals...
|
||||
#
|
||||
#------------------------------
|
||||
|
||||
### The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "5.509";
|
||||
|
||||
### Nonprintables (controls + x7F + 8bit):
|
||||
my $NONPRINT = "\\x00-\\x1F\\x7F-\\xFF";
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
# _decode_Q STRING
|
||||
# Private: used by _decode_header() to decode "Q" encoding, which is
|
||||
# almost, but not exactly, quoted-printable. :-P
|
||||
sub _decode_Q {
|
||||
my $str = shift;
|
||||
local $1;
|
||||
$str =~ s/_/\x20/g; # RFC-1522, Q rule 2
|
||||
$str =~ s/=([\da-fA-F]{2})/pack("C", hex($1))/ge; # RFC-1522, Q rule 1
|
||||
$str;
|
||||
}
|
||||
|
||||
# _encode_Q STRING
|
||||
# Private: used by _encode_header() to decode "Q" encoding, which is
|
||||
# almost, but not exactly, quoted-printable. :-P
|
||||
sub _encode_Q {
|
||||
my $str = shift;
|
||||
local $1;
|
||||
$str =~ s{([ _\?\=$NONPRINT])}{sprintf("=%02X", ord($1))}eog;
|
||||
$str;
|
||||
}
|
||||
|
||||
# _decode_B STRING
|
||||
# Private: used by _decode_header() to decode "B" encoding.
|
||||
sub _decode_B {
|
||||
my $str = shift;
|
||||
decode_base64($str);
|
||||
}
|
||||
|
||||
# _encode_B STRING
|
||||
# Private: used by _decode_header() to decode "B" encoding.
|
||||
sub _encode_B {
|
||||
my $str = shift;
|
||||
encode_base64($str, '');
|
||||
}
|
||||
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item decode_mimewords ENCODED
|
||||
|
||||
I<Function.>
|
||||
Go through the string looking for RFC 2047-style "Q"
|
||||
(quoted-printable, sort of) or "B" (base64) encoding, and decode them.
|
||||
|
||||
B<In an array context,> splits the ENCODED string into a list of decoded
|
||||
C<[DATA, CHARSET]> pairs, and returns that list. Unencoded
|
||||
data are returned in a 1-element array C<[DATA]>, giving an effective
|
||||
CHARSET of C<undef>.
|
||||
|
||||
$enc = '=?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk>';
|
||||
foreach (decode_mimewords($enc)) {
|
||||
print "", ($_->[1] || 'US-ASCII'), ": ", $_->[0], "\n";
|
||||
}
|
||||
|
||||
B<In a scalar context,> joins the "data" elements of the above
|
||||
list together, and returns that. I<Warning: this is information-lossy,>
|
||||
and probably I<not> what you want, but if you know that all charsets
|
||||
in the ENCODED string are identical, it might be useful to you.
|
||||
(Before you use this, please see L<MIME::WordDecoder/unmime>,
|
||||
which is probably what you want.)
|
||||
|
||||
In the event of a syntax error, $@ will be set to a description
|
||||
of the error, but parsing will continue as best as possible (so as to
|
||||
get I<something> back when decoding headers).
|
||||
$@ will be false if no error was detected.
|
||||
|
||||
Any arguments past the ENCODED string are taken to define a hash of options:
|
||||
|
||||
=cut
|
||||
|
||||
sub decode_mimewords {
|
||||
my $encstr = shift;
|
||||
my @tokens;
|
||||
local($1,$2,$3);
|
||||
$@ = ''; ### error-return
|
||||
|
||||
### Collapse boundaries between adjacent encoded words:
|
||||
$encstr =~ s{(\?\=)\s*(\=\?)}{$1$2}gs;
|
||||
pos($encstr) = 0;
|
||||
### print STDOUT "ENC = [", $encstr, "]\n";
|
||||
|
||||
### Decode:
|
||||
my ($charset, $encoding, $enc, $dec);
|
||||
while (1) {
|
||||
last if (pos($encstr) >= length($encstr));
|
||||
my $pos = pos($encstr); ### save it
|
||||
|
||||
### Case 1: are we looking at "=?..?..?="?
|
||||
if ($encstr =~ m{\G # from where we left off..
|
||||
=\?([^?]*) # "=?" + charset +
|
||||
\?([bq]) # "?" + encoding +
|
||||
\?([^?]+) # "?" + data maybe with spcs +
|
||||
\?= # "?="
|
||||
}xgi) {
|
||||
($charset, $encoding, $enc) = ($1, lc($2), $3);
|
||||
$dec = (($encoding eq 'q') ? _decode_Q($enc) : _decode_B($enc));
|
||||
push @tokens, [$dec, $charset];
|
||||
next;
|
||||
}
|
||||
|
||||
### Case 2: are we looking at a bad "=?..." prefix?
|
||||
### We need this to detect problems for case 3, which stops at "=?":
|
||||
pos($encstr) = $pos; # reset the pointer.
|
||||
if ($encstr =~ m{\G=\?}xg) {
|
||||
$@ .= qq|unterminated "=?..?..?=" in "$encstr" (pos $pos)\n|;
|
||||
push @tokens, ['=?'];
|
||||
next;
|
||||
}
|
||||
|
||||
### Case 3: are we looking at ordinary text?
|
||||
pos($encstr) = $pos; # reset the pointer.
|
||||
if ($encstr =~ m{\G # from where we left off...
|
||||
(.*? # shortest possible string,
|
||||
\n*) # followed by 0 or more NLs,
|
||||
(?=(\Z|=\?)) # terminated by "=?" or EOS
|
||||
}sxg) {
|
||||
length($1) or die "MIME::Words: internal logic err: empty token\n";
|
||||
push @tokens, [$1];
|
||||
next;
|
||||
}
|
||||
|
||||
### Case 4: bug!
|
||||
die "MIME::Words: unexpected case:\n($encstr) pos $pos\n\t".
|
||||
"Please alert developer.\n";
|
||||
}
|
||||
return (wantarray ? @tokens : join('',map {$_->[0]} @tokens));
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item encode_mimeword RAW, [ENCODING], [CHARSET]
|
||||
|
||||
I<Function.>
|
||||
Encode a single RAW "word" that has unsafe characters.
|
||||
The "word" will be encoded in its entirety.
|
||||
|
||||
### Encode "<<Franc,ois>>":
|
||||
$encoded = encode_mimeword("\xABFran\xE7ois\xBB");
|
||||
|
||||
You may specify the ENCODING (C<"Q"> or C<"B">), which defaults to C<"Q">.
|
||||
You may specify the CHARSET, which defaults to C<iso-8859-1>.
|
||||
|
||||
=cut
|
||||
|
||||
sub encode_mimeword {
|
||||
my $word = shift;
|
||||
my $encoding = uc(shift || 'Q');
|
||||
my $charset = uc(shift || 'ISO-8859-1');
|
||||
my $encfunc = (($encoding eq 'Q') ? \&_encode_Q : \&_encode_B);
|
||||
"=?$charset?$encoding?" . &$encfunc($word) . "?=";
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item encode_mimewords RAW, [OPTS]
|
||||
|
||||
I<Function.>
|
||||
Given a RAW string, try to find and encode all "unsafe" sequences
|
||||
of characters:
|
||||
|
||||
### Encode a string with some unsafe "words":
|
||||
$encoded = encode_mimewords("Me and \xABFran\xE7ois\xBB");
|
||||
|
||||
Returns the encoded string.
|
||||
Any arguments past the RAW string are taken to define a hash of options:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Charset
|
||||
|
||||
Encode all unsafe stuff with this charset. Default is 'ISO-8859-1',
|
||||
a.k.a. "Latin-1".
|
||||
|
||||
=item Encoding
|
||||
|
||||
The encoding to use, C<"q"> or C<"b">. The default is C<"q">.
|
||||
|
||||
=back
|
||||
|
||||
B<Warning:> this is a quick-and-dirty solution, intended for character
|
||||
sets which overlap ASCII. B<It does not comply with the RFC 2047
|
||||
rules regarding the use of encoded words in message headers>.
|
||||
You may want to roll your own variant,
|
||||
using C<encode_mimeword()>, for your application.
|
||||
I<Thanks to Jan Kasprzak for reminding me about this problem.>
|
||||
|
||||
=cut
|
||||
|
||||
sub encode_mimewords {
|
||||
my ($rawstr, %params) = @_;
|
||||
my $charset = $params{Charset} || 'ISO-8859-1';
|
||||
my $encoding = lc($params{Encoding} || 'q');
|
||||
|
||||
### Encode any "words" with unsafe characters.
|
||||
### We limit such words to 18 characters, to guarantee that the
|
||||
### worst-case encoding give us no more than 54 + ~10 < 75 characters
|
||||
my $word;
|
||||
local $1;
|
||||
$rawstr =~ s{([a-zA-Z0-9\x7F-\xFF]+\s*)}{ ### get next "word"
|
||||
$word = $1;
|
||||
(($word !~ /(?:[$NONPRINT])|(?:^\s+$)/o)
|
||||
? $word ### no unsafe chars
|
||||
: encode_mimeword($word, $encoding, $charset)); ### has unsafe chars
|
||||
}xeg;
|
||||
$rawstr =~ s/\?==\?/?= =?/g;
|
||||
$rawstr;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<MIME::Base64>, L<MIME::QuotedPrint>, L<MIME::Tools>
|
||||
|
||||
For other implementations of this or similar functionality (particularly, ones
|
||||
with proper UTF8 support), see:
|
||||
|
||||
L<Encode::MIME::Header>, L<MIME::EncWords>, L<MIME::AltWords>
|
||||
|
||||
At some future point, one of these implementations will likely replace
|
||||
MIME::Words and MIME::Words will become deprecated.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
Exports its principle functions by default, in keeping with
|
||||
MIME::Base64 and MIME::QuotedPrint.
|
||||
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Eryq (F<eryq@zeegee.com>), ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
Dianne Skoll (dfs@roaringpenguin.com) http://www.roaringpenguin.com
|
||||
|
||||
All rights reserved. This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
Thanks also to...
|
||||
|
||||
Kent Boortz For providing the idea, and the baseline
|
||||
RFC-1522-decoding code!
|
||||
KJJ at PrimeNet For requesting that this be split into
|
||||
its own module.
|
||||
Stephane Barizien For reporting a nasty bug.
|
||||
|
Reference in New Issue
Block a user