File Coverage

blib/lib/DB2/Row.pm
Criterion Covered Total %
statement 12 168 7.1
branch 0 76 0.0
condition 0 45 0.0
subroutine 4 29 13.7
pod 20 20 100.0
total 36 338 10.6


line stmt bran cond sub pod time code
1             package DB2::Row;
2              
3 1     1   6636 use diagnostics;
  1         2  
  1         5  
4 1     1   30 use Carp;
  1         1  
  1         45  
5 1     1   5 use strict;
  1         2  
  1         25  
6 1     1   4 use warnings;
  1         6  
  1         2159  
7              
8             our $VERSION = '0.23';
9              
10             =head1 NAME
11              
12             DB2::Row Framework wrapper around rows using DBD::DB2
13              
14             =head1 SYNOPSIS
15              
16             package myRow;
17             use DB2::Row;
18             our @ISA = qw( DB2::Row );
19            
20             ...
21            
22             use myDB;
23             use myTable;
24            
25             my $db = myDB->new;
26             my $tbl = $db->get_table('myTable');
27             my $row = $tbl->find($id);
28             print $row->col_name;
29              
30             =head1 FUNCTIONS
31              
32             =over 4
33              
34             =item C
35              
36             Do not call this - you should get your row through your table object.
37             To create a new row, see C
38              
39             =cut
40              
41             sub new
42             {
43 0     0 1   my $class = shift;
44 0           my $self = {};
45 0   0       bless $self, ref $class || $class;
46              
47 0           my $init = shift;
48 0 0         if ($init)
49             {
50 0           %{$self->{CONFIG}} = %$init;
  0            
51 0 0         if (exists $self->{CONFIG}{_db_object})
52             {
53 0           $self->{_db_object} = $self->{CONFIG}{_db_object};
54 0           delete $self->{CONFIG}{_db_object};
55             }
56 0           %{$self->{ORIGVALUE}} = %{$self->{CONFIG}};
  0            
  0            
57             }
58              
59 0           foreach my $p ($self->_table->column_list)
60             {
61 0 0         next if exists $self->{CONFIG}{$p};
62              
63 0           my $col = $self->_table->get_column($p);
64 0 0         $self->{CONFIG}{$p} = $col->{default} if exists $col->{default};
65             }
66              
67 0           return $self;
68             }
69              
70             sub _modified
71 0     0     { scalar keys %{shift->{modified}} > 0; }
  0            
