File Coverage

blib/lib/MIME/Signature.pm

Criterion	Covered	Total	%
statement	14	138	10.1
branch	0	68	0.0
condition	0	23	0.0
subroutine	5	34	14.7
pod	22	22	100.0
total	41	285	14.3

package MIME::Signature;

use 5.014;
use warnings;

our $VERSION = '0.15';

use Carp qw(croak);
use Encode qw(decode encode encode_utf8);
use MIME::Parser;

sub _decoded_body {
    my $entity = shift;
    my $body   = $entity->bodyhandle->as_string;
    if ( my $charset = $entity->head->mime_attr('content-type.charset') ) {
        $body = decode $charset, $body;
    }
    $body;
}

sub _replace_body {
    my ( $entity, $body ) = @_;
    $body .= "\n" if $body !~ /\n\z/;
    my $encoded_body;
    {
        my $encoding_ok;
        if ( my $charset = $entity->head->mime_attr('content-type.charset') ) {
            $encoding_ok = 1;
            $encoded_body = encode $charset, $body,
              sub { undef $encoding_ok; '' };
        }
        unless ($encoding_ok) {
            my $head = $entity->head;
            $head->mime_attr( 'Content-Type', 'text/plain' )
              unless $head->mime_attr('content-type');
            $head->mime_attr( 'content-type.charset' => 'UTF-8' );
            $encoded_body = encode_utf8($body);
        }
    }
    my $fh = $entity->bodyhandle->open('w') or die "Open body: $!\n";

    # Avoid "SMTP cannot transfer messages with partial final lines. (#5.6.2)":
    $fh->print($encoded_body);

    $fh->close or die "Cannot replace body: $!\n";
}

sub enriched {
    my $self = shift;
    if (@_) {
        $self->{enriched} = shift;
    }
    elsif ( defined wantarray ) {
        if ( !defined $self->{enriched} && defined( my $plain = $self->plain ) )
        {
            $self->{enriched} = $plain =~ s/
        }
        $self->{enriched};
    }
}

sub enriched_delimiter {
    my $self = shift;
    $self->{enriched_delimiter} = shift if @_;
    $self->{enriched_delimiter};
}

sub html {
    my $self = shift;
    if (@_) {
        $self->{html} = shift;
    }
    elsif ( defined wantarray ) {
        if ( !defined $self->{html} && defined( my $plain = $self->plain ) ) {
            require HTML::Entities
              and HTML::Entities->import('encode_entities')
              unless defined &encode_entities;
            $self->{html} =
              join( '', split /\n/, encode_entities($plain) ) . "\n";
        }
        $self->{html};
    }
}

sub html_delimiter {
    my $self = shift;
    $self->{html_delimiter} = shift if @_;
    $self->{html_delimiter};
}

sub plain {
    my $self = shift;
    $self->{plain} = shift if @_;
    $self->{plain};
}

sub plain_delimiter {
    my $self = shift;
    $self->{plain_delimiter} = shift if @_;
    $self->{plain_delimiter};
}

sub unsign {
    my $self = shift;
    $self->{unsign} = shift if @_;
    $self->{unsign};
}

sub _signature {
    my ( $self, $type ) = @_;
    defined( my $signature = $self->$type ) or return;
    my $delimiter_method = $type . '_delimiter';
    $self->$delimiter_method . $signature;
}

sub handler_multipart_alternative {    # add trailer to all parts
    my ( $self, $entity ) = @_;
    $self->append($_) for my @parts = $entity->parts;
    @parts;
}

sub handler_multipart_mixed {          # append trailer as separate part
    my ( $self, $entity ) = @_;
    require Encode and Encode->import('encode_utf8')
      unless defined &encode_utf8;
    $entity->add_part(
        my $e = MIME::Entity->build(
            Top      => 0,
            Charset  => 'UTF-8',
            Encoding => '-SUGGEST',
            Type     => grep( lc $_->mime_type eq 'text/html', $entity->parts )
            ? ( 'text/html', Data => encode_utf8( $self->_signature('html') ) )
            : grep( lc $_->mime_type eq 'text/enriched', $entity->parts )
            ? (
                'text/enriched',
                Data => encode_utf8( $self->_signature('enriched') )
              )
            : (
                'text/plain', Data => encode_utf8( $self->_signature('plain') )
            )
        )
    );
}

