GnuPG - Perl module interface to the GNU Privacy Guard.

    use GnuPG qw( :algo );

    my $gpg = new GnuPG();

    $gpg->encrypt(  plaintext    => "file.txt",    output        => "file.gpg",
            armor    => 1,         sign    => 1,
            passphrase  => $secret );

    $gpg->decrypt( ciphertext    => "file.gpg",    output        => "file.txt" );

    $gpg->clearsign( plaintext => "file.txt", output => "file.txt.asc",
             passphrase => $secret,   armor => 1,
            );

    $gpg->verify( signature => "file.txt.asc", file => "file.txt" );

    $gpg->gen_key( name => "Joe Blow",        comment => "My GnuPG key",
           passphrase => $secret,
            );

    Example: my $gpg = new GnuPG();

    Example: $gpg->gen_key( algo => DSA_ELGAMAL, size => 1024,
                name => "My name" );

    Example: $gpg->import_keys( keys => [ qw( key.pub key.sec ) ] );

    Example: $gpg->export_keys( armor => 1, output => "keyring.pub" );

    Example: $gpg->encrypt( plaintext => file.txt, output => "file.gpg",
                sign => 1, passphrase => $secret
                );

    Example: $gpg->sign( plaintext => "file.txt", output => "file.txt.asc",
             armor => 1,
             );

    Example : my $sig = $gpg->verify( signature => "file.txt.asc",
                      file => "file.txt" );

    Example: $gpg->decrypt( ciphertext => "file.gpg", output => "file.txt"
                passphrase => $secret );

#
#    GnuPG.pm - Interface to the GNU Privacy Guard.
#
#    This file is part of GnuPG.pm.
#
#    Author: Francis J. Lacoste <francis.lacoste@Contre.COM>
#
#    Copyright (C) 2000 iNsu Innovations Inc.
#    Copyright (C) 2001 Francis J. Lacoste
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
package GnuPG;


use strict;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK  %EXPORT_TAGS );

BEGIN {
    require Exporter;

    @ISA = qw(Exporter);

    @EXPORT = qw();

    %EXPORT_TAGS = (
            algo   => [ qw(    DSA_ELGAMAL DSA ELGAMAL_ENCRYPT
                    ELGAMAL
                    ) ],
            trust  => [ qw(    TRUST_UNDEFINED    TRUST_NEVER
                    TRUST_MARGINAL    TRUST_FULLY
                    TRUST_ULTIMATE ) ],
           );

    Exporter::export_ok_tags( qw( algo trust ) );

    $VERSION = '0.17';
}

use constant DSA_ELGAMAL    => 1;
use constant DSA        => 2;
use constant ELGAMAL_ENCRYPT    => 3;
use constant ELGAMAL        => 4;

use constant TRUST_UNDEFINED    => -1;
use constant TRUST_NEVER    => 0;
use constant TRUST_MARGINAL    => 1;
use constant TRUST_FULLY    => 2;
use constant TRUST_ULTIMATE    => 3;

use Carp;
use POSIX qw();
use Symbol;
use Fcntl;

sub parse_trust {
    for (shift) {
    /ULTIMATE/  && do { return TRUST_ULTIMATE;  };
    /FULLY/        && do { return TRUST_FULLY;        };
    /MARGINAL/  && do { return TRUST_MARGINAL;  };
    /NEVER/        && do { return TRUST_NEVER;        };
    # Default
    return TRUST_UNDEFINED;
    }
}

sub options($;$) {
    my $self = shift;
    $self->{cmd_options} = shift if ( $_[0] );
    $self->{cmd_options};
}

sub command($;$) {
    my $self = shift;
    $self->{command} = shift if ( $_[0] );
    $self->{command};
}

sub args($;$) {
    my $self = shift;
    $self->{args} = shift if ( $_[0] );
    $self->{args};
}

sub cmdline($) {
    my $self = shift;
    my $args = [ $self->{gnupg_path} ];

    # Default options
    push @$args, "--no-tty" unless $self->{trace};
    push @$args, "--no-greeting", "--yes", "--status-fd", fileno $self->{status_fd},
         "--run-as-shm-coprocess", "0";

    # Check for homedir and options file
    push @$args, "--homedir", $self->{homedir} if $self->{homedir};
    push @$args, "--options", $self->{options} if $self->{options};

    # Command options
    push @$args, @{ $self->options };


    # Command and arguments
    push @$args, "--" . $self->command;
    push @$args, @{ $self->args };

    return $args;
}

