[Bast-commits] r9402 - in trunk/DBIx-Class-EncodedColumn: . etc
lib/DBIx/Class t t/lib/DigestTest t/lib/DigestTest/Schema t/var
groditi at dev.catalyst.perl.org
groditi at dev.catalyst.perl.org
Mon May 17 18:03:28 GMT 2010
Author: groditi
Date: 2010-05-17 19:03:28 +0100 (Mon, 17 May 2010)
New Revision: 9402
Added:
trunk/DBIx-Class-EncodedColumn/t/bcrypt.t
trunk/DBIx-Class-EncodedColumn/t/class_level_encoders.t
trunk/DBIx-Class-EncodedColumn/t/digest_sha.t
trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/Bcrypt.pm
trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/PGP.pm
trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/SHA.pm
trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/Whirlpool.pm
trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/pubring.gpg
trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/secring.gpg
trunk/DBIx-Class-EncodedColumn/t/open_pgp.t
trunk/DBIx-Class-EncodedColumn/t/whirlpool.t
Removed:
trunk/DBIx-Class-EncodedColumn/t/01load.t
trunk/DBIx-Class-EncodedColumn/t/02digest.t
trunk/DBIx-Class-EncodedColumn/t/03crosstable_leak.t
trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/TableA.pm
trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/TableB.pm
trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/Test.pm
Modified:
trunk/DBIx-Class-EncodedColumn/Changes
trunk/DBIx-Class-EncodedColumn/Makefile.PL
trunk/DBIx-Class-EncodedColumn/etc/make_test_ddl_dir.pl
trunk/DBIx-Class-EncodedColumn/lib/DBIx/Class/EncodedColumn.pm
trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema.pm
trunk/DBIx-Class-EncodedColumn/t/var/DigestTest-Schema-1.x-SQLite.sql
Log:
completely re-written test suite, eliminated superfluous requirements, fixed test-db deployment and cleaned up Makefile.PL
Modified: trunk/DBIx-Class-EncodedColumn/Changes
===================================================================
--- trunk/DBIx-Class-EncodedColumn/Changes 2010-05-17 14:31:46 UTC (rev 9401)
+++ trunk/DBIx-Class-EncodedColumn/Changes 2010-05-17 18:03:28 UTC (rev 9402)
@@ -1,3 +1,5 @@
+0.00009 2010-05-17
+ - Rewritten test suite
0.00008 2010-04-30
- Fix packaging bug.
0.00007 2010-04-29
Modified: trunk/DBIx-Class-EncodedColumn/Makefile.PL
===================================================================
--- trunk/DBIx-Class-EncodedColumn/Makefile.PL 2010-05-17 14:31:46 UTC (rev 9401)
+++ trunk/DBIx-Class-EncodedColumn/Makefile.PL 2010-05-17 18:03:28 UTC (rev 9402)
@@ -19,27 +19,6 @@
test_requires 'DBD::SQLite';
test_requires 'Dir::Self';
test_requires 'File::Temp';
-test_requires 'Digest::SHA';
test_requires 'File::Spec';
-#recommended modules
-feature 'Digest::MD5 Support?',
- -default => 1,
- 'Digest',
- 'Digest::MD5';
-
-feature 'Digest::SHA Support?',
- -default => 1,
- 'Digest',
- 'Digest::SHA';
-
-feature 'Blowfish Support?',
- -default => 1,
- 'Crypt::Eksblowfish::Bcrypt';
-
-feature 'Crypt::OpenPGP (gpg) Support?',
- -default => 1,
- 'Crypt::OpenPGP',
- 'Crypt::CAST5_PP';
-
WriteAll;
Modified: trunk/DBIx-Class-EncodedColumn/etc/make_test_ddl_dir.pl
===================================================================
--- trunk/DBIx-Class-EncodedColumn/etc/make_test_ddl_dir.pl 2010-05-17 14:31:46 UTC (rev 9401)
+++ trunk/DBIx-Class-EncodedColumn/etc/make_test_ddl_dir.pl 2010-05-17 18:03:28 UTC (rev 9402)
@@ -8,5 +8,6 @@
use DigestTest::Schema;
my $var = File::Spec->catdir(__DIR__, '../', 't', 'var');
+DigestTest::Schema->load_classes(qw/SHA PGP Bcrypt Whirlpool/);
my $schema = DigestTest::Schema->connect("dbi:SQLite:");
$schema->create_ddl_dir(['SQLite',], undef, $var, undef, {add_drop_table => 0});
Modified: trunk/DBIx-Class-EncodedColumn/lib/DBIx/Class/EncodedColumn.pm
===================================================================
--- trunk/DBIx-Class-EncodedColumn/lib/DBIx/Class/EncodedColumn.pm 2010-05-17 14:31:46 UTC (rev 9401)
+++ trunk/DBIx-Class-EncodedColumn/lib/DBIx/Class/EncodedColumn.pm 2010-05-17 18:03:28 UTC (rev 9402)
@@ -4,12 +4,11 @@
use warnings;
use base qw/DBIx::Class/;
-use Digest;
use Sub::Name;
__PACKAGE__->mk_classdata( '_column_encoders' );
-our $VERSION = '0.00008';
+our $VERSION = '0.00009';
sub register_column {
my $self = shift;
@@ -185,18 +184,26 @@
=head2 encode_class
-The class to use for encoding. available classes are:
+The class to use for encoding. Available classes are:
=over 4
-=item C<Crypt::Eksblowfish::Bcrypt> - uses L<DBIx::Class::EncodedColumn::Crypt::Eksblowfish::Bcrypt>
+=item C<Crypt::Eksblowfish::Bcrypt> - uses
+L<DBIx::Class::EncodedColumn::Crypt::Eksblowfish::Bcrypt> and
+requires L<Crypt::Eksblowfish::Bcrypt> to be installed
=item C<Digest> - uses L<DBIx::Class::EncodedColumn::Digest>
+requires L<Digest> to be installed as well as the algorithm required
+(L<Digest::SHA>, L<Digest::Whirlpool>, etc)
+=item C<Crypt::OpenPGP> - L<DBIx::Class::EncodedColumn::Crypt::OpenPGP>
+and requires L<Crypt::OpenPGP> to be installed
+
=back
Please see the relevant class's documentation for information about the
-specific arguments accepted by each.
+specific arguments accepted by each and make sure you include the encoding
+algorithm (e.g. L<Crypt::OpenPGP>) in your application's requirements.
=head1 EXTENDED METHODS
Deleted: trunk/DBIx-Class-EncodedColumn/t/01load.t
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/01load.t 2010-05-17 14:31:46 UTC (rev 9401)
+++ trunk/DBIx-Class-EncodedColumn/t/01load.t 2010-05-17 18:03:28 UTC (rev 9402)
@@ -1,5 +0,0 @@
-use strict;
-use warnings;
-use Test::More tests => 1;
-
-use_ok('DBIx::Class::EncodedColumn');
Deleted: trunk/DBIx-Class-EncodedColumn/t/02digest.t
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/02digest.t 2010-05-17 14:31:46 UTC (rev 9401)
+++ trunk/DBIx-Class-EncodedColumn/t/02digest.t 2010-05-17 18:03:28 UTC (rev 9402)
@@ -1,234 +0,0 @@
-#! /usr/bin/perl -w
-
-use strict;
-use warnings;
-use Test::More;
-
-use Dir::Self;
-use File::Spec;
-use File::Temp 'tempdir';
-
-use lib File::Spec->catdir(__DIR__, 'lib');
-
-my ($sha_ok, $bcrypt_ok, $pgp_ok, $whirlpool_ok);
-
-BEGIN {
- $sha_ok = eval 'require Digest' && eval 'require Digest::SHA;';
- $bcrypt_ok = eval 'require Crypt::Eksblowfish::Bcrypt';
- $pgp_ok = eval 'require Crypt::OpenPGP';
- $whirlpool_ok = eval 'require Digest; 1' && eval 'require Digest::Whirlpool; 1';
-}
-
-my $tests = 5;
-$tests += 22 if $sha_ok;
-$tests += 6 if $bcrypt_ok;
-$tests += 6 if $pgp_ok;
-$tests += 7 if $whirlpool_ok;
-
-plan tests => $tests;
-
-#1
-use_ok('DigestTest::Schema');
-
-my $tmp = tempdir( CLEANUP => 1 );
-my $db_file = File::Spec->catfile($tmp, 'testdb.sqlite');
-my $schema = DigestTest::Schema->connect("dbi:SQLite:dbname=${db_file}");
-$schema->deploy({}, File::Spec->catdir(__DIR__, 'var'));
-
-my $rs = $schema->resultset('Test');
-
-my $checks = {};
-if( $sha_ok ){
- for my $algorithm( qw/SHA-1 SHA-256/){
- my $maker = Digest->new($algorithm);
- my $encodings = $checks->{$algorithm} = {};
- for my $encoding (qw/base64 hex/){
- my $values = $encodings->{$encoding} = {};
- my $encoding_method = $encoding eq 'binary' ? 'digest' :
- ($encoding eq 'hex' ? 'hexdigest' : 'b64digest');
- for my $value (qw/test1 test2/){
- $maker->add($value);
- $values->{$value} = $maker->$encoding_method;
- }
- }
- }
-}
-if ( $whirlpool_ok ) {
- for my $algorithm( qw/Whirlpool/){
- my $maker = Digest->new($algorithm);
- my $encodings = $checks->{$algorithm} = {};
- for my $encoding (qw/base64 hex/){
- my $values = $encodings->{$encoding} = {};
- my $encoding_method = $encoding eq 'binary' ? 'digest' :
- ($encoding eq 'hex' ? 'hexdigest' : 'b64digest');
- for my $value (qw/test1 test2/){
- $maker->reset()->add($value);
- $values->{$value} = $maker->$encoding_method;
- }
- }
- }
-}
-
-my %create_vals = (dummy_col => 'test1');
-if( $sha_ok ){
- $create_vals{$_} = 'test1'
- for(qw/sha1_hex sha1_b64 sha256_hex sha256_b64 sha256_b64_salted/);
-}
-if( $whirlpool_ok ){
- $create_vals{$_} = 'test1'
- for(qw/whirlpool_hex whirlpool_b64/);
-}
-
-if( $bcrypt_ok ){
- $create_vals{$_} = 'test1' for(qw/bcrypt_1 bcrypt_2/);
-}
-
-my $row = $rs->create( \%create_vals );
-
-#2
-is($row->dummy_col, 'test1','dummy on create');
-ok(!$row->can('check_dummy_col'));
-
-#8
-if( $bcrypt_ok ){
- is( length($row->bcrypt_1), 60, 'correct length');
- is( length($row->bcrypt_2), 59, 'correct length');
-
- ok( $row->bcrypt_1_check('test1'));
- ok( $row->bcrypt_2_check('test1'));
-
- $row->bcrypt_1('test2');
- $row->bcrypt_2('test2');
-
- ok( $row->bcrypt_1_check('test2'));
- ok( $row->bcrypt_2_check('test2'));
-}
-
-#14
-if( $sha_ok ) {
- is($row->sha1_hex, $checks->{'SHA-1'}{hex}{test1}, 'hex sha1 on create');
- is($row->sha1_b64, $checks->{'SHA-1'}{base64}{test1}, 'b64 sha1 on create');
- is($row->sha256_hex, $checks->{'SHA-256'}{hex}{test1}, 'hex sha256 on create');
- is($row->sha256b64, $checks->{'SHA-256'}{base64}{test1},'b64 sha256 on create');
- is( length($row->sha256_b64_salted), 57, 'correct salted length');
-
-# my $salted_check = sub {
-# my $col_v = $_[0]->get_column('sha256_b64_salted');
-# my $target = substr($col_v, 0, 43);
-# my $salt = substr($col_v, 43);
-# my $maybe = $_[0]->_column_encoders->{'sha256_b64_salted'}->($_[1], $salt);
-# print STDERR "$_[1]\t${salt}\t${maybe}\n";
-# $maybe eq $col_v;
-# };
-
- #die unless $salted_check->($row, 'test1');
-
- can_ok($row, qw/check_sha1_hex check_sha1_b64/);
- ok($row->check_sha1_hex('test1'),'Checking hex digest_check_method');
- ok($row->check_sha1_b64('test1'),'Checking b64 digest_check_method');
- ok($row->check_sha256_b64_salted('test1'), 'Checking salted digest_check_method');
-
- $row->sha1_hex('test2');
- is($row->sha1_hex, $checks->{'SHA-1'}{hex}{test2}, 'Checking accessor');
-
- $row->update({sha1_b64 => 'test2', dummy_col => 'test2'});
- is($row->sha1_b64, $checks->{'SHA-1'}{base64}{test2}, 'Checking update');
- is($row->dummy_col, 'test2', 'dummy on update');
-
- $row->set_column(sha256_hex => 'test2');
- is($row->sha256_hex, $checks->{'SHA-256'}{hex}{test2}, 'Checking set_column');
-
- $row->sha256b64('test2');
- is($row->sha256b64, $checks->{'SHA-256'}{base64}{test2}, 'custom accessor');
-
- $row->update;
-
-} else {
- #1
- $row->update({dummy_col => 'test2'});
- is($row->dummy_col, 'test2', 'dummy on update');
-
-}
-
-#4
-if( $sha_ok ) {
- my $copy = $row->copy({sha256_b64 => 'test2'});
- is($copy->sha1_hex, $checks->{'SHA-1'}{hex}{test2}, 'hex sha1 on copy');
- is($copy->sha1_b64, $checks->{'SHA-1'}{base64}{test2}, 'b64 sha1 on copy');
- is($copy->sha256_hex, $checks->{'SHA-256'}{hex}{test2}, 'hex sha256 on copy');
- is($copy->sha256b64, $checks->{'SHA-256'}{base64}{test2},'b64 sha256 on copy');
-}
-
-# 7
-if( $whirlpool_ok ){
- is( $row->whirlpool_hex, $checks->{'Whirlpool'}{hex}{test1}, 'Whirlpool hex');
- is( $row->whirlpool_b64, $checks->{'Whirlpool'}{base64}{test1}, 'Whirlpool b64');
-
- can_ok( $row, qw/check_whirlpool_hex check_whirlpool_b64/ );
- ok( $row->check_whirlpool_hex('test1'), 'Checking hex digest_check_method for Whirlpool');
- ok( $row->check_whirlpool_b64('test1'), 'Checking b64 digest_check_method for Whirlpool');
-
- $row->whirlpool_hex('test2');
- is( $row->whirlpool_hex, $checks->{'Whirlpool'}{hex}{test2}, 'Checking accessor (Whirlpool)');
-
- $row->update({ whirlpool_b64 => 'test2' });
- is( $row->whirlpool_b64, $checks->{'Whirlpool'}{base64}{test2}, 'Checking Update (Whirlpool)');
-
-}
-
-#1
-my $new = $rs->new( \%create_vals );
-is($new->dummy_col, 'test1', 'dummy on new');
-
-#4
-if( $sha_ok ){
- is($new->sha1_hex, $checks->{'SHA-1'}{hex}{test1}, 'hex sha1 on new');
- is($new->sha1_b64, $checks->{'SHA-1'}{base64}{test1}, 'b64 sha1 on new');
- is($new->sha256_hex, $checks->{'SHA-256'}{hex}{test1}, 'hex sha256 on new');
- is($new->sha256b64, $checks->{'SHA-256'}{base64}{test1}, 'b64 sha256 on new');
-}
-
-#6
-if ( $pgp_ok ) {
- my $row = $rs->create( {
- dummy_col => 'Dummy Column',
- pgp_col_passphrase => 'Test Encrypted Column with Passphrase',
- pgp_col_key => 'Test Encrypted Column with Key Exchange',
- pgp_col_key_ps => 'Test Encrypted Column with Key Exchange + Pass',
- } );
-
- like($row->pgp_col_passphrase, qr/BEGIN PGP MESSAGE/, 'Passphrase encrypted');
- like($row->pgp_col_key, qr/BEGIN PGP MESSAGE/, 'Key encrypted');
- like($row->pgp_col_key_ps, qr/BEGIN PGP MESSAGE/, 'Key+Passphrase encrypted');
-
- is(
- $row->decrypt_pgp_passphrase('Secret Words'),
- 'Test Encrypted Column with Passphrase',
- 'Passphrase decryption/encryption'
- );
-
- is(
- $row->decrypt_pgp_key,
- 'Test Encrypted Column with Key Exchange',
- 'Key Exchange decryption/encryption'
- );
-
- is(
- $row->decrypt_pgp_key_ps('Secret Words'),
- 'Test Encrypted Column with Key Exchange + Pass',
- 'Secured Key Exchange decryption/encryption'
- );
-
-
-}
-
-if( $sha_ok ){
- $row->sha1_hex(undef);
- $row->update;
- is($row->sha1_hex, undef, 'Check undef is passed through');
-}
-
-#TODO
-# -- dies_ok tests when using invalid cyphers and encodings
-
-1;
Deleted: trunk/DBIx-Class-EncodedColumn/t/03crosstable_leak.t
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/03crosstable_leak.t 2010-05-17 14:31:46 UTC (rev 9401)
+++ trunk/DBIx-Class-EncodedColumn/t/03crosstable_leak.t 2010-05-17 18:03:28 UTC (rev 9402)
@@ -1,43 +0,0 @@
-#! /usr/bin/perl -w
-
-use strict;
-use warnings;
-use Test::More tests => 5;
-
-use Dir::Self;
-use File::Spec;
-use File::Temp 'tempdir';
-
-use lib File::Spec->catdir(__DIR__, 'lib');
-
-#1
-BEGIN { use_ok("DigestTest::Schema"); }
-
-# ABOUT THIS TEST;
-#
-# TableA is not encoded.
-# TableB is encoded.
-#
-# Both share a field with the same name.
-#
-# This test is to demonstrate, that one is inheriting the encoding options wrongly from the other.
-#
-
-my $tmp = tempdir( CLEANUP => 1 );
-my $db_file = File::Spec->catfile($tmp, 'testdb.sqlite');
-my $schema = DigestTest::Schema->connect("dbi:SQLite:dbname=${db_file}");
-$schema->deploy({}, File::Spec->catdir(__DIR__, 'var'));
-
-my $tablea = $schema->resultset('TableA');
-my $tableb = $schema->resultset('TableB');
-
-my $objecta = $tablea->create( { conflicting_name => 'foo' } );
-my $objectb = $tableb->create( { conflicting_name => 'bar' } );
-
-is( $objecta->conflicting_name, 'foo', 'Table requested to not be encoded is not encoded' );
-unlike( $objectb->conflicting_name, qr/^(bar|foo)$/, 'Table requested to be encoded is encoded' );
-
-is( $objecta->can('check_conflict'), undef, 'Table that is requested to not be encoded has no check_conflict method' );
-ok( $objectb->can('check_conflict'), 'Table that is requested encoded has check_conflict method' );
-
-1;
Added: trunk/DBIx-Class-EncodedColumn/t/bcrypt.t
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/bcrypt.t (rev 0)
+++ trunk/DBIx-Class-EncodedColumn/t/bcrypt.t 2010-05-17 18:03:28 UTC (rev 9402)
@@ -0,0 +1,41 @@
+
+use strict;
+use warnings;
+use Test::More;
+
+use Dir::Self;
+use File::Spec;
+use File::Temp 'tempdir';
+use lib File::Spec->catdir(__DIR__, 'lib');
+
+BEGIN {
+ if( eval 'require Crypt::Eksblowfish::Bcrypt' ){
+ plan tests => 7;
+ use_ok('DigestTest::Schema');
+ } else {
+ plan skip_all => 'Crypt::Eksblowfish::Bcrypt not available';
+ exit;
+ }
+}
+
+#1
+DigestTest::Schema->load_classes('Bcrypt');
+
+my $tmp = tempdir( CLEANUP => 1 );
+my $db_file = File::Spec->catfile($tmp, 'testdb.sqlite');
+my $schema = DigestTest::Schema->connect("dbi:SQLite:dbname=${db_file}");
+$schema->deploy({}, File::Spec->catdir(__DIR__, 'var'));
+
+my %create_values = (bcrypt_1 => 'test1', bcrypt_2 => 'test1');
+my $row = $schema->resultset('Bcrypt')->create( \%create_values );
+is( length($row->bcrypt_1), 60, 'correct length');
+is( length($row->bcrypt_2), 59, 'correct length');
+
+ok( $row->bcrypt_1_check('test1'));
+ok( $row->bcrypt_2_check('test1'));
+
+$row->bcrypt_1('test2');
+$row->bcrypt_2('test2');
+
+ok( $row->bcrypt_1_check('test2'));
+ok( $row->bcrypt_2_check('test2'));
Added: trunk/DBIx-Class-EncodedColumn/t/class_level_encoders.t
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/class_level_encoders.t (rev 0)
+++ trunk/DBIx-Class-EncodedColumn/t/class_level_encoders.t 2010-05-17 18:03:28 UTC (rev 9402)
@@ -0,0 +1,53 @@
+
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+ if( eval 'require Digest' && eval 'require Digest::SHA' ){
+ plan tests => 1;
+ } else {
+ plan skip_all => 'Digest::SHA not available';
+ exit;
+ }
+}
+
+{
+ package TestCorrectlySetClassData;
+ use base qw/DBIx::Class/;
+ __PACKAGE__->load_components(qw/EncodedColumn Core/);
+ __PACKAGE__->table('test_register_column');
+}
+
+TestCorrectlySetClassData->add_columns(
+ sha1_hex => {
+ data_type => 'char',
+ is_nullable => 1,
+ size => 40,
+ encode_column => 1,
+ encode_class => 'Digest',
+ encode_args => {
+ format => 'hex',
+ algorithm => 'SHA-1',
+ },
+ encode_check_method => 'check_sha1_hex',
+ },
+);
+my $encoders_1 = TestCorrectlySetClassData->_column_encoders;
+
+TestCorrectlySetClassData->add_columns(
+ sha1_b64 => {
+ data_type => 'char',
+ is_nullable => 1,
+ size => 27,
+ encode_column => 1,
+ encode_class => 'Digest',
+ encode_args => {
+ algorithm => 'SHA-1',
+ },
+ encode_check_method => 'check_sha1_b64',
+ },
+);
+my $encoders_2 = TestCorrectlySetClassData->_column_encoders;
+
+isnt($encoders_1, $encoders_2, 'register_column uses fresh ref for econders');
Added: trunk/DBIx-Class-EncodedColumn/t/digest_sha.t
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/digest_sha.t (rev 0)
+++ trunk/DBIx-Class-EncodedColumn/t/digest_sha.t 2010-05-17 18:03:28 UTC (rev 9402)
@@ -0,0 +1,92 @@
+
+use strict;
+use warnings;
+use Test::More;
+
+use Dir::Self;
+use File::Spec;
+use File::Temp 'tempdir';
+use lib File::Spec->catdir(__DIR__, 'lib');
+
+use DigestTest::Schema;
+
+BEGIN {
+ if( eval 'require Digest' && eval 'require Digest::SHA' ){
+ plan tests => 25;
+ } else {
+ plan skip_all => 'Digest::SHA not available';
+ exit;
+ }
+}
+
+DigestTest::Schema->load_classes('SHA');
+
+my $tmp = tempdir( CLEANUP => 1 );
+my $db_file = File::Spec->catfile($tmp, 'testdb.sqlite');
+my $schema = DigestTest::Schema->connect("dbi:SQLite:dbname=${db_file}");
+$schema->deploy({}, File::Spec->catdir(__DIR__, 'var'));
+
+my $checks = {};
+for my $algorithm( qw/SHA-1 SHA-256/){
+ my $maker = Digest->new($algorithm);
+ my $encodings = $checks->{$algorithm} = {};
+ for my $encoding (qw/base64 hex/){
+ my $values = $encodings->{$encoding} = {};
+ my $encoding_method = $encoding eq 'binary' ? 'digest' :
+ ($encoding eq 'hex' ? 'hexdigest' : 'b64digest');
+ for my $value (qw/test1 test2/){
+ $maker->add($value);
+ $values->{$value} = $maker->$encoding_method;
+ }
+ }
+}
+
+
+my %create_values = map { $_ => 'test1' }
+ qw( dummy_col sha1_hex sha1_b64 sha256_hex sha256_b64 sha256_b64_salted );
+
+my $row = $schema->resultset('SHA')->create( \%create_values );
+is($row->dummy_col, 'test1','dummy on create');
+ok(!$row->can('check_dummy_col'), 'no "check_dummy_col" method');
+
+is($row->sha1_hex, $checks->{'SHA-1'}{hex}{test1}, 'hex sha1 on create');
+is($row->sha1_b64, $checks->{'SHA-1'}{base64}{test1}, 'b64 sha1 on create');
+is($row->sha256_hex, $checks->{'SHA-256'}{hex}{test1}, 'hex sha256 on create');
+is($row->sha256b64, $checks->{'SHA-256'}{base64}{test1},'b64 sha256 on create');
+is( length($row->sha256_b64_salted), 57, 'correct salted length');
+
+can_ok($row, qw/check_sha1_hex check_sha1_b64/);
+ok($row->check_sha1_hex('test1'),'Checking hex digest_check_method');
+ok($row->check_sha1_b64('test1'),'Checking b64 digest_check_method');
+ok($row->check_sha256_b64_salted('test1'), 'Checking salted digest_check_method');
+
+$row->sha1_hex('test2');
+is($row->sha1_hex, $checks->{'SHA-1'}{hex}{test2}, 'Checking accessor');
+
+$row->update({sha1_b64 => 'test2', dummy_col => 'test2'});
+is($row->sha1_b64, $checks->{'SHA-1'}{base64}{test2}, 'Checking update');
+is($row->dummy_col, 'test2', 'dummy on update');
+
+$row->set_column(sha256_hex => 'test2');
+is($row->sha256_hex, $checks->{'SHA-256'}{hex}{test2}, 'Checking set_column');
+
+$row->sha256b64('test2');
+is($row->sha256b64, $checks->{'SHA-256'}{base64}{test2}, 'custom accessor');
+
+$row->update;
+
+my $copy = $row->copy({sha256_b64 => 'test2'});
+is($copy->sha1_hex, $checks->{'SHA-1'}{hex}{test2}, 'hex sha1 on copy');
+is($copy->sha1_b64, $checks->{'SHA-1'}{base64}{test2}, 'b64 sha1 on copy');
+is($copy->sha256_hex, $checks->{'SHA-256'}{hex}{test2}, 'hex sha256 on copy');
+is($copy->sha256b64, $checks->{'SHA-256'}{base64}{test2},'b64 sha256 on copy');
+
+my $new = $schema->resultset('SHA')->new( \%create_values );
+is($new->sha1_hex, $checks->{'SHA-1'}{hex}{test1}, 'hex sha1 on new');
+is($new->sha1_b64, $checks->{'SHA-1'}{base64}{test1}, 'b64 sha1 on new');
+is($new->sha256_hex, $checks->{'SHA-256'}{hex}{test1}, 'hex sha256 on new');
+is($new->sha256b64, $checks->{'SHA-256'}{base64}{test1}, 'b64 sha256 on new');
+
+$row->sha1_hex(undef);
+$row->update;
+is($row->sha1_hex, undef, 'Check undef is passed through');
Added: trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/Bcrypt.pm
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/Bcrypt.pm (rev 0)
+++ trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/Bcrypt.pm 2010-05-17 18:03:28 UTC (rev 9402)
@@ -0,0 +1,37 @@
+package # hide from PAUSE
+ DigestTest::Schema::Bcrypt;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class/;
+
+__PACKAGE__->load_components(qw/EncodedColumn Core/);
+__PACKAGE__->table('test_bcrypt');
+__PACKAGE__->add_columns(
+ id => {
+ data_type => 'int',
+ is_nullable => 0,
+ is_auto_increment => 1
+ },
+ bcrypt_1 => {
+ data_type => 'text',
+ is_nullable => 1,
+ size => 60,
+ encode_column => 1,
+ encode_class => 'Crypt::Eksblowfish::Bcrypt',
+ encode_check_method => 'bcrypt_1_check',
+ },
+ bcrypt_2 => {
+ data_type => 'text',
+ is_nullable => 1,
+ size => 59,
+ encode_column => 1,
+ encode_class => 'Crypt::Eksblowfish::Bcrypt',
+ encode_args => {key_nul => 0, cost => 6 },
+ encode_check_method => 'bcrypt_2_check',
+ },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
Added: trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/PGP.pm
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/PGP.pm (rev 0)
+++ trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/PGP.pm 2010-05-17 18:03:28 UTC (rev 9402)
@@ -0,0 +1,69 @@
+package # hide from PAUSE
+ DigestTest::Schema::PGP;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class/;
+use Dir::Self;
+use File::Spec;
+
+my $pgp_conf = {
+ SecRing => File::Spec->catdir(__DIR__,'secring.gpg'),
+ PubRing => File::Spec->catdir(__DIR__,'pubring.gpg'),
+};
+
+__PACKAGE__->load_components(qw/EncodedColumn Core/);
+__PACKAGE__->table('test_pgp');
+__PACKAGE__->add_columns(
+ id => {
+ data_type => 'int',
+ is_nullable => 0,
+ is_auto_increment => 1
+ },
+ dummy_col => {
+ data_type => 'char',
+ size => 43,
+ encode_column => 0,
+ encode_class => 'Digest',
+ encode_check_method => 'check_dummy_col',
+ },
+ pgp_col_passphrase => {
+ data_type => 'text',
+ is_nullable => 1,
+ encode_column => 1,
+ encode_class => 'Crypt::OpenPGP',
+ encode_args => {
+ passphrase => 'Secret Words',
+ armour => 1
+ },
+ encode_check_method => 'decrypt_pgp_passphrase',
+ },
+ pgp_col_key => {
+ data_type => 'text',
+ is_nullable => 1,
+ encode_column => 1,
+ encode_class => 'Crypt::OpenPGP',
+ encode_args => {
+ recipient => '1B8924AA',
+ pgp_args => $pgp_conf,
+ armour => 1
+ },
+ encode_check_method => 'decrypt_pgp_key',
+ },
+ pgp_col_key_ps => {
+ data_type => 'text',
+ is_nullable => 1,
+ encode_column => 1,
+ encode_class => 'Crypt::OpenPGP',
+ encode_args => {
+ recipient => '7BEF6294',
+ pgp_args => $pgp_conf,
+ armour => 1
+ },
+ encode_check_method => 'decrypt_pgp_key_ps',
+ },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
Added: trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/SHA.pm
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/SHA.pm (rev 0)
+++ trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/SHA.pm 2010-05-17 18:03:28 UTC (rev 9402)
@@ -0,0 +1,75 @@
+package # hide from PAUSE
+ DigestTest::Schema::SHA;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class/;
+
+__PACKAGE__->load_components(qw/EncodedColumn Core/);
+__PACKAGE__->table('test_sha');
+__PACKAGE__->add_columns(
+ id => {
+ data_type => 'int',
+ is_nullable => 0,
+ is_auto_increment => 1
+ },
+ dummy_col => {
+ data_type => 'char',
+ size => 43,
+ encode_column => 0,
+ encode_class => 'Digest',
+ encode_check_method => 'check_dummy_col',
+ },
+ sha1_hex => {
+ data_type => 'char',
+ is_nullable => 1,
+ size => 40,
+ encode_column => 1,
+ encode_class => 'Digest',
+ encode_args => {
+ format => 'hex',
+ algorithm => 'SHA-1',
+ },
+ encode_check_method => 'check_sha1_hex',
+ },
+ sha1_b64 => {
+ data_type => 'char',
+ is_nullable => 1,
+ size => 27,
+ encode_column => 1,
+ encode_class => 'Digest',
+ encode_args => {
+ algorithm => 'SHA-1',
+ },
+ encode_check_method => 'check_sha1_b64',
+ },
+ sha256_hex => {
+ data_type => 'char',
+ is_nullable => 1,
+ size => 64,
+ encode_column => 1,
+ encode_class => 'Digest',
+ encode_args => { format => 'hex',},
+ },
+ sha256_b64 => {
+ data_type => 'char',
+ is_nullable => 1,
+ size => 43,
+ accessor => 'sha256b64',
+ encode_column => 1,
+ encode_class => 'Digest',
+ },
+ sha256_b64_salted => {
+ data_type => 'char',
+ is_nullable => 1,
+ size => 57,
+ encode_column => 1,
+ encode_class => 'Digest',
+ encode_check_method => 'check_sha256_b64_salted',
+ encode_args => {salt_length => 14}
+ },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
Deleted: trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/TableA.pm
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/TableA.pm 2010-05-17 14:31:46 UTC (rev 9401)
+++ trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/TableA.pm 2010-05-17 18:03:28 UTC (rev 9402)
@@ -1,25 +0,0 @@
-package # hide from PAUSE
- DigestTest::Schema::TableA;
-
-use base qw/DBIx::Class/;
-
-__PACKAGE__->load_components(qw/EncodedColumn Core/);
-__PACKAGE__->table('tablea');
-__PACKAGE__->add_columns(
- id => {
- data_type => 'int',
- is_nullable => 0,
- is_auto_increment => 1
- },
- conflicting_name => {
- data_type => 'char',
- size => 43,
- encode_column => 0,
- encode_class => 'Digest',
- encode_check_method => 'check_conflict',
- },
-);
-
-__PACKAGE__->set_primary_key('id');
-
-1;
Deleted: trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/TableB.pm
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/TableB.pm 2010-05-17 14:31:46 UTC (rev 9401)
+++ trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/TableB.pm 2010-05-17 18:03:28 UTC (rev 9402)
@@ -1,25 +0,0 @@
-package # hide from PAUSE
- DigestTest::Schema::TableB;
-
-use base qw/DBIx::Class/;
-
-__PACKAGE__->load_components(qw/EncodedColumn Core/);
-__PACKAGE__->table('tableb');
-__PACKAGE__->add_columns(
- id => {
- data_type => 'int',
- is_nullable => 0,
- is_auto_increment => 1
- },
- conflicting_name => {
- data_type => 'char',
- size => 43,
- encode_column => 1,
- encode_class => 'Digest',
- encode_check_method => 'check_conflict',
- },
-);
-
-__PACKAGE__->set_primary_key('id');
-
-1;
Deleted: trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/Test.pm
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/Test.pm 2010-05-17 14:31:46 UTC (rev 9401)
+++ trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/Test.pm 2010-05-17 18:03:28 UTC (rev 9402)
@@ -1,181 +0,0 @@
-package # hide from PAUSE
- DigestTest::Schema::Test;
-
-my ($sha_ok, $bcrypt_ok, $whirlpool_ok);
-BEGIN {
- $sha_ok = eval 'require Digest' && eval 'require Digest::SHA;';
- $bcrypt_ok = eval 'require Crypt::Eksblowfish::Bcrypt';
- $pgp_ok = eval 'require Crypt::OpenPGP';
- $whirlpool_ok = eval 'require Digest; 1' && eval 'require Digest::Whirlpool; 1';
-}
-
-use base qw/DBIx::Class/;
-
-__PACKAGE__->load_components(qw/EncodedColumn Core/);
-__PACKAGE__->table('test');
-__PACKAGE__->add_columns(
- id => {
- data_type => 'int',
- is_nullable => 0,
- is_auto_increment => 1
- },
- dummy_col => {
- data_type => 'char',
- size => 43,
- encode_column => 0,
- encode_class => 'Digest',
- encode_check_method => 'check_dummy_col',
- },
-);
-
-if( $sha_ok ) {
- __PACKAGE__->add_columns(
- sha1_hex => {
- data_type => 'char',
- is_nullable => 1,
- size => 40,
- encode_column => 1,
- encode_class => 'Digest',
- encode_args => {
- format => 'hex',
- algorithm => 'SHA-1',
- },
- encode_check_method => 'check_sha1_hex',
- },
- sha1_b64 => {
- data_type => 'char',
- is_nullable => 1,
- size => 27,
- encode_column => 1,
- encode_class => 'Digest',
- encode_args => {
- algorithm => 'SHA-1',
- },
- encode_check_method => 'check_sha1_b64',
- },
- sha256_hex => {
- data_type => 'char',
- is_nullable => 1,
- size => 64,
- encode_column => 1,
- encode_class => 'Digest',
- encode_args => { format => 'hex',},
- },
- sha256_b64 => {
- data_type => 'char',
- is_nullable => 1,
- size => 43,
- accessor => 'sha256b64',
- encode_column => 1,
- encode_class => 'Digest',
- },
- sha256_b64_salted => {
- data_type => 'char',
- is_nullable => 1,
- size => 57,
- encode_column => 1,
- encode_class => 'Digest',
- encode_check_method => 'check_sha256_b64_salted',
- encode_args => {salt_length => 14}
- },
- );
-}
-
-if ( $whirlpool_ok ) {
-
- __PACKAGE__->add_columns(
- whirlpool_hex => {
- data_type => 'char',
- is_nullable => 1,
- size => 128,
- encode_column => 1,
- encode_class => 'Digest',
- encode_args => {
- format => 'hex',
- algorithm => 'Whirlpool',
- },
- encode_check_method => 'check_whirlpool_hex',
- },
- whirlpool_b64 => {
- data_type => 'char',
- is_nullable => 1,
- size => 86,
- encode_column => 1,
- encode_class => 'Digest',
- encode_args => {
- algorithm => 'Whirlpool',
- },
- encode_check_method => 'check_whirlpool_b64',
- },
- );
-}
-
-if( $bcrypt_ok ){
- __PACKAGE__->add_columns(
- bcrypt_1 => {
- data_type => 'text',
- is_nullable => 1,
- size => 60,
- encode_column => 1,
- encode_class => 'Crypt::Eksblowfish::Bcrypt',
- encode_check_method => 'bcrypt_1_check',
- },
- bcrypt_2 => {
- data_type => 'text',
- is_nullable => 1,
- size => 59,
- encode_column => 1,
- encode_class => 'Crypt::Eksblowfish::Bcrypt',
- encode_args => {key_nul => 0, cost => 6 },
- encode_check_method => 'bcrypt_2_check',
- },
- );
-}
-
-if( $pgp_ok ){
- my $pgp_conf = {
- SecRing => "$FindBin::Bin/secring.gpg",
- PubRing => "$FindBin::Bin/pubring.gpg",
- };
- __PACKAGE__->add_columns(
- pgp_col_passphrase => {
- data_type => 'text',
- is_nullable => 1,
- encode_column => 1,
- encode_class => 'Crypt::OpenPGP',
- encode_args => {
- passphrase => 'Secret Words',
- armour => 1
- },
- encode_check_method => 'decrypt_pgp_passphrase',
- },
- pgp_col_key => {
- data_type => 'text',
- is_nullable => 1,
- encode_column => 1,
- encode_class => 'Crypt::OpenPGP',
- encode_args => {
- recipient => '1B8924AA',
- pgp_args => $pgp_conf,
- armour => 1
- },
- encode_check_method => 'decrypt_pgp_key',
- },
- pgp_col_key_ps => {
- data_type => 'text',
- is_nullable => 1,
- encode_column => 1,
- encode_class => 'Crypt::OpenPGP',
- encode_args => {
- recipient => '7BEF6294',
- pgp_args => $pgp_conf,
- armour => 1
- },
- encode_check_method => 'decrypt_pgp_key_ps',
- },
- );
-}
-
-__PACKAGE__->set_primary_key('id');
-
-1;
Added: trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/Whirlpool.pm
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/Whirlpool.pm (rev 0)
+++ trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/Whirlpool.pm 2010-05-17 18:03:28 UTC (rev 9402)
@@ -0,0 +1,43 @@
+package # hide from PAUSE
+ DigestTest::Schema::Whirlpool;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class/;
+
+__PACKAGE__->load_components(qw/EncodedColumn Core/);
+__PACKAGE__->table('test_whirlpool');
+__PACKAGE__->add_columns(
+ id => {
+ data_type => 'int',
+ is_nullable => 0,
+ is_auto_increment => 1
+ },
+ whirlpool_hex => {
+ data_type => 'char',
+ is_nullable => 1,
+ size => 128,
+ encode_column => 1,
+ encode_class => 'Digest',
+ encode_args => {
+ format => 'hex',
+ algorithm => 'Whirlpool',
+ },
+ encode_check_method => 'check_whirlpool_hex',
+ },
+ whirlpool_b64 => {
+ data_type => 'char',
+ is_nullable => 1,
+ size => 86,
+ encode_column => 1,
+ encode_class => 'Digest',
+ encode_args => {
+ algorithm => 'Whirlpool',
+ },
+ encode_check_method => 'check_whirlpool_b64',
+ },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
Added: trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/pubring.gpg
===================================================================
(Binary files differ)
Property changes on: trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/pubring.gpg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/secring.gpg
===================================================================
(Binary files differ)
Property changes on: trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema/secring.gpg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Modified: trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema.pm
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema.pm 2010-05-17 14:31:46 UTC (rev 9401)
+++ trunk/DBIx-Class-EncodedColumn/t/lib/DigestTest/Schema.pm 2010-05-17 18:03:28 UTC (rev 9402)
@@ -3,6 +3,4 @@
use base qw/DBIx::Class::Schema/;
-__PACKAGE__->load_classes(qw/Test TableA TableB/);
-
1;
Added: trunk/DBIx-Class-EncodedColumn/t/open_pgp.t
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/open_pgp.t (rev 0)
+++ trunk/DBIx-Class-EncodedColumn/t/open_pgp.t 2010-05-17 18:03:28 UTC (rev 9402)
@@ -0,0 +1,56 @@
+
+use strict;
+use warnings;
+use Test::More;
+
+use Dir::Self;
+use File::Spec;
+use File::Temp 'tempdir';
+use lib File::Spec->catdir(__DIR__, 'lib');
+use DigestTest::Schema;
+
+BEGIN {
+ if( eval 'require Crypt::OpenPGP' ){
+ plan tests => 6;
+ } else {
+ plan skip_all => 'Crypt::OpenPGP not available';
+ exit;
+ }
+}
+
+#1
+DigestTest::Schema->load_classes('PGP');
+
+my $tmp = tempdir( CLEANUP => 1 );
+my $db_file = File::Spec->catfile($tmp, 'testdb.sqlite');
+my $schema = DigestTest::Schema->connect("dbi:SQLite:dbname=${db_file}");
+$schema->deploy({}, File::Spec->catdir(__DIR__, 'var'));
+
+my $row = $schema->resultset('PGP')->create( {
+ dummy_col => 'Dummy Column',
+ pgp_col_passphrase => 'Test Encrypted Column with Passphrase',
+ pgp_col_key => 'Test Encrypted Column with Key Exchange',
+ pgp_col_key_ps => 'Test Encrypted Column with Key Exchange + Pass',
+} );
+
+like($row->pgp_col_passphrase, qr/BEGIN PGP MESSAGE/, 'Passphrase encrypted');
+like($row->pgp_col_key, qr/BEGIN PGP MESSAGE/, 'Key encrypted');
+like($row->pgp_col_key_ps, qr/BEGIN PGP MESSAGE/, 'Key+Passphrase encrypted');
+
+is(
+ $row->decrypt_pgp_passphrase('Secret Words'),
+ 'Test Encrypted Column with Passphrase',
+ 'Passphrase decryption/encryption'
+);
+
+is(
+ $row->decrypt_pgp_key,
+ 'Test Encrypted Column with Key Exchange',
+ 'Key Exchange decryption/encryption'
+);
+
+is(
+ $row->decrypt_pgp_key_ps('Secret Words'),
+ 'Test Encrypted Column with Key Exchange + Pass',
+ 'Secured Key Exchange decryption/encryption'
+);
Modified: trunk/DBIx-Class-EncodedColumn/t/var/DigestTest-Schema-1.x-SQLite.sql
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/var/DigestTest-Schema-1.x-SQLite.sql 2010-05-17 14:31:46 UTC (rev 9401)
+++ trunk/DBIx-Class-EncodedColumn/t/var/DigestTest-Schema-1.x-SQLite.sql 2010-05-17 18:03:28 UTC (rev 9402)
@@ -1,40 +1,51 @@
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Thu Apr 29 20:08:54 2010
+-- Created on Mon May 17 13:22:05 2010
--
BEGIN TRANSACTION;
--
--- Table: tablea
+-- Table: test_bcrypt
--
-CREATE TABLE tablea (
+CREATE TABLE test_bcrypt (
id INTEGER PRIMARY KEY NOT NULL,
- conflicting_name char(43) NOT NULL
+ bcrypt_1 text,
+ bcrypt_2 text
);
--
--- Table: tableb
+-- Table: test_pgp
--
-CREATE TABLE tableb (
+CREATE TABLE test_pgp (
id INTEGER PRIMARY KEY NOT NULL,
- conflicting_name char(43) NOT NULL
+ dummy_col char(43) NOT NULL,
+ pgp_col_passphrase text,
+ pgp_col_key text,
+ pgp_col_key_ps text
);
--
--- Table: test
+-- Table: test_sha
--
-CREATE TABLE test (
+CREATE TABLE test_sha (
id INTEGER PRIMARY KEY NOT NULL,
dummy_col char(43) NOT NULL,
sha1_hex char(40),
sha1_b64 char(27),
sha256_hex char(64),
sha256_b64 char(43),
- sha256_b64_salted char(57),
- bcrypt_1 text,
- bcrypt_2 text
+ sha256_b64_salted char(57)
);
+--
+-- Table: test_whirlpool
+--
+CREATE TABLE test_whirlpool (
+ id INTEGER PRIMARY KEY NOT NULL,
+ whirlpool_hex char(128),
+ whirlpool_b64 char(86)
+);
+
COMMIT;
Added: trunk/DBIx-Class-EncodedColumn/t/whirlpool.t
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/whirlpool.t (rev 0)
+++ trunk/DBIx-Class-EncodedColumn/t/whirlpool.t 2010-05-17 18:03:28 UTC (rev 9402)
@@ -0,0 +1,57 @@
+
+use strict;
+use warnings;
+use Test::More;
+
+use Dir::Self;
+use File::Spec;
+use File::Temp 'tempdir';
+use lib File::Spec->catdir(__DIR__, 'lib');
+use DigestTest::Schema;
+
+BEGIN {
+ if( eval 'require Digest; 1' && eval 'require Digest::Whirlpool; 1' ){
+ plan tests => 7;
+ } else {
+ plan skip_all => 'Digest::Whirlpool not available';
+ exit;
+ }
+}
+
+#1
+DigestTest::Schema->load_classes('Whirlpool');
+
+my $tmp = tempdir( CLEANUP => 1 );
+my $db_file = File::Spec->catfile($tmp, 'testdb.sqlite');
+my $schema = DigestTest::Schema->connect("dbi:SQLite:dbname=${db_file}");
+$schema->deploy({}, File::Spec->catdir(__DIR__, 'var'));
+
+my $checks = {};
+for my $algorithm( qw/Whirlpool/){
+ my $maker = Digest->new($algorithm);
+ my $encodings = $checks->{$algorithm} = {};
+ for my $encoding (qw/base64 hex/){
+ my $values = $encodings->{$encoding} = {};
+ my $encoding_method = $encoding eq 'binary' ? 'digest' :
+ ($encoding eq 'hex' ? 'hexdigest' : 'b64digest');
+ for my $value (qw/test1 test2/){
+ $maker->reset()->add($value);
+ $values->{$value} = $maker->$encoding_method;
+ }
+ }
+}
+
+my %create_values = (whirlpool_hex => 'test1', whirlpool_b64 => 'test1');
+my $row = $schema->resultset('Whirlpool')->create( \%create_values );
+is( $row->whirlpool_hex, $checks->{'Whirlpool'}{hex}{test1}, 'Whirlpool hex');
+is( $row->whirlpool_b64, $checks->{'Whirlpool'}{base64}{test1}, 'Whirlpool b64');
+
+can_ok( $row, qw/check_whirlpool_hex check_whirlpool_b64/ );
+ok( $row->check_whirlpool_hex('test1'), 'Checking hex digest_check_method for Whirlpool');
+ok( $row->check_whirlpool_b64('test1'), 'Checking b64 digest_check_method for Whirlpool');
+
+$row->whirlpool_hex('test2');
+is( $row->whirlpool_hex, $checks->{'Whirlpool'}{hex}{test2}, 'Checking accessor (Whirlpool)');
+
+$row->update({ whirlpool_b64 => 'test2' });
+is( $row->whirlpool_b64, $checks->{'Whirlpool'}{base64}{test2}, 'Checking Update (Whirlpool)');
More information about the Bast-commits
mailing list