1#!/usr/bin/perl 2# 3# Basic tests for PGP::Sign functionality. 4# 5# Copyright 1998-2001, 2004, 2007, 2018, 2020 Russ Allbery <rra@cpan.org> 6# 7# This program is free software; you may redistribute it and/or modify it 8# under the same terms as Perl itself. 9# 10# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl 11 12use 5.020; 13use autodie; 14use warnings; 15 16use lib 't/lib'; 17 18use File::Spec; 19use IO::File; 20use IPC::Cmd qw(can_run); 21use Test::More; 22use Test::PGP qw(gpg_is_gpg1 gpg_is_new_enough); 23 24# Check that GnuPG is available. If so, load the module and set the plan. 25BEGIN { 26 if (!can_run('gpg')) { 27 plan skip_all => 'gpg binary not available'; 28 } elsif (!gpg_is_new_enough('gpg')) { 29 plan skip_all => 'gpg binary is older than 1.4.20 or 2.1.23'; 30 } else { 31 use_ok('PGP::Sign'); 32 } 33} 34 35# Locate our test data directory for later use. 36my $data = 't/data'; 37 38# Open and load our data file. This is the sample data that we'll be signing 39# and checking signatures against. 40open(my $fh, '<', "$data/message"); 41my @data = <$fh>; 42close($fh); 43 44# The key ID and pass phrase to use for testing. 45my $keyid = 'testing'; 46my $passphrase = 'testing'; 47 48# There are three possibilities: gpg is GnuPG v1, gpg is GnuPG v2 and v1 is 49# not available, or gpg is GnuPG v2 and gpg1 is GnuPG v1. We ideally want to 50# test both styles, but we'll take what we can get. 51my @styles; 52if (gpg_is_gpg1()) { 53 @styles = qw(GPG1); 54} elsif (!can_run('gpg1')) { 55 @styles = qw(GPG); 56} else { 57 @styles = qw(GPG GPG1); 58} 59 60# Run all the tests twice, once with GnuPG v2 and then with GnuPG v1. 61for my $style (@styles) { 62 note("Testing PGPSTYLE $style"); 63 local $PGP::Sign::PGPSTYLE = $style; 64 my $pgpdir = ($style eq 'GPG') ? 'gnupg2' : 'gnupg1'; 65 local $PGP::Sign::PGPPATH = File::Spec->catdir($data, $pgpdir); 66 if ($style eq 'GPG1' && gpg_is_gpg1()) { 67 $PGP::Sign::PGPS = 'gpg'; 68 $PGP::Sign::PGPV = 'gpg'; 69 } 70 71 # Generate a signature. 72 my ($signature, $version) = pgp_sign($keyid, $passphrase, @data); 73 ok($signature, 'Sign'); 74 is(PGP::Sign::pgp_error(), q{}, '...with no errors'); 75 isnt($signature, undef, 'Signature'); 76 is(PGP::Sign::pgp_error(), q{}, '...with no errors'); 77 78 # Check signature. 79 is(pgp_verify($signature, $version, @data), $keyid, 'Verify'); 80 is(PGP::Sign::pgp_error(), q{}, '...with no errors'); 81 82 # The same without version, which shouldn't matter. 83 is(pgp_verify($signature, undef, @data), $keyid, 'Verify without version'); 84 is(PGP::Sign::pgp_error(), q{}, '...with no errors'); 85 86 # Check a failed signature by appending some nonsense to the data. 87 is(pgp_verify($signature, $version, @data, 'xyzzy'), q{}, 88 'Verify invalid'); 89 is(PGP::Sign::pgp_error(), q{}, '...with no errors'); 90 91 # Test taking code from a code ref and then verifying the reulting 92 # signature. Also test accepting only one return value from pgp_sign(). 93 my @code_input = @data; 94 my $data_ref = sub { 95 my $line = shift(@code_input); 96 return $line; 97 }; 98 $signature = pgp_sign($keyid, $passphrase, $data_ref); 99 isnt($signature, undef, 'Signature from code ref'); 100 is(PGP::Sign::pgp_error(), q{}, '...with no errors'); 101 is(pgp_verify($signature, $version, @data), $keyid, 'Verifies'); 102 is(PGP::Sign::pgp_error(), q{}, '...with no errors'); 103 104 # Test whitespace munging. 105 { 106 local $PGP::Sign::MUNGE = 1; 107 ($signature, $version) = pgp_sign($keyid, $passphrase, q{ }); 108 } 109 is(pgp_verify($signature, $version, q{ }), 110 q{}, 'Munged does not match'); 111 is(pgp_verify($signature, $version, q{}), 112 $keyid, '...but does match empty'); 113 { 114 local $PGP::Sign::MUNGE = 1; 115 is(pgp_verify($signature, $version, q{ }), 116 $keyid, '...and does match munged'); 117 } 118 119 # Test error handling. 120 is(pgp_verify('asfasdfasf', undef, @data), undef, 'Invalid signature'); 121 my @errors = PGP::Sign::pgp_error(); 122 my $errors = PGP::Sign::pgp_error(); 123 like( 124 $errors[-1], 125 qr{^ Execution [ ] of [ ] gpg.? [ ] failed}xms, 126 'Invalid signature', 127 ); 128 like( 129 $errors, 130 qr{\n Execution [ ] of [ ] gpg.? [ ] failed}xms, 131 'Errors contain newlines', 132 ); 133 is($errors, join(q{}, @errors), 'Two presentations of errors match'); 134} 135 136# Report the end of testing. 137done_testing(21 * scalar(@styles) + 1); 138