view release on metacpan or  search on metacpan

t/02-encrypt-decrypt.t  view on Meta::CPAN

        Crypt::Age->encrypt(plaintext => $plaintext, recipients => [uc($public)]);
    };
    is($@, '', 'an all-uppercase AGE1... recipient encrypts without dying');
    my $decrypted = Crypt::Age->decrypt(ciphertext => $encrypted, identities => [$secret]);
    is($decrypted, $plaintext,
        'ciphertext for an uppercase recipient decrypts with the matching identity');

    # (2) a mixed-case recipient is rejected, but specifically by the
    # bech32 mixed-case guard, not by the "Unsupported recipient format"
    # branch. That distinction is the regression: it shows the string
    # passed the /^age1/i prefix test and was only then rejected inside
    # decode_public_key -- a test that only checked "dies somehow" would
    # not catch the prefix test itself going missing.
    my $mixed = 'Age1' . substr($public, 4);
    ok($mixed =~ /^age1/i && $mixed ne lc($mixed) && $mixed ne uc($mixed),
        'fixture: mixed-case recipient matches the prefix case-insensitively and is genuinely mixed case')
        or die 'fixture assumption broken -- generated public key data has no lowercase letter to mix';

    eval { Crypt::Age->encrypt(plaintext => $plaintext, recipients => [$mixed]) };
    like($@, qr/Invalid bech32: mixed case/,
        'a mixed-case recipient dies with the bech32 mixed-case guard');
    unlike($@, qr/Unsupported recipient format/,
        'and not with the encrypt-side "Unsupported recipient format" rejection');

    # (3) an all-lowercase identity still decrypts -- the /i on the
    # identity side predates #19 and must stay untouched by it.
    my $encrypted2 = Crypt::Age->encrypt(plaintext => $plaintext, recipients => [$public]);
    my $decrypted2 = Crypt::Age->decrypt(ciphertext => $encrypted2, identities => [lc($secret)]);
    is($decrypted2, $plaintext, 'an all-lowercase identity still decrypts');
}

# Ticket #22 regression, the version-line half: parse_from_fh's version
# check used to interpolate the first line straight into the croak
# ("Invalid age version: $version_line"). That is unbounded when the input
# has no newline at all: parse_from_fh reads under `local $/ = "\n"`, so
# with no newline to stop at, <$fh> reads to EOF and the *entire* input
# becomes "the first line". Feed decrypt a plaintext string with no
# trailing newline that cannot possibly be a real age header, and confirm
# none of it survives into the error.
{
    my ($public, $secret) = Crypt::Age->generate_keypair;
    my $not_an_age_file = 'this is definitely not an age header and has no newline at all';
    ok(index($not_an_age_file, "\n") == -1, 'fixture: input contains no newline');

    my $err = do {
        local $@;
        eval { Crypt::Age->decrypt(ciphertext => $not_an_age_file, identities => [$secret]) };
        $@;
    };

    ok($err, 'decrypting a no-newline non-age input dies');
    like($err,
        qr/^Invalid age version: expected the literal age-encryption\.org\/v1 version line/,
        'the message names the expected literal version line');
    ok(index($err, $not_an_age_file) == -1,
        'none of the input content appears in the error');
}

# Ticket #26, carrying the #24 regression: the string API takes bytes. Perl
# refuses to map a string holding a code point above 0xFF into an in-memory
# handle, so handing encrypt/decrypt a character (decoded) string used to fail
# at the *input* open. #24 made that open croak instead of die, which put the
# blame on the caller -- those location assertions are kept below, they are
# the point of the block. #26 replaces what the caller is told: EINVAL from an
# in-memory open ("open on input string: Invalid argument") names no cause and
# suggests no fix, so encrypt/decrypt now run perl's own downgrade test first
# and say what is wrong. The open is no longer reached on this path, so perl's
# "code points over 0xFF" warning is gone too -- asserted, not suppressed.
#
# The output-side opens (on a lexical the method owns, written through :raw)
# have no caller-reachable failure and are deliberately not covered here.
{
    my ($public, $secret) = Crypt::Age->generate_keypair;
    my $wide = "\x{100} not bytes";

    my ($enc_err, $enc_line, @enc_warn);
    {
        local $SIG{__WARN__} = sub { push @enc_warn, $_[0] };
        local $@;
        $enc_line = __LINE__ + 1;
        eval { Crypt::Age->encrypt(plaintext => $wide, recipients => [$public]) };
        $enc_err = $@;
    }

    ok($enc_err, 'encrypt with a wide-character plaintext dies');
    like($enc_err,
        qr/^plaintext must be a byte string: it holds a code point above 0xFF, encode it before passing it in\b/,
        'the message names the cause and the fix, not EINVAL');
    unlike($enc_err, qr/Invalid argument/,
        'encrypt no longer passes perl\'s EINVAL through');
    is_deeply(\@enc_warn, [],
        'the check runs before the open, so perl emits no >0xFF warning');
    unlike($enc_err, qr{Crypt/Age\.pm},
        'encrypt croaks: Crypt/Age.pm is not blamed as the origin');
    my $enc_where = quotemeta(__FILE__).' line '.$enc_line;
    like($enc_err, qr/$enc_where/,
        'encrypt reports the caller position in this test file');
    ok(index($enc_err, 'not bytes') == -1,
        'no part of the plaintext appears in the error');

    my ($dec_err, $dec_line, @dec_warn);
    {
        local $SIG{__WARN__} = sub { push @dec_warn, $_[0] };
        local $@;
        $dec_line = __LINE__ + 1;
        eval { Crypt::Age->decrypt(ciphertext => $wide, identities => [$secret]) };
        $dec_err = $@;
    }

    ok($dec_err, 'decrypt with a wide-character ciphertext dies');
    like($dec_err,
        qr/^ciphertext must be a byte string: it holds a code point above 0xFF, read it with :raw rather than decoding it\b/,
        'the message names the cause and the fix, not EINVAL');
    unlike($dec_err, qr/Invalid argument/,
        'decrypt no longer passes perl\'s EINVAL through');
    is_deeply(\@dec_warn, [],
        'the check runs before the open, so perl emits no >0xFF warning');
    unlike($dec_err, qr{Crypt/Age\.pm},
        'decrypt croaks: Crypt/Age.pm is not blamed as the origin');
    my $dec_where = quotemeta(__FILE__).' line '.$dec_line;
    like($dec_err, qr/$dec_where/,