[Bast-commits] r9658 - in trunk/DBIx-Class-EncodedColumn: lib/DBIx/Class/EncodedColumn t

[wreis at dev.catalyst.perl.org]

Author: wreis
Date: 2010-08-27 19:31:58 +0100 (Fri, 27 Aug 2010)
New Revision: 9658

Added:
   trunk/DBIx-Class-EncodedColumn/lib/DBIx/Class/EncodedColumn/Crypt.pm
   trunk/DBIx-Class-EncodedColumn/t/crypt.t
Log:
add Crypt.pm

Added: trunk/DBIx-Class-EncodedColumn/lib/DBIx/Class/EncodedColumn/Crypt.pm
===================================================================
--- trunk/DBIx-Class-EncodedColumn/lib/DBIx/Class/EncodedColumn/Crypt.pm	                        (rev 0)
+++ trunk/DBIx-Class-EncodedColumn/lib/DBIx/Class/EncodedColumn/Crypt.pm	2010-08-27 18:31:58 UTC (rev 9658)
@@ -0,0 +1,51 @@
+package DBIx::Class::EncodedColumn::Crypt;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+sub make_encode_sub {
+    my ($class, $col, $args) = @_;
+    my $gen_salt_meth = $args->{'salt'};
+    die "Valid 'salt' is a coderef which returns the salt string."
+        unless ref $gen_salt_meth eq 'CODE';
+
+    return sub {
+        my ($plain_text, $salt) = @_;
+        $salt ||= $gen_salt_meth->();
+        return crypt($plain_text, $salt);
+    };
+}
+
+sub make_check_sub {
+    my($class, $col, $args) = @_;
+    #fast fast fast
+    return eval qq^ sub {
+        my \$col_v = \$_[0]->get_column('${col}');
+        \$_[0]->_column_encoders->{${col}}->(\$_[1], \$col_v) eq \$col_v;
+    } ^ || die($@);
+}
+
+1;
+
+__END__;
+
+=head1 NAME
+
+DBIx::Class::EncodedColumn::Crypt - Encrypt columns using crypt()
+
+=head1 SEE ALSO
+
+L<crypt|http://perldoc.perl.org/functions/crypt.html>
+
+=head1 AUTHOR
+
+wreis: Wallace reis <wreis at cpan.org>
+
+=head1 LICENSE
+
+This library is free software, you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut

Added: trunk/DBIx-Class-EncodedColumn/t/crypt.t
===================================================================
--- trunk/DBIx-Class-EncodedColumn/t/crypt.t	                        (rev 0)
+++ trunk/DBIx-Class-EncodedColumn/t/crypt.t	2010-08-27 18:31:58 UTC (rev 9658)
@@ -0,0 +1,39 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use DBIx::Class::EncodedColumn::Crypt;
+
+my $gen_salt_meth = sub {
+    my @salt_vals = (qw(. /), '0'..'9', 'a'..'z', 'A'..'Z');
+    return $salt_vals[int(rand(64))] . $salt_vals[int(rand(64))];
+};
+my ( $col_name, $col_info ) = ( 'password', { salt => $gen_salt_meth } );
+my $passwd = 'mypasswd';
+my $cripted_pass = crypt($passwd, $gen_salt_meth->());
+
+throws_ok { DBIx::Class::EncodedColumn::Crypt->make_encode_sub(
+    $col_name, { salt => $gen_salt_meth->() }
+) } qr{valid.*coderef}i;
+
+my $encoder = DBIx::Class::EncodedColumn::Crypt->make_encode_sub(
+    $col_name, $col_info
+);
+
+my $checker = DBIx::Class::EncodedColumn::Crypt->make_check_sub(
+    $col_name, $col_info
+);
+
+package MyEncodedColumn;
+
+sub new { return bless {}, shift }
+sub get_column { return $cripted_pass }
+sub _column_encoders { return { $col_name => $encoder } }
+
+package main;
+
+isnt($passwd, $encoder->($passwd));
+is($cripted_pass, $encoder->($passwd, $cripted_pass));
+ok($checker->(MyEncodedColumn->new, $passwd));
+
+done_testing();