decoded results from the CPAN

Courier-Filter

                my ($field, $value) = (lc($1), $2);
                try {
                    $value = MIME::Words::Better::decode($value, $self->fallback_8bit_char_encoding);
                };
                push(@{$header->{$field}}, $value);
            }
        }
        
        $self->{header} = $header;
        $self->{body} = $body_text;
    }
    
    return $self;
}

=item B<header>: returns I<hash-ref> of I<string>

=item B<header($field)>: returns I<list> of I<string>

Parses the message header once by doing the following: tries to interpret the
header as I<UTF-8>, falling back to the 8-bit legacy encoding I<Windows-1252>
(a superset of I<ISO-8859-1>) and decoding that to I<UTF-8>; parses header
fields from the header; and decodes any MIME encoded words in field values.  If
no field name is specified, returns a hash-ref containing all header fields and
array-refs of their values.  If a (case I<in>sensitive) field name is
specified, in list context returns a list of the values of all header fields of
that name, in the order they occurred in the message header, or in scalar
context returns the value of the first header field of that name (or B<undef>
if no such header field exists).

=cut

sub header {
    my ($self, @field) = @_;
    
    my $header = $self->parse()->{header};
    if (@field) {
        my $field_values = $header->{lc($field[0])} || [];
        return wantarray ? @$field_values : $field_values->[0];
    }
    else {
        return $header;
    }
}

=item B<body>: returns I<string>

Returns the raw message body as bytes (see L<bytes>, and L<PerlIO/"bytes">).

=cut

sub body {
    my ($self) = @_;
    return $self->parse()->{body};
}

=begin comment

=item B<subject>: returns I<string>

Returns the decoded value of the message's "Subject" header field.

=end comment

=cut

sub subject {
    my ($self) = @_;
    return $self->header('subject');
}

=back

=head3 Control properties

=over

=item B<control>: returns I<hash-ref> of I<string>; throws Perl exceptions

=item B<control($field)>: returns I<list> of I<string>; throws Perl exceptions

Reads and parses all of the message's control files once.  If a (case
sensitive) field name (i.e. record type) is specified, returns a list of the
values of all control fields of that name, in the order they occurred in the
control file(s).  If no field name is specified, returns a hash-ref containing
all control fields and array-refs of their values.  Throws a Perl exception if
any of the control files cannot be read.

=cut

sub control {
    my ($self, @field) = @_;
    
    my $control = $self->{control};
    
    if (not defined($control)) {
        # Read control files:
        foreach my $control_file_name (@{$self->{control_file_names}}) {
            my $control_file = IO::File->new($control_file_name);
            while (my $record = <$control_file>) {
                $record =~ /^(\w)(.*)$/;
                my ($field, $value) = ($1, $2);
                push(@{$control->{$field}}, $value);
            }
        }
        
        # Store control information:
        $self->{control} = $control;
    }
    
    if (@field) {
        my $field_values = $control->{$field[0]} || [];
        return wantarray ? @$field_values : $field_values->[0];
    }
    else {
        return $control;
    }
}

=begin comment

lib/Courier/Message.pm view on Meta::CPAN

sub remote_host_helo {
    my ($self) = @_;
    return $self->control_f('remote_host_helo');
}

=back

=head1 SEE ALSO

For AVAILABILITY, SUPPORT, and LICENSE information, see
L<Courier::Filter::Overview>.

=head1 AUTHOR

Julian Mehnle <julian@mehnle.net>

=cut


#
# MIME::Words replacement functions
#
# (C) 2004-2008 Julian Mehnle <julian@mehnle.net>
#
###############################################################################

package MIME::Words::Better;

use warnings;
use strict;

use base 'Exporter';

our @EXPORT = qw(decode_mimewords);

use Encode ();
use MIME::Base64 ();
use MIME::QuotedPrint ();

use Error ':try';

use constant TRUE   => (0 == 0);
use constant FALSE  => not TRUE;

use constant fallback_char_encoding => 'utf-8';

# MIME encoded words grammar (RFC 2047, section 2):
use constant encoded_word_pattern   => qr{
    =\? ([\w-]+) (?:\*([\w-]+))? \? ([\w]) \? ([^?]*?) \?=
    #   Charset     Language       Encoding    Chunk
}ox;

sub decode_mimewords {
    my ($text, $fallback_char_encoding) = @_;
    
    # Drop whitespace between two encoded words:
    $text =~ s/(${\encoded_word_pattern})\s+(${\encoded_word_pattern})/$1$6/;
    
    $text =~ s[(${\encoded_word_pattern})] {
        my ($encoded_word, $char_enc, $xfer_enc, $chunk) = ($1, $2, lc($4), $5);
        my $decoded_word;
        
        $char_enc =
            Encode::resolve_alias($char_enc) ||
            $fallback_char_encoding ||
            fallback_char_encoding;
        
        try {
            if ($xfer_enc eq 'b') {
                # Base 64!
                $chunk = MIME::Base64::decode($chunk);
            }
            elsif ($xfer_enc eq 'q') {
                # Quoted Printable!
                $chunk =~ tr/_/\x{20}/;
                $chunk = MIME::QuotedPrint::decode($chunk);
            }
            
            $decoded_word = Encode::decode($char_enc, $chunk);
        }
        otherwise {
            # The chunk contains invalid characters, leave the encoded word as is:
            $decoded_word = $encoded_word;
        };
        
        $decoded_word;
    }eg;
    
    return $text;
}

BEGIN {
    no warnings 'once';
    *decode = \&decode_mimewords;
}

TRUE;

( run in 1.391 second using v1.01-cache-2.11-cpan-59e3e3084b8 )