Mail-GPG
view release on metacpan or search on metacpan
1.0.11 Sat Aug 26, 2017, joern
Bugfix:
- Fixed I/O issue on (specific) bigger message bodies.
Thanks for report and test material to Markus Wernig
and Frank Fichtner.
Mail::GPG now depends on AnyEvent for I/O with GnuPG.
The alternative IO::Select based implementation (in
case no Event is installed) was dropped.
- Tests now use "./mail-gpg-test" temp dir instead
of /tmp/mail-gpg-test, which could cause issues
when tests are executed with different users on
the same machine.
1.0.10 Sat Sep 19, 2015, joern
Bugfix:
- Fixed incorrect and potentially insecure UTF8 handling.
Thanks for the report to Juerd Waalboer <juerd AT tnx.nl>.
1.0.9 Mon May 18, 2015, joern
Bugfix:
Perlbotics (Thanks!) fixing RT103828, RT81082, and
RT80500.
- Mail::GPG->query_keyring() has new 'coerce' option
which gives full control about multiple email addresses
per user (refer to manpage for details).
1.0.7 Wed Aug 3, 2011, joern
Features:
- Added support for empty passphrases. Thanks for the patch
to hlein AT korelogic DOT com.
- Improved gpg I/O performance and prevent rare blocking
cases by using the Event module (if installed).
Note: you can force the old IO::Select based algorithm
by setting $Mail::GPG::SKIP_EVENT = 1 or
$ENV{MAIL_GPG_SKIP_EVENT} = 1 before loading
Mail::GPG.
1.0.6 Sat Nov 18, 2006, joern
Bugfix:
- Mail::GPG->parse() missed setting MIME::Parser->output_to_core(1)
which the public key was missing (and thus no verification
possible). That's not what we expect, instead we can check
the verification through the returned result object but
have a successfully decrypted mail.
0.97 Tue Jun 15, 2004, joern
Bugfixes:
- Mail::GPG::Result->as_string() reported some warnings
regarding uninitialized values. Thanks to Edward J. Sabol
<sabol AT alderaan.gsfc.nasa.gov> for his patch.
- mgpg-test script now has the -w switch
0.96 Sat May 29, 2004, joern
Bugfixes:
- Added missing dependency GnuPG::Interface in Makefile.PL
Reported through cpan-testers.
0.95 Sat May 29, 2004, joern
Features:
- query_keyring() now returns all matching entries as a
list of key-id/address pairs, which can be slurped
to Daniel Ciaglia.
0.94 Sun Feb 15, 2004, joern
Bugfixes:
- New I/O multiplex code needed some adjustments to
work with Perl 5.005_03, because its read() and seek()
functions work on native filehandles only.
0.93 Sat Feb 14 2004, joern
Bugfixes:
- Perform multiplexed I/O with gpg to prevent buffering
deadlocks which may occur with huge amounts of data.
Added a new test t/04.big.t, which creates a 4 MB
entity and signs it. This test takes some time (on
an Athlon 1800XP about 20 seconds), so be patient ;)
- Set LC_MESSAGES=C where output of gpg is parsed to
get status information. Without this some Mail::GPG
methods didn't work on systems with non english locales.
0.92 Fri Feb 13 2004, joern
Bugfixes:
- make test failed on systems without the MIME-tools
patch, although the corresponding tests were skipped.
0.91 Wed Feb 11 2004, joern
Bugfixes:
- mime_sign_encrypt: check key_id only if entity should
be signed
- Ignore SIGPIPE from gpg
0.90 Sun Feb 8 2004 joern
First public release, including the following methods:
- mime_sign
- mime_encrypt
- mime_sign_encrypt
- armor_sign
- armor_encrypt
- armor_sign_encrypt
- decrypt
lib/Mail/GPG/Test.pm
lib/Mail/GPG/Result.pm
lib/Mail/GPG.pm
bin/mgpg-test
t/01.base.t
t/02.sign.t
t/03.enc.t
t/04.big.t
t/05.multipart.t
t/06.querykeys.t
t/mgpg-test-key.sec.asc
t/mgpg-test-key.pub.asc
Makefile.PL
MANIFEST
README
MYMETA.yml
MYMETA.json
genreadme
patches/GnuPG-Interface-0.33.tru-record-type.txt
Changes
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
Makefile.PL view on Meta::CPAN
};
if ( $@ ) {
print "Not Ok!\n";
print " Please read the README file and apply the required\n";
print " MIME-tools patch before installing Mail::GPG.\n";
print " You can use Mail::GPG without this patch, but\n";
print " Mail::GPG then can't verify all MIME signed messages.\n";
}
#-- check for gpg program
eval {
print "* Checking for gpg program... ";
my $out = qx[gpg --version 2>&1 && echo GPGOK];
die unless $out =~ /GPGOK/;
print "Ok\n";
};
if ( $@ ) {
print "Not Ok!\n";
print " Please read the README file and first install the\n";
print " gpg program in your PATH, or extend your PATH that\n";
print " the gpg program can be found. This is needed for\n";
print " the regression tests only.\n";
}
WriteMakefile(
'NAME' => 'Mail::GPG',
'VERSION_FROM' => 'lib/Mail/GPG.pm',
'PREREQ_PM' => {
'List::MoreUtils' => 0,
'MIME::Entity' => 5.419,
'MIME::Parser' => 5.419,
'Mail::Address' => 0,
'MIME::QuotedPrint' => 2.20,
'GnuPG::Interface' => 0,
'Encode' => 2.01,
},
'EXE_FILES' => [ 'bin/mgpg-test' ],
'dist' => {
COMPRESS => "gzip",
SUFFIX => "gz",
PREOP => q[./genreadme],
POSTOP => q[mkdir -p dist; mv Mail*tar.gz dist/],
},
);
AnyEvent
INSTALLATION
Then install Mail::GPG
% cd ../Mail-GPG-x.xx
% perl Makefile.PL
% make test
% make install
Mail::GPG has a bunch of tests which will create a temporary gpg keyring
to be able to do real encryption and stuff. You need to have gpg in your
path for the tests to succeed, otherwise all useful tests will be
skipped.
Note that the test 04.big needs some time, on an Athlon 1800XP about 12
seconds, so be patient ;)
KNOWN BUGS
Currently none. Please report any bugs to the author: Joern Reder <joern
AT zyn.de>.
bin/mgpg-test view on Meta::CPAN
#!/usr/bin/perl -w
# $Id: mgpg-test,v 1.7 2006/04/14 10:53:11 joern Exp $
use strict;
use lib 'lib';
use lib '/home/joern/projects/MIME-tools-5.411/lib';
use Mail::GPG;
use MIME::Parser;
use Getopt::Std;
$| = 1;
my %passwords;
main: {
# get options
my %opt;
my $opt_ok = getopts ('vd', \%opt);
if ( !@ARGV or not $opt_ok ) {
print STDERR "Usage: mgpg-test [-v] [-d] file ...\n";
exit 1;
}
my $verbose = $opt{v};
my $dump = $opt{d};
foreach my $file ( @ARGV ) {
open(FILE,$file) or die "can't read $file";
print STDERR "* $file\n";
test_file(\*FILE, $verbose, $dump);
lib/Mail/GPG.pm view on Meta::CPAN
use File::Temp;
use List::MoreUtils ();
sub get_default_key_id { shift->{default_key_id} }
sub get_default_passphrase { shift->{default_passphrase} }
sub get_debug { shift->{debug} }
sub get_debug_dir { shift->{debug_dir} }
sub get_gnupg_hash_init { shift->{gnupg_hash_init} }
sub get_digest { shift->{digest} }
sub get_default_key_encrypt { shift->{default_key_encrypt} }
sub get_gpg_call { shift->{gpg_call} }
sub get_no_strict_7bit_encoding { shift->{no_strict_7bit_encoding} }
sub get_use_long_key_ids { shift->{use_long_key_ids} }
sub set_default_key_id { shift->{default_key_id} = $_[1] }
sub set_default_passphrase { shift->{default_passphrase} = $_[1] }
sub set_debug { shift->{debug} = $_[1] }
sub set_debug_dir { shift->{debug_dir} = $_[1] }
sub set_gnupg_hash_init { shift->{gnupg_hash_init} = $_[1] }
sub set_digest { shift->{digest} = $_[1] }
sub set_default_key_encrypt { shift->{default_key_encrypt} = $_[1] }
sub set_gpg_call { shift->{gpg_call} = $_[1] }
sub set_no_strict_7bit_encoding { shift->{no_strict_7bit_encoding}=$_[1]}
sub set_use_long_key_ids { shift->{use_long_key_ids} = $_[1] }
sub new {
my $class = shift;
my %par = @_;
my ($default_key_id, $default_passphrase, $debug, $debug_dir) =
@par{'default_key_id','default_passphrase','debug','debug_dir'};
my ($gnupg_hash_init, $digest, $gpg_call, $default_key_encrypt) =
@par{'gnupg_hash_init','digest','gpg_call','default_key_encrypt'};
my ($no_strict_7bit_encoding, $use_long_key_ids) =
@par{'no_strict_7bit_encoding','use_long_key_ids'};
$debug_dir ||= $ENV{DUMPDIR} || File::Spec->tmpdir . '/mail-gpg-test';
$gnupg_hash_init ||= {};
$digest ||= "RIPEMD160";
$gpg_call ||= "gpg";
$no_strict_7bit_encoding ||= 0;
$use_long_key_ids ||= 0;
my $self = bless {
default_key_id => $default_key_id,
default_passphrase => $default_passphrase,
debug => $debug,
debug_dir => $debug_dir,
gnupg_hash_init => $gnupg_hash_init,
digest => $digest,
default_key_encrypt => $default_key_encrypt,
gpg_call => $gpg_call,
no_strict_7bit_encoding => $no_strict_7bit_encoding,
use_long_key_ids => $use_long_key_ids,
}, $class;
return $self;
}
sub new_gpg_interface {
my $self = shift;
my %par = @_;
my ($options, $passphrase) = @par{'options','passphrase'};
my $gpg = GnuPG::Interface->new;
$gpg->passphrase($passphrase) if defined $passphrase;
$gpg->call( $self->get_gpg_call ) if $self->get_gpg_call ne '';
my $gnupg_hash_init = $self->get_gnupg_hash_init;
if ($options) {
$gpg->options->hash_init( %{$options}, %{$gnupg_hash_init} );
}
else {
$gpg->options->hash_init( %{$gnupg_hash_init} );
}
$gpg->options->push_extra_args( '--digest', $self->get_digest );
$gpg->options->meta_interactive(0);
return $gpg;
}
sub save_debug_file {
my $self = shift;
my %par = @_;
my ($name, $data, $data_fh ) = @par{'name','data','data_fh' };
$name = $self->get_debug_dir . "/mgpg-" . $name;
open( DBG, ">$name" ) or die "can't write $name";
if ($data_fh) {
seek $data_fh, 0, 0;
print DBG $_ while <$data_fh>;
}
elsif ( ref $data ) {
print DBG $$data;
}
else {
lib/Mail/GPG.pm view on Meta::CPAN
unless $$encrypted_text_sref =~ /^-----BEGIN PGP MESSAGE-----/m;
$is_armor = 1;
}
else {
die "Entity is not multipart/encrypted and has no body";
}
return $is_armor;
}
sub perform_multiplexed_gpg_io {
my $self = shift;
my %par = @_;
my ($data_fh, $data_canonify, $stdin_fh, $stderr_fh) =
@par{'data_fh','data_canonify','stdin_fh','stderr_fh'};
my ($stdout_fh, $status_fh, $stderr_sref, $stdout_sref) =
@par{'stdout_fh','status_fh','stderr_sref','stdout_sref'};
my ($status_sref) =
$par{'status_sref'};
require IO::Select;
lib/Mail/GPG.pm view on Meta::CPAN
#-- filehandles in question
my $stdin = IO::Select->new($stdin_fh);
my $stderr = IO::Select->new($stderr_fh);
my $stdout = IO::Select->new($stdout_fh);
my $status = $status_fh ? IO::Select->new($status_fh) : undef;
my $buffer;
while (1) {
#-- as long we has data try to write
#-- it into gpg
while ( $data_fh && $stdin->can_write(0.001) ) {
if ( $data_fh_glob
? read $data_fh,
$buffer, 1024
: $data_fh->read( $buffer, 1024 ) ) {
#-- ok, got a block of data
if ($data_canonify) {
#-- canonify it if requested
$buffer =~ s/\x0A/\x0D\x0A/g;
$buffer =~ s/\x0D\x0D\x0A/\x0D\x0A/g;
}
#-- feed it into gpg
print $stdin_fh $buffer;
}
else {
#-- no data read, close gpg's stdin
#-- and set the data filehandle to false
close $stdin_fh;
$data_fh = 0;
}
}
#-- probably we can read from gpg's stdout
while ( $stdout->can_read(0.001) ) {
last if eof($stdout_fh);
$$stdout_sref .= <$stdout_fh>;
}
#-- probably we can read from gpg's stderr
while ( $stderr->can_read(0.001) ) {
last if eof($stderr_fh);
$$stderr_sref .= <$stderr_fh>;
}
#-- probably we can read from gpg's status
if ($status) {
while ( $status->can_read(0.001) ) {
last if eof($status_fh);
$$status_sref .= <$status_fh>;
}
}
#-- we're finished if no more data left
#-- and both gpg's stdout and stderr
#-- are at eof.
return
if !$data_fh
&& eof($stderr_fh)
&& eof($stdout_fh)
&& ( !$status_fh || eof($status_fh) );
}
1;
}
lib/Mail/GPG.pm view on Meta::CPAN
#-- Addresses bug: https://rt.cpan.org/Public/Bug/Display.html?id=103828 (here)
#-- Possibly also: https://rt.cpan.org/Public/Bug/Display.html?id=81082 (here)
# and https://rt.cpan.org/Public/Bug/Display.html?id=80500 (in Makefile.PL)
sub _parse_key_list {
my $self = shift;
my ($output_stdout, %par) = @_;
my ($coerce, $debug, $verbose) =
@par{'coerce','debug','verbose'};
#-- grab key ID's and emails from output (backward compatible to gpg 1.x)
#
# Example:
# search request: "--list-keys --with-colons 6C187D0F196ED9E3"
# format : see /usr/share/doc/packages/gpg2/DETAILS
#
#--OLD sample: gpg (GnuPG) 1.4.11
# tru:t:1:1431088683:0:3:1:5
# pub:-:1024:17:062F00DAE20F5035:2004-02-10:::-:Jörn Reder Mail\x3a\x3aGPG Test Key <mailgpg@localdomain>::scaESCA:
# sub:-:1024:16:6C187D0F196ED9E3:2004-02-10::::::e:
#
# expected output: (062F00DAE20F5035, 'Jörn Reder Mail::GPG Test Key <mailgpg@localdomain>')
#
#--NEW sample: gpg (GnuPG) 2.0.22
# tru:t:1:1429473192:0:3:1:5
# pub:-:1024:17:062F00DAE20F5035:1076425915:::-:::scaESCA:
# uid:-::::1076425915::588869ADE077B8FB05788A99565AEED15AED8231::Jörn Reder Mail\x3a\x3aGPG Test Key <mailgpg@localdomain>:
# sub:-:1024:16:6C187D0F196ED9E3:1076425917::::::e:
#
# expected output: (062F00DAE20F5035, 'Jörn Reder Mail::GPG Test Key <mailgpg@localdomain>',
# 6C187D0F196ED9E3, 'Jörn Reder Mail::GPG Test Key <mailgpg@localdomain>')
#
# PERLBOTIX<ätt>cpan.org / May, 2015
my @result;
#-- needed for utf8 handling
require Encode if $] >= 5.008;
$output_stdout .= "\nFLUSH\n"; #-- we add this token to trigger flushing of the last record
#-- these values are valid per "paragraph" (from pub: to pub:)
my @ids; #-- list of potential IDs (pub, sub)
my @emails; #-- list of potential email adresses (uid)
my $gpg2_mode = 0; #-- auto-detect OLD/NEW format: true if NEW (gpg2) format
#-- parse output line by line
#-- OLD-format (gpg 1.x): simulate old behaviour
#-- NEW-format (gpg 2.x): create all combinations of valid key-IDs and emails; return (pub) key-ID first,
# so the result stays backward compatible
while ( $output_stdout =~ m!^((\w+):?.*?)[\r\n]+!mg ) {
my ($line, $tag) = ($1, $2);
my @fields = split /:/, $line, -1;
warn("\nFields: ", join(", ", map { "($_)" } @fields)) if $debug;
#-- skip entries that are expired or otherwise invalid
lib/Mail/GPG.pm view on Meta::CPAN
carp "Incomplete key data - key is probably invalid? (@ids) x (@emails)!";
}
@ids = ();
@emails = ();
last if defined $fields[1] and $fields[1] eq 'FLUSH';
#-- parse 'new' format (pub:..; next: uid:..., uid:..., sub:... )
if ( not defined $fields[9] or $fields[9] =~ /^\s*$/ ) {
$gpg2_mode = 1;
push @ids, $fields[4];
}
#-- parse 'old' format (pub:)
elsif ( $fields[9] =~ /<[^>]+>/ ) {
$gpg2_mode = 0;
push @ids, $fields[4];
push @emails, $fields[9];
}
else {
die "Cannot parse: ($line)";
}
} #-- 'pub' & 'FLUSH' handled obove
#-- handle 'sub' entries / extract key-id
elsif ( $tag eq 'sub' and $gpg2_mode and $fields[4]) {
push @ids, $fields[4];
}
#-- handle 'uid' entries / extract email
elsif ( $tag eq 'uid' and $gpg2_mode and $fields[9] =~ /<[^>]+>/ ) {
push @emails, $fields[9];
}
#-- ignore anything else
else {
warn "Ignoring line [gpg2_mode=$gpg2_mode] -- '$line'" if $debug;
}
} #-- loop over output_stdout
warn Data::Dumper->Dump( [ \@result], [qw(RESULT_AS_REF)] ) if $debug;
return @result;
}
sub query_keyring {
my $self = shift;
my %par = @_;
my ($search, $debug) = @par{'search','debug'};
#-- ignore any PIPE signals, in case of gpg exited
#-- early before we fed our data into it.
local $SIG{PIPE} = 'IGNORE';
#-- we parse gpg's output and rely on english
local $ENV{LC_ALL} = "C";
#-- get a GnuPG::Interface
my $gpg = $self->new_gpg_interface;
#-- initialize Handles
my $stdout = IO::Handle->new;
my $stderr = IO::Handle->new;
my $handles = GnuPG::Handles->new(
stdout => $stdout,
stderr => $stderr,
);
#-- execute gpg --list-public-keys
my $pid = $gpg->wrap_call(
handles => $handles,
commands => [ "--list-keys", "--with-colons" ],
command_args => [$search],
);
#-- fetch gpg's STDERR
my $output_stderr;
$output_stderr .= $_ while <$stderr>;
close $stderr;
#-- fetch gpg's STDOUT
my $output_stdout;
$output_stdout .= $_ while <$stdout>;
close $stdout;
#-- wait on gpg exit
waitpid $pid, 0;
if ( $debug ) {
warn "LIST_KEYS(CMD) -- --list-keys --with-colons $search\n";
warn "LIST_KEYS(STDERR) -- search for ($search):\n$output_stderr\n";
warn "LIST_KEYS(STDOUT) -- search for ($search):\n$output_stdout\n";
}
my @result = $self->_parse_key_list( $output_stdout , %par);
#-- return result: undef if nothing found, first key-id if
#-- a scalar is requested, all entries suitable for a hash
#-- slurp if an array is requested
# Compatibility note: The first id is always the id of the 'pub' entry, even for a subkey-hit.
# gpgv2: The result should not be used to initialise a hash, since some emails will be clobbered.
# We need another interface here. Curently Mail::GPG uses only the first entry...
return if not @result;
return $result[0] if not wantarray;
return @result;
}
sub build_rfc3156_multipart_entity {
my $self = shift;
my %par = @_;
my ($entity, $method) = @par{'entity','method'};
lib/Mail/GPG.pm view on Meta::CPAN
#-- return the newly created entitiy and the part to work on
return ( $rfc_entity, $work_part );
}
sub mime_sign {
my $self = shift;
my %par = @_;
my ($key_id, $passphrase, $entity) =
@par{'key_id','passphrase','entity'};
#-- ignore any PIPE signals, in case of gpg exited
#-- early before we fed our data into it.
local $SIG{PIPE} = 'IGNORE';
#-- we parse gpg's output and rely on english
local $ENV{LC_ALL} = "C";
#-- get default key ID and passphrase, if not given
$key_id = $self->get_default_key_id if not defined $key_id;
$passphrase = $self->get_default_passphrase if not defined $passphrase;
#-- check parameters
die "No key_id set" if $key_id eq '';
die "No passphrase set" if not defined $passphrase;
#-- build entity for signed version
#-- (only the 2nd part with the signature data
#-- needs to be added later)
my ( $signed_entity, $sign_part ) = $self->build_rfc3156_multipart_entity(
entity => $entity,
method => "sign",
);
#-- get a GnuPG::Interface
my $gpg = $self->new_gpg_interface(
options => {
armor => 1,
default_key => $key_id,
},
passphrase => $passphrase,
);
#-- initialize handles
my $stdin = IO::Handle->new;
my $stdout = IO::Handle->new;
my $stderr = IO::Handle->new;
my $handles = GnuPG::Handles->new(
stdin => $stdin,
stdout => $stdout,
stderr => $stderr,
);
#-- execute gpg for signing
my $pid = $gpg->detach_sign( handles => $handles );
#-- put encoded entity data into temporary file
#-- (faster than in-memory operation)
my ( $data_fh, $data_file ) = File::Temp::tempfile();
unlink $data_file;
$sign_part->print($data_fh);
#-- perform I/O (multiplexed to prevent blocking)
my ( $output_stdout, $output_stderr ) = ("", "");
$self->perform_multiplexed_gpg_io(
data_fh => $data_fh,
data_canonify => 1,
stdin_fh => $stdin,
stderr_fh => $stderr,
stdout_fh => $stdout,
stderr_sref => \$output_stderr,
stdout_sref => \$output_stdout,
);
#-- close reader filehandles (stdin was closed
#-- by perform_multiplexed_gpg_io())
close $stdout;
close $stderr;
#-- fetch zombie
waitpid $pid, 0;
die $output_stderr if $?;
#-- attach OpenPGP signature as second part
$signed_entity->attach(
Type => "application/pgp-signature",
lib/Mail/GPG.pm view on Meta::CPAN
_no_sign => 1,
);
}
sub mime_sign_encrypt {
my $self = shift;
my %par = @_;
my ($key_id, $passphrase, $entity, $recipients, $_no_sign) =
@par{'key_id','passphrase','entity','recipients','_no_sign'};
#-- ignore any PIPE signals, in case of gpg exited
#-- early before we fed our data into it.
local $SIG{PIPE} = 'IGNORE';
#-- we parse gpg's output and rely on english
local $ENV{LC_ALL} = "C";
#-- get default key ID and passphrase, if not given
$key_id = $self->get_default_key_id if not defined $key_id;
$passphrase = $self->get_default_passphrase if not defined $passphrase;
#-- check parameters
die "No key_id set" if not $_no_sign and $key_id eq '';
die "No passphrase set" if not $_no_sign and not defined $passphrase;
#-- build entity for encrypted version
#-- (only the 2nd part with the encrypted data
#-- needs to be added later)
my ( $encrypted_entity, $encrypt_part )
= $self->build_rfc3156_multipart_entity(
entity => $entity,
method => "encrypt",
);
#-- get a GnuPG::Interface
my $gpg = $self->new_gpg_interface(
options => {
armor => 1,
default_key => $key_id,
},
passphrase => $passphrase,
);
#-- add recipients, but first extract the mail-adress
#-- part, otherwise gpg couldn't find keys for adresses
#-- with quoted printable encodings in the name part-
$recipients = $self->extract_mail_address( recipients => $recipients, );
$gpg->options->push_recipients($_) for @{$recipients};
#-- add default key to recipients if requested
$gpg->options->push_recipients( $self->get_default_key_id )
if $self->get_default_key_encrypt
and $self->get_default_key_id;
#-- initialize handles
my $stdin = IO::Handle->new;
my $stdout = IO::Handle->new;
my $stderr = IO::Handle->new;
my $handles = GnuPG::Handles->new(
stdin => $stdin,
stdout => $stdout,
stderr => $stderr,
);
#-- execute gpg for encryption
my $pid;
if ($_no_sign) {
$pid = $gpg->encrypt( handles => $handles );
}
else {
$pid = $gpg->sign_and_encrypt( handles => $handles );
}
#-- put encoded entity data into temporary file
#-- (faster than in-memory operation)
my ( $data_fh, $data_file ) = File::Temp::tempfile();
unlink $data_file;
$encrypt_part->print($data_fh);
#-- perform I/O (multiplexed to prevent blocking)
my ( $output_stdout, $output_stderr ) = ("", "");
$self->perform_multiplexed_gpg_io(
data_fh => $data_fh,
data_canonify => 1,
stdin_fh => $stdin,
stderr_fh => $stderr,
stdout_fh => $stdout,
stderr_sref => \$output_stderr,
stdout_sref => \$output_stdout,
);
#-- close reader filehandles (stdin was closed
#-- by perform_multiplexed_gpg_io())
close $stdout;
close $stderr;
#-- fetch zombie
waitpid $pid, 0;
die $output_stderr if $?;
#-- attach second part with the encrytped text
$encrypted_entity->attach(
Type => "application/octet-stream",
lib/Mail/GPG.pm view on Meta::CPAN
#-- return encrytped entity
return $encrypted_entity;
}
sub armor_sign {
my $self = shift;
my %par = @_;
my ($key_id, $passphrase, $entity) =
@par{'key_id','passphrase','entity'};
#-- ignore any PIPE signals, in case of gpg exited
#-- early before we fed our data into it.
local $SIG{PIPE} = 'IGNORE';
#-- we parse gpg's output and rely on english
local $ENV{LC_ALL} = "C";
#-- get default key ID and passphrase, if not given
$key_id = $self->get_default_key_id if not defined $key_id;
$passphrase = $self->get_default_passphrase if not defined $passphrase;
#-- check parameters
die "No key_id set" if $key_id eq '';
die "No passphrase set" if not defined $passphrase;
die "Entity has no body" if not $entity->bodyhandle;
#-- check, if body content-transfer-encoding is 7bit safe
if ( not $self->get_no_strict_7bit_encoding ) {
my $encoding = $entity->head->get("content-transfer-encoding");
die "Content transfer encoding '$encoding' is not 7bit safe"
unless $encoding =~ /^(quoted-printable|base64|7bit)\s*$/i;
}
#-- get a GnuPG::Interface, with ASCII armor enabled
my $gpg = $self->new_gpg_interface(
options => {
armor => 1,
default_key => $key_id,
},
passphrase => $passphrase,
);
#-- initialize handles
my $stdin = IO::Handle->new;
my $stdout = IO::Handle->new;
my $stderr = IO::Handle->new;
my $handles = GnuPG::Handles->new(
stdin => $stdin,
stdout => $stdout,
stderr => $stderr,
);
#-- execute gpg for signing
my $pid = $gpg->clearsign( handles => $handles );
#-- put encoded entity data into temporary file
#-- (faster than in-memory operation)
my ( $data_fh, $data_file ) = File::Temp::tempfile();
unlink $data_file;
$entity->print($data_fh);
#-- perform I/O (multiplexed to prevent blocking)
my ( $output_stdout, $output_stderr ) = ("", "");
$self->perform_multiplexed_gpg_io(
data_fh => $data_fh,
data_canonify => 1,
stdin_fh => $stdin,
stderr_fh => $stderr,
stdout_fh => $stdout,
stderr_sref => \$output_stderr,
stdout_sref => \$output_stdout,
);
#-- close reader filehandles (stdin was closed
#-- by perform_multiplexed_gpg_io())
close $stdout;
close $stderr;
#-- fetch zombie
waitpid $pid, 0;
die $output_stderr if $?;
#-- build entity for encrypted version
my $signed_entity = MIME::Entity->build( Data => [$output_stdout], );
lib/Mail/GPG.pm view on Meta::CPAN
_no_sign => 1,
);
}
sub armor_sign_encrypt {
my $self = shift;
my %par = @_;
my ($key_id, $passphrase, $entity, $recipients, $_no_sign) =
@par{'key_id','passphrase','entity','recipients','_no_sign'};
#-- ignore any PIPE signals, in case of gpg exited
#-- early before we fed our data into it.
local $SIG{PIPE} = 'IGNORE';
#-- we parse gpg's output and rely on english
local $ENV{LC_ALL} = "C";
#-- get default key ID and passphrase, if not given
if ( not $_no_sign ) {
$key_id = $self->get_default_key_id if not defined $key_id;
$passphrase = $self->get_default_passphrase
if not defined $passphrase;
#-- check parameters
die "No key_id set" if $key_id eq '';
die "No passphrase set" if not defined $passphrase;
}
#-- check parameters
die "Entity has no body" if not $entity->bodyhandle;
#-- get a GnuPG::Interface, with ASCII armor enabled
my $gpg = $self->new_gpg_interface(
options => {
armor => 1,
default_key => $key_id,
},
passphrase => $passphrase,
);
#-- add recipients, but first extract the mail-adress
#-- part, otherwise gpg couldn't find keys for adresses
#-- with quoted printable encodings in the name part-
$recipients = $self->extract_mail_address( recipients => $recipients, );
$gpg->options->push_recipients($_) for @{$recipients};
#-- add default key to recipients if requested
$gpg->options->push_recipients( $self->get_default_key_id )
if $self->get_default_key_encrypt
and $self->get_default_key_id;
#-- initialize handles
my $stdin = IO::Handle->new;
my $stdout = IO::Handle->new;
my $stderr = IO::Handle->new;
my $handles = GnuPG::Handles->new(
stdin => $stdin,
stdout => $stdout,
stderr => $stderr,
);
#-- execute gpg for encryption
my $pid;
if ($_no_sign) {
$pid = $gpg->encrypt( handles => $handles );
}
else {
$pid = $gpg->sign_and_encrypt( handles => $handles );
}
#-- put encoded entity data into temporary file
#-- (faster than in-memory operation)
my ( $data_fh, $data_file ) = File::Temp::tempfile();
unlink $data_file;
$entity->print($data_fh);
#-- perform I/O (multiplexed to prevent blocking)
my ( $output_stdout, $output_stderr ) = ("", "");
$self->perform_multiplexed_gpg_io(
data_fh => $data_fh,
data_canonify => 0,
stdin_fh => $stdin,
stderr_fh => $stderr,
stdout_fh => $stdout,
stderr_sref => \$output_stderr,
stdout_sref => \$output_stdout,
);
#-- close reader filehandles (stdin was closed
#-- by perform_multiplexed_gpg_io())
close $stdout;
close $stderr;
#-- fetch zombie
waitpid $pid, 0;
die $output_stderr if $?;
#-- build entity for encrypted version
my $encrypted_entity = MIME::Entity->build(
Type => "text/plain",
lib/Mail/GPG.pm view on Meta::CPAN
#-- return the signed entity
return $encrypted_entity;
}
sub decrypt {
my $self = shift;
my %par = @_;
my ($entity, $passphrase) = @par{'entity','passphrase'};
#-- ignore any PIPE signals, in case of gpg exited
#-- early before we fed our data into it.
local $SIG{PIPE} = 'IGNORE';
#-- we parse gpg's output and rely on english
local $ENV{LC_ALL} = "C";
#-- get default passphrase, if not given
$passphrase = $self->get_default_passphrase if not defined $passphrase;
#-- check if the entity is encrypted at all
#-- (dies if not)
my $encrypted_text;
my $is_armor = $self->check_encryption(
entity => $entity,
encrypted_text_sref => \$encrypted_text,
);
#-- get a GnuPG::Interface
my $gpg = $self->new_gpg_interface( passphrase => $passphrase, );
#-- initialize handles
my $stdin = IO::Handle->new;
my $stdout = IO::Handle->new;
my $stderr = IO::Handle->new;
my $status = IO::Handle->new;
my $handles = GnuPG::Handles->new(
stdin => $stdin,
stdout => $stdout,
stderr => $stderr,
status => $status,
);
#-- start gpg for decryption
my $pid = $gpg->decrypt( handles => $handles );
#-- put encoded entity data into temporary file
#-- (faster than in-memory operation)
my ( $data_fh, $data_file ) = File::Temp::tempfile();
unlink $data_file;
print $data_fh $encrypted_text;
#-- perform I/O (multiplexed to prevent blocking)
my ( $output_stdout, $output_stderr, $output_status ) = ( "", "", "" );
$self->perform_multiplexed_gpg_io(
data_fh => $data_fh,
data_canonify => 1,
stdin_fh => $stdin,
stderr_fh => $stderr,
stdout_fh => $stdout,
status_fh => $status,
stderr_sref => \$output_stderr,
stdout_sref => \$output_stdout,
status_sref => \$output_status,
);
#-- close reader filehandles (stdin was closed
#-- by perform_multiplexed_gpg_io())
close $stdout;
close $stderr;
#-- fetch zombie
waitpid $pid, 0;
my $rc = $? >> 8;
#-- don't die here for return values != 0, because
#-- this also happens for encrypted+signed mails,
#-- where the public key is missing for verification
lib/Mail/GPG.pm view on Meta::CPAN
}
#-- debugging: create file with encrypted data
if ( $self->get_debug ) {
$self->save_debug_file(
name => "dec-data.txt",
data => $dec_entity->as_string,
);
}
#-- fetch information from gpg's stderr output
#-- and construct a Mail::GPG::Result object from it
my $result = Mail::GPG::Result->new(
mail_gpg => $self,
gpg_stdout => \$output_stdout,
gpg_stderr => \$output_stderr,
gpg_status => \$output_status,
gpg_rc => $rc,
);
#-- return decrypted entity and result object
return $dec_entity if not wantarray;
return ( $dec_entity, $result );
}
sub verify {
my $self = shift;
my %par = @_;
my ($entity) = $par{'entity'};
#-- ignore any PIPE signals, in case of gpg exited
#-- early before we fed our data into it.
local $SIG{PIPE} = 'IGNORE';
#-- we parse gpg's output and rely on english
local $ENV{LC_ALL} = "C";
#-- check if the entity is signed
my ( $signed_text, $signature_text );
if ( $entity->effective_type =~ m!multipart/signed!i ) {
#-- is this a valid RFC 3156 multipart/signed entity?
die "Entity must have two parts"
if $entity->parts != 2;
lib/Mail/GPG.pm view on Meta::CPAN
#-- in that case we need the *decoded* data
$signed_text = $entity->bodyhandle->as_string;
die "Entity is not OpenPGP signed"
unless $signed_text =~ /^-----BEGIN PGP SIGNED MESSAGE-----/m;
}
else {
die "Entity is not multipart/signed and has no body";
}
#-- get a GnuPG::Interface
my $gpg = $self->new_gpg_interface;
#-- initialize handles
my $stdin = IO::Handle->new;
my $stdout = IO::Handle->new;
my $stderr = IO::Handle->new;
my $status = IO::Handle->new;
my $handles = GnuPG::Handles->new(
stdin => $stdin,
stdout => $stdout,
lib/Mail/GPG.pm view on Meta::CPAN
#-- distinguish between ascii amor embedded signature
#-- and detached signature (RFC 3156)
my ( $pid, $sign_file, $sign_fh );
if ($signature_text) {
#-- signature is detached, save it to a temp file
( $sign_fh, $sign_file ) = File::Temp::tempfile();
print $sign_fh $signature_text;
close $sign_fh;
#-- pass signature filename to gpg
$pid = $gpg->verify(
handles => $handles,
command_args => [ $sign_file, "-" ],
);
}
else {
#-- ASCII armor message with embedded signature
$pid = $gpg->verify( handles => $handles, );
}
#-- put encoded entity data into temporary file
#-- (faster than in-memory operation)
my ( $data_fh, $data_file ) = File::Temp::tempfile();
unlink $data_file;
print $data_fh $signed_text;
#-- perform I/O (multiplexed to prevent blocking)
my ( $output_stdout, $output_stderr, $output_status ) = ( "", "", "" );
$self->perform_multiplexed_gpg_io(
data_fh => $data_fh,
data_canonify => 1,
stdin_fh => $stdin,
stderr_fh => $stderr,
stdout_fh => $stdout,
status_fh => $status,
stderr_sref => \$output_stderr,
stdout_sref => \$output_stdout,
status_sref => \$output_status,
);
#-- close reader filehandles (stdin was closed
#-- by perform_multiplexed_gpg_io())
close $stdout;
close $stderr;
#-- fetch zombie
waitpid $pid, 0;
my $rc = $? >> 8;
#-- remove detached signature file
unlink $sign_file if defined $sign_file;
#-- debugging: create file with verified data
if ( $self->get_debug ) {
$self->save_debug_file(
name => "verify-data.txt",
data => \$signed_text,
);
}
#-- construct a Mail::GPG::Result object from
#-- gpg's stderr output
my $result = Mail::GPG::Result->new(
mail_gpg => $self,
gpg_stdout => \$output_stdout,
gpg_stderr => \$output_stderr,
gpg_status => \$output_status,
gpg_rc => $rc,
);
#-- return result object
return $result;
}
sub is_encrypted {
my $self = shift;
my %par = @_;
my ($entity) = $par{'entity'};
lib/Mail/GPG.pm view on Meta::CPAN
}
return 1;
}
sub get_decrypt_key {
my $self = shift;
my %par = @_;
my ($entity) = $par{'entity'};
#-- ignore any PIPE signals, in case of gpg exited
#-- early before we fed our data into it.
local $SIG{PIPE} = 'IGNORE';
#-- we parse gpg's output and rely on english
local $ENV{LC_ALL} = "C";
#-- check if the entity is encrypted at all
#-- (dies if not)
my $encrypted_text;
my $is_armor = $self->check_encryption(
entity => $entity,
encrypted_text_sref => \$encrypted_text,
);
#-- get a GnuPG::Interface
my $gpg = $self->new_gpg_interface;
#-- initialize handles
my $stdin = IO::Handle->new;
my $stdout = IO::Handle->new;
my $stderr = IO::Handle->new;
my $handles = GnuPG::Handles->new(
stdin => $stdin,
stdout => $stdout,
stderr => $stderr,
);
#-- start gpg for decryption
my $pid = $gpg->wrap_call(
handles => $handles,
commands =>
[ "--decrypt", "--batch", "--list-only", "--status-fd", "1" ],
);
#-- put encoded entity data into temporary file
#-- (faster than in-memory operation)
my ( $data_fh, $data_file ) = File::Temp::tempfile();
unlink $data_file;
print $data_fh $encrypted_text;
#-- perform I/O (multiplexed to prevent blocking)
my ( $output_stdout, $output_stderr ) = ( "", "" );
$self->perform_multiplexed_gpg_io(
data_fh => $data_fh,
data_canonify => 1,
stdin_fh => $stdin,
stderr_fh => $stderr,
stdout_fh => $stdout,
stderr_sref => \$output_stderr,
stdout_sref => \$output_stdout,
);
#-- close reader filehandles (stdin was closed
#-- by perform_multiplexed_gpg_io())
close $stdout;
close $stderr;
#-- fetch zombie
waitpid $pid, 0;
my $rc = $? >> 8;
#-- grep ENC_TO and NO_SECKEY items
my ( @enc_to_keys, %no_sec_keys, $line );
while ( $output_stdout =~ /^(.*)$/mg ) {
lib/Mail/GPG.pm view on Meta::CPAN
sub get_key_trust {
my $self = shift;
my %par = @_;
my ($key_id) = $par{'key_id'};
# Suppress warnings about unknown record type 'tru'
# in GnuPG::Interface
local $SIG{__WARN__} = sub {1};
my $gpg = $self->new_gpg_interface;
my @keys = $gpg->get_public_keys($key_id);
croak "Request for key ID '$key_id' got multiple result"
if @keys > 1;
return "" unless $keys[0];
return $keys[0]->owner_trust;
}
1;
lib/Mail/GPG.pm view on Meta::CPAN
=head1 INSTALLATION
Then install Mail::GPG
% cd ../Mail-GPG-x.xx
% perl Makefile.PL
% make test
% make install
Mail::GPG has a bunch of tests which will create a temporary
gpg keyring to be able to do real encryption and stuff. You
need to have gpg in your path for the tests to succeed, otherwise
all useful tests will be skipped.
Note that the test 04.big needs some time, on an Athlon 1800XP
about 12 seconds, so be patient ;)
=head1 KNOWN BUGS
Currently none. Please report any bugs to the author: Joern Reder
<joern AT zyn.de>.
=head1 EXAMPLES
The Mail::GPG distribution contains the program mgpg-test:
Usage: mgpg-test file ...
It takes one or more filenames of mails as
arguments, analyzes them, prints information about
signatures and decrypts encrypteded mails (after asking
for the correspondent passphrases). The script is rather
small and a good example of Mail::GPG usage.
The regression tests in the t/ directory of the
distribution show exemplary usage of all Mail::GPG features.
lib/Mail/GPG.pm view on Meta::CPAN
=item B<debug_dir>
This defaults to File::Spec->tmpdir. The directory is used
to store debug files (see B<debug> above).
=item B<gnupg_hash_init>
This attribute corresponds to the GnuPG::Interface hash_init
attribute. Please refer to the GnuPG::Interface manpage for
details. E.g. you can set gpg's --homedir option this way
and much more.
=item B<digest>
This is the digest used by GnuPG to calculate hash values
for signatures. By default Mail::GPG sets it to "RIPEMD160",
which is needed to handle DSA keys (which are very common).
You can check the supported digests of your gpg installation
by executing 'gpg --version'.
=item B<default_key_encrypt>
Set this attribute to a true value if you whish to have the
B<default_key_id> always added as a recipient for encrypted
mails.
=item B<no_strict_7bit_encoding>
By default this attribute is false, that means that all data
lib/Mail/GPG.pm view on Meta::CPAN
B<no_strict_7bit_encoding> to true, an exception will be
raised for non 7bit transparent encodings.
=item B<use_long_key_ids>
Mail::GPG prior version 1.0.4 always used short 32 bit key id's.
By setting this attribute to TRUE you can switch to long
64bit key id's. This affects the query_keyring() method and
the key id's stored in Mail::GPG::Result.
=item B<gpg_call>
This defaults to 'gpg' and is the path of the gpg program
executed through GnuPG::Interface. Change this attribute
if the 'gpg' program is not in your PATH.
=back
=head1 METHODS TO CREATE MIME OpenPGP MESSAGES (RFC 3156)
=head2 mime_sign
$signed_entity = $mg->mime_sign (
entity => $entity,
[ key_id => $key_id,
lib/Mail/GPG.pm view on Meta::CPAN
address pairs (suitable for a hash variable) is returned.
In scalar context the key id of the first entry is returned.
If nothing was found undef is returned.
If you need more detailed control about the query result,
use GnuPG::Interface->get_public_keys and
GnuPG::Interface->get_secret_keys instead. For
details refer to the GnuPG::PrimaryKey manpage.
If you use Perl 5.8.0 or better email addresses will
be returned as an utf8 enabled scalar, because gpg always
lists email adresses in utf8. Since Perl > 5.8.0 handles
utf8 very nice and transparently, you mostly don't need
to care about this ;)
If you use the module with older Perl versions you need
to handle utf8 encoded data yourself.
=head3 coerce option & GPGv2
When using GPGv2, the current implementation tries to
lib/Mail/GPG.pm view on Meta::CPAN
Key id or email address to query for.
=item coerce
When true, returns all emails belonging to a key as an array-reference.
(patched version only!)
=back
Tests: All temporary files are created in directory F</tmp/mail-gpg-test> now.
The environment variable C<DUMPDIR> can be used to select an alternative directory.
=head2 get_key_trust
$trust = $mg->get_key_trust (
key_id => $key_id
);
lib/Mail/GPG/Result.pm view on Meta::CPAN
package Mail::GPG::Result;
# $Id: Result.pm,v 1.8 2006/04/14 11:05:03 joern Exp $
use strict;
require Encode if $] >= 5.008;
sub get_mail_gpg { shift->{mail_gpg} }
sub get_is_encrypted { shift->{is_encrypted} }
sub get_enc_ok { shift->{enc_ok} }
sub get_enc_key_id { shift->{enc_key_id} }
sub get_enc_mail { shift->{enc_mail} }
sub get_enc_key_ids { shift->{enc_key_ids} }
sub get_enc_mails { shift->{enc_mails} }
sub get_is_signed { shift->{is_signed} }
sub get_sign_ok { shift->{sign_ok} }
sub get_sign_state { shift->{sign_state} }
lib/Mail/GPG/Result.pm view on Meta::CPAN
sub set_enc_key_ids { shift->{enc_key_ids} = $_[1] }
sub set_enc_mails { shift->{enc_mails} = $_[1] }
sub set_is_signed { shift->{is_signed} = $_[1] }
sub set_sign_ok { shift->{sign_ok} = $_[1] }
sub set_sign_state { shift->{sign_state} = $_[1] }
sub set_sign_key_id { shift->{sign_key_id} = $_[1] }
sub set_sign_mail { shift->{sign_mail} = $_[1] }
sub set_sign_mail_aliases { shift->{sign_mail_aliases} = $_[1] }
sub set_sign_fingerprint { shift->{sign_fingerprint} = $_[1] }
sub get_gpg_stdout { shift->{gpg_stdout} }
sub get_gpg_stderr { shift->{gpg_stderr} }
sub get_gpg_status { shift->{gpg_status} }
sub get_gpg_rc { shift->{gpg_rc} }
sub new {
my $class = shift;
my %par = @_;
my ($mail_gpg, $gpg_stdout, $gpg_stderr, $gpg_status, $gpg_rc) =
@par{'mail_gpg','gpg_stdout','gpg_stderr','gpg_status','gpg_rc'};
#-- initialize reference attributes to prevent
#-- dereferencing undef errors
$gpg_stdout = \"" if not defined $gpg_stdout;
$gpg_stderr = \"" if not defined $gpg_stderr;
$gpg_status = \"" if not defined $gpg_status;
my $self = bless {
mail_gpg => $mail_gpg,
gpg_stdout => $gpg_stdout,
gpg_stderr => $gpg_stderr,
gpg_status => $gpg_status,
gpg_rc => $gpg_rc,
}, $class;
$self->analyze_result;
return $self;
}
sub analyze_result {
my $self = shift;
my ($is_signed, $sign_ok, $sign_state,
$sign_key_id, $sign_mail, $sign_fingerprint,
@sign_mail_aliases, $is_encrypted, $enc_ok,
@enc_key_ids, @enc_mails
);
my $gpg_status = $self->get_gpg_status;
my $gpg_stderr = $self->get_gpg_stderr;
while ( $$gpg_status && $$gpg_status =~ m{^\[GNUPG:\]\s+(.*)$}mg ) {
my $line = $1;
if ( $line =~ /^(GOOD|EXP|EXPKEY|REVKEY|BAD)SIG\s+([^\s]+)\s+(.*)/ ) {
my ( $state, $key_id, $mail ) = ( $1, $2, $3 );
$is_signed = 1;
$sign_state = $state;
$sign_key_id = $key_id;
$sign_mail = decode($mail);
$sign_ok = $sign_state eq 'GOOD';
}
elsif ( $line =~ /^ERRSIG\s+([^\s]+)/ ) {
lib/Mail/GPG/Result.pm view on Meta::CPAN
}
}
elsif ( $line =~ /^BEGIN_DECRYPTION/ ) {
$is_encrypted = 1;
}
elsif ( $line =~ /^DECRYPTION_OKAY/ ) {
$enc_ok = 1;
}
}
@sign_mail_aliases = $$gpg_stderr =~ /^gpg:\s+aka\s+"(.*?)"/mg;
if ( !$self->get_mail_gpg->get_use_long_key_ids ) {
for ( $sign_key_id, @enc_key_ids ) {
$_ = substr( $_, -8, 8 ) if defined $_;
}
}
$self->set_is_signed( $is_signed || 0 );
$self->set_sign_ok( $sign_ok || 0 );
$self->set_sign_state( $sign_state || "" );
$self->set_sign_key_id( $sign_key_id || "" );
$self->set_sign_mail( $sign_mail || "" );
lib/Mail/GPG/Result.pm view on Meta::CPAN
my $self = shift;
my %par = @_;
my ($no_stdout) = $par{'no_stdout'};
my ( $method, $string );
foreach my $attr (
qw (is_encrypted enc_ok enc_key_id enc_mail
enc_key_ids enc_mails
is_signed sign_ok sign_state sign_key_id
sign_fingerprint sign_mail sign_mail_aliases
sign_trust gpg_rc )
) {
if ( $attr eq 'sign_mail_aliases' ) {
foreach my $value ( @{ $self->get_sign_mail_aliases } ) {
$string
.= sprintf( "%-18s: %s\n", "sign_mail_alias", $value );
}
}
elsif ( $attr eq 'enc_key_ids' ) {
foreach my $value ( @{ $self->get_enc_key_ids } ) {
$string .= sprintf( "%-18s: %s\n", "enc_key_ids", $value );
lib/Mail/GPG/Result.pm view on Meta::CPAN
}
}
else {
$method = "get_$attr";
my $value = $self->$method;
$value = "" unless defined $value;
$string .= sprintf( "%-18s: %s\n", $attr, $value );
}
}
my $stdout = ${ $self->get_gpg_stdout };
my $stderr = ${ $self->get_gpg_stderr };
my $status = ${ $self->get_gpg_status };
for ( $stdout, $stderr, $status ) {
next unless $_;
s/\n/\n /g;
s/\s+$//;
}
$string .= sprintf( "%-18s: %s\n", "gpg_stdout", $stdout || '' )
if not $no_stdout;
$string .= sprintf( "%-18s: %s\n", "gpg_stderr", $stderr || '' );
$string .= sprintf( "%-18s: %s\n", "gpg_status", $status || '' );
return $string;
}
sub as_short_string {
my $self = shift;
my $string;
if ( $self->get_is_encrypted ) {
lib/Mail/GPG/Result.pm view on Meta::CPAN
$string =~ s/ - $//;
return $string;
}
sub get_sign_trust {
my $self = shift;
return $self->{sign_trust} if exists $self->{sign_trust};
my $trust = $self->get_mail_gpg->get_key_trust(
key_id => $self->get_sign_key_id );
return $self->{sign_trust} = $trust;
}
1;
__END__
lib/Mail/GPG/Result.pm view on Meta::CPAN
$enc_mails = $result->get_enc_mails;
$signed = $result->get_is_signed;
$signature_ok = $result->get_sign_ok;
$signed_key = $result->get_sign_key_id;
$signed_fingerprint = $result->get_sign_fingerprint;
$trust = $result->get_sign_trust;
$signed_mail = $result->get_sign_mail;
$signed_mail_aliases = $result->get_sign_mail_aliases;
$stdout_sref = $result->get_gpg_stdout;
$stderr_sref = $result->get_gpg_stderr;
$status_sref = $result->get_gpg_status;
$gpg_exit_code = $result->get_gpg_rc;
=head1 DESCRIPTION
This class encapsulates decryption and verification results
of Mail::GPG. You never create objects of this class yourself,
they're all returned by Mail::GPG.
=head1 ATTRIBUTES
This class mainly has a bunch of attributes which reflect the
lib/Mail/GPG/Result.pm view on Meta::CPAN
recipient.
=item B<enc_key_ids>
This is an array reference of key ids in case the mail is encrypted
for several recipients.
=item B<enc_mails>
This is an array reference of the correspondent recipient mail adresses.
Entries may be empty, if gnugpg didn't report the mail address for
a specific key.
=item B<is_signed>
Indicates whether an entity was signed or not.
=item B<sign_ok>
Indicates whether the signature could be verified successfully or not.
lib/Mail/GPG/Result.pm view on Meta::CPAN
for a list of known levels and their meaning.
=item B<sign_mail>
The primary mail address of the sender who signed an entity.
=item B<sign_mail_aliases>
A reference to a list of the signer's mail alias addresses.
=item B<gpg_stdout>
This is reference to a scalar containing gpg's STDOUT output.
=item B<gpg_stderr>
This is reference to a scalar containing gpg's STDERR output.
=item B<gpg_rc>
Exit code of the gpg program. Don't rely on this, use the other
attributes to check wether operation was successful resp.
a verification went ok.
=back
=head1 METHODS
There are only two methods, both are for debugging purposes:
=head2 as_string
$string = $result->as_string ( no_stdout => $no_stdout )
Returns a printable string version of the object.
=over 4
=item no_stdout
If this option is set, gpg's stdout is ommitted in the
string represenation.
=back
=head2 as_short_string
$short_string = $result->as_short_string;
Returns a very short string representation, without any
gpg output, arranged in one line.
=head1 AUTHOR
Joern Reder <joern AT zyn.de>
=head1 COPYRIGHT
Copyright (C) 2004-2006 by Joern Reder, All Rights Reserved.
This library is free software; you can redistribute it
lib/Mail/GPG/Test.pm view on Meta::CPAN
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"
lib/Mail/GPG/Test.pm view on Meta::CPAN
. "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'};
t/02.sign.t view on Meta::CPAN
package Mail::GPG::Test;
use strict;
#no warnings;
use Test::More;
use MIME::Parser;
SKIP: {
if ( qx[gpg --version 2>&1 && echo GPGOK] !~ /GPGOK/ ) {
plan skip_all => "No gpg found in PATH";
}
eval { my $parser = MIME::Parser->new; $parser->decode_bodies(0) };
my $mime_tools_patched = $@ eq '';
if ( $mime_tools_patched ) {
plan tests => 31;
} else {
plan tests => 15;
t/02.sign.t view on Meta::CPAN
use_ok ("Mail::GPG::Test");
foreach my $use_long_key_ids ( 0, 1 ) {
my $test = Mail::GPG::Test->new(
use_long_key_ids => $use_long_key_ids
);
ok($test->init, "Mail::GPG::Test->init");
my $mg = $test->get_mail_gpg;
ok($mg, "Mail::GPG->new");
my $key_id = $mg->query_keyring (
search => $test->get_key_mail,
);
ok ($key_id eq $test->get_key_id, "Key ID query");
foreach my $invalid ( 0, 1 ) {
package Mail::GPG::Test;
use strict;
#no warnings;
use Test::More;
use MIME::Parser;
SKIP: {
if ( qx[gpg --version 2>&1 && echo GPGOK] !~ /GPGOK/ ) {
plan skip_all => "No gpg found in PATH";
}
plan tests => 31;
use_ok ("Mail::GPG::Test");
foreach my $use_long_key_ids ( 0, 1 ) {
my $test = Mail::GPG::Test->new(
use_long_key_ids => $use_long_key_ids
);
ok($test->init, "Mail::GPG::Test->init");
my $mg = $test->get_mail_gpg;
ok($mg, "Mail::GPG->new");
my $key_id = $mg->query_keyring (
search => $test->get_key_mail,
);
ok ($key_id eq $test->get_key_id, "Key ID retrieved");
foreach my $encoding ( qw( base64 quoted-printable ) ) {
package Mail::GPG::Test;
use strict;
#no warnings;
use Test::More;
use MIME::Parser;
SKIP: {
if ( qx[gpg --version 2>&1 && echo GPGOK] !~ /GPGOK/ ) {
plan skip_all => "No gpg found in PATH";
}
plan tests => 10;
use_ok ("Mail::GPG::Test");
my $test = Mail::GPG::Test->new;
ok($test->init, "Mail::GPG::Test->init");
my $mg = $test->get_mail_gpg;
ok($mg, "Mail::GPG->new");
my $key_id = $mg->query_keyring (
search => $test->get_key_mail,
);
ok ($key_id eq $test->get_key_id, "Key ID retrieved");
$test->big_test ( mg => $mg, chunks => 10_000 );
t/05.multipart.t view on Meta::CPAN
package Mail::GPG::Test;
use strict;
#no warnings;
use Test::More;
use MIME::Parser;
use MIME::Entity;
SKIP: {
if ( qx[gpg --version 2>&1 && echo GPGOK] !~ /GPGOK/ ) {
plan skip_all => "No gpg found in PATH";
}
plan tests => 3;
use_ok ("Mail::GPG::Test");
my $test = Mail::GPG::Test->new;
ok($test->init, "Mail::GPG::Test->init");
my $mg = $test->get_mail_gpg;
my $entity = MIME::Entity->build(
From => $test->get_key_mail,
Subject => "Mail::GPG Testmail",
Data => "", # a body is *required*, at least an empty one
Charset => "iso-8859-1",
Encoding => "base64",
);
$entity->attach(
t/06.querykeys.t view on Meta::CPAN
# PERLBOTIX<ätt>cpan.org, May 2015
package Mail::GPG::Test;
use strict;
use utf8;
use Test::More;
use MIME::Parser;
SKIP: {
if ( qx[gpg --version 2>&1 && echo GPGOK] !~ /GPGOK/ ) {
plan skip_all => "No gpg found in PATH";
}
BEGIN { plan tests => 29; }
BEGIN { use_ok ("Mail::GPG::Test"); }
# Hint: UTF8-file: ö = \x{c3b6}
my @test_cases = (
{
name => "GPGv1 - extracting valid keys",
input => <<'TEST',
tru:t:1:1431088683:0:3:1:5
pub:-:1024:17:062F00DAE20F5035:2004-02-10:::-:Jörn Reder Mail\x3a\x3aGPG Test Key <mailgpg@localdomain>::scaESCA:
sub:-:1024:16:6C187D0F196ED9E3:2004-02-10::::::e:
TEST
expected => [
['E20F5035', 'Jörn Reder Mail::GPG Test Key <mailgpg@localdomain>'],
['062F00DAE20F5035', 'Jörn Reder Mail::GPG Test Key <mailgpg@localdomain>'],
],
},
{
name => "GPGv2 - extracting valid keys",
input => <<'TEST',
tru:t:1:1429473192:0:3:1:5
pub:-:1024:17:062F00DAE20F5035:1076425915:::-:::scaESCA:
uid:-::::1076425915::588869ADE077B8FB05788A99565AEED15AED8231::Jörn Reder Mail\x3a\x3aGPG Test Key <mailgpg@localdomain>:
sub:-:1024:16:6C187D0F196ED9E3:1076425917::::::e:
TEST
expected => [
[ 'E20F5035', 'Jörn Reder Mail::GPG Test Key <mailgpg@localdomain>',
'196ED9E3', 'Jörn Reder Mail::GPG Test Key <mailgpg@localdomain>'],
[ '062F00DAE20F5035', 'Jörn Reder Mail::GPG Test Key <mailgpg@localdomain>',
'6C187D0F196ED9E3', 'Jörn Reder Mail::GPG Test Key <mailgpg@localdomain>'],
],
},
{
name => "Expired keys only.",
input => <<'TEST',
pub:e:1024:1:E3A5C360307E3D54:1142955357:1399122021::-:SuSE Package Signing Key <build@suse.de>:
sig:::1:E3A5C360307E3D54:1272978021:::::[selfsig]::13x:
TEST
t/06.querykeys.t view on Meta::CPAN
}
);
foreach my $use_long_key_ids ( 0, 1 ) {
my $tc_variant = "[" . ( $use_long_key_ids ? "long ":"short" ) . " keys] ";
my $test = Mail::GPG::Test->new( use_long_key_ids => $use_long_key_ids );
ok($test->init, "$tc_variant Mail::GPG::Test->init");
my $mg = $test->get_mail_gpg;
ok($mg, "$tc_variant Mail::GPG->new");
my (@res) = $mg->_parse_key_list( "\n" );
is (@res, 0, "$tc_variant Empty input.");
@res = $mg->_parse_key_list( "some junk" );
is (@res, 0, "$tc_variant Some junk.");
for my $tc (@test_cases) {
@res = $mg->_parse_key_list( $tc->{input},
( run in 0.872 second using v1.01-cache-2.11-cpan-df04353d9ac )