sub end_gnupg($) {
    my $self = shift;

    print STDERR "GnuPG: closing status fd " . fileno ($self->{status_fd})
      . "\n"
    if $self->{trace};

    close $self->{status_fd}
      or croak "error while closing pipe: $!\n";

    waitpid $self->{gnupg_pid}, 0
      or croak "error while waiting for gpg: $!\n";

    for ( qw(protocol gnupg_pid shmid shm_size shm_lock_size
         command options args status_fd input output
         next_status ) )
    {
    delete $self->{$_};
    }

}

sub abort_gnupg($$) {
    my ($self,$msg) = @_;

    # Signal our child that it is the end
    if ($self->{gnupg_pid} && kill 0 => $self->{gnupg_pid} ) {
        kill INT => $self->{gnupg_pid};
    }

    $self->end_gnupg;

    confess ( $msg );
}

# Used to push back status information
sub next_status($$$) {
    my ($self,$cmd,$arg) = @_;

    $self->{next_status} = [$cmd,$arg];
}

sub read_from_status($) {
    my $self = shift;
    # Check if a status was pushed back
    if ( $self->{next_status} ) {
        my $status = $self->{next_status};
        $self->{next_status} = undef;
        return @$status;
    }

    print STDERR "GnuPG: reading from status fd " . fileno ($self->{status_fd}) . "\n" if $self->{trace};

    my $fd = $self->{status_fd};
    local $/ = "\n"; # Just to be sure
    my $line = <$fd>;
    unless ($line) {
        print STDERR "GnuPG: got from status fd: EOF" if $self->{trace};
        return ();
    }

    print STDERR "GnuPG: got from status fd: $line" if $self->{trace};

    my ( $cmd,$arg ) = $line =~ /\[GNUPG:\] (\w+) ?(.+)?$/;
    $self->abort_gnupg( "error communicating with gnupg: bad status line: $line\n" ) unless $cmd;
    print STDERR "Read in " . $cmd . " - " . $arg if $self->{trace};
    return wantarray ? ( $cmd, $arg ) : $cmd;
}

sub run_gnupg($) {
    my $self = shift;

    my $fd  = gensym;
    my $wfd = gensym;

    pipe $fd, $wfd
      or croak ( "error creating pipe: $!\n" );
    my $old = select $wfd; $| = 1;  # Unbuffer
    select $old;

    # Keep pipe open after close
    fcntl( $fd, F_SETFD, 0 )
    or croak "error removing close on exec flag: $!\n" ;
    fcntl( $wfd, F_SETFD, 0 )
    or croak "error removing close on exec flag: $!\n" ;

    my $pid = fork;
    croak( "error forking: $!" ) unless defined $pid;
    if ( $pid ) {
    # Parent
    close $wfd;

    $self->{status_fd} = $fd;
    $self->{gnupg_pid} = $pid;

    my ($cmd, $arg ) = $self->read_from_status;

    $self->abort_gnupg( "wrong response from gnupg (expected SHM_INFO): $cmd\n")
      unless ( $cmd eq "SHM_INFO" );

    my ( $proto, $gpid, $shmid, $sz, $lz ) =
      $arg =~ /pv=(\d+) pid=(\d+) shmid=(\d+) sz=(\d+) lz=(\d+)/;

    $self->abort_gnupg( "unsupported protocol version: $proto\n" )
      unless $proto == 1;

    $self->{protocol}        = $proto;
    $self->{shmid}            = $shmid;
    $self->{shm_size}        = $sz;
    $self->{shm_lock_size}  = $lz;
    } else {
    # Child
    $self->{status_fd} = $wfd;

    my $cmdline = $self->cmdline;
    unless ( $self->{trace} ) {
        open (STDERR, "> /dev/null" )
           or die "can't redirect stderr to /dev/null: $!\n";
    }

    # This is where we grab the data
    if ( ref $self->{input} && defined fileno $self->{input} ) {
        open ( STDIN, "<&" . fileno $self->{input} )
          or die "error setting up data input: $!\n";
    } elsif ( $self->{input} && -t STDIN) {
        open ( STDIN, $self->{input} )
          or die "error setting up data input: $!\n";
    } elsif ( $self->{input} ) {
      push(@{$cmdline}, $self->{input});
    }# Defaults to stdin

    # This is where the output goes
    if ( ref $self->{output} && defined fileno $self->{output} ) {
        open ( STDOUT, ">&" . fileno $self->{output} )
          or die "can't redirect stdout to proper output fd: $!\n";
    } elsif ( $self->{output} && -t STDOUT ) {
        open ( STDOUT, ">".$self->{output} )
          or die "can't open $self->{output} for output: $!\n";
    } elsif ( $self->{output} ) {
      my $gpg = shift(@{$cmdline});
      unshift(@{$cmdline}, '--output', $self->{output});
      unshift(@{$cmdline}, $gpg);
    } # Defaults to stdout

    # Close all open file descriptors except STDIN, STDOUT, STDERR
    # and the status filedescriptor.
    #
    # This is needed for the tie interface which opens pipes which
    # some ends must be closed in the child.
    #
    # Besides this is just plain good hygiene
    my $max_fd = POSIX::sysconf( &POSIX::_SC_OPEN_MAX ) || 256;
    foreach my $f ( 3 .. $max_fd ) {
        next if $f == fileno $self->{status_fd};
        POSIX::close( $f );
    }

    print STDERR "GnuPG: executing `" . @{$cmdline} . "`" if 1 ||$self->{trace};

    exec ( @$cmdline )
      or CORE::die "can't exec gnupg: $!\n";
    }
}