72              
73             sub _db
74 0     0     { shift->{_db_object} }
75              
76             sub _table
77             {
78 0     0     my $self = shift;
79 0 0         unless (exists $self->{_table})
80             {
81 0           $self->{_table} = $self->_db->get_table_for_row_type(ref $self);
82             }
83 0           $self->{_table};
84             }
85              
86             =item C
87              
88             Save the current row. Will happen automatically if it can. Only
89             really need to call this if you're interested in any generated identity
90             column for a new row.
91              
92             =cut
93              
94             sub save
95             {
96 0     0 1   my $self = shift;
97 0 0 0       if ($self and $self->_modified)
98             {
99 0           my $rc = $self->_table->save($self);
100              
101             # if we have any "generated" value, see if we can find it.
102 0           my $genColumn = $self->_table->generatedIdentityColumn;
103 0 0 0       if ($genColumn and not defined $self->column($genColumn))
104             {
105 0           my $stmt = 'values (IDENTITY_VAL_LOCAL())';
106 0           my $sth = $self->_table->_prepare($stmt);
107 0           $sth->execute;
108 0           my $id = $sth->fetchrow_array();
109 0           $self->column($genColumn, $id);
110 0           $sth->finish();
111             }
112              
113 0           $self->{ORIGVALUE} = { %{$self->{CONFIG}} };
  0            
114              
115 0           delete $self->{modified};
116 0           $self->_table->commit;
117 0           return $rc;
118             }
119 0           return '0E0';
120             }
121              
122             =item C
123              
124             If you do not want your changes up to this point to be kept,
125             C will do the obvious
126              
127             =cut
128              
129             sub discard_changes
130             {
131 0     0 1   my $self = shift;
132 0 0         if ($self->_modified)
133             {
134 0           $self->{CONFIG} = { %{$self->{ORIGVALUE}} };
  0            
135 0           delete $self->{modified};
136             }
137             }
138              
139             =item C
140              
141             Converts a DB2 timestamp column to a perl ("C") time value
142              
143             =cut
144              
145             my $timestamp_re = qr/(\d{4})-(\d\d)-(\d\d)[- ](\d\d)[.:](\d\d)[.:](\d\d)[.:](\d{6})/;
146              
147             sub timestamp_to_time
148             {
149 0     0 1   my $self = shift;
150 0           my $ts = shift;
151              
152 0 0         if (not defined $ts)
153             {
154 0           return undef;
155             }
156              
157 0           my ($year, $mon, $mday, $hour, $min, $sec) =
158             ($ts =~ $timestamp_re);
159 0           $year -= 1900;
160 0           $mon -= 1;
161 0           timegm($sec, $min, $hour, $mday, $mon, $year);
162             }
163              
164             =item C
165              
166             Converts a perl ("C") time value to a DB2 timestamp string.
167              
168             =cut
169              
170             sub time_to_timestamp
171             {
172 0     0 1   my $self = shift;
173 0           my $time = shift;
174              
175 0 0         if (not defined $time)
176             {
177 0           return undef;
178             }
179              
180             # if you pass in a timestamp, you'll get it back.
181 0 0         if ($time =~ $timestamp_re)
182             {
183 0           return $time;
184             }
185              
186 0           my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
187 0           sprintf "%04d-%02d-%02d-%02d.%02d.%02d.%06d",
188             ($year + 1900), $mon + 1, $mday, $hour, $min, $sec, 0;
189             }
190              
191             =item C
192              
193             Convert time to date. Converts a C/perl time to DB2's DATE format.
194              
195             =cut
196              
197             sub time_to_date
198             {
199 0     0 1   my $self = shift;
200 0           my $time = shift;
201              
202 0 0         if (not defined $time)
203             {
204 0           return undef;
205             }
206              
207 0 0         if ($time =~ /^\d+$/)
    0          
    0          
208             {
209 0           my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
210 0           return sprintf "%04d-%02d-%02d", ($year + 1900), $mon + 1, $mday;
211             }
212             elsif ($time =~ m.^(\d{2})/(\d{2})/(\d{4})$.)
213             {
214             # assume mm/dd/yyyy?
215 0           my ($m, $d, $y) = ($1, $2, $3);
216 0 0         if ($m > 12)
217             {
218             # bad assumption?
219 0           my $t = $m;
220 0           $m = $d;
221 0           $d = $t;
222             }
223 0           return sprintf("%04d-%02d-%02d", $y, $m, $d);
224             }
225             elsif ($time =~ /^(\d{2}).(\d{2}).(\d{4})$/)
226             {
227             # assume dd.mm.yyyy
228 0           my ($d, $m, $y) = ($1, $2, $3);
229 0 0         if ($m > 12)
230             {
231             # bad assumption?
232 0           my $t = $m;
233 0           $m = $d;
234 0           $d = $t;
235             }
236 0           return sprintf("%04d-%02d-%02d", $y, $m, $d);
237             }
238             }
239              
240             =item C
241              
242             Override this if you need to validate changes to a column. Normally
243             you can leave this to the database itself, but you may want to do this
244             earlier than that. You can also use this to massage the value before
245             it is kept.
246              
247             The parameters are:
248              
249             self
250             column name
251             new value
252              
253             To keep the value as given, simply return it. To modify (massage) the
254             value, return the modified value. To prevent the update, die.
255              
256             Remember to call your SUPER before validating yourself to allow for
257             future enhancements in C. The base function may perform
258             massaging such as converting time to timestamp, etc., in the future, so
259             you can get that for free then. Currently this behaviour is done in
260             the C method, but it may move into here in the future.
261              
262             Beware not to try to update the current column directly or indirectly
263             through this method as you could easily end up with infinite recursion.
264              
265             =cut
266              
267             sub validate_column
268             {
269 0     0 1   my $self = shift;
270 0           my $column = shift;
271 0           my $value = shift;
272              
273 0           $value;
274             }
275              
276             =item C
277              
278             This get/set method allows you to retrieve or update any given column
279             for this row. With a single parameter, it will return the current
280             value of that column. The second parameter will be the new value to
281             use. This value will be validated before being used.
282              
283             =cut
284              
285             sub column
286             {
287 0     0 1   my $self = shift;
288 0           my $name = uc shift;
289 0           my $type = ref($self);
290              
291 0 0         if (scalar @_)
292             {
293             # modifying?
294 0           my $col_type = uc $self->_table->get_column($name, 'type');
295 0 0         if (scalar @_)
296             {
297 0           my $val = shift;
298              
299             # eval because validate_column may die.
300             eval
301 0           {
302 0 0         if ($col_type eq 'TIMESTAMP')
    0          
    0          
    0          
303             {
304 0           $val = $self->time_to_timestamp($val);
305             }
306             elsif ($col_type eq 'DATE')
307             {
308 0           $val = $self->time_to_date($val);
309             }
310             elsif ($col_type eq 'NULLBOOL')
311             {
312 0 0         $val = $val ? 'Y' : defined $val ? 'N' : undef;
    0          
313             }
314             elsif ($col_type eq 'BOOL')
315             {
316 0 0         $val = $val ? 'Y' : 'N';
317             }
318 0           $val = $self->validate_column($name, $val);
319 0           $self->{CONFIG}{$name} = $val;
320              
321             # if it's not what we started with, keep track of it.
322 0 0 0       if (not exists $self->{ORIGVALUE}{$name} or
      0        
      0        
323             (not defined $val and defined $self->{ORIGVALUE}{$name}) or
324             $val ne $self->{ORIGVALUE}{$name})
325             {
326 0           $self->{modified}{$name} = 1;
327             }
328             # if it is where we started, it may be BACK to the original
329             # setting - clear the modification tag.
330             else
331             {
332 0           delete $self->{modified}{$name};
333 0 0         delete $self->{modified} unless $self->_modified;
334             }
335             }
336             }
337 0           my $rc = $self->{CONFIG}{$name};
338             #if (not defined $self->{CONFIG}{$name})
339             #{
340             # $rc = undef;
341             #}
342             #els
343 0           return $rc;
344             }
345              
346 0           (my $name_mod = $name) =~ s/^IS_?//;
347 0 0         if (defined $self->_table->get_column($name_mod))
348             {
349 0           my $type = uc $self->_table->get_column($name_mod, 'type');
350 0           my $rc = $self->{CONFIG}{$name_mod};
351              
352 0 0         if ($type eq 'BOOL')
    0          
353             {
354 0           $rc = $rc eq 'Y';
355             }
356             elsif ($type eq 'NULLBOOL')
357             {
358 0 0         $rc =
    0          
359             not defined $rc ? undef :
360             uc $rc eq 'Y' ? 1 : 0;
361             }
362              
363 0           return $rc;
364             }
365              
366 0           croak "Can't do '$name' in $type";
367 0           undef;
368              
369             }
370              
371             =item C
372              
373             This is intended to help template users by returning the current row
374             as a hash/hashref. For example, if you have a set of rows, @rows,
375             you can give them to HTML::Template as:
376              
377             loop => [ map { $_->as_hash(1) } @rows ],
378              
379             The optional parameter will force a scalar return (hashref) despite an
380             array context, such as the map context above.
381              
382             =cut
383              
384             sub as_hash
385             {
386 0     0 1   my $self = shift;
387 0           my $force_scalar = shift;
388              
389 0           my %ret = map {
390 0           $_ => $self->column($_);
391             } $self->_table->column_list();
392 0 0 0       (not $force_scalar && wantarray) ? %ret : \%ret;
393             }
394              
395             =item C
396              
397             Shortcut to calling C.
398              
399             =cut
400              
401             sub find
402             {
403 0     0 1   my $self = shift;
404              
405 0 0 0       unless ((ref $self and $self->isa(__PACKAGE__)) or
      0        
      0        
      0        
406             $self eq __PACKAGE__ or ($self and $self->isa(__PACKAGE__)))
407             {
408 0           unshift @_,$self;
409             }
410 0           $self->_table->find_id(@_);
411             }
412              
413             =item C
414              
415             Shortcut to calling C
416              
417             =cut
418              
419             sub find_where
420             {
421 0     0 1   my $self = shift;
422              
423 0 0 0       unless ((ref $self and $self->isa(__PACKAGE__)) or
      0        
      0        
      0        
424             $self eq __PACKAGE__ or ($self and $self->isa(__PACKAGE__)))
425             {
426 0           unshift @_,$self;
427             }
428              
429 0           $self->_table->find_where(@_);
430             }
431              
432             =item C
433              
434             Shortcut to calling C
435              
436             =cut
437              
438             sub table_name
439             {
440 0     0 1   my $self = shift;
441 0           $self->_table->full_table_name;
442             }
443              
444             =item C
445              
446             Shortcut to calling C
447              
448             =cut
449              
450             sub count
451             {
452 0     0 1   my $self = shift;
453 0           $self->_table->count(@_);
454             }
455              
456             =item C
457              
458             Shortcut to calling C
459              
460             =cut
461              
462             sub count_where
463             {
464 0     0 1   my $self = shift;
465 0           $self->_table->count_where(@_);
466             }
467              
468             =item C
469              
470             Shortcut to calling C for this ID
471              
472             =cut
473              
474             sub delete
475             {
476 0     0 1   my $self = shift;
477 0           $self->_table->delete($self);
478             }
479              
480             sub DESTROY
481             {
482 0     0     my $self = shift;
483 0 0         $self->save if $self;
484             }
485              
486             =item C
487              
488             Shortcut to calling C
489              
490             =cut
491              
492             sub SELECT
493             {
494 0     0 1   my $self = shift;
495              
496 0           $self->_table->SELECT(@_);
497             }
498              
499             =item C
500              
501             =item C
502              
503             =item C
504              
505             The relevant variable from DBI for the last problem occurring on this
506             table.
507              
508             =cut
509              
510 0     0 1   sub dbi_err { shift->_table->dbi_err }
511 0     0 1   sub dbi_errstr { shift->_table->dbi_errstr }
512 0     0 1   sub dbi_state { shift->_table->dbi_state }
513              
514             =item Dump
515              
516             Dumps the current values of this row without any internal variables
517             that Data::Dumper would follow.
518              
519             =cut
520              
521             sub Dump
522             {
523 0     0 1   my $self = shift;
524 0           my @cols = $self->_table()->column_list();
525              
526 0           ref ($self) . '={' . join(', ', map {
527 0           my $val = $self->column($_);
528 0 0         $val = defined $val ? "'$val'" : "";
529 0           "$_ => " . $val;
530             } @cols) . '}';
531             }
532              
533             =back
534              
535             =head2 Ced functions
536              
537             Any column defined by the corresponding DB2::Table object is also a
538             get/set accessor method for DB2::Row. For example, if you have a
539             column named "LASTNAME" in your table, C<$row_obj-Elastname()> will
540             retrieve that column from the $row_obj object, while
541             C<$row_obj-Elastname('Smith')> will set that objects' lastname to
542             'Smith'.
543              
544             =cut
545              
546             sub AUTOLOAD
547             {
548 0     0     my $self = shift;
549 0           our $AUTOLOAD;
550 0           my $name = $AUTOLOAD;
551 0           $name =~ s/.*://; # strip fully-qualified portion
552              
553 0           $self->column($name, @_);
554             }
555              
556             1;