The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl

use strict;
use warnings;
use Test::More tests => 48;
use Test::Exception;
use IO::Scalar;

BEGIN {
	use_ok( 'Crypt::GpgME' );
}

delete $ENV{GPG_AGENT_INFO};
$ENV{GNUPGHOME} = 't/gpg';

my $ctx;
lives_ok (sub {
        $ctx = Crypt::GpgME->new;
}, 'create new context');

isa_ok ($ctx, 'Crypt::GpgME');

my $plain = IO::Scalar->new(\q/test test test/);

my $called = 0;

sub pass_cb {
    is (@_, 4, 'cb got 4 params');

    my ($c, $uid_hint, $passphrase_info, $prev_was_bad) = @_;

    isa_ok ($c, 'Crypt::GpgME');
    ok($c == $ctx, 'context references are equal');

    like ($uid_hint, qr/^[A-F0-9]{16}\s+[^<]+\s+<[^>]+>$/, 'uid hint looks sane');
    like ($passphrase_info, qr/^[A-F0-9]/, 'passphrase info looks sane');
    is ($prev_was_bad, ! !$called % 3, 'prev_was_bad looks sane');

    ++$called;
}

lives_ok (sub {
        $ctx->set_passphrase_cb(\&pass_cb);
}, 'setting passphrase cb without user data');

is ($called, 0, 'just setting the cb doesn\'t call it');

eval {
    $ctx->sign($plain, 'clear');
};

ok ($called > 0, 'signing calls the cb');

$called = 0;

sub pass_cb_ud {
    is (@_, 5, 'cb got 5 params');

    my ($c, $uid_hint, $passphrase_info, $prev_was_bad, $user_data) = @_;

    isa_ok ($c, 'Crypt::GpgME');
    ok($c == $ctx, 'context references are equal');

    like ($uid_hint, qr/^[A-F0-9]{16}\s+[^<]+\s+<[^>]+>$/, 'uid hint looks sane');
    like ($passphrase_info, qr/^[A-F0-9]/, 'passphrase info looks sane');
    is ($prev_was_bad, ! !$called % 3, 'prev_was_bad looks sane');
    is ($user_data, 'foo', 'user data looks sane');

    ++$called;
}

lives_ok (sub {
        $ctx->set_passphrase_cb(\&pass_cb_ud, 'foo');
}, 'setting passphrase cb with user data');

is ($called, 0, 'just setting the cb doesn\'t call it');

eval {
    $ctx->sign($plain, 'clear');
};

ok ($called > 0, 'signing calls the cb');