sub handler_multipart_related {    # add trailer to the first part
    my ( $self, $entity ) = @_;
    $self->append( ( $entity->parts )[0] );
}

sub handler_multipart_signed {
    my ( $self, $entity ) = @_;
    return unless $self->unsign;

    {                              # Inspired by MIME::Entity->make_singlepart:

        my ($part) = my @parts = $entity->parts;
        croak 'Invalid multipart/signed containing '
          . @parts . ' part'
          . ( @parts != 1 && 's' )
          if @parts != 2;

        # Get rid of all our existing content info:
        /^content-/i and $entity->head->delete($_) for $entity->head->tags;

        # Populate ourselves with any content info from the part:
        for my $tag ( grep /^content-/i, $part->head->tags ) {
            $entity->head->add( $tag, $_ ) for $part->head->get($tag);
        }

        # Save reconstructed header, replace our guts, and restore header:
        my $new_head = $entity->head;
        %$entity = %$part;    # shallow copy is ok!
        $entity->head($new_head);
    }

    $self->append($entity);
}

sub handler_text_enriched {    # append trailer
    my ( $self, $entity ) = @_;
    _replace_body( $entity,
        _decoded_body($entity) . $self->_signature('enriched') );
}

sub handler_text_html {        # append trailer to
    my ( $self, $entity ) = @_;
    my $body = _decoded_body($entity);
    require HTML::Parser;
    my $new_body;
    my $parser = HTML::Parser->new(
        end_h => [
            sub {
                my ( $text, $tagname ) = @_;
                $new_body .= $self->_signature('html') if lc $tagname eq 'body';
                $new_body .= $text;
            },
            'text,tagname'
        ],
        default_h => [ sub { $new_body .= shift }, 'text' ],
    );
    $parser->parse($body);
    _replace_body( $entity, $new_body );
}

sub handler_text_plain {    # append trailer
    my ( $self, $entity ) = @_;
    _replace_body( $entity,
        _decoded_body($entity) . $self->_signature('plain') );
}

sub new {
    my $package = shift;
    $package = ref $package if length ref $package;
    croak 'Invalid number of arguments to ->new' if @_ % 2;
    my $self = bless {
        enriched_delimiter => "\n\n-- \n",
        html_delimiter     => '',
        plain_delimiter    => "\n\n-- \n",
      },
      $package;
    while ( my $method = shift ) {
        $self->$method(shift);
    }
    $self;
}

sub entity {
    my $self = shift;
    $self->{entity} = shift if @_;
    $self->{entity};
}

sub parser {
    my $self = shift;
    if (@_) {
        $self->{parser} = shift;
    }
    elsif ( !$self->{parser} ) {
        for ( $self->{parser} ) {
            $_ = MIME::Parser->new;
            $_->tmp_to_core(1);
            $_->output_to_core(1);
        }
    }
    $self->{parser};
}

sub parse {
    my $self = shift;
    $self->{entity} = $self->parser->parse(@_);
}

sub parse_data {
    my $self = shift;
    $self->{entity} = $self->parser->parse_data(@_);
}

sub parse_open {
    my $self = shift;
    $self->{entity} = $self->parser->parse_open(@_);
}

sub parse_two {
    my $self = shift;
    $self->{entity} = $self->parser->parse_two(@_);
}

sub append {
    my $self = shift;
    my $entity = shift || $self->{entity}
      or croak( 'You must first hand in an e-mail message'
          . ' before trying to append a signature.' );
    ( my $handler_method =
          'handler_' . lc( my $mime_type = $entity->mime_type ) ) =~ y!/!_!;
    $self->can($handler_method) and $self->$handler_method($entity)
      or croak "Cannot handle $mime_type messages";
    $entity;
}

my $version_pod = <<'=cut';

=head1 NAME

MIME::Signature - appends signature to mail messages

=head1 VERSION

Version 0.15

=cut

# borrowed from tinita, see https://www.perlmonks.org/?node_id=562735
sub __test_version {
    my $v = __PACKAGE__->VERSION;
    return 1 if $version_pod =~ m/^Version \Q$v\E$/m;
    return;
}

__END__