File Coverage

blib/lib/DB2/Table.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1             package DB2::Table;
2              
3 1     1   1697 use diagnostics;
  1         2  
  1         4  
4 1     1   30 use strict;
  1         2  
  1         26  
5 1     1   5 use warnings;
  1         2  
  1         24  
6 1     1   5 use Carp;
  1         2  
  1         69  
7              
8 1     1   416 use DBI qw(:sql_types);
  0            
  0            
9              
10             our $VERSION = '0.23';
11              
12             =head1 NAME
13              
14             DB2::Table - Framework wrapper around tables using DBD::DB2
15              
16             =head1 SYNOPSIS
17              
18             package myTable;
19             use DB2::Table;
20             our @ISA = qw( DB2::Table );
21            
22             ...
23            
24             use myDB;
25             use myTable;
26            
27             my $db = myDB->new;
28             my $tbl = $db->get_table('myTable');
29             my $row = $tbl->find($id);
30              
31             =head1 FUNCTIONS
32              
33             =over 4
34              
35             =item C
36              
37             Do not call this - you should get your table through your database object.
38              
39             =cut
40              
41             sub new
42             {
43             my $class = shift;
44             my $self = {};
45             bless $self, ref $class || $class || confess("Unknown table");
46              
47             my $db = shift;
48             confess("Need the db handle as parameter")
49             unless $db and ref $db and $db->isa("DB2::db");
50             $self->{db} = $db;
51              
52             my %tableOrder;
53             my @cl = $self->column_list;
54             @tableOrder{ @cl } = (0..$#cl);
55             $self->{tableOrder} = \%tableOrder;
56              
57             $self;
58             }
59              
60             =item C
61              
62             the key sub to override! The data must be a reference to an array of hashes. Each
63             element (hash) in the array must contain certain keys, others are optional.
64              
65             =over 2
66              
67             =item Required:
68              
69             =over 2
70              
71             =item C
72              
73             Column Name (must be upper case)
74              
75             =item C
76              
77             SQL type or one of:
78              
79             =over 4
80              
81             =item C
82              
83             This will be represented by a NOT NULL CHAR that is limited to 'Y' or 'N'.
84             In perl, this will be auto-converted to perlish true/false values. An
85             undef will be treated as expected in perl: as false.
86              
87             =item C
88              
89             As above, but NULLs will be permitted. In this case, an 'N' in the database
90             will become a false, but defined, value. Only a NULL in the database will
91             translate to undef in perl.
92              
93             =back
94              
95             =back
96              
97             =item Optional:
98              
99             =over 2
100              
101             =item C
102              
103             for CHAR, VARCHAR, etc.
104              
105             =item C
106              
107             optional stuff - C, C, etc.
108             (Should use C rather than C 'PRIMARY KEY'>.)
109              
110             =item C
111              
112             default value
113              
114             =item C
115              
116             true for the primary key
117              
118             =item C
119              
120             stuff that is placed in the table create independantly
121              
122             =item C
123              
124             For this column, will create a FOREIGN KEY statement. The value here
125             is used during creation of the table, and should begin with the foreign
126             table name and include any "ON DELETE", "ON UPDATE", etc., portions.
127             This may change in the future where C will be itself another
128             hashref with all these fields.
129              
130             =item C
131              
132             For this column, will create as a generated identity. If this is undef
133             or the word 'default', the option will be C<(START WITH 0, INCREMENT BY 1, NO CACHE)>,
134             otherwise it will use whatever you provide here.
135              
136             =back
137              
138             =back
139              
140             This is somewhat based on a single column for a primary key, which is not
141             necessarily the "right" thing to do in relational design, but sure as heck
142             simplifies coding!
143             NOTE: Other columns may be present, but would only be used by the subclass.
144              
145             =cut
146              
147             sub data_order
148             {
149             die "Gotta override data_order!";
150             }
151              
152             sub _internal_data_order
153             {
154             my $self = shift;
155             unless ($self->{_data_order})
156             {
157             $self->{_data_order} = $self->data_order();
158             }
159             $self->{_data_order};
160             }
161              
162             sub _internal_data_reset
163             {
164             my $self = shift;
165             delete $self->{_data_order};
166             delete $self->{column_list};
167             delete $self->{ALL_DATA};
168             delete $self->{PRIMARY};
169             delete $self->{GENERATEDIDENTITY};
170             }
171              
172             =item C
173              
174             When allowing the framework to create your row type object because there
175             is no backing module, we need to know what to derive it from. If you have
176             a generic row type that is derived from DB2::Row that you want all your
177             rows to be derived from, you can override this.
178              
179             If all your empty Row types are derived from a single type that is not
180             DB2::Row, you should create a single Table type and have all your tables
181             derived from that. That is, to create a derivation tree for your row such as:
182              
183             DB2::Row -> My::Row -> My::UserR
184              
185             your derivation tree for your tables should look like:
186              
187             DB2::Table -> My::Table -> My::User
188              
189             And then C can override C to return
190             C
191              
192             =cut
193              
194             sub get_base_row_type
195             {
196             q(DB2::Row);
197             }
198              
199              
200             =item C
201              
202             Gets the DB2::db object that contains this table
203              
204             =cut
205              
206             sub getDB
207             {
208             shift->{db};
209             }
210              
211             =item C
212              
213             You need to override this. Must return the DB2 Schema to use for this
214             table. Generally, you may want to derive a single "schema" class from
215             DB2::Table which only overrides this method, and then derive each table
216             in that schema from that class.
217              
218             =cut
219              
220             sub schema_name { confess("You must override schema_name") }
221              
222             sub _connection
223             {
224             my $self = shift;
225             $self->getDB->connection;
226             }
227              
228             sub _find_create_row
229             {
230             my $self = shift;
231             my $type = $self->{db}->get_row_type_for_table(ref $self);
232              
233             my @row = @_;
234              
235             my %params = ( _db_object => $self->getDB );
236             if ($row[-1] and ref $row[-1] eq 'HASH')
237             {
238             %params = ( %params, %{$row[-1]} );
239             pop @row;
240             }
241              
242             my $data_order = $self->_internal_data_order();
243             foreach my $i (0..$#$data_order)
244             {
245             my $column = $data_order->[$i]{column};
246             if (defined $row[$i] and not exists $params{$column})
247             {
248             ($params{$column} = $row[$i]) =~ s/\s*$//;
249             }
250             }
251              
252             return $type->new(\%params);
253             }
254              
255             =item C
256              
257             Creates a new DB2::Row object for this table. Called instead of the
258             constructor for the DB2::Row object. Sets up defaults, etc. B:
259             this will not generate any identity column! We leave that up to the
260             database, so we will retrieve that during the save before committing.
261              
262             =cut
263              
264             sub create_row
265             {
266             my $self = shift;
267              
268             $self->_find_create_row( map (
269             {
270             $self->get_column($_, 'default');
271             } $self->column_list
272             ),
273             @_ );
274             }
275              
276             =item C
277              
278             Should be obvious - a full count of all the rows in this table
279              
280             =cut
281              
282             sub count
283             {
284             my $self = shift;
285              
286             $self->SELECT('COUNT(*)')->[0][0];
287             }
288              
289             =item C
290              
291             Similar to C, except that the first parameter will be the SQL
292             WHERE condition while the rest of the parameters will be the bind
293             values for that WHERE condition.
294              
295             =cut
296              
297             sub count_where
298             {
299             my $self = shift;
300              
301             $self->SELECT('COUNT(*)', @_)->[0][0];
302             }
303              
304             =item C
305              
306             Finds all rows with the primary column matching any of the parameters.
307             For example, $tbl->find_id(1, 2, 10) will return an array of DB2::Row
308             derived objects with all the data from 0-3 rows from this table, if
309             the primary column for that row is either 1, 2, or 10.
310              
311             =cut
312              
313             sub find_id
314             {
315             my $self = shift;
316              
317             $self->find_where(
318             $self->primaryColumn . ' IN (' .
319             join (', ', map {'?'} @_) . ')',
320             @_
321             );
322             }
323              
324             =item C
325              
326             Similar to C, the first parameter is the SQL WHERE condition
327             while the rest of the parameters are the bind values for the WHERE
328             condition.
329              
330             In array context, will return the array of DB2::Row derived objects
331             returned, whether empty or not.
332              
333             In scalar context, will return undef if no rows are found, will return
334             the single Row object if only one row is found, or an array ref if more
335             than one row is found.
336              
337             =cut
338              
339             sub find_where
340             {
341             my $self = shift;
342             $self->find_join($self->full_table_name, @_);
343             }
344              
345             =item C
346              
347             Similar to C, the first parameter is the tables to join
348             and how they are joined (any '!!!' found will be replaced with the
349             current table's full name), the second parameter is the where condition,
350             if any, and the rest are bind values.
351              
352             =cut
353              
354             sub find_join
355             {
356             my $self = shift;
357              
358             my @cols = $self->column_list();
359             my $prefix = "";
360             my $tables = shift;
361             if (ref $tables and ref $tables eq 'ARRAY')
362             {
363             $tables = join ' ', @$tables;
364             }
365              
366             if ($tables and (
367             $tables =~ /!!!\s+[Aa][Ss]\s+(\w+)/ or
368             $tables =~ /$self->full_table_name()\s+[Aa][Ss]\s+(\w+)/ or
369             $tables =~ /$self->table_name()\s+[Aa][Ss]\s+(\w+)/
370             )
371             )
372             {
373             $prefix = "$1.";
374             }
375              
376             my $ary_ref = $self->SELECT_join(
377             {
378             forreadonly => 1,
379             #distinct => 1,
380             prepare_attributes => $self->_prepare_attributes('SELECT'),
381             },
382             join(', ', map {$prefix . $_} $self->column_list),
383             $tables, @_);
384              
385             my @rc;
386             foreach my $row (@$ary_ref)
387             {
388             push @rc, $self->_find_create_row(@$row);
389             }
390              
391             # array, empty or not.
392             if (wantarray)
393             {
394             return @rc;
395             }
396             # if there aren't any, send back undef.
397             if (scalar @rc < 1)
398             {
399             return undef;
400             }
401             # no array wanted, and only one answer, send it back.
402             if (scalar @rc == 1)
403             {
404             return $rc[0];
405             }
406             # no array wanted, send back ref to array.
407             return \@rc;
408             }
409              
410             =item C<_prepare_attributes>
411              
412             Internally used to set any prepare attributes. Parameter says what
413             type of prepare this is, although the list is not finalised yet.
414              
415             =cut
416              
417             sub _prepare_attributes
418             {
419             {}
420             }
421              
422             =item C<_prepare>
423              
424             Internally used to cache statements. This may change to
425             C if it is found to be useful.
426              
427             =cut
428              
429             sub _prepare
430             {
431             my $self = shift;
432             my $stmt = shift;
433             my $attr = shift;
434              
435             DB2::db::_debug("$stmt\n");
436             my $sth = $self->_connection->prepare_cached($stmt, $attr);
437              
438             croak "Can't prepare [$stmt]: " . $self->_connection->errstr() unless $sth;
439              
440             $sth;
441             }
442              
443             sub _execute
444             {
445             my $self = shift;
446             my $sth = shift;
447              
448             delete $self->{_dbi};
449             unless ($sth->execute(@_))
450             {
451             $self->{_dbi}{err} = $sth->err;
452             $self->{_dbi}{errstr} = $sth->errstr;
453             $self->{_dbi}{state} = $sth->state;
454              
455             DB2::db::_debug("Failed to execute $sth->{Statement}: ", $sth->errstr());
456              
457             undef;
458             }
459             }
460              
461             =item C
462              
463             =item C
464              
465             =item C
466              
467             Shortcuts to get the DBI err, errstr, and state's, respectively.
468              
469             =cut
470              
471             sub dbi_err { shift->{_dbi}{err} }
472             sub dbi_errstr { shift->{_dbi}{errstr} }
473             sub dbi_state { shift->{_dbi}{state} }
474              
475             sub _already_exists_in_db
476             {
477             my $self = shift;
478             my $obj = shift;
479              
480             my $dbh = $self->_connection;
481             my $count = 0;
482              
483             my $column = $self->primaryColumn;
484              
485             if (ref $obj)
486             {
487             if ($column)
488             {
489             $obj = $obj->column($column);
490             }
491             }
492              
493             if (defined $obj and not ref $obj)
494             {
495              
496             #my $stmt = "SELECT COUNT(*) FROM " . $self->full_table_name .
497             # " WHERE $column IN ?";
498             #$count = $dbh->selectrow_array($stmt, undef, $objval);
499             $count = $self->SELECT('COUNT(*)', "$column IN ?", $obj)->[0][0];
500             }
501              
502             return $count;
503             }
504              
505             sub _update_db
506             {
507             my $self = shift;
508             my $obj = shift;
509             my $prep_attr = shift;
510              
511             # it's an update.
512             my $stmt = "UPDATE " . $self->full_table_name . " SET ";
513             my $prim_key = $self->primaryColumn;
514              
515             # find all modified fields.
516             my @sets;
517             my @newVal;
518             my @bind;
519              
520             {
521             for my $key (keys %{$obj->{modified}})
522             {
523             next if $key eq $prim_key;
524              
525             push @sets, "$key = ?";
526             push @bind, [$obj->{CONFIG}{$key}];
527             if ($self->get_column($key,'type') =~ /LOB$/)
528             {
529             push @{$bind[$#bind]}, 'SQL_BLOB';
530             }
531             }
532             }
533              
534             if (@sets)
535             {
536             $stmt .= join(", ", @sets);
537             $stmt .= " WHERE " . $self->primaryColumn . " IN ?";
538             my $sth = $self->_prepare($stmt, $prep_attr);
539              
540             my $i = 0;
541             for (; $i < @bind; ++$i)
542             {
543             if ($DB2::db::debug)
544             {
545             print "Binding ", $i + 1, " => ";
546             if (scalar @{$bind[$i]} > 1 and
547             $bind[$i][1] == SQL_BLOB)
548             {
549             print "[blob],", SQL_BLOB;
550             }
551             else
552             {
553             print join(",",@{$bind[$i]});
554             }
555             print "\n";
556             }
557             $sth->bind_param($i + 1, @{$bind[$i]});
558             }
559             $sth->bind_param($i + 1, $obj->{CONFIG}{$prim_key});
560             print "stmt = $stmt\n" if $DB2::db::debug;
561              
562             $self->_execute($sth); #, @newVal);
563             $sth->finish();
564             $self->commit();
565             }
566             else
567             {
568             '0E0'; # default return value.
569             }
570             }
571              
572             sub _insert_into_db
573             {
574             my $self = shift;
575             my $obj = shift;
576             my $prep_attr = shift;
577              
578             my @cols = grep {
579             not $self->get_column($_, 'NOCREATE') and
580             $_ ne $self->generatedIdentityColumn()
581             } $self->column_list;
582              
583             my $stmt = "INSERT INTO " . $self->full_table_name . " (" .
584             join(', ', @cols) .
585             ") VALUES(" . join(', ', map {'?'} @cols) . ")";
586              
587             DB2::db::_debug("$stmt\n");
588              
589             my $sth = $self->_prepare($stmt, $prep_attr);
590              
591             my @bind;
592             {
593             my $i = 0;
594             for my $key (map { uc $_ } @cols)
595             {
596             ++$i;
597              
598             push @bind, [$obj->{CONFIG}{$key}];
599             if ($self->get_column($key,'type') =~ /LOB$/)
600             {
601             my $x = $obj->{CONFIG}{$key};
602             #$bind[$#bind] = [\$x, {TYPE => SQL_BLOB}];
603             $bind[$#bind] = [$x, {TYPE => SQL_BLOB}];
604             #$bind[$#bind] = [$x, SQL_BLOB];
605             }
606             }
607             }
608             #print STDERR "stmt = $stmt -- ", join @newVal, "\n";
609             for (my $i = 0; $i < @bind; ++$i)
610             {
611             if ($DB2::db::debug)
612             {
613             print "Binding ", $i + 1, " => ";
614             if (scalar @{$bind[$i]} > 1 and
615             $bind[$i][1] == SQL_BLOB)
616             {
617             print "[blob],", SQL_BLOB;
618             }
619             else
620             {
621             print join(",", map { defined $_ ? $_ : "" } @{$bind[$i]});
622             }
623             print "\n";
624             }
625             $sth->bind_param($i + 1, @{$bind[$i]});
626             }
627              
628              
629             my $rc = $self->_execute($sth);
630             $sth->finish();
631             $rc;
632             }
633              
634             =item C
635              
636             The table is what saves a row. If you've made changes to a row, this
637             function will save it. Not really needed since the Row's destructor
638             will save, but doesn't hurt.
639              
640             =cut
641              
642             sub save
643             {
644             my $self = shift;
645             my $obj = shift;
646             my $prep_attr = shift;
647              
648             unless (ref $obj and $obj->isa("DB2::Row"))
649             {
650             croak("Got a " . ref($obj) . " which isn't a 'DB2::Row'");
651             }
652              
653             if ($self->_already_exists_in_db($obj))
654             {
655             if ($self->primaryColumn)
656             {
657             $self->_update_db($obj, $prep_attr);
658             }
659             }
660             # else it's new
661             else
662             {
663             $self->_insert_into_db($obj, $prep_attr);
664             }
665             }
666              
667             =item C
668              
669             Commits all current actions
670              
671             =cut
672              
673             sub commit
674             {
675             my $self = shift;
676             $self->_connection->commit;
677             }
678              
679             =item C
680              
681             Deletes the given row from the database.
682              
683             =cut
684              
685             sub delete
686             {
687             my $self = shift;
688             my $obj = shift;
689             my $prep_attr = shift;
690              
691             unless (ref $obj and $obj->isa("DB2::Row"))
692             {
693             croak("Got a " . ref($obj) . " which isn't a 'DB2::Row'");
694             }
695              
696             if ($self->_already_exists_in_db($obj))
697             {
698             $self->_delete_db($obj, $prep_attr);
699             }
700             }
701              
702             =item delete_id
703              
704             Deletes a row based on its ID. To delete multiple IDs simultaneously,
705             simply pass in an array ref.
706              
707             =cut
708              
709             sub delete_id
710             {
711             my $self = shift;
712             my $id = shift;
713             my $prep_attr = shift;
714             if (ref $id ne 'ARRAY')
715             {
716             $id = [ $id ];
717             }
718              
719             if ($self->primaryColumn() and $self->_already_exists_in_db($id))
720             {
721             my $stmt = 'DELETE FROM ' . $self->full_table_name() . ' WHERE ' .
722             $self->primaryColumn() . ' IN (' .
723             join(',', map { '?' } @$id) . ')';
724             my $sth = $self->_prepare($stmt, $prep_attr);
725             $self->_execute($sth, @$id);
726             $sth->finish();
727             }
728             }
729              
730             =item delete_where
731              
732             Deletes rows based on the given WHERE clause. Further parameters are
733             then bound to the DELETE statement.
734              
735             =cut
736              
737             sub delete_where
738             {
739             my $self = shift;
740             my $opts = ref $_[0] eq 'HASH' ? shift : {};
741             my $where = shift;
742              
743             my $stmt = 'DELETE FROM ' .
744             $self->full_table_name() . ' WHERE ' . $self->_replace_bangs($where);
745             my %prep_attr = exists $opts->{prepare_attributes} ? %{$opts->{prepare_attributes}} : ();
746             my $sth = $self->_prepare($stmt, \%prep_attr);
747             my $rc = $self->_execute($sth, @_);
748             $sth->finish();
749             $rc;
750             }
751              
752             sub _delete_db
753             {
754             my $self = shift;
755             my $obj = shift;
756             my $prep_attr = shift;
757              
758             my $primcol = $self->primaryColumn;
759             if ($primcol)
760             {
761             my $stmt = 'DELETE FROM ' . $self->full_table_name . ' WHERE ' .
762             $primcol . ' IN ?';
763              
764             my $sth = $self->_prepare($stmt, $prep_attr);
765             $self->_execute($sth, $obj->column($primcol));
766             $sth->finish();
767             $self->commit();
768             }
769             else
770             {
771             my $stmt = 'DELETE FROM ' . $self->full_table_name . ' WHERE ' .
772             join (' AND ', map { "$_ IN ?" } $self->column_list());
773             my $sth = $self->_prepare($stmt, $prep_attr);
774             $self->_execute($sth, map { $obj->column($_) } $self->column_list());
775             $sth->finish();
776             $self->commit();
777             }
778             }
779              
780             =item C
781              
782             Wrapper around performing an SQL SELECT statement.
783              
784             Parameters:
785              
786             =over 4
787              
788             =item *
789              
790             B: Hashref of options. Options may include:
791              
792             =over 4
793              
794             =item with
795              
796             This is the WITH clause tacked on to the front of the SELECT statement,
797             if any. (!!! replacement as per SELECT_join is done on this.)
798              
799             Or, this can be a hashref:
800              
801             with => {
802             temp2 => {
803             fields => [ qw/empno firstnme/ ],
804             as => q[SELECT EMPNO, FIRSTNAME FROM !!!,!XYZ! WHERE ...],
805             },
806             temp1 => {
807             as => q[...],
808             },
809             },
810              
811             This will create a WITH clause like this:
812              
813             WITH temp1 AS (...), temp2 (empno,firstname) AS (SELECT EMPNO, FIRSTNAME
814             FROM !!!,!XYZ! WHERE ...
815              
816             (except that !!! and !XYZ! will be expanded in the context of the current
817             table) which will then go in the front of the rest of the SELECT statement.
818              
819             =item distinct
820              
821             If true, the DISTINCT keyword will be added prior to the column names
822             resulting in a return set where each row is unique. Somewhat useless if
823             the columns are all columns or include UNIQUE columns.
824              
825             =item forreadonly
826              
827             Set the query up as a "FOR READ ONLY" statement (potential performance
828             enhancement).
829              
830             =item tables
831              
832             This is either a string with the table names, or an array ref of table names.
833             Used in joins.
834              
835             =item prepare_attributes
836              
837             This is used in the prepare statement as extra options - see DBD::DB2
838             under the heading C. The value here must be a
839             hashref ready to be passed in to the prepare function.
840              
841             =back
842              
843             =item *
844              
845             Arrayref of columns I string of columns, seperated
846             by commas. For example:
847              
848             [ qw(col1 col2 col3) ]
849              
850             or
851             'col1,col2,col3'
852              
853             =item *
854              
855             B: Where-clause for SQL query.
856              
857             =item *
858              
859             B: Bind values for the where-clause - this is not an arrayref
860             but the actual elements.
861              
862             =back
863              
864             For example:
865              
866             $table-ESELECT({distinct=>1},[qw(col1 col2)],
867             'col3 in (?,?,?)', 'blah', 'burg', 'frob');
868              
869             This will result in an SQL statement of:
870              
871             SELECT DISTINCT col1, col2 FROM myschema.mytable WHERE col3 in (?,?,?)
872              
873             And ('blah', 'burg', 'frob') will be bound to the ?'s.
874              
875             =cut
876              
877             sub SELECT
878             {
879             my $self = shift;
880             my $opts = ref $_[0] eq 'HASH' ? shift : {};
881             my $cols = shift;
882             my $where = shift;
883             my @params = @_;
884              
885             if (ref $cols and ref $cols eq 'ARRAY')
886             {
887             $cols = join ', ', @$cols;
888             }
889              
890             my $select_modifier = '';
891             my $table = $self->full_table_name();
892              
893             # is this a join?
894             if (exists $opts->{tables})
895             {
896             $table = $opts->{tables};
897             if (ref $table and ref $table eq 'ARRAY')
898             {
899             $table = join ', ', @$table;
900             }
901             $self->_replace_bangs($table);
902             }
903              
904             # distinct?
905             $select_modifier .= 'DISTINCT ' if $opts->{distinct};
906              
907             my $stmt = '';
908             $stmt .= 'WITH ' . $self->_with($opts->{with}). ' ' if $opts->{with};
909             $stmt .= 'SELECT ' . $select_modifier . $cols . ' FROM ' . $table;
910             $stmt .= ' WHERE ' . $self->_replace_bangs($where) if $where;
911             $stmt .= ' FOR READ ONLY' if $opts->{forreadonly};
912              
913             my %prep_attr = exists $opts->{prepare_attributes} ? %{$opts->{prepare_attributes}} : ();
914              
915              
916              
917             my $sth = $self->_prepare($stmt, \%prep_attr);
918             $self->_execute($sth, @params) or die "Failed to execute $stmt: " . $self->dbi_errstr();
919              
920             if ($opts->{as_hashes})
921             {
922             my @r;
923             while (my $h = $sth->fetchrow_hashref())
924             {
925             push @r, $h;
926             }
927             $sth->finish();
928             return wantarray ? @r : \@r;
929             }
930              
931             if ($opts->{as_hash})
932             {
933             return $sth->fetchall_hashref($opts->{as_hash});
934             }
935              
936             return $sth->fetchall_arrayref();
937             }
938              
939             sub _with
940             {
941             my $self = shift;
942             my $with = shift;
943              
944             if (ref $with)
945             {
946             my $substmt = join ', ', map {
947             my $fields = '';
948             if ($with->{$_}{fields})
949             {
950             $fields = $with->{$_}{fields};
951             if (ref $fields)
952             {
953             $fields = join ',', @$fields;
954             }
955             $fields = " ($fields)"
956             }
957             my $as = $self->_replace_bangs($with->{$_}{as});
958             $as = " AS ($as)";
959              
960             "$_$fields$as";
961             } sort keys %$with;
962             }
963             else
964             {
965             $with;
966             }
967             }
968              
969             =item C
970              
971             Wrapper around performing an SQL SELECT statement with distinct rows only
972             returned. Otherwise, it's exactly the same as C
973              
974             =cut
975              
976             sub SELECT_distinct
977             {
978             my $self = shift;
979             my $opts = {};
980             my $cols = shift;
981              
982             if (ref $cols and ref $cols eq 'HASH')
983             {
984             $opts = $cols;
985             $cols = shift;
986             }
987              
988             $opts->{distinct}++;
989              
990             return $self->SELECT($opts, $cols, @_);
991             }
992              
993             =item C
994              
995             Wrapper around performing an SQL SELECT statement where you may be joining
996             with other tables. The first argument is the columns you want, the second
997             is the tables, and how they are to be joined, while the third is the WHERE
998             condition. Further parameters are bind values. Any text matching '!!!' in
999             the columns text will be replaced with this table's full table name. Any
1000             text matching '!(\S+?)!' will be replaced with $1's full table name.
1001              
1002             =cut
1003              
1004             sub _replace_bangs
1005             {
1006             my $self = shift;
1007              
1008             $_[0] =~ s/!!!/$self->full_table_name()/ge;
1009             $_[0] =~ s/!(\S+?)!/$self->getDB()->get_table("$1")->full_table_name()/ge;
1010             $_[0];
1011             }
1012              
1013             sub SELECT_join
1014             {
1015             my $self = shift;
1016             my $opts = {};
1017             my $cols = shift;
1018              
1019             if (ref $cols and ref $cols eq 'HASH')
1020             {
1021             $opts = $cols;
1022             $cols = shift;
1023             }
1024              
1025             $opts->{tables} = shift;
1026             return $self->SELECT($opts, $cols, @_);
1027             }
1028              
1029             =item C
1030              
1031             The name of this table, excluding schema. This will default to the
1032             part of the current package after the last double-colon. For example,
1033             if your table is in package "myDB2::foo", then the table name will be
1034             "foo".
1035              
1036             =cut
1037              
1038             sub table_name
1039             {
1040             my $self = shift;
1041             unless (exists $self->{table_name})
1042             {
1043             my $type = ref $self;
1044             ( my $tbl = $type ) =~ s/.*::(\w+)/$1/;
1045             $self->{table_name} = uc $tbl;
1046             }
1047             $self->{table_name};
1048             }
1049              
1050             =item C
1051              
1052             Shortcut to schema.table_name
1053              
1054             =cut
1055              
1056             sub full_table_name
1057             {
1058             my $self = shift;
1059             unless (exists $self->{full_table_name})
1060             {
1061             $self->{full_table_name} = uc $self->schema_name . '.' . $self->table_name;
1062             }
1063             $self->{full_table_name};
1064             }
1065              
1066             =item C
1067              
1068             Returns an array of all the column names, in order
1069              
1070             =cut
1071              
1072             sub column_list
1073             {
1074             my $self = shift;
1075             if (not exists $self->{column_list})
1076             {
1077             $self->{column_list} = [map { $_->{column} } @{$self->_internal_data_order}];
1078             }
1079             @{$self->{column_list}}
1080             }
1081              
1082             =item C
1083              
1084             Returns a hash ref which is all the data from C, but in no
1085             particular order (it's a hash, right?).
1086              
1087             =cut
1088              
1089             sub all_data
1090             {
1091             my $self = shift;
1092             unless ($self->{ALL_DATA})
1093             {
1094             foreach my $h (@{$self->_internal_data_order()})
1095             {
1096             $self->{ALL_DATA}{uc $h->{column}} = $h;
1097             }
1098             }
1099             $self->{ALL_DATA}
1100             }
1101              
1102             =item C
1103              
1104             Gets information about a column or its data. First parameter is the
1105             column. Second parameter is the key (NAME, type, etc.). If
1106             the key is not given, a hash ref is returned with all the data for
1107             this column. If the key is given, only that scalar is returned.
1108              
1109             =cut
1110              
1111             sub get_column
1112             {
1113             my $self = shift;
1114             my $column = uc shift;
1115             my $data = @_ ? lc shift : undef;
1116             my $all_data = $self->all_data;
1117              
1118             return undef unless exists $all_data->{$column};
1119              
1120             if ($data)
1121             {
1122             exists $all_data->{$column}{$data} ? $all_data->{$column}{$data} : undef;
1123             }
1124             else
1125             {
1126             $all_data->{$column};
1127             }
1128             }
1129              
1130             =item C
1131              
1132             Find the primary column. First time it is called, it will determine
1133             the primary column, and then it will cache this for later calls. If
1134             you want a table with no primary column, you must override this method
1135             to return undef.
1136              
1137             If no column has the primary attribute, then the last column is
1138             defaulted to be the primary column.
1139              
1140             =cut
1141              
1142             # Find the primary column (and cache it)
1143             sub primaryColumn
1144             {
1145             my $self = shift;
1146             # Check cache.
1147             if (not exists $self->{PRIMARY})
1148             {
1149             # default to last one.
1150             $self->{PRIMARY} = $self->_internal_data_order()->[$#{$self->_internal_data_order()}]{column};
1151              
1152             my $data_order = $self->_internal_data_order();
1153             for (my $i = 0; $i < scalar @$data_order; ++$i)
1154             {
1155             if (exists $data_order->[$i]{primary} and $data_order->[$i]{primary})
1156             {
1157             $self->{PRIMARY} = $data_order->[$i]{column};
1158             last;
1159             }
1160             }
1161             }
1162             $self->{PRIMARY};
1163             }
1164              
1165             =item C
1166              
1167             Determine the generated identity column, if any. This is determined by
1168             looking for the string 'GENERATED ALWAYS AS IDENTITY' in the opts of
1169             the column. Again, this is cached on first use.
1170              
1171             =cut
1172              
1173             sub generatedIdentityColumn
1174             {
1175             my $self = shift;
1176             if (not exists $self->{GENERATEDIDENTITY})
1177             {
1178             $self->{GENERATEDIDENTITY} = '';
1179             foreach my $col (@{$self->_internal_data_order()})
1180             {
1181             if (exists $col->{generatedidentity} or
1182             (
1183             exists $col->{opts} and
1184             $col->{opts} =~ /GENERATED ALWAYS AS IDENTITY/i)
1185             )
1186             {
1187             $self->{GENERATEDIDENTITY} = $col->{column};
1188             last;
1189             }
1190             }
1191             }
1192             $self->{GENERATEDIDENTITY};
1193             }
1194              
1195             =item C
1196              
1197             Check if the table already exists. Normally only called by create_table.
1198              
1199             =cut
1200              
1201             sub table_exists
1202             {
1203             my $self = shift;
1204             my $dbh = $self->_connection;
1205             my @tables = $dbh->tables(
1206             {
1207             TABLE_SCHEM => uc $self->schema_name,
1208             TABLE_NAME => uc $self->table_name,
1209             }
1210             );
1211             die "Unexpected - more than one table with same schema/name!" if scalar @tables > 1;
1212             scalar @tables;
1213             }
1214              
1215             # INTERNAL - get current table structure (column names)
1216             sub create_table_get_current
1217             {
1218             my $self = shift;
1219             my $dbh = $self->_connection;
1220              
1221             my @row;
1222             if ($self->table_exists())
1223             {
1224             my $query = 'SELECT * FROM ' . $self->full_table_name . ' WHERE 1 = 0';
1225             my $sth = $dbh->prepare($query);
1226              
1227             $self->_execute($sth);
1228             @row = @{$sth->{NAME}};
1229             $sth->finish;
1230             }
1231             @row;
1232             }
1233             # INTERNAL - common code between CREATE and ALTER - column definitions
1234             sub _create_table_column_definition
1235             {
1236             my $self = shift;
1237             my $column = shift;
1238             my $tbl = $column->{column} . ' ';
1239             $tbl .= uc $column->{type} =~ /(?:NULL)?BOOL/ ? 'CHAR' : $column->{type};
1240             $tbl .= ' (' . $column->{length} . ')' if exists $column->{length};
1241             $tbl .= ' ' . $column->{opts} if $column->{opts};
1242             $tbl .= ' NOT NULL' if
1243             (
1244             $column->{primary} or
1245             uc $column->{type} ne 'NULLBOOL' and (not $column->{opts} or $column->{opts} !~ /NOT NULL/)) or
1246             ($column->{type} eq 'BOOL' and $column->{opts} !~ /NOT NULL/);
1247             if (exists $column->{sqldefault})
1248             {
1249             $tbl .= ' WITH DEFAULT ' . $column->{sqldefault};
1250             }
1251              
1252             $tbl .= ' CHECK (' . $column->{column} . q[ in ('Y','N'))] if uc $column->{type} eq 'BOOL';
1253             $tbl .= ' CHECK (' . $column->{column} . q[ in ('Y','N') OR ] . $column->{column} . q[ IS NULL)] if uc $column->{type} eq 'NULLBOOL';
1254             if (exists $column->{generatedidentity})
1255             {
1256             $tbl .= ' GENERATED ALWAYS AS IDENTITY ';
1257             if (not defined $column->{generatedidentity} or
1258             $column->{generatedidentity} eq 'default')
1259             {
1260             $tbl .= '(START WITH 0, INCREMENT BY 1, NO CACHE)';
1261             }
1262             else
1263             {
1264             $tbl .= $column->{generatedidentity};
1265             }
1266             }
1267              
1268             $self->_replace_bangs($tbl);
1269             }
1270             # Create the table as given by data_order.
1271              
1272             =item C
1273              
1274             Creates the current table. Normally only called by L.
1275              
1276             =cut
1277              
1278             sub create_table
1279             {
1280             my $self = shift;
1281             my $dbh = $self->_connection;
1282             my %current_col_names = map { $_ => 1 } $self->create_table_get_current();
1283              
1284             if (scalar keys %current_col_names == 0)
1285             { # new table
1286             my $tbl = 'CREATE TABLE ' . $self->full_table_name . ' (';
1287             my @columns;
1288             my @constraints;
1289             my @foreign_keys;
1290             foreach my $f ( $self->column_list )
1291             {
1292             my $column = $self->get_column($f);
1293             push @columns, $self->_create_table_column_definition($column);
1294             if (exists $column->{constraint})
1295             {
1296             push @constraints, map {
1297             my $x = 'CONSTRAINT ' . $_;
1298             $self->_replace_bangs($x);
1299             } ref($column->{constraint}) eq 'ARRAY' ? @{$column->{constraint}} : $column->{constraint};
1300             }
1301             if (exists $column->{foreignkey})
1302             {
1303             push @foreign_keys, map {
1304             my $x = 'FOREIGN KEY (' . $column->{column} . ') REFERENCES ' . $_;
1305             $self->_replace_bangs($x);
1306             } ref($column->{foreignkey}) eq 'ARRAY' ? @{$column->{foreignkey}} : $column->{foreignkey};
1307             }
1308             }
1309             if ($self->primaryColumn)
1310             {
1311             push @constraints, 'PRIMARY KEY (' . $self->primaryColumn . ')';
1312             }
1313             $tbl .= join(', ', @columns, @constraints, @foreign_keys);
1314             $tbl .= ') DATA CAPTURE NONE';
1315              
1316             print "$tbl\n";
1317             unless ($dbh->do($tbl))
1318             {
1319             print $DBI::err, '[', $DBI::state, '] : ', $DBI::errstr, "\n";
1320             }
1321              
1322             $self->create_table_initialise('CREATE', $self->column_list());
1323             }
1324             else
1325             { # existing table - anything need to be updated?
1326             my $alter = 'ALTER TABLE ' . $self->full_table_name;
1327             my @add = grep { not exists $current_col_names{uc $_} } ($self->column_list);
1328              
1329             if (scalar @add)
1330             {
1331             foreach my $add (@add)
1332             {
1333             my $column = $self->get_column($add);
1334             $alter .= ' ADD ' . $self->_create_table_column_definition($column);
1335             }
1336             print $alter, "\n";
1337             $dbh->do($alter);
1338              
1339             $self->create_table_initialise('ALTER', @add);
1340             }
1341             }
1342              
1343             }
1344              
1345             =item C
1346              
1347             A hook that will allow you to initialise the table immediately after
1348             its creation. If the table is newly created, the only parameter will
1349             be 'CREATE'. If the table is being altered, the first parameter will
1350             be 'ALTER' while the rest of the parameters will be the list of columns
1351             added.
1352              
1353             The default action is mildly dangerous. It grants full select, insert,
1354             update, and delete authority to the user 'nobody'. This is the user
1355             that many daemons, including the default Apache http daemon, run under.
1356             If you override this, you can do whatever you want, including nothing.
1357             This default was put in primarily because many perl DBI scripts are
1358             expected to also be CGI scripts, so this may make certain things
1359             easier. This does not change the fact that when this grant is executed
1360             you will need some admin authority on the database.
1361              
1362             =cut
1363              
1364             sub create_table_initialise
1365             {
1366             my $self = shift;
1367             my $action = shift;
1368             if ($action eq 'CREATE')
1369             {
1370             # default: grant authority to nobody (useful for web apps)
1371             my $grant =
1372             'GRANT SELECT,INSERT,UPDATE,DELETE ON TABLE ' .
1373             $self->full_table_name .
1374             ' TO USER NOBODY';
1375             $self->_connection->do($grant);
1376             }
1377              
1378             }
1379              
1380             =back
1381              
1382             =cut
1383              
1384             1;