File Coverage

blib/lib/Mail/MboxParser/Mail/Body.pm

Criterion	Covered	Total	%
statement	53	130	40.7
branch	13	52	25.0
condition	8	26	30.7
subroutine	10	18	55.5
pod	5	6	83.3
total	89	232	38.3

# Mail::MboxParser - object-oriented access to UNIX-mailboxes
# Body.pm		   - the (textual) body of an email
#
# Copyright (C) 2001  Tassilo v. Parseval
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

# Version: $Id: Body.pm,v 1.14 2002/02/21 09:06:14 parkerpine Exp $

package Mail::MboxParser::Mail::Body;

require 5.004;

use Carp;

use strict;
use base qw(Exporter);
use vars qw($VERSION @EXPORT @ISA $AUTOLOAD $_HAVE_NOT_URI_FIND);
$VERSION 	= "0.15";
@EXPORT  	= qw();
@ISA	 	= qw(Mail::MboxParser::Base Mail::MboxParser::Mail);

use overload '""' => sub { shift->as_string }, fallback => 1;

BEGIN {
    eval { require URI::Find; };
    if ($@) {
	$_HAVE_NOT_URI_FIND = 1;
    }
}

sub init(@) {
    my ($self, $ent, $bound, $conf) = @_;
    $self->{CONTENT}	= $ent->body;
    $self->{BOUNDARY}	= $bound;	     # the one in Content-type
    $self->{ARGS}	= $conf;

    $self->{ARGS}->{decode} ||= 'NEVER';

    $self->_make_decoder($ent->head->mime_encoding)
	if $self->{ARGS}->{decode} =~ /BODY|ALL/;;
    $self;
}

sub _make_decoder {
    my ($self, $enc) = @_;
    if ($enc eq 'base64') {
	require MIME::Base64;
	return $self->{DECODER} = sub { MIME::Base64::decode_base64(shift) };
    }
    if ($enc eq 'quoted-printable') {
	require MIME::QuotedPrint;
	return $self->{DECODER} = sub { MIME::QuotedPrint::decode_qp(shift) };
    }
    $self->{DECODER} = sub { $_[0] };
}

sub as_string {
    my ($self, %args) = @_;
    $self->reset_last;
    return join "", $self->as_lines(strip_sig => 1) if $args{strip_sig};
    my $decode = $self->{ARGS}->{decode};
    if ($decode eq 'BODY' || $decode eq 'ALL') {
	return join "", map { $self->{DECODER}->($_) } @{$self->{CONTENT}};
    }
    return join "", @{$self->{CONTENT}};
}


sub as_lines() {
    my ($self, %args) = @_;
    $self->reset_last;
    my $decode = $self->{ARGS}->{decode};
    if ($decode eq 'BODY' || $decode eq 'ALL') {
	return map { $self->{DECODER}->($_) } @{$self->{CONTENT}};
    }

    return @{$self->{CONTENT}} if ! $args{strip_sig};

    my @lines;
    for (@{ $self->{CONTENT} }) {
	last if /^--\040?[\r\n]?$/;
	push @lines, $_;
    }
    return @lines;
}


sub signature() {
    my $self = shift;
    $self->reset_last;
    my $decode = $self->{ARGS}->{decode};
    my $bound = $self->{BOUNDARY};

    my @signature;
    my $seperator = 0;
    for (@{$self->{CONTENT}}) {

	# we are still outside the signature
	if (! /^--\040?[\r\n]?$/ && not $seperator) {
	    next;
	}

	# we hit the signature delimiter (--)
	elsif (not $seperator) { $seperator = 1; next }

	chomp;

	# we are inside signature: is line perhaps MIME-boundary?
	last if $bound && /^--\Q$bound\E/ && $seperator;

	# none of the above => signature line
	push @signature, $_;
    }

    $self->{LAST_ERR} = "No signature found" if !@signature;
    if ($decode eq 'BODY' || $decode eq 'ALL') {
	$_ = $self->{DECODER}->($_) for @signature;
    }
    return @signature if $seperator;
    return ();
}

sub extract_urls(@) {
    my ($self, %args) = @_;
    $self->reset_last;

    $args{unique} = 0 if not exists $args{unique};

    if ($_HAVE_NOT_URI_FIND) {
	carp <
You need the URI::Find module in order to use extract_urls.
EOW
	return;
    }
    else {
	my @uris; my %seen;

	for my $line (@{$self->{CONTENT}}) {
	    chomp $line;
	    URI::Find::find_uris($line, sub {
		    my (undef, $url) = @_;
		    $line =~ s/^\s+|\s+$//;
		    if (not $seen{$url}) {
			push @uris, { url => $url, context => $line };
		    }
		    $seen{$url}++ if $args{unique};
		}
	    );
	}
	$self->{LAST_ERR} = "No URLs found" if @uris == 0;

	return @uris;
    }
}

sub quotes() {
    my $self = shift;
    my $decode = $self->{ARGS}->{decode};
    $self->reset_last;

    my %ret;
    my $q 		= 0; # num of '>'
    my $in 		= 0; # being inside a quote
    my $last 	= 0; # num of quotes in last line

    for (@{$self->{CONTENT}}) {

	if ($decode eq 'ALL' || $decode eq 'BODY') {
	    $_ = $self->{DECODER}->($_);
	}

	# count quotation signs
	$q = 0;
	my $t = "a" x length;
	for my $c (unpack $t, $_) {
	    if ($c eq '>') 		{ $q++ }
	    if ($c ne '>' && $c ne ' ') { last }
	}

	# first: create a hash-element for level $q
	if (! exists $ret{$q}) {
	    $ret{$q} = [];
	}

	# if last line had the same level as current one:
	# attach the line to the last one
	if ($last == $q) {
	    if (@{$ret{$q}} == 0)   { $ret{$q}->[$q] .= $_ }
	    else		    { $ret{$q}->[-1] .= $_ }
	}
	# if not:
	# create a new array-element in the appropriate hash-element
	else {
	    push @{$ret{$q}}, $_;
	}
	$last = $q;
    }
    return \%ret;
}


1;

__END__