sub cpr_maybe_send($$$) {
    ($_[0])->cpr_send( @_[1, $#_], 1);
}

sub cpr_send($$$;$) {
    my ($self,$key,$value, $optional) = @_;

    my ( $cmd, $arg ) = $self->read_from_status;
    unless ( defined $cmd && $cmd =~ /^SHM_GET/) {
    $self->abort_gnupg( "protocol error: expected SHM_GET_XXX got $cmd\n" )
      unless $optional;
    $self->next_status( $cmd, $arg );
    return;
    }

    unless ( $arg eq $key ) {
    $self->abort_gnupg ( "protocol error: expected key $key got $arg\n" )
      unless $optional;
    return;
    }

    my $shmid        = $self->{shmid};
    my $shm_size    = $self->{shm_size};

    my $offset = 0;
    shmread $shmid,$offset,0,2
      or $self->abort_gnupg( "shared memory error: $!\n" );

    $offset = unpack "n", $offset;
    $self->abort_gnupg( "Too long parameter for shared memory\n" )
      if ( ( $shm_size - $offset ) < length $value );

    if ( $cmd eq "SHM_GET_BOOL" ) {
    my $truth = $value ? 1 : 0;
    shmwrite $shmid, pack( "nC", 1, $truth ), $offset, 3
      or $self->abort_gnupg( "shared memory error: $!\n" );
    } else {
    my $len = length $value;
    shmwrite $shmid, pack( "na*", $len, $value ), $offset, $len + 2
      or $self->abort_gnupg( "shared memory error: $!\n" );
    }

    # Set data ready flag
    shmwrite $shmid, "\001", 3, 1
      or $self->abort_gnupg( "shared memory error: $!\n" );
    kill USR1 => $self->{gnupg_pid};
}

sub send_passphrase($$) {
    my ($self,$passwd) = @_;

    # GnuPG should now tell us that it needs a passphrase
    my $cmd = $self->read_from_status;
    # Skip UserID hint
    $cmd = $self->read_from_status if ( $cmd =~ /USERID_HINT/ );
    if ($cmd =~ /GOOD_PASSPHRASE/) { # This means we didnt need a passphrase
      $self->next_status($cmd); # We push this back on for read_from_status
      return; 
    }
    $self->abort_gnupg( "Protocol error: expected NEED_PASSPHRASE.* got $cmd\n")
      unless $cmd =~ /NEED_PASSPHRASE/;
    $self->cpr_send( "passphrase.enter", $passwd );
    unless ( $passwd ) {
    my $cmd = $self->read_from_status;
    $self->abort_gnupg( "Protocol error: expected MISSING_PASSPHRASE got $cmd\n" )
      unless $cmd eq "MISSING_PASSPHRASE";
    }
}

sub new($%) {
    my $proto = shift;
    my $class = ref $proto || $proto;

    my %args = @_;

    my $self = {};
    if ($args{homedir}) {
    croak ( "Invalid home directory: $args{homedir}\n")
      unless -d $args{homedir} && -w _ && -x _;
    $self->{homedir} = $args{homedir};
    }
    if ($args{options}) {
    croak ( "Invalid options file: $args{options}\n")
      unless -r $args{options};
    $self->{options} = $args{options};
    }
    if ( $args{gnupg_path} ) {
    croak ( "Invalid gpg path: $args{gnupg_path}\n")
      unless -x $args{gnupg_path};
    $self->{gnupg_path} = $args{gnupg_path};
    } else {
    my ($path) = grep { -x "$_/gpg" } split /:/, $ENV{PATH};
    croak ( "Couldn't find gpg in PATH ($ENV{PATH})\n" )
      unless $path;
    $self->{gnupg_path} = "$path/gpg";
    }
    $self->{trace} = $args{trace} ? 1 : 0;

    bless $self, $class;
}

sub DESTROY {
    my $self = shift;
    # Signal our child that it is the end
    if ($self->{gnupg_pid} && kill 0 => $self->{gnupg_pid} ) {
    kill INT => $self->{gnupg_pid};
    }
}

sub gen_key($%) {
    my ($self,%args) = @_;

    my $algo      = $args{algo};
    $algo ||= DSA_ELGAMAL;

    my $size      = $args{size};
    $size ||= 1024;
    croak ( "Keysize is too small: $size" ) if $size < 768;
    croak ( "Keysize is too big: $size" )   if $size > 2048;

    my $expire      = $args{valid};
    $expire          ||= 0;

    my $passphrase = $args{passphrase} || "";
    my $name      = $args{name};

    croak "Missing key name\n"      unless $name;
    croak "Invalid name: $name\n"
      unless $name =~ /^\s*[^0-9\<\(\[\]\)\>][^\<\(\[\]\)\>]+$/;

    my $email      = $args{email};
    if ( $email ) {
    croak "Invalid email address: $email"
      unless $email =~ /^\s*        # Whitespace are okay
                                [a-zA-Z0-9_-]    # Doesn't start with a dot
                                [a-zA-Z0-9_.-]*
                                \@        # Contains at most one at
                                [a-zA-Z0-9_.-]+
                                [a-zA-Z0-9_-]    # Doesn't end in a dot
                                      /x
                 && $email !~ /\.\./;
    } else {
    $email = "";
    }

    my $comment      = $args{comment};
    if ( $comment ) {
    croak "Invalid characters in comment" if $comment =~ /[()]/;
    } else {
    $comment = "";
    }

    $self->command( "gen-key" );
    $self->options( [] );
    $self->args( [] );

    $self->run_gnupg;

    $self->cpr_send("keygen.algo", $algo );
    if ( $algo == ELGAMAL ) {
        # Shitty interactive program, yes I'm sure.
        # I'm a program, I can't change my mind now.
        $self->cpr_send( "keygen.algo.elg_se", 1 )
    }
    $self->cpr_send( "keygen.size",        $size );
    $self->cpr_send( "keygen.valid",    $expire );
    $self->cpr_send( "keygen.name",        $name );
    $self->cpr_send( "keygen.email",    $email );
    $self->cpr_send( "keygen.comment",    $comment );

    $self->send_passphrase( $passphrase );

    $self->end_gnupg;

    # Woof. We should now have a generated key !
}

sub import_keys($%) {
    my ($self,%args) = @_;


    $self->command( "import" );
    $self->options( [] );

    my $count;
    if ( ref $args{keys} ) {
    $self->args( $args{keys} );
    } else {
    # Only one file to import
    $self->{input} = $args{keys};
    $self->args( [] );
    }

    $self->run_gnupg;
  FILE:
    my $num_files = ref $args{keys} ? @{$args{keys}} : 1;
    my ($cmd,$arg);

    # We will see one IMPORTED for each key that is imported
  KEY:
    while ( 1 ) {
    ($cmd,$arg) = $self->read_from_status;
    last KEY unless $cmd =~ /IMPORTED/;
    $count++
    }

    # We will see one IMPORT_RES for all files processed
    $self->abort_gnupg ( "protocol error expected IMPORT_OK got $cmd\n" )
      unless $cmd =~ /IMPORT_OK/;
    $self->end_gnupg;

    # We return the number of imported keys
    return $count;
}

sub export_keys($%) {
    my ($self,%args) = @_;

    my $options = [];
    push @$options, "--armor"        if $args{armor};

    $self->{output} = $args{output};

    my $keys = [];
    if ( $args{keys}) {
    push @$keys,
      ref $args{keys} ? @{$args{keys}} : $args{keys};
    }

    if ( $args{secret} ) {
    $self->command( "export-secret-keys" );
    } elsif ( $args{all} ){
    $self->command( "export-all" );
    } else {
    $self->command( "export" );
    }
    $self->options( $options );
    $self->args( $keys );

    $self->run_gnupg;
    $self->end_gnupg;
}

sub encrypt($%) {
    my ($self,%args) = @_;

    my $options = [];
    croak ( "no recipient specified\n" )
      unless $args{recipient} or $args{symmetric};
    $args{recipient} =~ s/ /\ /g; # Escape spaces in the recipient. This fills some strange edge case
    push @$options, "--recipient" => $args{recipient};

    push @$options, "--sign"        if $args{sign};
    croak ( "can't sign an symmetric encrypted message\n" )
      if $args{sign} and $args{symmetric};

    my $passphrase  = $args{passphrase} || "";

    push @$options, "--armor"        if $args{armor};
    push @$options, "--local-user", $args{"local-user"}
      if defined $args{"local-user"};

    $self->{input}  = $args{plaintext} || $args{input};
    $self->{output} = $args{output};
    if ( $args{symmetric} ) {
    $self->command( "symmetric" );
    } else {
    $self->command( "encrypt" );
    }
    $self->options( $options );
    $self->args( [] );

    $self->run_gnupg;

    # Unless we decided to sign or are using symmetric cipher, we are done
    if ( $args{sign} or $args{symmetric} ) {
        $self->send_passphrase( $passphrase );
        if ( $args{sign} ) {
            my ($cmd,$line) = $self->read_from_status;
            $self->abort_gnupg( "invalid passphrase - $cmd\n" )
              unless $cmd =~ /GOOD_PASSPHRASE/;
        }
    }

    # It is possible that this key has no assigned trust value.
    # Assume the caller knows what he is doing.
    $self->cpr_maybe_send( "untrusted_key.override", 1 );

    $self->end_gnupg unless $args{tie_mode};
}

sub sign($%) {
    my ($self,%args) = @_;

    my $options = [];
    my $passphrase  = $args{passphrase} || "";

    push @$options, "--armor"        if $args{armor};
    push @$options, "--local-user", $args{"local-user"}
      if defined $args{"local-user"};

    $self->{input}  = $args{plaintext} || $args{input};
    $self->{output} = $args{output};
    if ( $args{clearsign} ) {
    $self->command( "clearsign" );
    } elsif ( $args{"detach-sign"}) {
    $self->command( "detach-sign" );
    } else {
    $self->command( "sign" );
    }
    $self->options( $options );
    $self->args( [] );

    $self->run_gnupg;

    # We need to unlock the private key
    $self->send_passphrase( $passphrase );
    my ($cmd,$line) = $self->read_from_status;
    $self->abort_gnupg( "invalid passphrase - $cmd\n" ) 
      unless $cmd =~ /GOOD_PASSPHRASE/;

    $self->end_gnupg unless $args{tie_mode};
}

sub clearsign($%) {
    my $self = shift;
    $self->sign( @_, clearsign => 1 );
}


sub check_sig($;$$) {
    my ( $self, $cmd, $arg) = @_;

    # Our caller may already have grabbed the first line of
    # signature reporting.
    ($cmd,$arg) = $self->read_from_status unless ( $cmd );

    # Ignore patent warnings.
    ( $cmd, $arg ) = $self->read_from_status()
      if ( $cmd =~ /RSA_OR_IDEA/ );

    # Ignore automatic key imports
    ( $cmd, $arg ) = $self->read_from_status()
      if ( $cmd =~ /IMPORTED/ );

    ( $cmd, $arg ) = $self->read_from_status()
      if ( $cmd =~ /IMPORT_OK/ );

    ( $cmd, $arg ) = $self->read_from_status()
      if ( $cmd =~ /IMPORT_RES/ );

    $self->abort_gnupg( "invalid signature from ", $arg =~ /[^ ](.+)/, "\n" )
      if ( $cmd =~ /BADSIG/);

    if ( $cmd =~ /ERRSIG/)
      {
        my ($keyid, $key_algo, $digest_algo, $sig_class, $timestamp, $rc)
           = split ' ', $arg;
        if ($rc == 9)
          {
            ($cmd, $arg) = $self->read_from_status();
            $self->abort_gnupg( "no public key $keyid" );
          }
        $self->abort_gnupg( "error verifying signature from $keyid" )
      }

    $self->abort_gnupg ( "protocol error: expected SIG_ID" )
      unless $cmd =~ /SIG_ID/;
    my ( $sigid, $date, $time ) = split /\s+/, $arg;

    ( $cmd, $arg ) = $self->read_from_status;
    $self->abort_gnupg ( "protocol error: expected GOODSIG" )
      unless $cmd =~ /GOODSIG/;
    my ( $keyid, $name ) = split /\s+/, $arg, 2;

    ( $cmd, $arg ) = $self->read_from_status;
    my $policy_url = undef;
    if ( $cmd =~ /POLICY_URL/ ) {
        $policy_url = $arg;
        ( $cmd, $arg ) = $self->read_from_status;
    }

    $self->abort_gnupg ( "protocol error: expected VALIDSIG" )
      unless $cmd =~ /VALIDSIG/;
    my ( $fingerprint ) = split /\s+/, $arg, 2;

    ( $cmd, $arg ) = $self->read_from_status;
    $self->abort_gnupg ( "protocol error: expected TRUST*" )
      unless $cmd =~ /TRUST/;
    my ($trust) = parse_trust( $cmd );

    return { sigid        => $sigid,
         date        => $date,
         timestamp        => $time,
         keyid        => $keyid,
         user        => $name,
         fingerprint    => $fingerprint,
         trust        => $trust,
         policy_url        => $policy_url,
       };
}

sub verify($%) {
    my ($self,%args) = @_;

    croak ( "missing signature argument\n" ) unless $args{signature};
    my $files = [];
    if ( $args{file} ) {
    croak ( "detached signature must be in a file\n" )
      unless -f $args{signature};
    push @$files, $args{signature},
      ref $args{file} ? @{$args{file}} : $args{file};
    } else {
    $self->{input} = $args{signature};
    }
    $self->command( "verify" );
    $self->options( [] );
    $self->args( $files );

    $self->run_gnupg;
    my $sig = $self->check_sig;

    $self->end_gnupg;

    return $sig;
}

sub decrypt($%) {
    my $self = shift;
    my %args = @_;

    $self->{input}  = $args{ciphertext} || $args{input};
    $self->{output} = $args{output};
    $self->command( "decrypt" );
    $self->options( [] );
    $self->args( [] );

    $self->run_gnupg;

    return $self->decrypt_postwrite( @_ ) unless $args{tie_mode};
}

sub decrypt_postwrite($%) {
    my ($self,%args) = @_;

    my $passphrase  = $args{passphrase} || "";

    my ( $cmd, $arg );
    unless ( $args{symmetric} ) {
    ( $cmd, $arg ) = $self->read_from_status;
    $self->abort_gnupg ( "protocol error: expected ENC_TO got $cmd: \n" )
      unless $cmd =~ /ENC_TO/;
    }

    $self->send_passphrase( $passphrase );
    ($cmd,$arg) = $self->read_from_status;

    $self->abort_gnupg ( "invalid passphrase - $cmd\n" )
      if $cmd =~ /BAD_PASSPHRASE/;

    my $sig = undef;

    if ( ! $args{symmetric} ) {
      $self->abort_gnupg ( "protocol error: expected GOOD_PASSPHRASE got $cmd: \n" )
        unless $cmd =~ /GOOD_PASSPHRASE/;

      $sig = $self->decrypt_postread() unless $args{tie_mode};
    } else {
        # gnupg 1.0.2 adds this status message
        ( $cmd, $arg ) = $self->read_from_status() if $cmd =~ /BEGIN_DECRYPTION/;

        $self->abort_gnupg( "invalid passphrase - $cmd" ) unless $cmd =~ /PLAINTEXT/;
    }

    $self->end_gnupg() unless $args{tie_mode};

    return $sig ? $sig : 1;
}

sub decrypt_postread($) {
    my $self = shift;

    my @cmds;
    # gnupg 1.0.2 adds this status message
    my ( $cmd, $arg ) = $self->read_from_status;
    push @cmds, $cmd;

    if ($cmd =~ /BEGIN_DECRYPTION/) {
    ( $cmd, $arg ) = $self->read_from_status();
    push @cmds, $cmd;
    };

    my $sig = undef;
    while (defined $cmd && !($cmd =~ /DECRYPTION_OKAY/)) {
    if ( $cmd =~ /SIG_ID/ ) {
        $sig = $self->check_sig( $cmd, $arg );
    }
    ( $cmd, $arg ) = $self->read_from_status();
    push @cmds, $cmd if defined $cmd;
    };

    my $cmds = join ', ', @cmds;
    $self->abort_gnupg( "protocol error: expected DECRYPTION_OKAY but never got it (all I saw was: $cmds): \n" )
      unless $cmd =~ /DECRYPTION_OKAY/;

    return $sig ? $sig : 1;
}

1;
__END__