File Coverage

blib/lib/CAM/SQLObject.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package CAM::SQLObject;
2              
3              
4             =head1 NAME
5              
6             CAM::SQLObject - Object parent class for SQL delegates
7              
8             =head1 LICENSE
9              
10             Copyright 2005 Clotho Advanced Media, Inc.,
11              
12             This library is free software; you can redistribute it and/or modify it
13             under the same terms as Perl itself.
14              
15             =head1 COMPARISON
16              
17             This is one of many modules that tries to apply an Object-Oriented
18             front on SQL database content. The primary thing that's special about
19             it is that the helper module, CAM::SQLManager, has a slick way of
20             encapsulating the SQL so your Perl code has no SQL in it.
21              
22             The advantage of externalizing your SQL is like the advantage of
23             externalizing HTML content via templating systems. You can work on
24             them separately and you don't need your programmer to also be a DBA.
25             Having the SQL be separate also lets you easily test and optimize your
26             queries separately from the main program logic. Very handy. See
27             CAM::SQLManager for more info.
28              
29             =head1 SYNOPSIS
30              
31             package Foo;
32             use CAM::SQLObject;
33             our @ISA = qw(CAM::SQLObject);
34            
35             sub sqlcmd { return "foo.xml" }
36             sub keyName { return "foo_id" }
37             sub insertQueryName { return "add" }
38             [ ... other specific changes for this package ... ]
39            
40             sub renderfoo_name {
41             my ($self) = @_;
42             return "NAME: " . $self->getfoo_name();
43             }
44            
45             sub getfoo_name {
46             my ($self) = @_;
47             return $self->{fields}->{foo_name};
48             }
49            
50             sub setfoo_name {
51             my ($self, $value) = @_;
52             $self->{fields}->{foo_name} = $value;
53             }
54            
55             sub setfoo_id {
56             my ($self, $value) = @_;
57             $self->{fields}->{foo_id} = $value;
58             $self->{keyvalue} = $value;
59             }
60              
61             =head1 DESCRIPTION
62              
63             This class is not meant to be instantiated directly. Instead, it is
64             intended to be the superclass of real database frontend objects.
65             Those objects will typically add several get and set
66             routines to act as accessors and mutators for the database fields.
67              
68             =cut
69              
70             require 5.005_62;
71 1     1   32607 use strict;
  1         2  
  1         39  
72 1     1   5 use warnings;
  1         2  
  1         33  
73 1     1   7 use Carp;
  1         2  
  1         97  
74 1     1   422 use CAM::SQLManager;
  0            
  0            
