view release on metacpan or  search on metacpan

lib/Mail/GPG/Test.pm  view on Meta::CPAN

package Mail::GPG::Test;

# $Id: Test.pm,v 1.6 2006/11/18 08:48:28 joern Exp $

use strict;

use Mail::GPG;
use MIME::Entity;
use MIME::Parser;
use Data::Dumper;
use File::Path;

use File::Temp qw(tempdir);

my $TIMEIT = 0;

our $DUMPDIR;

BEGIN {
  $DUMPDIR  = $ENV{DUMPDIR} || './mail-gpg-test';

  if (not -d $DUMPDIR ) {
    File::Path::make_path($DUMPDIR) or die "Cannot create '$DUMPDIR' - $!";
  }
}



my $has_encode = eval { require Encode; 1 };

sub get_gpg_home_dir            { shift->{gpg_home_dir}                 }
sub get_use_long_key_ids        { shift->{use_long_key_ids}             }

sub set_gpg_home_dir            { shift->{gpg_home_dir}         = $_[1] }
sub set_use_long_key_ids        { shift->{use_long_key_ids}     = $_[1] }

#-- These methods return information about the shipped test key.
#-- The email adress has a German umlaut and colons
#-- to test the proper decoding of gpg --list-keys output.
sub get_key_id                  { $_[0]->get_use_long_key_ids ?
                                  '062F00DAE20F5035' : 'E20F5035' }
sub get_key_sub_id              { $_[0]->get_use_long_key_ids ?
                                  '6C187D0F196ED9E3' : '196ED9E3' }
sub get_key_mail                { 'Jörn Reder Mail::GPG Test Key <mailgpg@localdomain>' }
sub get_passphrase              { 'test' }

sub new {
    my $class = shift;
    my %par = @_;
    my ($use_long_key_ids) = $par{'use_long_key_ids'};

    my $gpg_home_dir = tempdir("mgpgXXXX");

    my $self = bless {
        gpg_home_dir     => $gpg_home_dir,
        use_long_key_ids => $use_long_key_ids,
    }, $class;

    return $self;
}

sub DESTROY {
    my $self = shift;

    #-- tempdir ( CLEANUP => 1 ) seem not to work if
    #-- an exception occured, so we use this destructor
    #-- to remove the gpg home dir on exit.
    rmtree( [ $self->get_gpg_home_dir ], 0, 0 );

    1;
}

sub init {
    my $self = shift;

    my $gpg_home_dir = $self->get_gpg_home_dir;

    my $command = "gpg --batch --no-tty --homedir $gpg_home_dir"
        . "    --import t/mgpg-test-key.pub.asc"
        . "    >/dev/null 2>&1 && "
        . "gpg --batch --no-tty --homedir $gpg_home_dir"
        . "    --allow-secret-key-import"
        . "    --import t/mgpg-test-key.sec.asc"
        . "    >/dev/null 2>&1 && echo MGPG_OK";

    my $output = qx[ $command ];

    return $output =~ /MGPG_OK/;
}

sub get_mail_gpg {
    my $self = shift;

    my $mg = Mail::GPG->new(
        debug              => $ENV{DUMPFILES},
        default_key_id     => $self->get_key_id,
        default_passphrase => $self->get_passphrase,
        use_long_key_ids   => $self->get_use_long_key_ids,
        gnupg_hash_init    => {
            homedir      => $self->get_gpg_home_dir,
            always_trust => 1,

        },
    );

    return $mg;
}

sub get_test_mail_body {
    "This is a test mail body,\n"
        . "with special characters: ÄÜÖß\n"
        . "and lines with whitespace   \n"
        . "and a cr/lf line ending\r\n" . "and\n"
        . "From at the beginning\n"
        . "Let's see what happens.\n";
}

sub print_parse_entity {
    my $self = shift;
    my %par = @_;
    my  ($entity, $modify) =
    @par{'entity','modify'};

    my ( $fh, $file ) = File::Temp::tempfile(
        'mgpgXXXXXXXX',
        DIR    => $DUMPDIR,
        UNLINK => 1,
    );

    $entity->print($fh);
    close $fh;

    if ($modify) {
        open( $fh, $file ) or die "can't read $file";
        my $data = join( '', <$fh> );
        close $fh;
        $data =~ s/whitespace/spacewhite/g;
        $data =~ tr/L/l/;
        open( $fh, ">$file" ) or die "can't write $file";
        print $fh $data;
        close $fh;
    }

    open( $fh, $file ) or die "can't read $file";
    my $mg = $self->get_mail_gpg;
    my $parsed_entity = $mg->parse( mail_fh => $fh );
    close $fh;;
    return $parsed_entity;
}

sub sign_test {
    my $self = shift;
    my %par = @_;
    my  ($mg, $method, $encoding, $attach, $invalid) =
    @par{'mg','method','encoding','attach','invalid'};

    $attach  = "" if not defined $attach;
    $invalid = "" if not defined $invalid;

    $attach  = " (w/ attachmnt)" if $attach;
    $invalid = ""                if not $invalid;
    $invalid = " (invalid)"      if $invalid;

    my $test_name = "$method:$encoding Signature $attach$invalid";

    my $entity = MIME::Entity->build(
        From     => $self->get_key_mail,
        Subject  => "Mail::GPG Testmail",
        Data     => [ $self->get_test_mail_body ],
        Encoding => $encoding,
        Charset  => "iso-8859-1",
    );

    if ($attach) {
        $entity->attach(
            Type        => "application/octet-stream",
            Disposition => "inline",
            Data        => [ "A great Ättächment.  \n" x 10 ],
            Encoding    => "base64",
        );
    }

    my $signed_entity = $mg->$method( entity => $entity );

    if ( not $mg->is_signed( entity => $signed_entity ) ) {
        ok( 0, "$test_name: Entity not signed" );
        return;
    }

    my $signed_entity_string = $signed_entity->as_string;

    my $parsed_entity = $self->print_parse_entity(
        entity        => $signed_entity,
        modify        => $invalid,
    );

    if ( $ENV{DUMPFILES} ) {
        my $tmp_file = "$DUMPDIR/$method-$encoding-"
            . ( $attach  ? "attach"  : "noattach" ) . "-"
            . ( $invalid ? "invalid" : "valid" );

        open( SEND, ">$tmp_file.send" );
        open( RETR, ">$tmp_file.retr" );

        print SEND $signed_entity->as_string;