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

use strict;
use warnings;
use Test::More qw/no_plan/;
use Test::Exception;
use Scalar::Util qw/refaddr/;
use lib "lib";
use_ok "Digest::PBKDF2";

### Base class testing

my $rawsalted   = Crypt::PBKDF2->new;
my $rawunsalted = Crypt::PBKDF2->new;

is( $rawsalted->salt_len, 4, "By default my salt_len is 4" );
throws_ok { $rawsalted->salt_len(5) } qr/read-only accessor/,
    "I cannot change my salt_len";

my $salted = $rawsalted->generate('bebop');
my $unsalted = $rawunsalted->generate( 'bebop', salt => undef );

isnt( $salted, $unsalted, "The unsalted does not equal the salted" );

ok( $rawsalted->validate( $salted, 'bebop' ),
    "I can validate my salted password without specifying the salt" );
ok( $rawunsalted->validate( $unsalted, 'bebop' ),
    "I can validate my unsalted password"
);

### My module testing

my $orig = Digest::PBKDF2->new;
can_ok( $orig, qw/new clone add digest/ );

diag "I will try a password_pre_salt first";
lives_ok( sub { $orig->add('cool') }, "I can add one chunk" );

lives_ok( sub { $orig->add('jazz') }, "I can add another chunk" );

my $clone;
lives_ok( sub { $clone = $orig->clone }, "I can clone my object" );
isnt(
    refaddr $orig,
    refaddr $clone,
    "Cloning gives me a new Digest::PBKDF2 object"
);
isnt(
    refaddr \$orig->{_data},
    refaddr \$clone->{_data},
    "Cloning gives me a new data slot"
);
lives_ok( sub { delete $clone->{_data} },
    "I can delete the data in my clone" );
is( $clone->{_data}, undef,      "And the data is gone" );
is( $orig->{_data},  'cooljazz', "And the original remains intact" );
lives_ok( sub { $clone->add('cooljazz') }, "I can put back the clone data" );

###
my ( $clone_digest, $clone2_digest, $orig_digest, $orig2_digest );

( $clone_digest, $orig_digest ) = ( $clone->digest, $orig->digest );

is( $clone_digest, $orig_digest,
    "Clone and orginal produce the same string" );

is( $clone_digest,
    '$PBKDF2$HMACSHA1:1000:Y29vbA==$6LZU9raZ5BzrMRo0mwa8Z7ON+Mc=',
    "And that string is what it should be"
);
is( $orig_digest,
    '$PBKDF2$HMACSHA1:1000:Y29vbA==$6LZU9raZ5BzrMRo0mwa8Z7ON+Mc=',
    "Making sure it is..."
);

### No salt

diag "I will try no salt this time";

my $orig2 = Digest::PBKDF2->new;

lives_ok( sub { $orig2->add('jazz') }, "I can add the password chunk" );

my $clone2;
lives_ok( sub { $clone2 = $orig2->clone }, "I can clone my object" );
isnt(
    refaddr $orig2,
    refaddr $clone2,
    "Cloning gives me a new Digest::PBKDF2 object"
);
( $clone2_digest, $orig2_digest ) = ( $clone2->digest, $orig2->digest );
is( $clone2_digest, $orig2_digest,
    "Clone and orginal produce the same string" );
is( $clone2_digest,
    '$PBKDF2$HMACSHA1:1000:$zpYCcE4kGAQD37LhEQa56B7/kCc=',
    "And that string is what it should be"
);
is( $orig2_digest,
    '$PBKDF2$HMACSHA1:1000:$zpYCcE4kGAQD37LhEQa56B7/kCc=',
    "Making sure it is..."
);