File Coverage

blib/lib/DBIx/Raw/Crypt.pm
Criterion Covered Total %
statement 12 64 18.7
branch 0 12 0.0
condition 0 4 0.0
subroutine 4 9 44.4
pod 0 5 0.0
total 16 94 17.0


line stmt bran cond sub pod time code
1             # THIS IS BORROWED FROM Gantry::Utils::Crypt
2             # He did not have Crypt::CBC listed as a dependency, and didn't fix it
3             # even though it was listed as a bug several years ago. Thus, I have copied
4             # this into my package so that installation will work. Also, since this was a
5             # part of the Gantry web Framework, it would install a lot of unnecessary modules
6             # not needed for DBIx::Raw. So I have copied this here for my own use. If you are
7             # interested in using this crypt functionality, please see Gantry::Utils::Crypt instead
8             # of using this module
9             package DBIx::Raw::Crypt;
10 71     71   542 use strict;
  71         173  
  71         2279  
11              
12 71     71   37922 use Crypt::CBC;
  71         347649  
  71         2507  
13 71     71   31455 use MIME::Base64;
  71         46229  
  71         4639  
14 71     71   556 use Digest::MD5 qw( md5_hex );
  71         179  
  71         44662  
15              
16             sub new {
17 0     0 0   my ( $class, $opt ) = @_;
18              
19 0           my $self = { options => $opt };
20 0           bless( $self, $class );
21              
22 0           my @errors;
23 0           foreach( qw/secret/ ) {
24 0 0         push( @errors, "$_ is not set properly" ) if ! $opt->{$_};
25             }
26              
27 0 0         if ( scalar( @errors ) ) {
28 0           die join( "\n", @errors );
29             }
30            
31             # populate self with data from site
32 0           return( $self );
33              
34             } # end new
35              
36             #-------------------------------------------------
37             # decrypt()
38             #-------------------------------------------------
39             sub decrypt {
40 0     0 0   my ( $self, $encrypted ) = @_;
41              
42 0   0       $encrypted ||= '';
43 0           $self->set_error( undef );
44            
45 0           local $^W = 0;
46            
47 0           my $c;
48 0           eval {
49             $c = new Crypt::CBC ( {
50             'key' => $self->{options}{secret},
51 0           'cipher' => 'Blowfish',
52             'padding' => 'null',
53             } );
54             };
55 0 0         if ( $@ ) {
56 0           my $error = (
57             "Error building CBC object are your Crypt::CBC and"
58             . " Crypt::Blowfish up to date? Actual error: $@"
59             );
60            
61 0           $self->set_error( $error );
62 0           die $error;
63             }
64              
65 0           my $p_text = $c->decrypt( MIME::Base64::decode( $encrypted ) );
66            
67 0           $c->finish();
68            
69 0           my @decrypted_values = split( ':;:', $p_text );
70 0           my $md5 = pop( @decrypted_values );
71 0   0       my $omd5 = md5_hex( join( '', @decrypted_values ) ) || '';
72              
73 0 0         if ( $omd5 eq $md5 ) {
74 0 0         if ( wantarray ) {
75 0           return @decrypted_values;
76             }
77             else {
78 0           return join( ' ', @decrypted_values );
79             }
80             }
81             else {
82 0           $self->set_error( 'bad encryption' );
83             }
84              
85             } # END decrypt_cookie
86              
87             #-------------------------------------------------
88             # encrypt
89             #-------------------------------------------------
90             sub encrypt {
91 0     0 0   my ( $self, @to_encrypt ) = @_;
92              
93 0           local $^W = 0;
94 0           $self->set_error( undef );
95            
96 0           my $c;
97 0           eval {
98             $c = new Crypt::CBC( {
99             'key' => $self->{options}{secret},
100 0           'cipher' => 'Blowfish',
101             'padding' => 'null',
102             } );
103             };
104 0 0         if ( $@ ) {
105 0           my $error = (
106             "Error building CBC object are your Crypt::CBC and"
107             . " Crypt::Blowfish up to date? Actual error: $@"
108             );
109              
110 0           $self->set_error( $error );
111 0           die $error;
112             }
113              
114 0           my $md5 = md5_hex( join( '', @to_encrypt ) );
115 0           push ( @to_encrypt, $md5 );
116            
117 0           my $str = join( ':;:', @to_encrypt );
118 0           my $encd = $c->encrypt( $str );
119 0           my $c_text = MIME::Base64::encode( $encd, '' );
120              
121 0           $c->finish();
122            
123 0           return( $c_text );
124            
125             } # END encrypt
126              
127             #-------------------------------------------------
128             # set_error()
129             #-------------------------------------------------
130             sub set_error {
131 0     0 0   my $self = shift;
132 0           $self->{__error__} = shift;
133              
134 0           return $self->{__error__};
135             }
136              
137             #-------------------------------------------------
138             # get_error()
139             #-------------------------------------------------
140             sub get_error {
141 0     0 0   my $self = shift;
142 0           return $self->{__error__};
143             }
144              
145             # EOF
146             1;
147              
148             __END__