File Coverage

blib/lib/Rose/DB/Object/MakeMethods/Pg.pm
Criterion Covered Total %
statement 56 101 55.4
branch 23 62 37.1
condition 10 64 15.6
subroutine 9 10 90.0
pod 1 1 100.0
total 99 238 41.6


line stmt bran cond sub pod time code
1             package Rose::DB::Object::MakeMethods::Pg;
2              
3 2     2   1992 use strict;
  2         5  
  2         94  
4              
5             our $VERSION = '0.771';
6              
7 2     2   14 use Rose::Object::MakeMethods;
  2         93  
  2         14  
8             our @ISA = qw(Rose::Object::MakeMethods);
9              
10             use Rose::DB::Object::Constants
11 2     2   95 qw(STATE_LOADING STATE_SAVING MODIFIED_COLUMNS MODIFIED_NP_COLUMNS SET_COLUMNS STATE_IN_DB);
  2         5  
  2         150  
12              
13 2     2   11 use constant SALT_CHARS => './0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
  2         5  
  2         2856  
14              
15             sub chkpass
16             {
17 5     5 1 2690 my($class, $name, $args) = @_;
18              
19 5   66     21 my $key = $args->{'hash_key'} || $name;
20 5   100     18 my $interface = $args->{'interface'} || 'get_set';
21              
22 5 100       12 my $column_name = $args->{'column'} ? $args->{'column'}->name : $name;
23              
24 5   50     30 my $undef_overrides_default = $args->{'undef_overrides_default'} || 0;
25              
26 5   50     24 my $encrypted = $name . ($args->{'encrypted_suffix'} || '_encrypted');
27 5   50     27 my $cmp = $name . ($args->{'cmp_suffix'} || '_is');
28              
29 5         12 my $default = $args->{'default'};
30              
31 5 100       11 my $mod_columns_key = ($args->{'column'} ? $args->{'column'}->nonpersistent : 0) ?
    50          
32             MODIFIED_NP_COLUMNS : MODIFIED_COLUMNS;
33              
34 5         20 my %methods;
35              
36 5 100       25 if($interface eq 'get_set')
    100          
    50          
37             {
38             $methods{$name} = sub
39             {
40 1     1   3 my($self) = shift;
41              
42 1 50       5 if(@_)
43             {
44             $self->{$mod_columns_key}{$column_name} = 1
45 0 0       0 unless($self->{STATE_LOADING()});
46              
47 0 0       0 if(defined $_[0])
48             {
49 0 0       0 if(index($_[0], ':') == 0)
50             {
51 0         0 $self->{$key} = undef;
52 0         0 return $self->{$encrypted} = shift;
53             }
54             else
55             {
56 0         0 my $salt = substr(SALT_CHARS, int rand(length SALT_CHARS), 1) .
57             substr(SALT_CHARS, int rand(length SALT_CHARS), 1);
58 0         0 $self->{$encrypted} = ':' . crypt($_[0], $salt);
59 0         0 return $self->{$key} = $_[0];
60             }
61             }
62              
63 0         0 return $self->{$encrypted} = $self->{$key} = undef;
64             }
65              
66 1 50       5 if($self->{STATE_SAVING()})
67             {
68              
69              
70 0 0 0     0 unless(!defined $default || defined $self->{$encrypted} ||
      0        
      0        
      0        
71             ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
72             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
73             #if(!defined $self->{$encrypted} && defined $default)
74             {
75 0 0       0 if(index($default, ':') == 0)
76             {
77 0         0 $self->{$encrypted} = $default;
78             }
79             else
80             {
81 0         0 my $salt = substr(SALT_CHARS, int rand(length SALT_CHARS), 1) .
82             substr(SALT_CHARS, int rand(length SALT_CHARS), 1);
83 0         0 $self->{$encrypted} = ':' . crypt($default, $salt);
84             }
85             }
86              
87 0         0 return $self->{$encrypted};
88             }
89              
90 1         6 return $self->{$key};
91 3         35 };
92              
93             $methods{$encrypted} = sub
94             {
95 0     0   0 my($self) = shift;
96              
97 0 0       0 if(@_)
98             {
99             $self->{$mod_columns_key}{$column_name} = 1
100 0 0       0 unless($self->{STATE_LOADING()});
101              
102 0 0 0     0 if(!defined $_[0] || index($_[0], ':') == 0)
103             {
104 0         0 return $self->{$encrypted} = shift;
105             }
106             else
107             {
108 0         0 my $salt = substr(SALT_CHARS, int rand(length SALT_CHARS), 1) .
109             substr(SALT_CHARS, int rand(length SALT_CHARS), 1);
110 0         0 $self->{$encrypted} = ':' . crypt($_[0], $salt);
111 0         0 $self->{$key} = $_[0];
112             }
113             }
114              
115 0 0 0     0 unless(!defined $default || defined $self->{$encrypted} ||
      0        
      0        
      0        
116             ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
117             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
118             #if(!defined $self->{$encrypted} && defined $default)
119             {
120 0 0       0 if(index($default, ':') == 0)
121             {
122 0         0 $self->{$encrypted} = $default;
123             }
124             else
125             {
126 0         0 my $salt = substr(SALT_CHARS, int rand(length SALT_CHARS), 1) .
127             substr(SALT_CHARS, int rand(length SALT_CHARS), 1);
128 0         0 $self->{$encrypted} = ':' . crypt($default, $salt);
129             }
130             }
131              
132 0         0 return $self->{$encrypted};
133 3         31 };
134              
135             $methods{$cmp} = sub
136             {
137 2     2   46169 my($self, $check) = @_;
138              
139 2         8 my $pass = $self->{$key};
140              
141 2 100       8 if(defined $pass)
142             {
143 1 50       9 return ($check eq $pass) ? 1 : 0;
144             }
145              
146 1         2 my $crypted = $self->{$encrypted};
147              
148 1 0 33     6 unless(!defined $default || defined $crypted ||
      0        
      0        
      33        
149             ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
150             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
151             #if(!defined $crypted && defined $default)
152             {
153 0 0       0 if(index($default, ':') == 0)
154             {
155 0         0 $crypted = $self->{$encrypted} = $default;
156             }
157             else
158             {
159 0         0 my $salt = substr(SALT_CHARS, int rand(length SALT_CHARS), 1) .
160             substr(SALT_CHARS, int rand(length SALT_CHARS), 1);
161 0         0 $crypted = $self->{$encrypted} = ':' . crypt($default, $salt);
162             }
163             }
164              
165 1 50       4 if(defined $crypted)
166             {
167 1         3 my $salt = substr($crypted, 1, 2);
168              
169 1 50       13 if(':' . crypt($check, $salt) eq $crypted)
170             {
171 1         4 $self->{$key} = $check;
172 1         8 return 1;
173             }
174              
175 0         0 return 0;
176             }
177              
178 0         0 return undef;
179 3         20 };
180             }
181             elsif($interface eq 'get')
182             {
183             $methods{$name} = sub
184             {
185 1     1   3 my($self) = shift;
186              
187 1 50       5 if($self->{STATE_SAVING()})
188             {
189              
190 0 0 0     0 unless(!defined $default || defined $self->{$encrypted} ||
      0        
      0        
      0        
191             ($undef_overrides_default && ($self->{$mod_columns_key}{$column_name} ||
192             ($self->{STATE_IN_DB()} && !($self->{SET_COLUMNS()}{$column_name} || $self->{$mod_columns_key}{$column_name})))))
193             #if(!defined $self->{$encrypted} && defined $default)
194             {
195 0 0       0 if(index($default, ':') == 0)
196             {
197 0         0 $self->{$encrypted} = $default;
198             }
199             else
200             {
201 0         0 my $salt = substr(SALT_CHARS, int rand(length SALT_CHARS), 1) .
202             substr(SALT_CHARS, int rand(length SALT_CHARS), 1);
203 0         0 $self->{$encrypted} = ':' . crypt($default, $salt);
204             }
205             }
206              
207 0         0 return $self->{$encrypted};
208             }
209              
210 1         5 return $self->{$key};
211 1         4 };
212             }
213             elsif($interface eq 'set')
214             {
215 1   50     6 my $encrypted = $key . ($args->{'encrypted_suffix'} || '_encrypted');
216              
217             $methods{$name} = sub
218             {
219 2     2   298 my($self) = shift;
220              
221 2 100       176 Carp::croak "Missing argument in call to $name" unless(@_);
222              
223             $self->{$mod_columns_key}{$column_name} = 1
224 1 50       7 unless($self->{STATE_LOADING()});
225              
226 1 50       5 if(defined $_[0])
227             {
228 1 50       5 if(index($_[0], ':') == 0)
229             {
230 0         0 $self->{$key} = undef;
231 0         0 return $self->{$encrypted} = shift;
232             }
233             else
234             {
235 1         50 my $salt = substr(SALT_CHARS, int rand(length SALT_CHARS), 1) .
236             substr(SALT_CHARS, int rand(length SALT_CHARS), 1);
237 1         27 $self->{$encrypted} = ':' . crypt($_[0], $salt);
238 1         5 return $self->{$key} = $_[0];
239             }
240             }
241              
242 0         0 return $self->{$encrypted} = $self->{$key} = undef;
243 1         4 };
244             }
245 0         0 else { Carp::croak "Unknown interface: $interface" }
246              
247 5         26 return \%methods;
248             }
249              
250             1;
251              
252             __END__
253              
254             =head1 NAME
255              
256             Rose::DB::Object::MakeMethods::Pg - Create PostgreSQL-specific object methods for Rose::DB::Object-derived objects.
257              
258             =head1 SYNOPSIS
259              
260             package MyDBObject;
261              
262             our @ISA = qw(Rose::DB::Object);
263              
264             use Rose::DB::Object::MakeMethods::Pg
265             (
266             chkpass =>
267             [
268             'password',
269             'secret' =>
270             {
271             encrypted_suffix => '_mangled',
272             cmp_suffix => '_equals',
273             },
274             ],
275             );
276              
277             ...
278              
279             $o = MyDBObject->new(...);
280              
281             $o->password('foobar');
282              
283             # Something like: ":vOR7BujbRZSLM" (varies based on salt used)
284             print $o->password_encrypted;
285              
286             print $o->password; # "foobar"
287             print "ok" if($o->password_is('foobar'); # "ok"
288              
289             $o->secret('baz');
290              
291             # Something like: ":jqROBZMqtWGJE" (varies based on salt used)
292             print $o->secret_mangled;
293              
294             print $o->secret; # "baz"
295             print "ok" if($o->secret_equals('baz'); # "ok"
296              
297             =head1 DESCRIPTION
298              
299             C<Rose::DB::Object::MakeMethods::Pg> creates methods that deal with data types that are specific to the PostgreSQL database server. It inherits from L<Rose::Object::MakeMethods>. See the L<Rose::Object::MakeMethods> documentation to learn about the interface. The method types provided by this module are described below.
300              
301             All method types defined by this module are designed to work with objects that are subclasses of (or otherwise conform to the interface of) L<Rose::DB::Object>. In particular, the object is expected to have a C<db> method that returns a L<Rose::DB>-derived object. See the L<Rose::DB::Object> documentation for more details.
302              
303             =head1 METHODS TYPES
304              
305             =over 4
306              
307             =item B<chkpass>
308              
309             Create a family methods for handling PostgreSQL's "CHKPASS" data type. This data type is not installed by default, but is included in the standard PostgreSQL source code distribution (in the "contrib" directory). From the README file for CHKPASS:
310              
311             "Chkpass is a password type that is automatically checked and converted upon
312             entry. It is stored encrypted. To compare, simply compare against a clear
313             text password and the comparison function will encrypt it before comparing.
314              
315             If you precede the string with a colon, the encryption and checking are
316             skipped so that you can enter existing passwords into the field.
317              
318             On output, a colon is prepended. This makes it possible to dump and reload
319             passwords without re-encrypting them. If you want the password (encrypted)
320             without the colon then use the raw() function. This allows you to use the
321             type with things like Apache's Auth_PostgreSQL module."
322              
323             This data type is very handy for storing encrypted values such as passwords while still retaining the ability to perform SELECTs and such using unencrypted values in comparisons. For example, the query
324              
325             SELECT * FROM users WHERE password = 'foobar'
326              
327             will actually find all the users whose passwords are "foobar", even though all the passwords are encrypted in the database.
328              
329             =over 4
330              
331             =item Options
332              
333             =over 4
334              
335             =item C<cmp_suffix>
336              
337             The string appended to the default method name to form the name of the comparison method. Defaults to "_is".
338              
339             =item C<encrypted_suffix>
340              
341             The string appended to the default method name to form the name of the get/set method that handles the encrypted version of the CHKPASS value. Defaults to "_encrypted".
342              
343             =item C<hash_key>
344              
345             The key inside the hash-based object to use for the storage of the unencrypted value. Defaults to the name of the method.
346              
347             The encrypted value is stored in a hash key with the same name, but with C<encrypted_suffix> appended.
348              
349             =item C<interface>
350              
351             Choose the interface. The default is C<get_set>.
352              
353             =back
354              
355             =item Interfaces
356              
357             =over 4
358              
359             =item C<get_set>
360              
361             Creates a family of methods for handling PostgreSQL's "CHKPASS" data type. The methods are:
362              
363             =over 4
364              
365             =item C<default>
366              
367             The get/set method for the unencrypted value. (This method uses the default method name.) If called with no arguments, the unencrypted value is returned, if it is known. If not, undef is returned.
368              
369             If passed an argument that begins with ":", it is assumed to be an encrypted value and is stored as such. Undef is returned, since it is not feasible to determine the unencrypted value based on the encrypted value.
370              
371             If passed an argument that does not begin with ":", it is taken as the unencrypted value. The value is encrypted using Perl's C<crypt()> function paired with a randomly selected salt, and the unencrypted value is returned.
372              
373             =item C<encrypted>
374              
375             The get/set method for the encrypted value. The method name will be formed by concatenating the C<default> method name (above) and the value of the C<encrypted_suffix> option.
376              
377             If called with no arguments, the encrypted value is returned, if it is known. If not, undef is returned.
378              
379             If passed an argument that begins with ":", it is assumed to be an encrypted value and is stored as such. The unencrypted value is set to undef, since it is not feasible to determine the unencrypted value based on the encrypted value. The encrypted value is returned.
380              
381             If passed an argument that does not begin with ":", it is taken as the unencrypted value. The value is encrypted using Perl's C<crypt()> function paired with a randomly selected salt, and the encrypted value is returned.
382              
383             =item C<comparison>
384              
385             This method compares its argument to the unencrypted value and returns true if the two values are identical (string comparison), false if they are not, and undef if both the encrypted and unencrypted values are undefined.
386              
387             =back
388              
389             =back
390              
391             =item C<get>
392              
393             Creates an accessor method for PostgreSQL's "CHKPASS" data type. This method behaves like the C<get_set> method, except that the value cannot be set.
394              
395             =item C<set>
396              
397             Creates a mutator method for PostgreSQL's "CHKPASS" data type. This method behaves like the C<get_set> method, except that a fatal error will occur if no arguments are passed.
398              
399             =back
400              
401             Example:
402              
403             package MyDBObject;
404              
405             our @ISA = qw(Rose::DB::Object);
406              
407             use Rose::DB::Object::MakeMethods::Pg
408             (
409             chkpass =>
410             [
411             'password',
412             'get_password' => { interface => 'get', hash_key => 'password' },
413             'set_password' => { interface => 'set', hash_key => 'password' },
414             'secret' =>
415             {
416             encrypted_suffix => '_mangled',
417             cmp_suffix => '_equals',
418             },
419             ],
420             );
421              
422             ...
423              
424             $o = MyDBObject->new(...);
425              
426             $o->set_password('blah');
427              
428             $o->password('foobar');
429              
430             # Something like: ":vOR7BujbRZSLM" (varies based on salt used)
431             print $o->password_encrypted;
432              
433             print $o->get_password; # "foobar"
434             print $o->password; # "foobar"
435             print "ok" if($o->password_is('foobar'); # "ok"
436              
437             $o->secret('baz');
438              
439             # Something like: ":jqROBZMqtWGJE" (varies based on salt used)
440             print $o->secret_mangled;
441              
442             print $o->secret; # "baz"
443             print "ok" if($o->secret_equals('baz'); # "ok"
444              
445             =back
446              
447             =head1 AUTHOR
448              
449             John C. Siracusa (siracusa@gmail.com)
450              
451             =head1 LICENSE
452              
453             Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is
454             free software; you can redistribute it and/or modify it under the same terms
455             as Perl itself.