75              
76             our @ISA = qw();
77             our $VERSION = '1.01';
78             our $AUTOLOAD;
79              
80             #----------------
81              
82             =head1 CLASS METHODS
83              
84             =over 4
85              
86             =cut
87              
88             #----------------
89              
90             =item AUTOLOAD
91              
92             If you call a method on this class that does not exist, the AUTOLOAD
93             function takes over. The CAM::SQLObject autoloader handles a few
94             specialized dynamic methods:
95              
96             If that method name looks like one of:
97              
98             $obj->set(...)
99             $obj->get(...)
100             $obj->render(...)
101              
102             then AUTOLOAD implements the appropriate call of the following:
103              
104             $obj->set(, ...)
105             $obj->get(, ...)
106             $obj->render(, ...)
107              
108             If a subclass overrides a particular get, set, or render method, then
109             that one will be used. The SYNOPSIS above shows how to write an
110             override method.
111              
112             Special case: If the field starts with C, then that is
113             replaced with the tableName() value plus and underscore. If the class
114             does not define the table name, then the method will fail and a
115             warning will be emitted.
116              
117              
118             If the method name looks like:
119              
120             $pkg->retrieve(...)
121              
122             then AUTOLOAD implements a call to:
123              
124             $pkg->retrieve(, ...)
125              
126             which can be overloaded in ways similar to the object methods above.
127              
128             Note that get(), set() and render() are instance methods while
129             retrieve() is a class method.
130              
131             =cut
132              
133             sub AUTOLOAD
134             {
135             my ($func) = $AUTOLOAD =~ /([^:]+)$/;
136             return if ($func eq "DESTROY");
137            
138             # Use default accessor/mutator
139             if ($func =~ /^(get|render|set)(Table_)?(.+)$/)
140             {
141             my $type = $1;
142             my $table = $2;
143             my $field = $3;
144             my $self = $_[0];
145             if ($self && ref($self))
146             {
147             if ($table)
148             {
149             my $tablename = $self->{tablename};
150             if (!$tablename)
151             {
152             &carp("Undefined tablename in $AUTOLOAD");
153             return undef;
154             }
155             $field = $tablename."_".$field;
156             }
157             my $pkg = ref($self);
158             if ($type eq "get")
159             {
160             eval 'sub '.$pkg.'::get'.$field.'{shift()->{fields}->{"'.$field.'"}}';
161             return $self->get($field);
162             }
163             elsif ($type eq "set")
164             {
165             eval 'sub '.$pkg.'::set'.$field.'{shift()->set("'.$field.'",@_)}';
166             return $self->set($field, $_[1]);
167             }
168             elsif ($type eq "render")
169             {
170             eval 'sub '.$pkg.'::render'.$field.'{my$v=shift()->get'.$field.'();defined $v?$v:""}';
171             return $self->render($field);
172             }
173             }
174             }
175              
176             # Use default object retrieval method
177             elsif ($func =~ /^(retrieve)(.+)$/)
178             {
179             my $type = $1;
180             my $queryname = $2;
181             my $pkg = $_[0];
182             if ($pkg)
183             {
184             if ($type eq "retrieve")
185             {
186             eval 'sub '.$pkg.'::retrieve'.$queryname.'{shift()->retrieve("'.$queryname.'", @_)}';
187             return $pkg->retrieve($queryname, @_[1..$#_]);
188             }
189             }
190             }
191             &carp("Undefined function $AUTOLOAD");
192             }
193             #----------------
194              
195             =item new
196              
197             Creates a new stub object.
198              
199             The following documenation is DEPRECATED as of version 0.50. New
200             subclasses should instead override individual functions instead of
201             changing the new() method.
202              
203             Subclasses should consider overriding the
204             following fields, in order of priority:
205              
206             Name Default Purpose
207             ---- ------- -------
208             sqlcmd undef location of the SQL templates (see SQLManager)
209             keyname undef name of the primary key field (needed for save())
210             tablename undef name of the SQL table (needed for fieldNames())
211             update_name "update" name of query in sqlcmd (needed for save())
212             insert_name "insert" name of query in sqlcmd (needed for save())
213             delete_name "delete" name of query in sqlcmd
214             keygen undef which technique should be used to get new keys
215             keygen_data undef info needed for how to generate keys
216              
217             See newkey() below for more information on keygen and keygen_data.
218              
219             =cut
220              
221             sub new
222             {
223             my $pkg = shift;
224              
225             my @sqlcmds = $pkg->sqlcmd();
226             my $self = {
227             keyname => $pkg->keyName(),
228             keyvalue => undef,
229             sqlcmd => $sqlcmds[0],
230             sqlcmds => [@sqlcmds],
231             tablename => $pkg->tableName(),
232             update_name => $pkg->updateQueryName(),
233             insert_name => $pkg->insertQueryName(),
234             delete_name => $pkg->deleteQueryName(),
235             keygen => $pkg->keygenAlgorithm(),
236             keygen_data => $pkg->keygenData,
237             fields => {},
238             };
239             return bless($self, $pkg);
240             }
241             #----------------
242              
243             =item getMgr
244              
245             Retrieves a CAM::SQLManager instance for this class. This can be
246             called as a class method or as an instance method.
247              
248             =cut
249              
250             sub getMgr
251             {
252             my $pkg_or_self = shift;
253              
254             my @args = ();
255             my $dbh = $pkg_or_self->_getDBH();
256             push @args, "-dbh" => $dbh if ($dbh);
257              
258             my $mgr;
259             if (ref $pkg_or_self)
260             {
261             my $self = $pkg_or_self;
262             $self->{lastmgr} ||= CAM::SQLManager->getMgr(@args, $self->_getCmds());
263             $mgr = $self->{lastmgr};
264             }
265             else
266             {
267             my $pkg = $pkg_or_self;
268             $mgr = CAM::SQLManager->getMgr(@args, $pkg->_getCmds());
269             }
270              
271             return $mgr;
272             }
273             #----------------
274              
275             # Internal method, default for super class. Sub classes get
276             # overridden ONLY in setDBH()
277              
278             sub _getDBH
279             {
280             my $pkg_or_self = shift;
281             return undef;
282             }
283             #----------------
284              
285             =item setDBH DBH
286              
287             Tells the SQL manager to use the specified database handle for all
288             interaction with objects of this class. If setDBH() is not called,
289             the default database handle from CAM::SQLManager is used. This method
290             must be called before any objects are instantiated.
291              
292             =cut
293              
294             sub setDBH
295             {
296             my $pkg_or_self = shift;
297             my $dbh = shift;
298            
299             my $pkg = ref($pkg_or_self) || $pkg_or_self;
300             no warnings; # block the "function redefined" warning message
301             eval "*".$pkg."::_getDBH = sub{return \$dbh};";
302             }
303             #----------------
304              
305             =item retrieveByKey KEYVALUE
306              
307             Class method to retrieve a single object for the specified key.
308             Objects with complicated SQL representations should override this
309             method.
310              
311             This method executes an implicit query that looks like:
312              
313             select * from where =
314              
315             =cut
316              
317             sub retrieveByKey
318             {
319             my $pkg = shift;
320             my $keyValue = shift;
321              
322             return undef if (!$keyValue);
323              
324             my $self = $pkg->new();
325             my $mgr = $self->getMgr();
326             my $tableName = $self->{tablename};
327             my $keyName = $self->{keyname};
328             return undef if (!($mgr && $tableName && $keyName));
329              
330             my $dbh = $mgr->{dbh};
331             my $sth = $dbh->prepare("select * from $tableName " .
332             "where $keyName=" . $dbh->quote($keyValue));
333              
334             # Use intimate knowledge of SQLManager internals to time this query
335             $mgr->_startclock() if ($CAM::SQLManager::global_benchmarking);
336              
337             $sth->execute();
338              
339             $mgr->_stopclock() if ($CAM::SQLManager::global_benchmarking);
340             $mgr->_incrStats("retrieveByKey") if ($CAM::SQLManager::global_benchmarking);
341              
342             my $row = $sth->fetchrow_hashref();
343             $sth->finish();
344              
345             return undef if (!$row);
346              
347             no strict 'refs';
348             foreach my $fieldName (keys %$row)
349             {
350             my $function = "set$fieldName";
351             $self->$function($row->{$fieldName});
352             }
353             return $self;
354             }
355             #----------------
356              
357             =item retrieve QUERYNAME, [KEY => VALUE, KEY => VALUE, ...]
358              
359             Generic class method to retrieve objects from a specified query. The
360             extra parameters are passed as bind variables to the query. This is
361             pretty much just a handy wrapper around the CAM::SQLManager method
362             retrieveObjects().
363              
364             In scalar context, just the first object will be returned. In array
365             context, all of the matching objects are returned.
366              
367             Recommended usage: Use this via the autoloaded method
368             retrieve(). For example, if you have a query
369             "GetOldClients" which takes "year" as a query parameter, then call it
370             like:
371              
372             @clients = CAM::SQLObject->retrieveGetOldClients(year => "1998");
373              
374             instead of
375              
376             @clients = CAM::SQLObject->retrieve("GetOldClients", year => "1998");
377              
378             The former example has the advantage that subclasses can easily
379             override it to do different and interesting things.
380              
381             =cut
382              
383             sub retrieve
384             {
385             my $pkg_or_self = shift;
386             my $queryname = shift;
387              
388             my $mgr = $pkg_or_self->getMgr();
389             return wantarray ? () : undef if (!$mgr);
390             my @results;
391             if (ref($pkg_or_self))
392             {
393             my $self = $pkg_or_self;
394             my $pkg = ref($self);
395             @results = $mgr->retrieveObjects($queryname, $pkg, [],
396             $self->getAllFields(), @_);
397             }
398             else
399             {
400             my $pkg = $pkg_or_self;
401             @results = $mgr->retrieveObjects($queryname, $pkg, [], @_);
402             }
403             return wantarray ? @results : $results[0];
404             }
405             #----------------
406              
407             =back
408              
409             =head1 OVERRIDE METHODS
410              
411             The following methods are all class or instance methods. Subclasses
412             are encouraged to override them for more specific functionality.
413              
414             =over 4
415              
416             =cut
417              
418             #----------------
419              
420             =item sqlcmd
421              
422             This class or instance method returns the name of the XML file used to
423             hold SQL commands. Subclasses have the following options:
424              
425             - override the new() method to explicitly set the sqlcmd parameter
426             (this is the old style and is deprecated, since it did not work
427             as a class method)
428             - override the sqlcmd() method to specify the file
429             (recommended for unusual file names)
430             - let CAM::SQLObject try to find the file
431              
432             With the latter option, this method will search in the following
433             places for the sqlcmd file (in this order):
434              
435             - use the package name, replacing '::' with '/' (e.g. Foo::Bar
436             becomes $sqldir/Foo/Bar.xml)
437             - use the trailing component of the package name (e.g. Foo::Bar
438             becomes $sqldir/Bar.xml)
439              
440             Subclasses which are happy to use these default file names should not
441             override this method, or change the sqlcmd proprty of any instances.
442             Otherwise, this method should either be overridden by all subclasses
443             (which is the recommended style), or those subclasses should override
444             the new() method to set the sqlcmd field explicitly (which is the
445             previous, now deprecated, style).
446              
447             Here is a simple example override method:
448              
449             sub sqlcmd { return "foobar.xml"; }
450              
451             =cut
452              
453             sub sqlcmd
454             {
455             my $pkg_or_self = shift;
456              
457             my $pkg = ref($pkg_or_self) || $pkg_or_self;
458             my $self = ref($pkg_or_self) ? $pkg_or_self : undef;
459              
460             my @files = ();
461             if ($self && $self->{sqlcmd})
462             {
463             push @files, $self->{sqlcmd};
464             }
465              
466             my $fullpath = $pkg;
467             $fullpath =~s/\:\:/\//g;
468             $fullpath .= ".xml";
469             push @files, $fullpath;
470              
471             my $shortpath = $fullpath;
472             $shortpath =~ s/^.*\///;
473             push @files, $shortpath;
474              
475             return wantarray ? @files : $files[0];
476             }
477             #----------------
478              
479             =item keyName
480              
481             Returns the name of the primary key field (needed for save() and
482             retrieveByKey()). This default method returns the primary key name
483             from the SQL Manager's XML file, or undef.
484              
485             =cut
486              
487             sub keyName
488             {
489             my $pkg_or_self = shift;
490              
491             my $mgr = $pkg_or_self->getMgr();
492             if ($mgr)
493             {
494             return $mgr->keyName() || undef;
495             }
496             return undef;
497             }
498             #----------------
499              
500             =item tableName
501              
502             Returns the name of the SQL table (needed for fieldNames() and
503             retrieveByKey()). This default method returns the table name from the
504             SQL Manager's XML file, or undef.
505              
506             =cut
507              
508             sub tableName
509             {
510             my $pkg_or_self = shift;
511              
512             my $mgr = $pkg_or_self->getMgr();
513             if ($mgr)
514             {
515             return $mgr->tableName() || undef;
516             }
517             return undef;
518             }
519             #----------------
520              
521             =item updateQueryName
522              
523             Returns the name of the default query to do record updates in SQL XML
524             file (needed for save()). This default method returns "update".
525              
526             =cut
527              
528             sub updateQueryName
529             {
530             my $pkg_or_self = shift;
531              
532             return "update";
533             }
534             #----------------
535              
536             =item insertQueryName
537              
538             Returns the name of the default query to do record inserts in SQL XML
539             file (needed for save()). This default method returns "insert".
540              
541             =cut
542              
543             sub insertQueryName
544             {
545             my $pkg_or_self = shift;
546              
547             return "insert";
548             }
549             #----------------
550              
551             =item deleteQueryName
552              
553             Returns the name of the default query to do record deletes in SQL XML
554             file. This default method returns "delete".
555              
556             =cut
557              
558             sub deleteQueryName
559             {
560             my $pkg_or_self = shift;
561              
562             return "delete";
563             }
564             #----------------
565              
566             =item keygenAlgorithm
567              
568             Returns the name of the algorithm that the newkey() method uses to
569             generate its keys. This default method returns undef. See newkey()
570             for more details.
571              
572             =cut
573              
574             sub keygenAlgorithm
575             {
576             my $pkg_or_self = shift;
577              
578             return undef;
579             }
580             #----------------
581              
582             =item keygenData
583              
584             Returns the ancillary data needed to support the algorithm specified
585             by keygenAlgorithm(). The contents of this data depend on the
586             algorithm chosen. This default method returns undef. See newkey()
587             for more details.
588              
589             =cut
590              
591             sub keygenData
592             {
593             my $pkg_or_self = shift;
594              
595             return undef;
596             }
597             #----------------
598              
599             =back
600              
601             =head1 INSTANCE METHODS
602              
603             =over 4
604              
605             =cut
606              
607             #----------------
608              
609             =item get_key
610              
611             Retrieve the object key.
612              
613             =cut
614              
615             sub get_key
616             {
617             my $self = shift;
618              
619             if (!$self->{keyname})
620             {
621             &carp("No keyname defined");
622             return undef;
623             }
624             no strict 'refs';
625             my $function = "get" . $self->{keyname};
626             return $self->$function();
627             }
628             #----------------
629              
630             =item set_key
631              
632             Change the object key.
633              
634             =cut
635              
636             sub set_key
637             {
638             my $self = shift;
639             my $newkey = shift;
640              
641             if (!$self->{keyname})
642             {
643             &carp("No keyname defined");
644             return undef;
645             }
646              
647             no strict 'refs';
648             my $function = "set" . $self->{keyname};
649             return $self->$function($newkey);
650             }
651             #----------------
652              
653             =item get FIELD
654              
655             Retrieve a field. This method is intended for internal use only,
656             i.e. from AUTOLOAD or from subclass accessors. An example of the
657             latter:
658              
659             sub getFOO_ID {
660             my $self = shift;
661             return $self->get("FOO_ID") + $ID_offset;
662             }
663              
664             =cut
665              
666             sub get
667             {
668             my $self = shift;
669             my $field = shift;
670              
671             return $field ? $self->{fields}->{$field} : undef;
672             }
673             #----------------
674              
675             =item render FIELD
676              
677             Retrieve a field, with output formatting applied. This method is
678             intended for internal use only, i.e. from AUTOLOAD or from subclass
679             accessors. An example of the latter:
680              
681             sub renderFOO_ID {
682             my $self = shift;
683             return "ID " . &html_escape($self->render("FOO_ID"));
684             }
685              
686             =cut
687              
688             sub render
689             {
690             my $self = shift;
691             my $field = shift;
692              
693             no strict 'refs';
694             my $function = "get$field";
695             my $value = $self->$function();
696             $value = "" if (!defined $value);
697             return $value;
698             }
699             #----------------
700              
701             =item set FIELD, VALUE [FIELD, VALUE, ...]
702              
703             Assign a field. This method is intended for internal use only,
704             i.e. from AUTOLOAD or from subclass mutators. An example of the
705             latter:
706              
707             sub setFOO_ID {
708             my $self = shift;
709             my $value = shift;
710             return $self->set("FOO_ID", $value - $ID_offset);
711             }
712              
713             =cut
714              
715             sub set
716             {
717             my $self = shift;
718             # process additional args below
719              
720             while (@_ > 0)
721             {
722             my $field = shift;
723             my $value = shift;
724              
725             if ($field)
726             {
727             if ($self->{keyname} && $self->{keyname} eq $field)
728             {
729             $self->{keyvalue} = $value;
730             }
731             $self->{fields}->{$field} = $value;
732             }
733             else
734             {
735             &carp("Attempt to set undef field");
736             }
737             }
738             return $self;
739             }
740             #----------------
741              
742             =item fill QUERYNAME
743              
744             Given an object with partially filled fields, run an SQL query that
745             will retrieve more fields. The query should be designed to return
746             just one row. If any command in the query does not return exactly one
747             row, the command will fail.
748              
749             Example:
750              
751             $obj = new ACME::Towel;
752             $obj->set_serial_number("0123456789");
753             $obj->fill("get_towel_by_sn");
754              
755             =cut
756              
757             sub fill
758             {
759             my $self = shift;
760             my $queryname = shift;
761              
762             return $self->_runSelectSQL($queryname, @_);
763             }
764             #----------------
765              
766             =item fieldNames
767              
768             =item fieldNames TABLENAME
769              
770             Retrieves an array of the names of the fields in the primary SQL
771             table. If TABLENAME is omitted, this applies to the primary table
772             (this only works if the subclass sets the $self->{tablename}
773             property). This function uses some MySQL specific directives...
774              
775             (Note: this is a kludge in that it runs the "describe " SQL
776             directly, instead of going through the SQLManager's XML interface)
777              
778             =cut
779              
780             sub fieldNames
781             {
782             my $self = shift;
783             my $tablename = shift || $self->{tablename};
784              
785             if (!$tablename)
786             {
787             warn "No tablename specified";
788             return ();
789             }
790              
791             my $mgr = $self->getMgr();
792             if (!$mgr)
793             {
794             &carp("Failed to retrieve an SQL manager");
795             return ();
796             }
797             my $sth = $mgr->{dbh}->prepare("describe $tablename");
798             return () if (!$sth);
799             $sth->execute() or return ();
800             my @fieldnames = ();
801             while (my $row = $sth->fetchrow_arrayref())
802             {
803             push @fieldnames, $row->[0];
804             }
805             return @fieldnames;
806             }
807             #----------------
808              
809             =item query
810              
811             Run the specified query against this object. All bound SQL parameters
812             will be read from this object. This is applicable to both SELECT as
813             well as UPDATE/INSERT queries. While usually called as an instance
814             method, this can be called as a class method if all you are interested
815             in is the side effects of the SQL query instead of the data.
816              
817             NOTE! This method does not retrieve the results of SELECT statements
818             into the object. If you wish to apply SELECT data to your objects,
819             use either fill() or retrieve().
820              
821             =cut
822              
823             sub query
824             {
825             my $pkg_or_self = shift;
826             my $queryname = shift;
827              
828             return $pkg_or_self->_runSQL($queryname, @_);
829             }
830             #----------------
831              
832             =item save
833              
834             Either update or insert this object into the database. The keyname
835             field must be set so this function can figure out whether to update or
836             insert.
837              
838             =cut
839              
840             sub save
841             {
842             my $self = shift;
843              
844             if (!$self->{keyname})
845             {
846             &carp("No keyname defined");
847             return undef;
848             }
849             if (defined $self->{keyvalue})
850             {
851             return $self->update();
852             }
853             else
854             {
855             return $self->insert();
856             }
857             }
858             #----------------
859              
860             =item update
861              
862             Run the default update SQL template. This function is usually just
863             called from the save() function.
864              
865             =cut
866              
867             sub update
868             {
869             my $self = shift;
870             my $query = shift || $self->{update_name};
871              
872             return $self->_runSQL($query);
873             }
874             #----------------
875              
876             =item insert
877              
878             Run the default insert SQL template. This function is usually just
879             called from the save() function.
880              
881             =cut
882              
883             sub insert
884             {
885             my $self = shift;
886             my $query = shift || $self->{insert_name};
887              
888             my $result = $self->_runSQL($query);
889             if ($result && $self->{keyname})
890             {
891             # Retrieve the key. Store in both places.
892             # This is likely dependent on the database. It works on MySQL
893             $self->{keyvalue} = $self->{lastmgr}->getLastInsertID();
894             $self->set_key($self->{keyvalue});
895             }
896             return $result;
897             }
898             #----------------
899              
900             =item delete
901              
902             Run the default delete SQL template.
903              
904             =cut
905              
906             sub delete
907             {
908             my $self = shift;
909             my $query = shift || $self->{delete_name};
910              
911             return $self->_runSQL($query);
912             }
913             #----------------
914              
915             =item getAllFields
916              
917             =item allFields
918              
919             Returns a hash of all the fields, all retrieved via the accessor
920             functions. "allFields" is the old name for this function, and is here
921             for backward compatibility only.
922              
923             =cut
924              
925             sub allFields
926             {
927             my $self = shift;
928             return $self->getAllFields(@_);
929             }
930              
931             sub getAllFields
932             {
933             my $self = shift;
934              
935             my %hash = ();
936             no strict 'refs';
937             foreach my $key (keys %{$self->{fields}})
938             {
939             my $function = "get$key";
940             $hash{$key} = $self->$function();
941             }
942             return (%hash);
943             }
944             #----------------
945              
946             =item renderAllFields
947              
948             Returns a hash of all the fields, retrieved via the render
949             functions.
950              
951             =cut
952              
953             sub renderAllFields
954             {
955             my $self = shift;
956              
957             my %hash = ();
958             no strict 'refs';
959             foreach my $key (keys %{$self->{fields}})
960             {
961             my $function = "render$key";
962             $hash{$key} = $self->$function();
963             }
964             return (%hash);
965             }
966             #----------------
967              
968             =item newkey
969              
970             =item newkey KEYGEN, KEYGENDATA
971              
972             Create a new, unique key. Note that this key is NOT added to the
973             object. This is a wrapper for several different key generation
974             techniques. The following techniques are provided:
975              
976             =over
977              
978             =cut
979              
980             sub newkey
981             {
982             my $self = shift;
983              
984             my $keygen = defined $_[0] ? shift : $self->{keygen};
985             my $data = defined $_[0] ? shift : $self->{keygen_data};
986              
987             if (defined $keygen)
988             {
989             if (ref($keygen))
990             {
991             if (ref($keygen) eq "CODE")
992             {
993              
994             =item keygen = , keygen_data =
995              
996             The specified function is called with keygen_data as its argument.
997             This function should return the new key.
998              
999             =cut
1000              
1001             return &$keygen($data);
1002             }
1003             }
1004             else
1005             {
1006             # All non-SQL techniques should be first
1007              
1008             # ...
1009              
1010             # All SQL techniques get the database handle from the SQLManager and share this code:
1011              
1012             my $mgr = $self->getMgr();
1013             my $dbh = $mgr->{dbh};
1014              
1015             if ($keygen eq "query")
1016             {
1017              
1018             =item keygen = query, keygen_data = 'queryname'
1019              
1020             The key generation SQL is part of the SQL command template.
1021             is run via SQLManager.
1022              
1023             =cut
1024              
1025             if (!$data)
1026             {
1027             &croak("No SQL template query has been specified");
1028             }
1029             my $sth = $mgr->query($data);
1030             my ($key) = $sth->fetchrow_array();
1031             $sth->finish();
1032             return $key;
1033             }
1034             elsif ($keygen eq "insertcountertable")
1035             {
1036              
1037             =item keygen = insertcountertable, keygen_data = 'table.keycol,randcol'
1038              
1039             Insert into a counter table and retrieve the resulting key. This
1040             technique uses a random number to distinguish between concurrent
1041             inserts. This technique does not lock the counter table. This
1042             technique calls srand() and rand(). Note: this technique assumes that the
1043             keycolumn is an autoincrementing column that des not backtrack upon
1044             deletes.
1045              
1046             =cut
1047              
1048             if ((!$data) || $data !~ /^(\w+).(\w+),(\w+)$/)
1049             {
1050             &croak("No SQL table and columns specified for $keygen key generation");
1051             }
1052             my ($table,$keycol,$randcol) = ($1,$2,$3);
1053             my $key;
1054            
1055             if (!$cache::did_srand)
1056             {
1057             srand(time() ^ ($$ + ($$<<15))); # from perl reference book
1058             $cache::did_srand = 1;
1059             }
1060             while (!$key)
1061             {
1062             my $rn = rand();
1063             $dbh->do("INSERT INTO $table SET $randcol=$rn");
1064             my $sth = $dbh->prepare("SELECT $keycol FROM $table WHERE $randcol=$rn");
1065             $dbh->do("DELETE FROM $table WHERE $randcol=$rn");
1066             if ($sth->rows() == 1)
1067             {
1068             my ($key) = $sth->fetchrow_array();
1069             $sth->finish();
1070             return $key;
1071             }
1072             }
1073             }
1074             elsif ($keygen eq "lockcountertable")
1075             {
1076              
1077             =item keygen = lockcountertable, keygen_data = 'table.keycol'
1078              
1079             Lock the counter table, add one to the counter, retrieve the counter,
1080             unlock the counter table.
1081              
1082             =cut
1083              
1084             if ((!$data) || $data !~ /^(\w+).(\w+)$/)
1085             {
1086             &croak("No SQL table and column specified for $keygen key generation");
1087             }
1088             my ($table,$column) = ($1,$2);
1089             $dbh->do("LOCK TABLE $table WRITE");
1090             $dbh->do("UPDATE $table SET $column=$column+1");
1091             my $sth = $dbh->prepare("SELECT $column FROM $table");
1092             $sth->execute();
1093             my ($key) = $sth->fetchrow_array();
1094             $sth->finish();
1095             $dbh->do("UNLOCK TABLE");
1096             return $key;
1097             }
1098             elsif ($keygen eq "mysqlcountertable")
1099             {
1100              
1101             =item keygen = mysqlcountertable, keygen_data = 'table.keycol'
1102              
1103             Add one to the counter and use MySQL's atomic retrieval to return the
1104             new value of that counter. This technique does not lock the counter
1105             table.
1106              
1107             =cut
1108              
1109             if ((!$data) || $data !~ /^(\w+).(\w+)$/)
1110             {
1111             &croak("No SQL table and column specified for $keygen key generation");
1112             }
1113             my ($table,$column) = ($1,$2);
1114             $dbh->do("UPDATE $table SET $column=LAST_INSERT_ID($column+1)");
1115             my $sth = $dbh->prepare("SELECT LAST_INSERT_ID()");
1116             $sth->execute();
1117             my ($key) = $sth->fetchrow_array();
1118             $sth->finish();
1119             return $key;
1120             }
1121             elsif ($keygen eq "maxcountertable")
1122             {
1123              
1124             =item keygen = maxcountertable, keygen_data = 'table.keycol'
1125              
1126             Find the maximum value in the specified column, then add one to get
1127             the new key. This does not lock, so you may want to lock manually.
1128              
1129             =cut
1130              
1131             if ((!$data) || $data !~ /^(\w+).(\w+)$/)
1132             {
1133             &croak("No SQL table and column specified for $keygen key generation");
1134             }
1135             my ($table,$column) = ($1,$2);
1136             my $sth = $dbh->prepare("SELECT max($column)+1 FROM $table");
1137             $sth->execute();
1138             my ($key) = $sth->fetchrow_array();
1139             $sth->finish();
1140             return $key;
1141             }
1142             }
1143             }
1144              
1145             =back
1146              
1147             =cut
1148              
1149             # Should have returned a key by now
1150             &croak("No valid key generation technique has been specified");
1151             }
1152              
1153             #----------------
1154             # PRIVATE METHOD
1155             # Run a non-select SQL template
1156              
1157             sub _runSQL
1158             {
1159             my $pkg_or_self = shift;
1160             my $type = shift;
1161              
1162             my $mgr = $pkg_or_self->getMgr();
1163             if (!$mgr)
1164             {
1165             &carp("Failed to retrieve an SQL manager");
1166             return undef;
1167             }
1168             if (ref($pkg_or_self))
1169             {
1170             my $self = $pkg_or_self;
1171             return $mgr->storeObject($type, $self, @_);
1172             }
1173             else
1174             {
1175             return $mgr->do($type, @_);
1176             }
1177             }
1178              
1179             #----------------
1180             # PRIVATE METHOD
1181             # Run a select SQL template
1182              
1183             sub _runSelectSQL
1184             {
1185             my $self = shift;
1186             my $type = shift;
1187              
1188             my $mgr = $self->getMgr();
1189             if (!$mgr)
1190             {
1191             &carp("Failed to retrieve an SQL manager");
1192             return undef;
1193             }
1194             return $mgr->fillObject($type, $self, @_);
1195             }
1196              
1197             #----------------
1198             # PRIVATE METHOD
1199              
1200             sub _getCmds
1201             {
1202             my $pkg_or_self = shift;
1203              
1204             my @cmds;
1205             if (ref($pkg_or_self))
1206             {
1207             my $self = $pkg_or_self;
1208             @cmds = grep {$_} $self->{sqlcmd}, @{$self->{sqlcmds} || []};
1209             shift @cmds if ($cmds[0] && $cmds[1] && $cmds[0] eq $cmds[1]);
1210             }
1211             else
1212             {
1213             my $pkg = $pkg_or_self;
1214             @cmds = $pkg->sqlcmd();
1215             if (! $cmds[0])
1216             {
1217             # fall into this block if we are using an old-style subclass
1218             # that does not override the sqlcmd() class method.
1219            
1220             # Kludge: I need a copy of the XMLfile name, so we instantiate a
1221             # dummy object. This should have been in a class accessor
1222             my $dummy = $pkg->new();
1223             @cmds = $dummy->_getCmds();
1224             }
1225             }
1226             return @cmds;
1227             }
1228              
1229             #----------------
1230             # PRIVATE METHOD
1231             # For debugging
1232              
1233             sub _lastStatement
1234             {
1235             my $self = shift;
1236             return $self->{lastmgr} ? $self->{lastmgr}->{laststatement} : "";
1237             }
1238             sub _lastStatements
1239             {
1240             my $self = shift;
1241             return $self->{lastmgr} ? join(";",@{$self->{lastmgr}->{laststatements}}) : "";
1242             }
1243              
1244             #----------------
1245             # PRIVATE METHOD
1246             # For debugging
1247              
1248             sub _lastBinds
1249             {
1250             my $self = shift;
1251             my $lastbinds = $self->{lastmgr} ? $self->{lastmgr}->{lastbinds} : undef;
1252             return $lastbinds ? @$lastbinds : ();
1253             }
1254             sub _lastBindss
1255             {
1256             my $self = shift;
1257             my $lastbinds = $self->{lastmgr} ? $self->{lastmgr}->{lastbindss} : [];
1258             return join(";", map {join(",", map {defined $_ ? $_ : "(undef)"} @$_)} @$lastbinds);
1259             }
1260              
1261             1;
1262             __END__