File Coverage

blib/lib/Rose/DB.pm
Criterion Covered Total %
statement 469 1180 39.7
branch 188 584 32.1
condition 112 330 33.9
subroutine 81 210 38.5
pod 69 158 43.6
total 919 2462 37.3


line stmt bran cond sub pod time code
1             package Rose::DB;
2              
3 16     16   2515164 use strict;
  16         153  
  16         476  
4              
5 16     16   26628 use DBI;
  16         292250  
  16         902  
6 16     16   136 use Carp();
  16         42  
  16         238  
7 16     16   7474 use Clone::PP();
  16         13289  
  16         379  
8 16     16   8602 use Bit::Vector::Overload;
  16         188861  
  16         782  
9 16     16   8513 use SQL::ReservedWords();
  16         241006  
  16         543  
10              
11 16     16   8175 use Time::Clock;
  16         56733  
  16         555  
12 16     16   7147 use Rose::DateTime::Util();
  16         7653652  
  16         522  
13              
14 16     16   9542 use Rose::DB::Cache;
  16         54  
  16         521  
15 16     16   7518 use Rose::DB::Registry;
  16         49  
  16         542  
16 16     16   119 use Rose::DB::Registry::Entry;
  16         48  
  16         428  
17 16     16   7048 use Rose::DB::Constants qw(IN_TRANSACTION);
  16         46  
  16         1020  
18              
19 16     16   119 use Rose::Object;
  16         42  
  16         1397  
20             our @ISA = qw(Rose::Object);
21              
22             our $Error;
23              
24             our $VERSION = '0.784';
25              
26             our $Debug = 0;
27              
28             #
29             # Class data
30             #
31              
32             use Rose::Class::MakeMethods::Generic
33             (
34 16         206 inheritable_scalar =>
35             [
36             'default_domain',
37             'default_type',
38             'registry',
39             'max_array_characters',
40             'max_interval_characters',
41             '_db_cache',
42             'db_cache_class',
43             'parent_class',
44             ],
45              
46             inheritable_boolean =>
47             [
48             'default_keyword_function_calls',
49             ]
50 16     16   113 );
  16         44  
51              
52             use Rose::Class::MakeMethods::Generic
53             (
54 16         212 inheritable_hash =>
55             [
56             driver_classes => { interface => 'get_set_all' },
57             _driver_class => { interface => 'get_set', hash_key => 'driver_classes' },
58             delete_driver_class => { interface => 'delete', hash_key => 'driver_classes' },
59              
60             default_connect_options => { interface => 'get_set_all', },
61             default_connect_option => { interface => 'get_set', hash_key => 'default_connect_options' },
62             delete_connect_option => { interface => 'delete', hash_key => 'default_connect_options' },
63             ],
64 16     16   10770 );
  16         45  
65              
66             __PACKAGE__->db_cache_class('Rose::DB::Cache');
67             __PACKAGE__->default_domain('default');
68             __PACKAGE__->default_type('default');
69              
70             __PACKAGE__->max_array_characters(255); # Used for array type emulation
71             __PACKAGE__->max_interval_characters(255); # Used for interval type emulation
72              
73             __PACKAGE__->default_keyword_function_calls(
74             defined $ENV{'ROSE_DB_KEYWORD_FUNCTION_CALLS'} ? $ENV{'ROSE_DB_KEYWORD_FUNCTION_CALLS'} : 0);
75              
76             __PACKAGE__->driver_classes
77             (
78             mysql => 'Rose::DB::MySQL',
79             mariadb => 'Rose::DB::MariaDB',
80             pg => 'Rose::DB::Pg',
81             informix => 'Rose::DB::Informix',
82             oracle => 'Rose::DB::Oracle',
83             sqlite => 'Rose::DB::SQLite',
84             generic => 'Rose::DB::Generic',
85             );
86              
87             __PACKAGE__->default_connect_options
88             (
89             AutoCommit => 1,
90             RaiseError => 1,
91             PrintError => 1,
92             ChopBlanks => 1,
93             Warn => 0,
94             );
95              
96 16     16   9835 BEGIN { __PACKAGE__->registry(Rose::DB::Registry->new(parent => __PACKAGE__)) }
97              
98             my %Class_Loaded;
99              
100             # Load on demand instead
101             # LOAD_SUBCLASSES:
102             # {
103             # my %seen;
104             #
105             # my $map = __PACKAGE__->driver_classes;
106             #
107             # foreach my $class (values %$map)
108             # {
109             # eval qq(require $class) unless($seen{$class}++);
110             # die "Could not load $class - $@" if($@);
111             # }
112             # }
113              
114             #
115             # Object data
116             #
117              
118             use Rose::Object::MakeMethods::Generic
119             (
120 16         237 'scalar' =>
121             [
122             qw(dbi_driver username _dbh_refcount id)
123             ],
124              
125             'boolean' =>
126             [
127             'auto_create' => { default => 1 },
128             'european_dates' => { default => 0 },
129             ],
130              
131             'scalar --get_set_init' =>
132             [
133             'domain',
134             'type',
135             'date_handler',
136             'server_time_zone',
137             'keyword_function_calls',
138             ],
139              
140             'array' =>
141             [
142             'post_connect_sql',
143             'pre_disconnect_sql',
144             ],
145              
146             'hash' =>
147             [
148             connect_options => { interface => 'get_set_init' },
149             ]
150 16     16   2209 );
  16         44  
151              
152             #
153             # Class methods
154             #
155              
156             sub register_db
157             {
158 224     224 1 315236 my $class = shift;
159              
160             # Smuggle parent/caller in with an otherwise nonsensical arrayref arg
161 224         610 my $entry = $class->registry->add_entry([ $class ], @_);
162              
163 224 50       942 if($entry)
164             {
165 224         545 my $driver = $entry->driver;
166              
167 224 50       852 Carp::confess "No driver found for registry entry $entry"
168             unless(defined $driver);
169              
170 224         591 $class->setup_dynamic_class_for_driver($driver);
171             }
172              
173 224         3443 return $entry;
174             }
175              
176             our %Rebless;
177              
178             sub setup_dynamic_class_for_driver
179             {
180 306     306 0 659 my($class, $driver) = @_;
181              
182 306   33     749 my $driver_class = $class->driver_class($driver) ||
183             $class->driver_class('generic') || Carp::croak
184             "No driver class found for drivers '$driver' or 'generic'";
185              
186 306 100       5795 unless($Rebless{$class,$driver_class})
187             {
188 16     16   30169 no strict 'refs';
  16         41  
  16         2503  
189 184 100 100     541 unless($Class_Loaded{$driver_class} || @{"${driver_class}::ISA"})
  164         1308  
190             {
191 82         155 my $error;
192              
193             TRY:
194             {
195 82         126 local $@;
  82         137  
196 82         4680 eval "require $driver_class";
197 82         424 $error = $@;
198             }
199              
200 82 50       287 Carp::croak "Could not load driver class '$driver_class' - $error" if($error);
201             }
202              
203 184         413 $Class_Loaded{$driver_class}++;
204              
205             # Make a new driver class based on the current class
206 184         575 my $new_class = $class . '::__RoseDBPrivate__::' . $driver_class;
207              
208 16     16   150 no strict 'refs';
  16         71  
  16         26187  
209 184         329 @{"${new_class}::ISA"} = ($driver_class, $class);
  184         4941  
210 184         646 *{"${new_class}::STORABLE_thaw"} = \&STORABLE_thaw;
  184         1174  
211 184         375 *{"${new_class}::STORABLE_freeze"} = \&STORABLE_freeze;
  184         708  
212              
213 184         1784 $new_class->parent_class($class);
214              
215             # Cache result
216 184         2308 $Rebless{$class,$driver_class} = $new_class;
217             }
218              
219 306         807 return $Rebless{$class,$driver_class};
220             }
221              
222 0     0 1 0 sub unregister_db { shift->registry->delete_entry(@_) }
223              
224 0     0 0 0 sub default_implicit_schema { undef }
225 0     0 0 0 sub registration_schema { undef }
226              
227 19     19 1 2288 sub use_private_registry { $_[0]->registry(Rose::DB::Registry->new(parent => $_[0])) }
228              
229             sub modify_db
230             {
231 4     4 1 16652 my($class, %args) = @_;
232              
233 4   33     21 my $domain = delete $args{'domain'} || $class->default_domain ||
234             Carp::croak "Missing domain";
235              
236 4   33     17 my $type = delete $args{'type'} || $class->default_type ||
237             Carp::croak "Missing type";
238              
239 4 50       15 my $entry = $class->registry->entry(domain => $domain, type => $type) or
240             Carp::croak "No db defined for domain '$domain' and type '$type'";
241              
242 4         50 while(my($key, $val) = each(%args))
243             {
244 8         50 $entry->$key($val);
245             }
246              
247 4         26 return $entry;
248             }
249              
250             sub db_exists
251             {
252 14     14 1 8803 my($class) = shift;
253              
254 14 100       60 my %args = (@_ == 1) ? (type => $_[0]) : @_;
255              
256 14   33     57 my $domain = $args{'domain'} || $class->default_domain ||
257             Carp::croak "Missing domain";
258              
259 14   33     192 my $type = $args{'type'} || $class->default_type ||
260             Carp::croak "Missing type";
261              
262 14         37 return $class->registry->entry_exists(domain => $domain, type => $type);
263             }
264              
265             sub alias_db
266             {
267 2     2 1 27 my($class, %args) = @_;
268              
269 2 50       12 my $source = $args{'source'} or Carp::croak "Missing source";
270              
271 2 50       11 my $src_domain = $source->{'domain'} or Carp::croak "Missing source domain";
272 2 50       8 my $src_type = $source->{'type'} or Carp::croak "Missing source type";
273              
274 2 50       9 my $alias = $args{'alias'} or Carp::croak "Missing alias";
275              
276 2 50       8 my $alias_domain = $alias->{'domain'} or Carp::croak "Missing source domain";
277 2 50       8 my $alias_type = $alias->{'type'} or Carp::croak "Missing source type";
278              
279 2         7 my $registry = $class->registry;
280              
281 2 50       104 my $entry = $registry->entry(domain => $src_domain, type => $src_type) or
282             Carp::croak "No db defined for domain '$src_domain' and type '$src_type'";
283              
284 2         25 $registry->add_entry(domain => $alias_domain,
285             type => $alias_type,
286             entry => $entry);
287             }
288              
289 0     0 1 0 sub unregister_domain { shift->registry->delete_domain(@_) }
290              
291             sub driver_class
292             {
293 546     546 1 7256 my($class, $driver) = (shift, lc shift);
294              
295 546 100       1144 if(@_)
296             {
297 82         372 $class->_driver_class($driver, @_);
298 82         2443 $class->setup_dynamic_class_for_driver($driver);
299             }
300              
301 546         1381 return $class->_driver_class($driver);
302             }
303              
304             sub db_cache
305             {
306 0     0 1 0 my($class) = shift;
307              
308 0 0       0 if(@_)
309             {
310 0         0 return $class->_db_cache(@_);
311             }
312              
313 0 0       0 if(my $cache = $class->_db_cache)
314             {
315 0         0 return $cache;
316             }
317              
318 0         0 my $cache_class = $class->db_cache_class;
319              
320 0         0 my $error;
321              
322             TRY:
323             {
324 0         0 local $@;
  0         0  
325 0         0 eval "use $cache_class";
326 0         0 $error = $@;
327             }
328              
329 0 0       0 die "Could not load db cache class '$cache_class' - $error" if($error);
330              
331 0         0 return $class->_db_cache($cache_class->new);
332             }
333              
334             sub use_cache_during_apache_startup
335             {
336 0     0 1 0 shift->db_cache->use_cache_during_apache_startup(@_);
337             }
338              
339             sub prepare_cache_for_apache_fork
340             {
341 0     0 1 0 shift->db_cache->prepare_for_apache_fork(@_);
342             }
343              
344             sub new_or_cached
345             {
346 0     0 1 0 my($class) = shift;
347              
348 0 0       0 @_ = (type => $_[0]) if(@_ == 1);
349              
350 0         0 my %args = @_;
351              
352 0 0       0 $args{'domain'} = $class->default_domain unless(exists $args{'domain'});
353 0 0       0 $args{'type'} = $class->default_type unless(exists $args{'type'});
354              
355             #$Debug && warn "New or cached db type: $args{'type'}, domain: $args{'domain'}\n";
356              
357 0         0 my $cache = $class->db_cache;
358              
359 0 0       0 if(my $db = $cache->get_db(%args))
360             {
361 0 0       0 $Debug && warn "$$ $class Returning cached db (", $db->domain, ', ', $db->type,
362             ") $db from ", $cache, "\n";
363 0         0 return $db;
364             }
365              
366 0 0       0 if($Debug)
367             {
368 0         0 my $db = $class->new(@_);
369             $Debug && warn "$$ $class Setting cached db $db (",
370 0 0       0 join(', ', map { $args{$_} } qw(domain type)),
  0         0  
371             ") in ", $cache, "\n";
372              
373             # The set_db() call may refuse to set, so call get_db() to properly
374             # register clean-up handlers, etc., but fall back to the db returned
375             # by set_db() in the case where the db was never cached.
376 0         0 $db = $cache->set_db($class->new(@_));
377 0   0     0 return $cache->get_db(%args) || $db;
378             }
379             else
380             {
381             # The set_db() call may refuse to set, so call get_db() to properly
382             # register clean-up handlers, etc., but fall back to the db returned
383             # by set_db() in the case where the db was never cached.
384 0         0 my $db = $cache->set_db($class->new(@_));
385 0   0     0 return $cache->get_db(%args) || $db;
386             }
387             }
388              
389 0     0 0 0 sub clear_db_cache { shift->db_cache->clear(@_) }
390              
391             #
392             # Object methods
393             #
394              
395             sub new
396             {
397 86     86 1 119706 my($class) = shift;
398              
399 86 100       378 @_ = (type => $_[0]) if(@_ == 1);
400              
401 86         275 my %args = @_;
402              
403 86   33     276 my $allow_empty = $args{'driver'} && !($args{'type'} || $args{'domain'});
404              
405             my $domain =
406 86 100       436 exists $args{'domain'} ? delete $args{'domain'} : $class->default_domain;
407              
408             my $type =
409 86 100       1197 exists $args{'type'} ? delete $args{'type'} : $class->default_type;
410              
411 86         277 my $db_info;
412              
413             # I'm being bad here for speed purposes, digging into private hashes instead
414             # of using object methods. I'll fix it when the first person emails me to
415             # complain that I'm breaking their Rose::DB or Rose::DB::Registry[::Entry]
416             # subclass by doing this. Call it "demand-paged programming" :)
417 86         281 my $registry = $class->registry->hash;
418              
419 86 100 100     2138 if(exists $registry->{$domain} && exists $registry->{$domain}{$type})
    50          
420             {
421 68         171 $db_info = $registry->{$domain}{$type}
422             }
423             elsif(!$allow_empty)
424             {
425 18         2665 Carp::croak "No database information found for domain '$domain' and ",
426             "type '$type' and no driver type specified in call to ",
427             "$class->new(...)";
428             }
429              
430 68   33     281 my $driver = $db_info->{'driver'} || $args{'driver'};
431              
432 68 50       162 Carp::croak "No driver found for domain '$domain' and type '$type'"
433             unless(defined $driver);
434              
435 68   33     260 my $driver_class = $class->driver_class($driver) ||
436             $class->driver_class('generic') || Carp::croak
437             "No driver class found for drivers '$driver' or 'generic'";
438              
439 68 50       1273 unless($Class_Loaded{$driver_class})
440             {
441 0         0 $class->load_driver_class($driver_class);
442             }
443              
444 68         118 my $self;
445              
446             REBLESS: # Do slightly evil re-blessing magic
447             {
448             # Check cache
449 68 50       107 if(my $new_class = $Rebless{$class,$driver_class})
  68         332  
450             {
451 68         342 $self = bless {}, $new_class;
452             }
453             else
454             {
455             # Make a new driver class based on the current class
456 0         0 my $new_class = $class . '::__RoseDBPrivate__::' . $driver_class;
457              
458 16     16   143 no strict 'refs';
  16         45  
  16         5059  
459 0         0 @{"${new_class}::ISA"} = ($driver_class, $class);
  0         0  
460              
461 0         0 $self = bless {}, $new_class;
462              
463 0         0 $new_class->parent_class($class);
464              
465             # Cache result
466 0         0 $Rebless{$class,$driver_class} = ref $self;
467             }
468             }
469              
470 68         586 $self->class($class);
471              
472 68         221 $self->{'id'} = "$domain\0$type";
473 68         136 $self->{'type'} = $type;
474 68         141 $self->{'domain'} = $domain;
475              
476 68         481 $self->init(@_);
477              
478 68         1169 $self->init_db_info;
479              
480 68         361 return $self;
481             }
482              
483             sub class
484             {
485 140     140 0 251 my($self) = shift;
486 140 100       678 return $self->{'_origin_class'} = shift if(@_);
487 72   33     291 return $self->{'_origin_class'} || ref $self;
488             }
489              
490 6     6 0 117 sub init_keyword_function_calls { ref($_[0])->default_keyword_function_calls }
491              
492             # sub init
493             # {
494             # my($self) = shift;
495             # $self->SUPER::init(@_);
496             # $self->init_db_info;
497             # }
498              
499             sub load_driver_class
500             {
501 80     80 0 159 my($class, $arg) = @_;
502              
503 80   33     159 my $driver_class = $class->driver_class($arg) || $arg;
504              
505 16     16   133 no strict 'refs';
  16         42  
  16         41663  
506 80 100       1083 unless(defined ${"${driver_class}::VERSION"})
  80         393  
507             {
508 16         49 my $error;
509              
510             TRY:
511             {
512 16         38 local $@;
  16         36  
513 16         902 eval "require $driver_class";
514 16         109 $error = $@;
515             }
516              
517 16 50       83 Carp::croak "Could not load driver class '$driver_class' - $error" if($error);
518             }
519              
520 80         262 $Class_Loaded{$driver_class}++;
521             }
522              
523 0     0 0 0 sub driver_class_is_loaded { $Class_Loaded{$_[1]} }
524              
525             sub load_driver_classes
526             {
527 16     16 0 12648 my($class) = shift;
528              
529 16         112 my $map = $class->driver_classes;
530              
531 16 50       285 foreach my $arg (@_ ? @_ : keys %$map)
532             {
533 80         185 $class->load_driver_class($arg);
534             }
535              
536 16         72 return;
537             }
538              
539             sub database
540             {
541 75     75 1 214 my($self) = shift;
542              
543 75 100       208 if(@_)
544             {
545 73 100       197 $self->{'dsn'} = undef if($self->{'dsn'});
546 73         289 return $self->{'database'} = shift;
547             }
548              
549 2         14 return $self->{'database'};
550             }
551              
552             sub schema
553             {
554 0     0 1 0 my($self) = shift;
555              
556 0 0       0 if(@_)
557             {
558 0 0       0 $self->{'dsn'} = undef if($self->{'dsn'});
559 0         0 return $self->{'schema'} = shift;
560             }
561              
562 0         0 return $self->{'schema'};
563             }
564              
565             sub catalog
566             {
567 0     0 1 0 my($self) = shift;
568              
569 0 0       0 if(@_)
570             {
571 0 0       0 $self->{'dsn'} = undef if($self->{'dsn'});
572 0         0 return $self->{'catalog'} = shift;
573             }
574              
575 0         0 return $self->{'catalog'};
576             }
577              
578             sub service
579             {
580 0     0 0 0 my($self) = shift;
581              
582 0 0       0 if(@_)
583             {
584 0 0       0 $self->{'dsn'} = undef if($self->{'dsn'});
585 0         0 return $self->{'service'} = shift;
586             }
587              
588 0         0 return $self->{'service'};
589             }
590              
591             sub host
592             {
593 62     62 1 150 my($self) = shift;
594              
595 62 50       154 if(@_)
596             {
597 62 50       164 $self->{'dsn'} = undef if($self->{'dsn'});
598 62         242 return $self->{'host'} = shift;
599             }
600              
601 0         0 return $self->{'host'};
602             }
603              
604             sub port
605             {
606 9     9 1 23 my($self) = shift;
607              
608 9 50       20 if(@_)
609             {
610 9 50       22 $self->{'dsn'} = undef if($self->{'dsn'});
611 9         19 return $self->{'port'} = shift;
612             }
613              
614 0         0 return $self->{'port'};
615             }
616              
617             sub database_version
618             {
619 0     0 0 0 my($self) = shift;
620 0 0       0 return $self->{'database_version'} if(defined $self->{'database_version'});
621 0         0 return $self->{'database_version'} = $self->dbh->get_info(18); # SQL_DBMS_VER
622             }
623              
624             # Use a closure to keep the password from appearing when the
625             # object is dumped using Data::Dumper
626             sub password
627             {
628 95     95 1 189 my($self) = shift;
629              
630 95 100       245 if(@_)
631             {
632 54         121 my $password = shift;
633 54     31   295 $self->{'password_closure'} = sub { $password };
  31         203  
634 54         216 return $password;
635             }
636              
637 41 100       173 return $self->{'password_closure'} ? $self->{'password_closure'}->() : undef;
638             }
639              
640             # These have to "cheat" to get the right values by going through
641             # the real origin class because they may be called after the
642             # re-blessing magic takes place.
643 0     0 0 0 sub init_domain { shift->{'_origin_class'}->default_domain }
644 0     0 0 0 sub init_type { shift->{'_origin_class'}->default_type }
645              
646 2     2 0 48 sub init_date_handler { Rose::DateTime::Format::Generic->new }
647 0     0 0 0 sub init_server_time_zone { 'floating' }
648              
649             sub init_db_info
650             {
651 72     72 1 172 my($self, %args) = @_;
652              
653 72 100       186 return 1 if($self->{'dsn'});
654              
655 70         158 my $class = ref $self;
656              
657 70         302 my $domain = $self->domain;
658 70         530 my $type = $self->type;
659              
660 70         355 my $db_info;
661              
662             # I'm being bad here for speed purposes, digging into private hashes instead
663             # of using object methods. I'll fix it when the first person emails me to
664             # complain that I'm breaking their Rose::DB or Rose::DB::Registry[::Entry]
665             # subclass by doing this. Call it "demand-paged programming" :)
666 70         146 my $registry = $self->class->registry->hash;
667              
668 70 50 33     1545 if(exists $registry->{$domain} && exists $registry->{$domain}{$type})
669             {
670 70         152 $db_info = $registry->{$domain}{$type}
671             }
672             else
673             {
674 0 0       0 return 1 if($self->{'driver'});
675 0         0 Carp::croak "No database information found for domain '$domain' and type '$type'";
676             }
677              
678 70 50 33     383 unless($args{'refresh'} || ($self->{'connect_options_for'}{$domain} &&
      66        
679             $self->{'connect_options_for'}{$domain}{$type}))
680             {
681 66 100       233 if(my $custom_options = $db_info->{'connect_options'})
682             {
683 28         138 my $options = $self->connect_options;
684 28         2436 @$options{keys %$custom_options} = values %$custom_options;
685             }
686              
687 66         271 $self->{'connect_options_for'} = { $domain => { $type => 1 } };
688             }
689              
690 70         391 $self->driver($db_info->{'driver'});
691              
692 70         347 while(my($field, $value) = each(%$db_info))
693             {
694 573 100 66     2898 if($field ne 'connect_options' && defined $value && !defined $self->{$field})
      100        
695             {
696 317         1964 $self->$field($value);
697             }
698             }
699              
700 70         246 return 1;
701             }
702              
703             sub init_connect_options
704             {
705 57     57 0 644 my($class) = ref $_[0];
706 57         310 return Clone::PP::clone(scalar $class->default_connect_options);
707             }
708              
709             sub connect_option
710             {
711 50     50 1 106 my($self, $param) = (shift, shift);
712              
713 50         173 my $options = $self->connect_options;
714              
715 50 100       2294 return $options->{$param} = shift if(@_);
716 25         67 return $options->{$param};
717             }
718              
719             sub dsn
720             {
721 51     51 1 22159 my($self) = shift;
722              
723 51 100       151 unless(@_)
724             {
725 45   66     481 return $self->{'dsn'} || $self->build_dsn(%$self);
726             }
727              
728 6 50       17 if(my $dsn = shift)
729             {
730 6         15 foreach my $method (qw(database host port))
731             {
732 18         45 $self->$method(undef);
733             }
734              
735 6         20 $self->init($self->parse_dsn($dsn));
736 4         17 return $self->{'dsn'} = $dsn;
737             }
738             else
739             {
740 0         0 $self->{'dsn'} = undef;
741 0         0 return $self->build_dsn(%$self);
742             }
743             }
744              
745             my %DSN_Attr_Method =
746             (
747             db => 'database',
748             dbname => 'database',
749             user => 'username',
750             hostname => 'host',
751             hostaddr => 'host',
752             sid => 'database',
753             service => 'service_name',
754             );
755              
756 16     16 0 65 sub dsn_attribute_to_db_method { $DSN_Attr_Method{$_[1]} }
757              
758             sub parse_dsn
759             {
760 6     6 0 13 my($self, $dsn) = @_;
761              
762 6         12 my($scheme, $driver, $attr_string, $attr_hash, $driver_dsn);
763              
764             # x DBI->parse_dsn('dbi:mysql:database=test;host=localhost')
765             # 0 'dbi'
766             # 1 'mysql'
767             # 2 undef
768             # 3 undef
769             # 4 'database=test;host=localhost'
770              
771 6 50       44 if(DBI->can('parse_dsn'))
772             {
773 6         21 ($scheme, $driver, $attr_string, $attr_hash, $driver_dsn) =
774             DBI->parse_dsn($dsn);
775             }
776             else
777             {
778 0         0 ($scheme, $driver, $attr_string, $driver_dsn) =
779             ($dsn =~ /^((?i)dbi) : (\w+) : (?: \( ([^)]+) \) : )? (.*)/x);
780             }
781              
782 6         151 my %init =
783             (
784             dbi_driver => $driver,
785             driver => $driver,
786             );
787              
788 6         38 while($driver_dsn =~ /\G(\w+)=([^;]+)(?:;|$)?/g)
789             {
790 16         41 my($name, $value) = ($1, $2);
791              
792 16 100       39 if(my $method = $self->dsn_attribute_to_db_method($name))
    50          
793             {
794 4         23 $init{$method} = $value;
795             }
796             elsif($self->can($name))
797             {
798 12         53 $init{$name} = $value;
799             }
800             }
801              
802 6 50       17 unless($init{'database'})
803             {
804 0         0 $init{'database'} = $driver_dsn;
805             }
806              
807 6         51 return %init;
808             }
809              
810             sub database_from_dsn
811             {
812 0     0 0 0 my($self_or_class, $dsn) = @_;
813 0         0 my %attrs = $self_or_class->parse_dsn($dsn);
814 0         0 return $attrs{'database'};
815             }
816              
817             sub dbh
818             {
819 41     41 1 80 my($self) = shift;
820              
821 41 50       140 unless(@_)
822             {
823 41 50       135 if(my $dbh = $self->{'dbh'})
824             {
825             # If this db connection wasn't created in another process or thread, return it
826 0 0 0     0 if((!$INC{'threads.pm'} || $dbh->{'private_tid'} == threads->tid) &&
      0        
827             $dbh->{'private_pid'} == $$)
828             {
829 0         0 return $dbh;
830             }
831              
832             # This $dbh wasn't created here, so disable destroy actions,
833             # undef it, and create a new one by falling through to the
834             # init_dbh() call below.
835 0         0 $dbh->{'InactiveDestroy'} = 1;
836 0         0 $self->{'dbh'} = undef;
837             }
838              
839 41         238 return $self->init_dbh;
840             }
841              
842 0 0       0 unless(defined($_[0]))
843             {
844 0         0 return $self->{'dbh'} = undef;
845             }
846              
847 0         0 $self->driver($_[0]->{'Driver'}{'Name'});
848              
849 0         0 $self->{'_dbh_refcount'}++;
850 0         0 return $self->{'dbh'} = $_[0];
851             }
852              
853             sub driver
854             {
855 76 50   76 1 224 if(@_ > 1)
856             {
857 76         194 my $driver = lc $_[1];
858              
859 76 100 66     449 if(defined $driver && defined $_[0]->{'driver'} && $_[0]->{'driver'} ne $driver)
      100        
860             {
861 2         281 Carp::croak "Attempt to change driver from '$_[0]->{'driver'}' to ",
862             "'$driver' detected. The driver cannot be changed after ",
863             "object creation.";
864             }
865              
866 74         194 return $_[0]->{'driver'} = $driver;
867             }
868              
869 0         0 return $_[0]->{'driver'};
870             }
871              
872             sub retain_dbh
873             {
874 41     41 1 227 my($self) = shift;
875 41 0       182 my $dbh = $self->dbh or return undef;
876             #$Debug && warn "$self->{'_dbh_refcount'} -> ", ($self->{'_dbh_refcount'} + 1), " $dbh\n";
877 0         0 $self->{'_dbh_refcount'}++;
878 0         0 return $dbh;
879             }
880              
881             sub release_dbh
882             {
883 68     68 1 165 my($self, %args) = @_;
884              
885 68 50       1199 my $dbh = $self->{'dbh'} or return 0;
886              
887 0 0       0 if($args{'force'})
888             {
889 0         0 $self->{'_dbh_refcount'} = 0;
890              
891             # Account for possible Apache::DBI magic
892 0 0       0 if(UNIVERSAL::isa($dbh, 'Apache::DBI::db'))
893             {
894 0         0 return $dbh->DBI::db::disconnect; # bypass Apache::DBI
895             }
896             else
897             {
898 0         0 return $dbh->disconnect;
899             }
900             }
901              
902             #$Debug && warn "$self->{'_dbh_refcount'} -> ", ($self->{'_dbh_refcount'} - 1), " $dbh\n";
903 0         0 $self->{'_dbh_refcount'}--;
904              
905 0 0 0     0 unless($self->{'_dbh_refcount'} || $self->{'_dbh_has_foreign_owner'})
906             {
907 0 0       0 if(my $sqls = $self->pre_disconnect_sql)
908             {
909 0         0 my $error;
910              
911             TRY:
912             {
913 0         0 local $@;
  0         0  
914              
915             eval
916 0         0 {
917 0         0 foreach my $sql (@$sqls)
918             {
919 0 0       0 $dbh->do($sql) or die "$sql - " . $dbh->errstr;
920 0         0 return undef;
921             }
922             };
923              
924 0         0 $error = $@;
925             }
926              
927 0 0       0 if($error)
928             {
929 0         0 $self->error("Could not do pre-disconnect SQL: $error");
930 0         0 return undef;
931             }
932             }
933              
934             #$Debug && warn "DISCONNECT $dbh ", join(':', (caller(3))[0,2]), "\n";
935 0         0 return $dbh->disconnect;
936             }
937             #else { $Debug && warn "DISCONNECT NOOP $dbh ", join(':', (caller(2))[0,2]), "\n"; }
938              
939 0         0 return 1;
940             }
941              
942             sub dbh_attribute
943             {
944 0     0 0 0 my($self, $name) = (shift, shift);
945              
946 0 0       0 if(@_)
947             {
948 0 0       0 if(my $dbh = $self->{'dbh'})
949             {
950 0         0 return $self->{'dbh'}{$name} = $self->{'__dbh_attributes'}{$name} = shift;
951             }
952             else
953             {
954 0         0 return $self->{'__dbh_attributes'}{$name} = shift;
955             }
956             }
957              
958 0 0       0 if(my $dbh = $self->{'dbh'})
959             {
960 0         0 return $self->{'dbh'}{$name};
961             }
962             else
963             {
964 0         0 return $self->{'__dbh_attributes'}{$name};
965             }
966             }
967              
968             sub dbh_attribute_boolean
969             {
970 0     0 0 0 my($self, $name) = (shift, shift);
971 0 0       0 return $self->dbh_attribute($name, (@_ ? ($_[0] ? 1 : 0) : ()));
    0          
972             }
973              
974 2     2 1 15 sub has_dbh { defined shift->{'dbh'} }
975              
976             sub dbi_connect
977             {
978 41     41 1 96 shift;
979 41 50       113 $Debug && warn "DBI->connect('$_[1]', '$_[2]', ...)\n";
980 41         297 DBI->connect(@_);
981             }
982              
983 16     16   144 use constant DID_PCSQL_KEY => 'private_rose_db_did_post_connect_sql';
  16         64  
  16         13921  
984              
985             sub init_dbh
986             {
987 41     41 0 137 my($self) = shift;
988              
989 41         132 my $options = $self->connect_options;
990              
991 41         1787 $options->{'private_pid'} = $$;
992 41 50       148 $options->{'private_tid'} = threads->tid if($INC{'threads.pm'});
993              
994 41         227 my $dsn = $self->dsn;
995              
996 41         115 $self->{'error'} = undef;
997 41         82 $self->{'database_version'} = undef;
998 41         85 $self->{'_dbh_refcount'} = 0;
999 41         144 $self->{'_dbh_has_foreign_owner'} = undef;
1000              
1001 41         228 my $dbh = $self->dbi_connect($dsn, $self->username, $self->password, $options);
1002              
1003 0 0       0 unless($dbh)
1004             {
1005 0         0 $self->error("Could not connect to database: $DBI::errstr");
1006 0         0 return undef;
1007             }
1008              
1009 0 0       0 if($dbh->{'private_rose_db_inited'})
1010             {
1011             # Someone else owns this dbh
1012 0         0 $self->{'_dbh_has_foreign_owner'} = 1;
1013             }
1014             else # Only initialize if this is really a new connection
1015             {
1016 0         0 $dbh->{'private_rose_db_inited'} = 1;
1017              
1018 0 0       0 if($self->{'__dbh_attributes'})
1019             {
1020 0         0 foreach my $attr (keys %{$self->{'__dbh_attributes'}})
  0         0  
1021             {
1022 0         0 my $val = $self->dbh_attribute($attr);
1023 0 0       0 next unless(defined $val);
1024 0         0 $dbh->{$attr} = $val;
1025             }
1026             }
1027              
1028 0 0 0     0 if((my $sqls = $self->post_connect_sql) && !$dbh->{DID_PCSQL_KEY()})
1029             {
1030 0         0 my $error;
1031              
1032             TRY:
1033             {
1034 0         0 local $@;
  0         0  
1035              
1036             eval
1037 0         0 {
1038 0         0 foreach my $sql (@$sqls)
1039             {
1040             #$Debug && warn "$dbh DO: $sql\n";
1041 0 0       0 $dbh->do($sql) or die "$sql - " . $dbh->errstr;
1042             }
1043             };
1044              
1045 0         0 $error = $@;
1046             }
1047              
1048 0 0       0 if($error)
1049             {
1050 0         0 $self->error("Could not do post-connect SQL: $error");
1051 0         0 $dbh->disconnect;
1052 0         0 return undef;
1053             }
1054              
1055 0         0 $dbh->{DID_PCSQL_KEY()} = 1;
1056             }
1057             }
1058              
1059 0         0 $self->{'_dbh_refcount'} = 1;
1060              
1061 0         0 return $self->{'dbh'} = $dbh;
1062             }
1063              
1064 25     25 1 303 sub print_error { shift->_dbh_and_connect_option('PrintError', @_) }
1065 0     0 1 0 sub raise_error { shift->_dbh_and_connect_option('RaiseError', @_) }
1066 0     0 1 0 sub autocommit { shift->_dbh_and_connect_option('AutoCommit', @_) }
1067 0     0 1 0 sub handle_error { shift->_dbh_and_connect_option('HandleError', @_) }
1068              
1069             sub _dbh_and_connect_option
1070             {
1071 25     25   67 my($self, $param) = (shift, shift);
1072              
1073 25 50       86 if(@_)
1074             {
1075 25 50       77 my $val = $_[0] ? 1 : 0;
1076 25         158 $self->connect_option($param => $val);
1077              
1078 25 50       87 $self->{'dbh'}{$param} = $val if($self->{'dbh'});
1079             }
1080              
1081 25 50       139 return $self->{'dbh'} ? $self->{'dbh'}{$param} :
1082             $self->connect_option($param);
1083             }
1084              
1085             sub connect
1086             {
1087 0     0 1 0 my($self) = shift;
1088              
1089 0 0       0 $self->dbh or return 0;
1090 0         0 return 1;
1091             }
1092              
1093             sub disconnect
1094             {
1095 68     68 1 160 my($self) = shift;
1096              
1097 68 50       327 $self->release_dbh(@_) or return undef;
1098              
1099 0         0 $self->{'dbh'} = undef;
1100             }
1101              
1102             sub begin_work
1103             {
1104 0     0 1 0 my($self) = shift;
1105              
1106 0 0       0 my $dbh = $self->dbh or return undef;
1107              
1108 0 0       0 if($dbh->{'AutoCommit'})
1109             {
1110 0         0 my $ret;
1111              
1112             #$Debug && warn "BEGIN TRX\n";
1113              
1114             my $error;
1115              
1116             TRY:
1117             {
1118 0         0 local $@;
  0         0  
1119              
1120             eval
1121 0         0 {
1122 0         0 local $dbh->{'RaiseError'} = 1;
1123              
1124             # XXX: Detect DBD::mysql bug (in some versions before 4.012) that
1125             # XXX: fails to set Active back to 1 when mysql_auto_reconnect
1126             # XXX: is in use.
1127 0 0       0 unless($dbh->{'Active'})
1128             {
1129 0 0 0     0 if($dbh->{'Driver'}{'Name'} eq 'mysql' && $dbh->{'Driver'}{'Version'} < 4.012)
1130             {
1131 0         0 die 'Database handle does not have Active set to a true value. DBD::mysql ',
1132             'versions before 4.012 may fail to set Active back to 1 when the ',
1133             'mysql_auto_reconnect is set. Try upgrading to DBD::mysql 4.012 or later';
1134             }
1135             else
1136             {
1137 0         0 die "Cannot start transaction on inactive database handle ($dbh)";
1138             }
1139             }
1140              
1141 0         0 $ret = $dbh->begin_work
1142             };
1143              
1144 0         0 $error = $@;
1145             }
1146              
1147 0 0       0 if($error)
1148             {
1149 16     16   165 no warnings 'uninitialized';
  16         45  
  16         4925  
1150 0         0 $self->error("begin_work() - $error " . $dbh->errstr);
1151 0         0 return undef;
1152             }
1153              
1154 0 0       0 unless($ret)
1155             {
1156 0         0 $self->error('begin_work() failed - ' . $dbh->errstr);
1157 0         0 return undef;
1158             }
1159              
1160 0         0 return 1;
1161             }
1162              
1163 0         0 return IN_TRANSACTION;
1164             }
1165              
1166             sub in_transaction
1167             {
1168 0 0   0 1 0 my $dbh = shift->{'dbh'} or return undef;
1169 0 0       0 return ($dbh->{'AutoCommit'}) ? 0 : 1;
1170             }
1171              
1172             sub commit
1173             {
1174 0     0 1 0 my($self) = shift;
1175              
1176 0 0 0     0 my $is_active = (defined $self->{'dbh'} && $self->{'dbh'}{'Active'}) ? 1 : 0;
1177              
1178 0 0       0 unless(defined $self->{'dbh'})
1179             {
1180 0         0 $self->error("Could not commit transaction: database handle is undefined");
1181 0         0 return 0;
1182             }
1183              
1184 0 0       0 my $dbh = $self->dbh or return undef;
1185              
1186 0 0       0 unless($dbh->{'AutoCommit'})
1187             {
1188 0         0 my $ret;
1189              
1190             #$Debug && warn "COMMIT TRX\n";
1191              
1192             my $error;
1193              
1194             TRY:
1195             {
1196 0         0 local $@;
  0         0  
1197              
1198             eval
1199 0         0 {
1200 0         0 local $dbh->{'RaiseError'} = 1;
1201 0         0 $ret = $dbh->commit;
1202             };
1203              
1204 0         0 $error = $@;
1205             }
1206              
1207 0 0       0 if($error)
1208             {
1209 16     16   132 no warnings 'uninitialized';
  16         36  
  16         5303  
1210 0         0 $self->error("commit() $error - " . $dbh->errstr);
1211              
1212 0 0       0 unless($is_active)
1213             {
1214 0 0 0     0 if($dbh->{'Driver'}{'Name'} eq 'mysql' && $dbh->{'Driver'}{'Version'} < 4.012)
1215             {
1216 0         0 $self->error($self->error . '; Also, the database handle did not ' .
1217             'have Active set to a true value. DBD::mysql versions before 4.012 ' .
1218             'may fail to set Active back to 1 when the mysql_auto_reconnect is ' .
1219             'set. Try upgrading to DBD::mysql 4.012 or later');
1220             }
1221              
1222 0         0 return 0;
1223             }
1224              
1225 0         0 return undef;
1226             }
1227              
1228 0 0       0 unless($ret)
1229             {
1230 0   0     0 $self->error('Could not commit transaction: ' .
1231             ($dbh->errstr || $DBI::errstr ||
1232             'Possibly a referential integrity violation. ' .
1233             'Check the database error log for more information.'));
1234 0         0 return undef;
1235             }
1236              
1237 0         0 return 1;
1238             }
1239              
1240 0         0 return -1;
1241             }
1242              
1243             sub rollback
1244             {
1245 0     0 1 0 my($self) = shift;
1246              
1247 0 0 0     0 my $is_active = (defined $self->{'dbh'} && $self->{'dbh'}{'Active'}) ? 1 : 0;
1248              
1249 0 0       0 unless(defined $self->{'dbh'})
1250             {
1251 0         0 $self->error("Could not roll back transaction: database handle is undefined");
1252 0         0 return 0;
1253             }
1254              
1255 0 0       0 my $dbh = $self->dbh or return undef;
1256              
1257 0         0 my $ac = $dbh->{'AutoCommit'};
1258              
1259 0 0       0 return 1 if($ac);
1260              
1261 0         0 my $ret;
1262              
1263             #$Debug && warn "ROLLBACK TRX\n";
1264              
1265             my $error;
1266              
1267             TRY:
1268             {
1269 0         0 local $@;
  0         0  
1270              
1271             eval
1272 0         0 {
1273 0         0 local $dbh->{'RaiseError'} = 1;
1274 0         0 $ret = $dbh->rollback;
1275             };
1276              
1277 0         0 $error = $@;
1278             }
1279              
1280 0 0       0 if($error)
1281             {
1282 16     16   482 no warnings 'uninitialized';
  16         41  
  16         9600  
1283 0         0 $self->error("rollback() - $error " . $dbh->errstr);
1284              
1285 0 0       0 unless($is_active)
1286             {
1287 0 0 0     0 if($dbh->{'Driver'}{'Name'} eq 'mysql' && $dbh->{'Driver'}{'Version'} < 4.012)
1288             {
1289 0         0 $self->error($self->error . '; Also, the database handle did not ' .
1290             'have Active set to a true value. DBD::mysql versions before 4.012 ' .
1291             'may fail to set Active back to 1 when the mysql_auto_reconnect is ' .
1292             'set. Try upgrading to DBD::mysql 4.012 or later');
1293             }
1294              
1295 0         0 return 0;
1296             }
1297              
1298 0         0 return undef;
1299             }
1300              
1301 0 0 0     0 unless($ret || $ac)
1302             {
1303 0         0 $self->error('rollback() failed - ' . $dbh->errstr);
1304 0         0 return undef;
1305             }
1306              
1307             # DBI does this for me...
1308             #$dbh->{'AutoCommit'} = 1;
1309              
1310 0         0 return 1;
1311             }
1312              
1313             sub do_transaction
1314             {
1315 0     0 1 0 my($self, $code) = (shift, shift);
1316              
1317 0 0       0 my $dbh = $self->dbh or return undef;
1318              
1319 0         0 my $error;
1320              
1321             TRY:
1322             {
1323 0         0 local $@;
  0         0  
1324              
1325             eval
1326 0         0 {
1327 0 0       0 $self->begin_work or die $self->error;
1328 0         0 $code->(@_);
1329 0 0       0 $self->commit or die $self->error;
1330             };
1331              
1332 0         0 $error = $@;
1333             }
1334              
1335 0 0       0 if($error)
1336             {
1337 0 0       0 $error = ref $error ? $error : "do_transaction() failed - $error";
1338              
1339 0 0       0 if($self->rollback)
1340             {
1341 0         0 $self->error($error);
1342             }
1343             else
1344             {
1345 0         0 $self->error("$error. rollback() also failed - " . $self->error)
1346             }
1347              
1348 0         0 return undef;
1349             }
1350              
1351 0         0 return 1;
1352             }
1353              
1354             sub auto_quote_table_name
1355             {
1356 0     0 0 0 my($self, $name) = @_;
1357              
1358 0 0 0     0 if($name =~ /\W/ || $self->is_reserved_word($name))
1359             {
1360 0         0 return $self->quote_table_name($name, @_);
1361             }
1362              
1363 0         0 return $name;
1364             }
1365              
1366             sub auto_quote_column_name
1367             {
1368 0     0 0 0 my($self, $name) = @_;
1369              
1370 0 0 0     0 if($name =~ /\W/ || $self->is_reserved_word($name))
1371             {
1372 0         0 return $self->quote_column_name($name, @_);
1373             }
1374              
1375 0         0 return $name;
1376             }
1377              
1378             sub quote_column_name
1379             {
1380 0     0 1 0 my $name = $_[1];
1381 0         0 $name =~ s/"/""/g;
1382 0         0 return qq("$name");
1383             }
1384              
1385             sub quote_table_name
1386             {
1387 0     0 0 0 my $name = $_[1];
1388 0         0 $name =~ s/"/""/g;
1389 0         0 return qq("$name");
1390             }
1391              
1392             sub unquote_column_name
1393             {
1394 0     0 0 0 my($self_or_class, $name) = @_;
1395              
1396 16     16   127 no warnings 'uninitialized';
  16         46  
  16         4915  
1397              
1398             # handle quoted strings with quotes doubled inside them
1399 0 0       0 if($name =~ /^(['"`])(.+)\1$/)
1400             {
1401 0         0 my $q = $1;
1402 0         0 $name = $2;
1403 0         0 $name =~ s/$q$q/$q/g;
1404             }
1405              
1406 0         0 return $name;
1407             }
1408              
1409             *unquote_table_name = \&unquote_column_name;
1410              
1411             #sub is_reserved_word { 0 }
1412              
1413             *is_reserved_word = \&SQL::ReservedWords::is_reserved;
1414              
1415             BEGIN
1416             {
1417             sub quote_identifier_dbi
1418             {
1419 0     0 0 0 my($self) = shift;
1420 0 0       0 my $dbh = $self->dbh or die $self->error;
1421 0         0 return $dbh->quote_identifier(@_);
1422             }
1423              
1424             sub quote_identifier_fallback
1425             {
1426 0     0 0 0 my($self, $catalog, $schema, $table) = @_;
1427 0         0 return join('.', map { qq("$_") } grep { defined } ($schema, $table));
  0         0  
  0         0  
1428             }
1429              
1430 16 50   16   160 if($DBI::VERSION >= 1.21)
1431             {
1432 16         6155 *quote_identifier = \&quote_identifier_dbi;
1433             }
1434             else
1435             {
1436 0         0 *quote_identifier = \&quote_identifier_fallback;
1437             }
1438             }
1439              
1440             *quote_identifier_for_sequence = \&quote_identifier;
1441              
1442             sub quote_column_with_table
1443             {
1444 0     0 0 0 my($self, $column, $table) = @_;
1445              
1446 0 0       0 return $table ?
1447             $self->quote_table_name($table) . '.' .
1448             $self->quote_column_name($column) :
1449             $self->quote_column_name($column);
1450             }
1451              
1452             sub auto_quote_column_with_table
1453             {
1454 0     0 0 0 my($self, $column, $table) = @_;
1455              
1456 0 0       0 return $table ?
1457             $self->auto_quote_table_name($table) . '.' .
1458             $self->auto_quote_column_name($column) :
1459             $self->auto_quote_column_name($column);
1460             }
1461              
1462             sub has_primary_key
1463             {
1464 0     0 1 0 my($self) = shift;
1465 0         0 my $columns = $self->primary_key_column_names(@_);
1466 0 0 0     0 return (ref $columns && @$columns) ? 1 : 0;
1467             }
1468              
1469             sub primary_key_column_names
1470             {
1471 0     0 1 0 my($self) = shift;
1472              
1473 0 0       0 my %args = @_ == 1 ? (table => @_) : @_;
1474              
1475 0 0       0 my $table = $args{'table'} or Carp::croak "Missing table name parameter";
1476 0   0     0 my $catalog = $args{'catalog'} || $self->catalog;
1477 0   0     0 my $schema = $args{'schema'} || $self->schema;
1478              
1479 0 0       0 $schema = $self->default_implicit_schema unless(defined $schema);
1480              
1481 0 0       0 $table = lc $table if($self->likes_lowercase_table_names);
1482              
1483 0 0 0     0 $schema = lc $schema
1484             if(defined $schema && $self->likes_lowercase_schema_names);
1485              
1486 0 0 0     0 $catalog = lc $catalog
1487             if(defined $catalog && $self->likes_lowercase_catalog_names);
1488              
1489 0         0 my $table_unquoted = $self->unquote_table_name($table);
1490              
1491 0         0 my $columns;
1492              
1493             my $error;
1494              
1495             TRY:
1496             {
1497 0         0 local $@;
  0         0  
1498              
1499             eval
1500 0         0 {
1501 0         0 $columns =
1502             $self->_get_primary_key_column_names($catalog, $schema, $table_unquoted);
1503             };
1504              
1505 0         0 $error = $@;
1506             }
1507              
1508 0 0 0     0 if($error || !$columns)
1509             {
1510 16     16   140 no warnings 'uninitialized'; # undef strings okay
  16         43  
  16         2725  
1511 0 0       0 $error = 'no primary key columns found' unless(defined $error);
1512 0         0 Carp::croak "Could not get primary key columns for catalog '" .
1513             $catalog . "' schema '" . $schema . "' table '" .
1514             $table_unquoted . "' - " . $error;
1515             }
1516              
1517 0 0       0 return wantarray ? @$columns : $columns;
1518             }
1519              
1520             sub _get_primary_key_column_names
1521             {
1522 0     0   0 my($self, $catalog, $schema, $table) = @_;
1523              
1524 0 0       0 my $dbh = $self->dbh or die $self->error;
1525              
1526 0         0 local $dbh->{'FetchHashKeyName'} = 'NAME';
1527              
1528 0         0 my $sth = $dbh->primary_key_info($catalog, $schema, $table);
1529              
1530 0 0       0 unless(defined $sth)
1531             {
1532 16     16   127 no warnings 'uninitialized'; # undef strings okay
  16         35  
  16         1472  
1533 0         0 $self->error("No primary key information found for catalog '", $catalog,
1534             "' schema '", $schema, "' table '", $table, "'");
1535 0         0 return [];
1536             }
1537              
1538 0         0 my @columns;
1539              
1540 0         0 my $supports_catalog = $self->supports_catalog;
1541              
1542 0         0 PK: while(my $pk_info = $sth->fetchrow_hashref)
1543             {
1544             CHECK_TABLE: # Make sure this column is from the right table
1545             {
1546 16     16   124 no warnings; # Allow undef coercion to empty string
  16         52  
  16         14764  
  0         0  
1547              
1548             $pk_info->{'TABLE_NAME'} =
1549 0         0 $self->unquote_table_name($pk_info->{'TABLE_NAME'});
1550              
1551             next PK unless((!$supports_catalog || $pk_info->{'TABLE_CAT'} eq $catalog) &&
1552             $pk_info->{'TABLE_SCHEM'} eq $schema &&
1553 0 0 0     0 $pk_info->{'TABLE_NAME'} eq $table);
      0        
      0        
1554             }
1555              
1556 0 0       0 unless(defined $pk_info->{'COLUMN_NAME'})
1557             {
1558 0         0 Carp::croak "Could not extract column name from DBI primary_key_info()";
1559             }
1560              
1561 0         0 push(@columns, $self->unquote_column_name($pk_info->{'COLUMN_NAME'}));
1562             }
1563              
1564 0         0 return \@columns;
1565             }
1566              
1567             #
1568             # These methods could/should be overridden in driver-specific subclasses
1569             #
1570              
1571 0     0 1 0 sub insertid_param { undef }
1572 0     0 0 0 sub null_date { '0000-00-00' }
1573 0     0 0 0 sub null_datetime { '0000-00-00 00:00:00' }
1574 0     0 0 0 sub null_timestamp { '00000000000000' }
1575 0     0 0 0 sub min_timestamp { '00000000000000' }
1576 0     0 0 0 sub max_timestamp { '00000000000000' }
1577              
1578 0     0 1 0 sub last_insertid_from_sth { $_[1]->{$_[0]->insertid_param} }
1579 0   0 0 0 0 sub generate_primary_key_values { (undef) x ($_[1] || 1) }
1580 0   0 0 0 0 sub generate_primary_key_placeholders { (undef) x ($_[1] || 1) }
1581              
1582 0     0 0 0 sub max_column_name_length { 255 }
1583 0     0 0 0 sub max_column_alias_length { 255 }
1584              
1585             # Boolean formatting and parsing
1586              
1587 0 0   0 1 0 sub format_boolean { $_[1] ? 1 : 0 }
1588              
1589             sub parse_boolean
1590             {
1591 0     0 1 0 my($self, $value) = @_;
1592              
1593 0 0 0     0 return $value if($self->validate_boolean_keyword($_[1]) ||
      0        
1594             ($self->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/));
1595 0 0       0 return 1 if($value =~ /^(?:t(?:rue)?|y(?:es)?|1)$/i);
1596 0 0       0 return 0 if($value =~ /^(?:f(?:alse)?|no?|0)$/i);
1597              
1598 0         0 $self->error("Invalid boolean value: '$value'");
1599 0         0 return undef;
1600             }
1601              
1602             # Date formatting
1603              
1604             sub format_date
1605             {
1606 0     0 1 0 my($self, $date) = @_;
1607 0 0 0     0 return $date
      0        
1608             if($self->validate_date_keyword($date) ||
1609             ($self->keyword_function_calls && $date =~ /^\w+\(.*\)$/));
1610 0         0 return $self->date_handler->format_date($date);
1611             }
1612              
1613             sub format_datetime
1614             {
1615 0     0 1 0 my($self, $date) = @_;
1616 0 0 0     0 return $date if($self->validate_datetime_keyword($date) ||
      0        
1617             ($self->keyword_function_calls && $date =~ /^\w+\(.*\)$/));
1618 0         0 return $self->date_handler->format_datetime($date);
1619             }
1620              
1621 16     16   151 use constant HHMMSS_PRECISION => 6;
  16         41  
  16         1004  
1622 16     16   114 use constant HHMM_PRECISION => 4;
  16         31  
  16         70008  
1623              
1624             sub format_time
1625             {
1626 24     24 1 19557 my($self, $time, $precision) = @_;
1627 24 50 33     64 return $time if($self->validate_time_keyword($time) ||
      33        
1628             ($self->keyword_function_calls && $time =~ /^\w+\(.*\)$/));
1629              
1630 24 50       191 if(defined $precision)
1631             {
1632 0 0       0 if($precision > HHMMSS_PRECISION)
    0          
    0          
1633             {
1634 0         0 my $scale = $precision - HHMMSS_PRECISION;
1635 0         0 return $time->format("%H:%M:%S%${scale}n");
1636             }
1637             elsif($precision == HHMMSS_PRECISION)
1638             {
1639 0         0 return $time->format("%H:%M:%S");
1640             }
1641             elsif($precision == HHMM_PRECISION)
1642             {
1643 0         0 return $time->format("%H:%M");
1644             }
1645             }
1646              
1647             # Punt
1648 24         67 return $time->as_string;
1649             }
1650              
1651             sub format_timestamp
1652             {
1653 0     0 1 0 my($self, $date) = @_;
1654 0 0 0     0 return $date if($self->validate_timestamp_keyword($date) ||
      0        
1655             ($self->keyword_function_calls && $date =~ /^\w+\(.*\)$/));
1656 0         0 return $self->date_handler->format_timestamp($date);
1657             }
1658              
1659             sub format_timestamp_with_time_zone
1660             {
1661 0     0 1 0 my($self, $date) = @_;
1662 0 0 0     0 return $date if($self->validate_timestamp_keyword($date) ||
      0        
1663             ($self->keyword_function_calls && $date =~ /^\w+\(.*\)$/));
1664 0         0 return $self->date_handler->format_timestamp_with_time_zone($date);
1665             }
1666              
1667             # Date parsing
1668              
1669             sub parse_date
1670             {
1671 0     0 1 0 my($self, $value) = @_;
1672              
1673 0 0 0     0 if(UNIVERSAL::isa($value, 'DateTime') || $self->validate_date_keyword($value))
1674             {
1675 0         0 return $value;
1676             }
1677              
1678 0         0 my($dt, $error);
1679              
1680             TRY:
1681             {
1682 0         0 local $@;
  0         0  
1683 0         0 eval { $dt = $self->date_handler->parse_date($value) };
  0         0  
1684 0         0 $error = $@;
1685             }
1686              
1687 0 0       0 if($error)
1688             {
1689 0         0 $self->error("Could not parse date '$value' - $error");
1690 0         0 return undef;
1691             }
1692              
1693 0         0 return $dt;
1694             }
1695              
1696             sub parse_datetime
1697             {
1698 0     0 1 0 my($self, $value) = @_;
1699              
1700 0 0 0     0 if(UNIVERSAL::isa($value, 'DateTime') ||
1701             $self->validate_datetime_keyword($value))
1702             {
1703 0         0 return $value;
1704             }
1705              
1706 0         0 my($dt, $error);
1707              
1708             TRY:
1709             {
1710 0         0 local $@;
  0         0  
1711 0         0 eval { $dt = $self->date_handler->parse_datetime($value) };
  0         0  
1712 0         0 $error = $@;
1713             }
1714              
1715 0 0       0 if($error)
1716             {
1717 0         0 $self->error("Could not parse datetime '$value' - $error");
1718 0         0 return undef;
1719             }
1720              
1721 0         0 return $dt;
1722             }
1723              
1724             sub parse_timestamp
1725             {
1726 0     0 1 0 my($self, $value) = @_;
1727              
1728 0 0 0     0 if(UNIVERSAL::isa($value, 'DateTime') ||
1729             $self->validate_timestamp_keyword($value))
1730             {
1731 0         0 return $value;
1732             }
1733              
1734 0         0 my($dt, $error);
1735              
1736             TRY:
1737             {
1738 0         0 local $@;
  0         0  
1739 0         0 eval { $dt = $self->date_handler->parse_timestamp($value) };
  0         0  
1740 0         0 $error = $@;
1741             }
1742              
1743 0 0       0 if($error)
1744             {
1745 0         0 $self->error("Could not parse timestamp '$value' - $error");
1746 0         0 return undef;
1747             }
1748              
1749 0         0 return $dt;
1750             }
1751              
1752             sub parse_timestamp_with_time_zone
1753             {
1754 0     0 1 0 my($self, $value) = @_;
1755              
1756 0 0 0     0 if(UNIVERSAL::isa($value, 'DateTime') ||
1757             $self->validate_timestamp_keyword($value))
1758             {
1759 0         0 return $value;
1760             }
1761              
1762 0         0 my($dt, $error);
1763              
1764             TRY:
1765             {
1766 0         0 local $@;
  0         0  
1767 0         0 eval { $dt = $self->date_handler->parse_timestamp_with_time_zone($value) };
  0         0  
1768 0         0 $error = $@;
1769             }
1770              
1771 0 0       0 if($error)
1772             {
1773 0         0 $self->error("Could not parse timestamp with time zone '$value' - $error");
1774 0         0 return undef;
1775             }
1776              
1777 0         0 return $dt;
1778             }
1779              
1780             sub parse_time
1781             {
1782 30     30 1 19682 my($self, $value) = @_;
1783              
1784 30 50 33     303 if(!defined $value || UNIVERSAL::isa($value, 'Time::Clock') ||
      33        
      33        
      33        
1785             $self->validate_time_keyword($value) ||
1786             ($self->keyword_function_calls && $value =~ /^\w+\(.*\)$/))
1787             {
1788 0         0 return $value;
1789             }
1790              
1791 30         249 my($time, $error);
1792              
1793             TRY:
1794             {
1795 30         41 local $@;
  30         41  
1796 30         56 eval { $time = Time::Clock->new->parse($value) };
  30         109  
1797 30         3200 $error = $@;
1798             }
1799              
1800 30 100       70 if($error)
1801             {
1802 6         11 my $second_error;
1803              
1804             TRY:
1805             {
1806 6         11 local $@;
  6         10  
1807              
1808             eval
1809 6         10 {
1810 6         35 my $dt = $self->date_handler->parse_time($value);
1811             # Using parse()/strftime() is faster than using the
1812             # Time::Clock constructor and the DateTime accessors.
1813 0         0 $time = Time::Clock->new->parse($dt->strftime('%H:%M:%S.%N'));
1814             };
1815              
1816 6         116 $second_error = $@;
1817             }
1818              
1819 6 50       16 if($second_error)
1820             {
1821 6         55 $self->error("Could not parse time '$value' - Time::Clock::parse() failed " .
1822             "($error) and $second_error");
1823 6         34 return undef;
1824             }
1825             }
1826              
1827 24         159 return $time;
1828             }
1829              
1830             sub parse_bitfield
1831             {
1832 0     0 1 0 my($self, $val, $size) = @_;
1833              
1834 0 0       0 return undef unless(defined $val);
1835              
1836 0 0       0 if(ref $val)
1837             {
1838 0 0 0     0 if($size && $val->Size != $size)
1839             {
1840 0         0 return Bit::Vector->new_Bin($size, $val->to_Bin);
1841             }
1842              
1843 0         0 return $val;
1844             }
1845              
1846 0 0 0     0 if($val =~ /^[10]+$/)
    0 0        
    0          
    0          
1847             {
1848 0   0     0 return Bit::Vector->new_Bin($size || length $val, $val);
1849             }
1850             elsif($val =~ /^\d*[2-9]\d*$/)
1851             {
1852 0   0     0 return Bit::Vector->new_Dec($size || (length($val) * 4), $val);
1853             }
1854             elsif($val =~ s/^0x// || $val =~ s/^X'(.*)'$/$1/ || $val =~ /^[0-9a-f]+$/i)
1855             {
1856 0   0     0 return Bit::Vector->new_Hex($size || (length($val) * 4), $val);
1857             }
1858             elsif($val =~ s/^B'([10]+)'$/$1/i)
1859             {
1860 0   0     0 return Bit::Vector->new_Bin($size || length $val, $val);
1861             }
1862             else
1863             {
1864 0         0 $self->error("Could not parse bitfield value '$val'");
1865 0         0 return undef;
1866             #return Bit::Vector->new_Bin($size || length($val), $val);
1867             }
1868             }
1869              
1870             sub format_bitfield
1871             {
1872 0     0 1 0 my($self, $vec, $size) = @_;
1873              
1874 0 0       0 if($size)
1875             {
1876 0         0 $vec = Bit::Vector->new_Bin($size, $vec->to_Bin);
1877 0         0 return sprintf('%0*b', $size, hex($vec->to_Hex));
1878             }
1879              
1880 0         0 return sprintf('%b', hex($vec->to_Hex));
1881             }
1882              
1883 0     0 0 0 sub select_bitfield_column_sql { shift->auto_quote_column_with_table(@_) }
1884              
1885             sub parse_array
1886             {
1887 0     0 0 0 my($self) = shift;
1888              
1889 0 0       0 return $_[0] if(ref $_[0]);
1890 0 0       0 return [ @_ ] if(@_ > 1);
1891              
1892 0         0 my $val = $_[0];
1893              
1894 0 0       0 return undef unless(defined $val);
1895              
1896 0         0 $val =~ s/^ (?:\[.+\]=)? \{ (.*) \} $/$1/sx;
1897              
1898 0         0 my @array;
1899              
1900 0         0 while($val =~ s/(?:"((?:[^"\\]+|\\.)*)"|([^",]+))(?:,|$)//)
1901             {
1902 0 0       0 my($item) = map { $_ eq 'NULL' ? undef : $_ } (defined $1 ? $1 : $2);
  0 0       0  
1903 0 0       0 $item =~ s{\\(.)}{$1}g if(defined $item);
1904 0         0 push(@array, $item);
1905             }
1906              
1907 0         0 return \@array;
1908             }
1909              
1910             sub format_array
1911             {
1912 0     0 0 0 my($self) = shift;
1913              
1914 0 0 0     0 return undef unless(ref $_[0] || defined $_[0]);
1915              
1916 0 0       0 my @array = (ref $_[0]) ? @{$_[0]} : @_;
  0         0  
1917              
1918             my $str = '{' . join(',', map
1919             {
1920 0 0       0 if(!defined $_)
  0 0       0  
1921             {
1922 0         0 'NULL'
1923             }
1924             elsif(/^[-+]?\d+(?:\.\d*)?$/)
1925             {
1926 0         0 $_
1927             }
1928             else
1929             {
1930 0         0 s/\\/\\\\/g;
1931 0         0 s/"/\\"/g;
1932 0         0 qq("$_")
1933             }
1934             } @array) . '}';
1935              
1936 0 0       0 if(length($str) > $self->max_array_characters)
1937             {
1938 0         0 Carp::croak "Array string is longer than ", ref($self),
1939             "->max_array_characters (", $self->max_array_characters,
1940             ") characters long: $str";
1941             }
1942              
1943 0         0 return $str;
1944             }
1945              
1946             my $Interval_Regex = qr{
1947             (?:\@\s*)?
1948             (?:
1949             (?: (?: \s* ([+-]?) (\d+) : ([0-5]?\d)? (?:: ([0-5]?\d (?:\.\d+)? )? )?)) # (sign)hhh:mm:ss
1950             |
1951             (?: \s* ( [+-]? \d+ (?:\.\d+(?=\s+s))? ) \s+ # quantity
1952             (?: # unit
1953             (?:\b(dec) (?:ades?\b | s?\b)?\b) # decades
1954             | (?:\b(d) (?:ays?\b)?\b) # days
1955             | (?:\b(y) (?:ears?\b)?\b) # years
1956             | (?:\b(h) (?:ours?\b)?\b) # hours
1957             | (?:\b(mon) (?:s\b | ths?\b)?\b) # months
1958             | (?:\b(mil) (?:s\b | lenniums?\b)?\b) # millenniums
1959             | (?:\b(m) (?:inutes?\b | ins?\b)?\b) # minutes
1960             | (?:\b(s) (?:ec(?:s | onds?)?)?\b) # seconds
1961             | (?:\b(w) (?:eeks?\b)?\b) # weeks
1962             | (?:\b(c) (?:ent(?:s | ury | uries)?\b)?\b) # centuries
1963             )
1964             )
1965             )
1966             (?: \s+ (ago) \b)? # direction
1967             | (.+)
1968             }ix;
1969              
1970             sub parse_interval
1971             {
1972 76     76 1 45789 my($self, $value, $end_of_month_mode) = @_;
1973              
1974 76 100 33     660 if(!defined $value || UNIVERSAL::isa($value, 'DateTime::Duration') ||
      33        
      100        
      66        
1975             $self->validate_interval_keyword($value) ||
1976             ($self->keyword_function_calls && $value =~ /^\w+\(.*\)$/))
1977             {
1978 2         36 return $value;
1979             }
1980              
1981 74         759 for($value)
1982             {
1983 74         148 s/\A //;
1984 74         122 s/ \z//;
1985 74         477 s/\s+/ /g;
1986             }
1987              
1988 74         214 my(%units, $is_ago, $sign, $error, $dt_duration);
1989              
1990 74         0 my $value_pos;
1991              
1992 74   66     892 while(!$error && $value =~ /$Interval_Regex/go)
1993             {
1994 218         345 $value_pos = pos($value);
1995              
1996 218 100       426 $is_ago = 1 if($16);
1997              
1998 218 100 100     1411 if($2 || $3 || $4)
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
1999             {
2000 22 100 100     111 if($sign || defined $units{'hours'} || defined $units{'minutes'} ||
      66        
      100        
2001             defined $units{'seconds'})
2002             {
2003 10         13 $error = 1;
2004 10         20 last;
2005             }
2006              
2007 12 100 66     44 $sign = ($1 && $1 eq '-') ? -1 : 1;
2008              
2009 12         38 my $secs = $4;
2010              
2011 12 50 33     30 if(defined $secs && $secs != int($secs))
2012             {
2013 0         0 my $fsecs = substr($secs, index($secs, '.') + 1);
2014 0         0 $secs = int($secs);
2015              
2016 0         0 my $len = length $fsecs;
2017              
2018 0 0       0 if($len < 9)
    0          
2019             {
2020 0         0 $fsecs .= ('0' x (9 - length $fsecs));
2021             }
2022             elsif($len > 9)
2023             {
2024 0         0 $fsecs = substr($fsecs, 0, 9);
2025             }
2026              
2027 0         0 $units{'nanoseconds'} = $sign * $fsecs;
2028             }
2029              
2030 12   100     41 $units{'hours'} = $sign * ($2 || 0);
2031 12   100     40 $units{'minutes'} = $sign * ($3 || 0);
2032 12   50     90 $units{'seconds'} = $sign * ($secs || 0);
2033             }
2034             elsif($6)
2035             {
2036 10 50       24 if($units{'decades'}) { $error = 1; last }
  0         0  
  0         0  
2037 10         71 $units{'decades'} = $5;
2038             }
2039             elsif(defined $7)
2040             {
2041 28 100       57 if($units{'days'}) { $error = 1; last }
  2         6  
  2         5  
2042 26         152 $units{'days'} = $5;
2043             }
2044             elsif(defined $8)
2045             {
2046 20 50       48 if($units{'years'}) { $error = 1; last }
  0         0  
  0         0  
2047 20         156 $units{'years'} = $5;
2048             }
2049             elsif(defined $9)
2050             {
2051 18 50       54 if($units{'hours'}) { $error = 1; last }
  0         0  
  0         0  
2052 18         148 $units{'hours'} = $5;
2053             }
2054             elsif(defined $10)
2055             {
2056 14 50       33 if($units{'months'}) { $error = 1; last }
  0         0  
  0         0  
2057 14         95 $units{'months'} = $5;
2058             }
2059             elsif(defined $11)
2060             {
2061 14 50       36 if($units{'millenniums'}) { $error = 1; last }
  0         0  
  0         0  
2062 14         126 $units{'millenniums'} = $5;
2063             }
2064             elsif(defined $12)
2065             {
2066 22 50       51 if($units{'minutes'}) { $error = 1; last }
  0         0  
  0         0  
2067 22         171 $units{'minutes'} = $5;
2068             }
2069             elsif(defined $13)
2070             {
2071 26 50       56 if($units{'seconds'}) { $error = 1; last }
  0         0  
  0         0  
2072              
2073 26         45 my $secs = $5;
2074              
2075 26         63 $units{'seconds'} = int($secs);
2076              
2077 26 100       126 if($units{'seconds'} != $secs)
2078             {
2079 2         12 my $fsecs = substr($secs, index($secs, '.') + 1);
2080              
2081 2         4 my $len = length $fsecs;
2082              
2083 2 50       9 if($len < 9)
    0          
2084             {
2085 2         9 $fsecs .= ('0' x (9 - length $fsecs));
2086             }
2087             elsif($len > 9)
2088             {
2089 0         0 $fsecs = substr($fsecs, 0, 9);
2090             }
2091              
2092 2         10 $units{'nanoseconds'} = $fsecs;
2093             }
2094             }
2095             elsif(defined $14)
2096             {
2097 10 50       25 if($units{'weeks'}) { $error = 1; last }
  0         0  
  0         0  
2098 10         64 $units{'weeks'} = $5;
2099             }
2100             elsif(defined $15)
2101             {
2102 10 50       26 if($units{'centuries'}) { $error = 1; last }
  0         0  
  0         0  
2103 10         75 $units{'centuries'} = $5;
2104             }
2105             elsif(defined $17)
2106             {
2107 22         34 $error = 1;
2108 22         34 last;
2109             }
2110             }
2111              
2112 74 100       144 if($error)
2113             {
2114 34         149 $self->error("Could not parse interval '$value' - found overlaping time units");
2115 34         123 return undef;
2116             }
2117              
2118 40 50       83 if($value_pos != length($value))
2119             {
2120 0         0 $self->error("Could not parse interval '$value' - could not interpret all tokens");
2121 0         0 return undef;
2122             }
2123              
2124 40 100       84 if(defined $units{'millenniums'})
2125             {
2126 14         33 $units{'years'} += 1000 * $units{'millenniums'};
2127 14         31 delete $units{'millenniums'};
2128             }
2129              
2130 40 100       88 if(defined $units{'centuries'})
2131             {
2132 10         20 $units{'years'} += 100 * $units{'centuries'};
2133 10         12 delete $units{'centuries'};
2134             }
2135              
2136 40 100       72 if(defined $units{'decades'})
2137             {
2138 10         15 $units{'years'} += 10 * $units{'decades'};
2139 10         36 delete $units{'decades'};
2140             }
2141              
2142 40 100 100     275 if($units{'hours'} || $units{'minutes'} || $units{'seconds'})
      100        
2143             {
2144             my $seconds = ($units{'hours'} || 0) * 60 * 60 +
2145             ($units{'minutes'} || 0) * 60 +
2146 24   100     118 ($units{'seconds'} || 0);
      100        
      100        
2147 24         53 $units{'hours'} = int($seconds / 3600);
2148 24         38 $seconds -= $units{'hours'} * 3600;
2149 24         39 $units{'minutes'} = int($seconds / 60);
2150 24         39 $units{'seconds'} = $seconds - $units{'minutes'} * 60;
2151             }
2152              
2153 40 50       78 $units{'end_of_month'} = $end_of_month_mode if(defined $end_of_month_mode);
2154              
2155 40 100       234 $dt_duration = $is_ago ?
2156             DateTime::Duration->new(%units)->inverse :
2157             DateTime::Duration->new(%units);
2158              
2159             # XXX: Ugly hack workaround for DateTime::Duration bug (RT 53985)
2160 40 50 66     5243 if($is_ago && defined $end_of_month_mode &&
      33        
2161             $dt_duration->end_of_month_mode ne $end_of_month_mode)
2162             {
2163 0         0 $dt_duration->{'end_of_month'} = $end_of_month_mode;
2164             }
2165              
2166 40         161 return $dt_duration;
2167             }
2168              
2169             sub format_interval
2170             {
2171 74     74 1 1611 my($self, $dur) = @_;
2172              
2173 74 50 66     251 if(!defined $dur || $self->validate_interval_keyword($dur) ||
      66        
      66        
2174             ($self->keyword_function_calls && $dur =~ /^\w+\(.*\)$/))
2175             {
2176 34         130 return $dur;
2177             }
2178              
2179 40         469 my $output = '';
2180              
2181 40         63 my(%deltas, %unit, $neg);
2182              
2183 40         129 @deltas{qw/years mons days h m s/} =
2184             $dur->in_units(qw/years months days hours minutes seconds/);
2185              
2186 40         2087 foreach (qw/years mons days/)
2187             {
2188 120         169 $unit{$_} = $_;
2189 120 100       265 $unit{$_} =~ s/s\z// if $deltas{$_} == 1;
2190             }
2191              
2192 40 100       120 $output .= "$deltas{'years'} $unit{'years'} " if($deltas{'years'});
2193 40 100       80 $neg = 1 if($deltas{'years'} < 0);
2194              
2195 40 50 66     100 $output .= '+' if ($neg && $deltas{'mons'} > 0);
2196 40 100       90 $output .= "$deltas{'mons'} $unit{'mons'} " if($deltas{'mons'});
2197             $neg = $deltas{'mons'} < 0 ? 1 :
2198 40 100       127 $deltas{'mons'} ? 0 :
    100          
2199             $neg;
2200              
2201 40 100 100     101 $output .= '+' if($neg && $deltas{'days'} > 0);
2202 40 100       100 $output .= "$deltas{'days'} $unit{'days'} " if($deltas{'days'});
2203              
2204 40 100 100     186 if($deltas{'h'} || $deltas{'m'} || $deltas{'s'} || $dur->nanoseconds)
      100        
      100        
2205             {
2206             $neg = $deltas{'days'} < 0 ? 1 :
2207 26 100       130 $deltas{'days'} ? 0 :
    100          
2208             $neg;
2209              
2210 26 100 66     92 if($neg && (($deltas{'h'} > 0) || (!$deltas{'h'} && $deltas{'m'} > 0) ||
      100        
2211             (!$deltas{'h'} && !$deltas{'m'} && $deltas{'s'} > 0)))
2212             {
2213 4         8 $output .= '+';
2214             }
2215              
2216 26         63 my $nsec = $dur->nanoseconds;
2217              
2218 26 100 66     893 $output .= '-' if(!$deltas{'h'} && ($deltas{'m'} < 0 || $deltas{'s'} < 0));
      66        
2219 26         54 @deltas{qw/m s/} = (abs($deltas{'m'}), abs($deltas{'s'}));
2220 52         260 $deltas{'hms'} = join(':', map { sprintf('%.2d', $deltas{$_}) } (qw/h m/)) .
2221             ($nsec ? sprintf(':%02d.%09d', $deltas{'s'}, $nsec) :
2222 26 100       40 sprintf(':%02d', $deltas{'s'}));
2223              
2224 26 50       90 $output .= "$deltas{'hms'}" if($deltas{'hms'});
2225             }
2226              
2227 40         627 $output =~ s/ \z//;
2228              
2229 40 100       134 if(length($output) > $self->max_interval_characters)
2230             {
2231 2         57 Carp::croak "Interval string is longer than ", ref($self),
2232             "->max_interval_characters (", $self->max_interval_characters,
2233             ") characters long: $output";
2234             }
2235              
2236 38         1855 return $output;
2237             }
2238              
2239 0     0 0 0 sub build_dsn { 'override in subclass' }
2240              
2241 0     0 0 0 sub validate_integer_keyword { 0 }
2242 0     0 0 0 sub validate_float_keyword { 0 }
2243 0     0 0 0 sub validate_numeric_keyword { 0 }
2244 0     0 0 0 sub validate_decimal_keyword { 0 }
2245 0     0 0 0 sub validate_double_precision_keyword { 0 }
2246 0     0 0 0 sub validate_bigint_keyword { 0 }
2247 0     0 1 0 sub validate_date_keyword { 0 }
2248 0     0 1 0 sub validate_datetime_keyword { 0 }
2249 54     54 1 282 sub validate_time_keyword { 0 }
2250 0     0 1 0 sub validate_timestamp_keyword { 0 }
2251 116     116 1 519 sub validate_interval_keyword { 0 }
2252 0     0 0 0 sub validate_set_keyword { 0 }
2253 0     0 0 0 sub validate_array_keyword { 0 }
2254 0     0 0 0 sub validate_bitfield_keyword { 0 }
2255              
2256             sub validate_boolean_keyword
2257             {
2258 16     16   173 no warnings 'uninitialized';
  16         47  
  16         1819  
2259 0     0 1 0 $_[1] =~ /^(?:TRUE|FALSE)$/;
2260             }
2261              
2262             sub should_inline_keyword
2263             {
2264 16     16   141 no warnings 'uninitialized';
  16         33  
  16         4669  
2265 0 0   0 0 0 ($_[1] =~ /^\w+\(.*\)$/) ? 1 : 0;
2266             }
2267              
2268             BEGIN
2269             {
2270 16     16   86 *should_inline_integer_keyword = \&should_inline_keyword;
2271 16         47 *should_inline_float_keyword = \&should_inline_keyword;
2272 16         54 *should_inline_decimal_keyword = \&should_inline_keyword;
2273 16         44 *should_inline_numeric_keyword = \&should_inline_keyword;
2274 16         32 *should_inline_double_precision_keyword = \&should_inline_keyword;
2275 16         64 *should_inline_bigint_keyword = \&should_inline_keyword;
2276 16         52 *should_inline_date_keyword = \&should_inline_keyword;
2277 16         42 *should_inline_datetime_keyword = \&should_inline_keyword;
2278 16         57 *should_inline_time_keyword = \&should_inline_keyword;
2279 16         57 *should_inline_timestamp_keyword = \&should_inline_keyword;
2280 16         35 *should_inline_interval_keyword = \&should_inline_keyword;
2281 16         45 *should_inline_set_keyword = \&should_inline_keyword;
2282 16         46 *should_inline_array_keyword = \&should_inline_keyword;
2283 16         30 *should_inline_boolean_keyword = \&should_inline_keyword;
2284 16         36233 *should_inline_bitfield_value = \&should_inline_keyword;
2285             }
2286              
2287             sub next_value_in_sequence
2288             {
2289 0     0 0 0 my($self, $seq) = @_;
2290 0         0 $self->error("Don't know how to select next value in sequence '$seq' " .
2291             "for database driver " . $self->driver);
2292 0         0 return undef;
2293             }
2294              
2295             sub current_value_in_sequence
2296             {
2297 0     0 0 0 my($self, $seq) = @_;
2298 0         0 $self->error("Don't know how to select current value in sequence '$seq' " .
2299             "for database driver " . $self->driver);
2300 0         0 return undef;
2301             }
2302              
2303             sub sequence_exists
2304             {
2305 0     0 0 0 my($self, $seq) = @_;
2306 0         0 $self->error("Don't know how to tell if sequence '$seq' exists " .
2307             "for database driver " . $self->driver);
2308 0         0 return undef;
2309             }
2310              
2311 0     0 0 0 sub auto_sequence_name { undef }
2312              
2313 0     0 0 0 sub supports_multi_column_count_distinct { 1 }
2314 0     0 0 0 sub supports_nested_joins { 1 }
2315 0     0 0 0 sub supports_limit_with_offset { 1 }
2316 0     0 0 0 sub supports_arbitrary_defaults_on_insert { 0 }
2317 0     0 0 0 sub supports_select_from_subselect { 0 }
2318 0     0 0 0 sub format_select_from_subselect { "(\n$_[1]\n )" }
2319              
2320 0     0 0 0 sub likes_redundant_join_conditions { 0 }
2321 0     0 0 0 sub likes_lowercase_table_names { 0 }
2322 0     0 0 0 sub likes_uppercase_table_names { 0 }
2323 0     0 0 0 sub likes_lowercase_schema_names { 0 }
2324 0     0 0 0 sub likes_uppercase_schema_names { 0 }
2325 0     0 0 0 sub likes_lowercase_catalog_names { 0 }
2326 0     0 0 0 sub likes_uppercase_catalog_names { 0 }
2327 0     0 0 0 sub likes_lowercase_sequence_names { 0 }
2328 0     0 0 0 sub likes_uppercase_sequence_names { 0 }
2329 0     0 0 0 sub likes_implicit_joins { 0 }
2330              
2331 0     0 0 0 sub supports_schema { 0 }
2332 0     0 0 0 sub supports_catalog { 0 }
2333              
2334 0     0 0 0 sub use_auto_sequence_name { 0 }
2335              
2336             sub format_limit_with_offset
2337             {
2338 0     0 0 0 my($self, $limit, $offset, $args) = @_;
2339              
2340 0         0 delete $args->{'limit'};
2341 0         0 delete $args->{'offset'};
2342              
2343 0 0       0 if(defined $offset)
2344             {
2345 0         0 $args->{'limit_suffix'} = "LIMIT $limit OFFSET $offset";
2346             }
2347             else
2348             {
2349 0         0 $args->{'limit_suffix'} = "LIMIT $limit";
2350             }
2351             }
2352              
2353             sub format_table_with_alias
2354             {
2355             #my($self, $table, $alias, $hints) = @_;
2356 0     0 0 0 return "$_[1] $_[2]";
2357             }
2358              
2359             sub format_select_start_sql
2360             {
2361 0     0 0 0 my($self, $hints) = @_;
2362 0 0       0 return 'SELECT' unless($hints);
2363 0 0       0 return 'SELECT ' . ($hints->{'comment'} ? "/* $hints->{'comment'} */" : '');
2364             }
2365              
2366 0     0 0 0 sub format_select_lock { '' }
2367              
2368             sub column_sql_from_lock_on_value
2369             {
2370 0     0 0 0 my($self, $object_or_class, $name, $tables) = @_;
2371              
2372 0         0 my %map;
2373              
2374 0 0       0 if($tables)
2375             {
2376 0         0 my $tn = 1;
2377              
2378 0         0 foreach my $table (@$tables)
2379             {
2380 0         0 (my $table_key = $table) =~ s/^(["']?)[^.]+\1\.//;
2381 0         0 $map{$table_key} = 't' . $tn++;
2382             }
2383             }
2384              
2385 0         0 my $table;
2386 0         0 my $chase_meta = $object_or_class->meta;
2387              
2388             # Chase down multi-level keys: e.g., products.vendor.name
2389 0         0 while($name =~ /\G([^.]+)(\.|$)/g)
2390             {
2391 0         0 my($sub_name, $more) = ($1, $2);
2392              
2393 0   0     0 my $key = $chase_meta->foreign_key($sub_name) ||
2394             $chase_meta->relationship($sub_name);
2395              
2396 0 0       0 if($key)
2397             {
2398 0 0       0 $chase_meta = $key->can('foreign_class') ?
2399             $key->foreign_class->meta : $key->class->meta;
2400              
2401 0         0 $table = $chase_meta->table;
2402             }
2403             else
2404             {
2405 0 0       0 if($more)
2406             {
2407 0         0 Carp::confess 'Invalid lock => { on => ... } argument: ',
2408             "no foreign key or relationship named '$sub_name' ",
2409             'found in ', $chase_meta->class;
2410             }
2411             else
2412             {
2413 0         0 my $column = $sub_name;
2414              
2415 0 0       0 if($table)
2416             {
2417 0 0       0 $table = $map{$table} if(defined $map{$table});
2418 0         0 return $self->auto_quote_column_with_table($column, $table);
2419             }
2420             else
2421             {
2422 0         0 return $self->auto_quote_column_name($column);
2423             }
2424             }
2425             }
2426             }
2427              
2428 0         0 Carp::confess "Invalid lock => { on => ... } argument: $name";
2429             }
2430              
2431             sub table_sql_from_lock_on_value
2432             {
2433 0     0 0 0 my($self, $object_or_class, $name, $tables) = @_;
2434              
2435 0         0 my %map;
2436              
2437 0 0       0 if($tables)
2438             {
2439 0         0 my $tn = 1;
2440              
2441 0         0 foreach my $table (@$tables)
2442             {
2443 0         0 (my $table_key = $table) =~ s/^(["']?)[^.]+\1\.//;
2444 0         0 $map{$table_key} = 't' . $tn++;
2445             }
2446             }
2447              
2448 0         0 my $table;
2449 0         0 my $chase_meta = $object_or_class->meta;
2450              
2451             # Chase down multi-level keys: e.g., products.vendor.location
2452 0         0 while($name =~ /\G([^.]+)(\.|$)/g)
2453             {
2454 0         0 my($sub_name, $more) = ($1, $2);
2455              
2456 0   0     0 my $key = $chase_meta->foreign_key($sub_name) ||
2457             $chase_meta->relationship($sub_name);
2458              
2459 0 0 0     0 if($key || !$more)
2460             {
2461 0 0       0 if($key)
2462             {
2463 0 0       0 $chase_meta = $key->can('foreign_class') ?
2464             $key->foreign_class->meta : $key->class->meta;
2465              
2466 0         0 $table = $chase_meta->table;
2467             }
2468             else
2469             {
2470 0         0 $table = $sub_name;
2471             }
2472              
2473 0 0       0 next if($more);
2474              
2475 0 0       0 $table = $map{$table} if(defined $map{$table});
2476 0         0 return $self->auto_quote_table_name($table);
2477             }
2478             else
2479             {
2480 0         0 Carp::confess 'Invalid lock => { on => ... } argument: ',
2481             "no foreign key or relationship named '$sub_name' ",
2482             'found in ', $chase_meta->class;
2483             }
2484             }
2485              
2486 0         0 Carp::confess "Invalid lock => { on => ... } argument: $name";
2487             }
2488              
2489 0     0 0 0 sub supports_on_duplicate_key_update { 0 }
2490              
2491             #
2492             # DBI introspection
2493             #
2494              
2495             sub refine_dbi_column_info
2496             {
2497 0     0 0 0 my($self, $col_info) = @_;
2498              
2499             # Parse odd default value syntaxes
2500             $col_info->{'COLUMN_DEF'} =
2501 0         0 $self->parse_dbi_column_info_default($col_info->{'COLUMN_DEF'}, $col_info);
2502              
2503             # Make sure the data type name is lowercase
2504 0         0 $col_info->{'TYPE_NAME'} = lc $col_info->{'TYPE_NAME'};
2505              
2506             # Unquote column name
2507 0         0 $col_info->{'COLUMN_NAME'} = $self->unquote_column_name($col_info->{'COLUMN_NAME'});
2508              
2509 0         0 return;
2510             }
2511              
2512             sub refine_dbi_foreign_key_info
2513             {
2514 0     0 0 0 my($self, $fk_info) = @_;
2515              
2516             # Unquote names
2517 0         0 foreach my $name (qw(NAME COLUMN_NAME DATA_TYPE TABLE_NAME TABLE_CAT TABLE_SCHEM))
2518             {
2519 0         0 foreach my $prefix (qw(FK_ UK_))
2520             {
2521 0         0 my $param = $prefix . $name;
2522             $fk_info->{$param} = $self->unquote_column_name($fk_info->{$param})
2523 0 0       0 if(exists $fk_info->{$param});
2524             }
2525             }
2526              
2527 0         0 return;
2528             }
2529              
2530 0     0 0 0 sub parse_dbi_column_info_default { $_[1] }
2531              
2532             sub list_tables
2533             {
2534 0     0 1 0 my($self, %args) = @_;
2535              
2536 0 0       0 my $types = $args{'include_views'} ? "'TABLE','VIEW'" : 'TABLE';
2537              
2538 0         0 my(@tables, $error);
2539              
2540             TRY:
2541             {
2542 0         0 local $@;
  0         0  
2543              
2544             eval
2545 0         0 {
2546 0 0       0 my $dbh = $self->dbh or die $self->error;
2547              
2548 0         0 local $dbh->{'RaiseError'} = 1;
2549 0         0 local $dbh->{'FetchHashKeyName'} = 'NAME';
2550              
2551 0         0 my $sth = $dbh->table_info($self->catalog, $self->schema, '%', $types);
2552              
2553 0         0 $sth->execute;
2554              
2555 0         0 while(my $table_info = $sth->fetchrow_hashref)
2556             {
2557 0         0 push(@tables, $table_info->{'TABLE_NAME'})
2558             }
2559             };
2560              
2561 0         0 $error = $@;
2562             }
2563              
2564 0 0       0 if($error)
2565             {
2566 0         0 Carp::croak "Could not list tables from ", $self->dsn, " - $error";
2567             }
2568              
2569 0 0       0 return wantarray ? @tables : \@tables;
2570             }
2571              
2572             #
2573             # Setup overrides
2574             #
2575              
2576             # - Rose::DB development init file - Perl code
2577             # - Rose::DB fixup rc file - YAML format
2578              
2579             sub auto_load_fixups
2580             {
2581 0     0 1 0 my($class) = shift;
2582              
2583             # Load a file full of fix-ups for the data sources (usually just passwords)
2584             # from a "well-known" (or at least "well-specified") location.
2585 0         0 my $fixup_file = $ENV{'ROSEDBRC'};
2586 0 0 0     0 $fixup_file = '/etc/rosedbrc' unless(defined $fixup_file && -e $fixup_file);
2587              
2588 0 0       0 if(-e $fixup_file)
2589             {
2590 0 0       0 if(-r $fixup_file)
2591             {
2592 0         0 $class->load_yaml_fixup_file($fixup_file);
2593             }
2594             else
2595             {
2596 0         0 warn "Cannot read Rose::DB fixup file '$fixup_file'";
2597             }
2598             }
2599              
2600             # Load a file or package full of arbitrary Perl used to alter the data
2601             # source registry. This is intended for use in development only.
2602 0         0 my $rosedb_devinit = $ENV{'ROSEDB_DEVINIT'};
2603              
2604 0         0 my $error;
2605              
2606 0 0       0 if(defined $rosedb_devinit)
2607             {
2608 0 0       0 if(-e $rosedb_devinit)
2609             {
2610             TRY:
2611             {
2612 0         0 local $@;
  0         0  
2613 0         0 do $rosedb_devinit;
2614 0         0 $error = $@;
2615             }
2616             }
2617             else
2618             {
2619             TRY:
2620             {
2621 0         0 local $@;
  0         0  
2622 0         0 eval qq(require $rosedb_devinit);
2623 0         0 $error = $@;
2624             }
2625              
2626 0 0       0 if($rosedb_devinit->can('fixup'))
2627             {
2628 0         0 $rosedb_devinit->fixup($class);
2629             }
2630             }
2631             }
2632              
2633 0 0 0     0 if($error || !defined $rosedb_devinit)
2634             {
2635 0         0 my $username;
2636              
2637             # The getpwuid() function is often(?) unimplemented in perl on Windows
2638             TRY:
2639             {
2640 0         0 local $@;
  0         0  
2641 0         0 eval { $username = lc getpwuid($<) };
  0         0  
2642 0         0 $error = $@;
2643             }
2644              
2645 0 0       0 unless($error)
2646             {
2647 0         0 $rosedb_devinit = "Rose::DB::Devel::Init::$username";
2648              
2649             TRY:
2650             {
2651 0         0 local $@;
  0         0  
2652 0         0 eval qq(require $rosedb_devinit);
2653 0         0 $error = $@;
2654             }
2655              
2656 0 0       0 if($error)
2657             {
2658             TRY:
2659             {
2660 0         0 local $@;
  0         0  
2661 0         0 eval { do $rosedb_devinit };
  0         0  
2662 0         0 $error = $@;
2663             }
2664             }
2665             else
2666             {
2667 0 0       0 if($rosedb_devinit->can('fixup'))
2668             {
2669 0         0 $rosedb_devinit->fixup($class);
2670             }
2671             }
2672             }
2673             }
2674             }
2675              
2676             # YAML syntax example:
2677             #
2678             # ---
2679             # production:
2680             # g3db:
2681             # password: mysecret
2682             # ---
2683             # mqa:
2684             # g3db:
2685             # password: myothersecret
2686              
2687             our $YAML_Class;
2688              
2689             sub load_yaml_fixup_file
2690             {
2691 0     0 0 0 my($class, $file) = @_;
2692              
2693 0         0 my $registry = $class->registry;
2694              
2695 0 0       0 unless($YAML_Class)
2696             {
2697 0         0 my $error;
2698              
2699             TRY:
2700             {
2701 0         0 local $@;
  0         0  
2702 0         0 eval { require YAML::Syck };
  0         0  
2703 0         0 $error = $@;
2704             }
2705              
2706 0 0       0 if($error)
2707             {
2708 0         0 require YAML;
2709             #warn "# Using YAML\n";
2710 0         0 $YAML_Class = 'YAML';
2711             }
2712             else
2713             {
2714             #warn "# Using YAML::Syck\n";
2715 0         0 $YAML_Class = 'YAML::Syck';
2716             }
2717             }
2718              
2719 0 0       0 $Debug && warn "$class - Loading fixups from $file...\n";
2720 16     16   152 no strict 'refs';
  16         40  
  16         9116  
2721 0         0 my @data = &{"${YAML_Class}::LoadFile"}($file);
  0         0  
2722              
2723 0         0 foreach my $data (@data)
2724             {
2725 0         0 foreach my $domain (sort keys %$data)
2726             {
2727 0         0 foreach my $type (sort keys %{$data->{$domain}})
  0         0  
2728             {
2729 0         0 my $entry = $registry->entry(domain => $domain, type => $type);
2730              
2731 0 0       0 unless($entry)
2732             {
2733 0         0 warn "No $class data source found for domain '$domain' ",
2734             "and type '$type'";
2735 0         0 next;
2736             }
2737              
2738 0         0 while(my($method, $value) = each(%{$data->{$domain}{$type}}))
  0         0  
2739             {
2740             #$Debug && warn "$class - $domain:$type - $method = $value\n";
2741 0         0 $entry->$method($value);
2742             }
2743             }
2744             }
2745             }
2746             }
2747              
2748             #
2749             # Storable hooks
2750             #
2751              
2752             sub STORABLE_freeze
2753             {
2754 0     0 0 0 my($self, $cloning) = @_;
2755              
2756 0 0       0 return if($cloning);
2757              
2758             # Ditch the DBI $dbh and pull the password out of its closure
2759 0         0 my $db = { %$self };
2760 0         0 $db->{'dbh'} = undef;
2761 0         0 $db->{'password'} = $self->password;
2762 0         0 $db->{'password_closure'} = undef;
2763              
2764 0         0 require Storable;
2765 0         0 return Storable::freeze($db);
2766             }
2767              
2768             sub STORABLE_thaw
2769             {
2770 0     0 0 0 my($self, $cloning, $serialized) = @_;
2771              
2772 0         0 %$self = %{ Storable::thaw($serialized) };
  0         0  
2773              
2774             # Put the password back in a closure
2775 0         0 my $password = delete $self->{'password'};
2776 0 0   0   0 $self->{'password_closure'} = sub { $password } if(defined $password);
  0         0  
2777             }
2778              
2779             #
2780             # This is both a class and an object method
2781             #
2782              
2783             sub error
2784             {
2785 54     54 1 1598 my($self_or_class) = shift;
2786              
2787 54 100       129 if(ref $self_or_class) # Object method
2788             {
2789 48 100       104 if(@_)
2790             {
2791 44         120 return $self_or_class->{'error'} = $Error = shift;
2792             }
2793 4         20 return $self_or_class->{'error'};
2794             }
2795              
2796             # Class method
2797 6 100       21 return $Error = shift if(@_);
2798 4         21 return $Error;
2799             }
2800              
2801             sub DESTROY
2802             {
2803 68     68   71507 $_[0]->disconnect;
2804             }
2805              
2806             BEGIN
2807 0         0 {
2808             package Rose::DateTime::Format::Generic;
2809              
2810 16     16   139 use Rose::Object;
  16         33  
  16         929  
2811 16     16   14496 our @ISA = qw(Rose::Object);
2812              
2813             use Rose::Object::MakeMethods::Generic
2814             (
2815 16         147 scalar => 'server_tz',
2816             boolean => 'european',
2817 16     16   127 );
  16         41  
2818              
2819 0     0     sub format_date { shift; Rose::DateTime::Util::format_date($_[0], '%Y-%m-%d') }
  0            
2820 0     0     sub format_datetime { shift; Rose::DateTime::Util::format_date($_[0], '%Y-%m-%d %T') }
  0            
2821 0     0     sub format_timestamp { shift; Rose::DateTime::Util::format_date($_[0], '%Y-%m-%d %H:%M:%S.%N') }
  0            
2822 0     0     sub format_timestamp_with_time_zone { shift->format_timestamp(@_) }
2823              
2824 0     0     sub parse_date { shift; Rose::DateTime::Util::parse_date($_[0], $_[0]->server_tz) }
  0            
2825 0     0     sub parse_datetime { shift; Rose::DateTime::Util::parse_date($_[0], $_[0]->server_tz) }
  0            
2826 0     0     sub parse_timestamp { shift; Rose::DateTime::Util::parse_date($_[0], $_[0]->server_tz) }
  0            
2827 0     0     sub parse_timestamp_with_time_zone { shift->parse_timestamp(@_) }
2828             }
2829              
2830             1;
2831              
2832             __END__
2833              
2834             =encoding utf8
2835              
2836             =head1 NAME
2837              
2838             Rose::DB - A DBI wrapper and abstraction layer.
2839              
2840             =head1 SYNOPSIS
2841              
2842             package My::DB;
2843              
2844             use Rose::DB;
2845             our @ISA = qw(Rose::DB);
2846              
2847             My::DB->register_db(
2848             domain => 'development',
2849             type => 'main',
2850             driver => 'Pg',
2851             database => 'dev_db',
2852             host => 'localhost',
2853             username => 'devuser',
2854             password => 'mysecret',
2855             server_time_zone => 'UTC',
2856             );
2857              
2858             My::DB->register_db(
2859             domain => 'production',
2860             type => 'main',
2861             driver => 'Pg',
2862             database => 'big_db',
2863             host => 'dbserver.acme.com',
2864             username => 'dbadmin',
2865             password => 'prodsecret',
2866             server_time_zone => 'UTC',
2867             );
2868              
2869             My::DB->default_domain('development');
2870             My::DB->default_type('main');
2871             ...
2872              
2873             $db = My::DB->new;
2874              
2875             my $dbh = $db->dbh or die $db->error;
2876              
2877             $db->begin_work or die $db->error;
2878             $dbh->do(...) or die $db->error;
2879             $db->commit or die $db->error;
2880              
2881             $db->do_transaction(sub
2882             {
2883             $dbh->do(...);
2884             $sth = $dbh->prepare(...);
2885             $sth->execute(...);
2886             while($sth->fetch) { ... }
2887             $dbh->do(...);
2888             })
2889             or die $db->error;
2890              
2891             $dt = $db->parse_timestamp('2001-03-05 12:34:56.123');
2892             $val = $db->format_timestamp($dt);
2893              
2894             $dt = $db->parse_datetime('2001-03-05 12:34:56');
2895             $val = $db->format_datetime($dt);
2896              
2897             $dt = $db->parse_date('2001-03-05');
2898             $val = $db->format_date($dt);
2899              
2900             $bit = $db->parse_bitfield('0x0AF', 32);
2901             $val = $db->format_bitfield($bit);
2902              
2903             ...
2904              
2905             =head1 DESCRIPTION
2906              
2907             L<Rose::DB> is a wrapper and abstraction layer for L<DBI>-related functionality. A L<Rose::DB> object "has a" L<DBI> object; it is not a subclass of L<DBI>.
2908              
2909             Please see the L<tutorial|Rose::DB::Tutorial> (perldoc Rose::DB::Tutorial) for an example usage scenario that reflects "best practices" for this module.
2910              
2911             B<Tip:> Are you looking for an object-relational mapper (ORM)? If so, please see the L<Rose::DB::Object> module. L<Rose::DB::Object> is an ORM that uses this module to manage its database connections. L<Rose::DB> alone is simply a data source abstraction layer; it is not an ORM.
2912              
2913             =head1 DATABASE SUPPORT
2914              
2915             L<Rose::DB> currently supports the following L<DBI> database drivers:
2916              
2917             DBD::Pg (PostgreSQL)
2918             DBD::mysql (MySQL)
2919             DBD::MariaDB (MariaDB)
2920             DBD::SQLite (SQLite)
2921             DBD::Informix (Informix)
2922             DBD::Oracle (Oracle)
2923              
2924             L<Rose::DB> will attempt to service an unsupported database using a L<generic|Rose::DB::Generic> implementation that may or may not work. Support for more drivers may be added in the future. Patches are welcome.
2925              
2926             All database-specific behavior is contained and documented in the subclasses of L<Rose::DB>. L<Rose::DB>'s constructor method (L<new()|/new>) returns a database-specific subclass of L<Rose::DB>, chosen based on the L<driver|/driver> value of the selected L<data source|"Data Source Abstraction">. The default mapping of databases to L<Rose::DB> subclasses is:
2927              
2928             DBD::Pg -> Rose::DB::Pg
2929             DBD::mysql -> Rose::DB::MySQL
2930             DBD::MariaDB -> Rose::DB::MariaDB
2931             DBD::SQLite -> Rose::DB::SQLite
2932             DBD::Informix -> Rose::DB::Informix
2933             DBD::Oracle -> Rose::DB::Oracle
2934              
2935             This mapping can be changed using the L<driver_class|/driver_class> class method.
2936              
2937             The L<Rose::DB> object method documentation found here defines the purpose of each method, as well as the default behavior of the method if it is not overridden by a subclass. You must read the subclass documentation to learn about behaviors that are specific to each type of database.
2938              
2939             Subclasses may also add methods that do not exist in the parent class, of course. This is yet another reason to read the documentation for the subclass that corresponds to your data source's database software.
2940              
2941             =head1 FEATURES
2942              
2943             The basic features of L<Rose::DB> are as follows.
2944              
2945             =head2 Data Source Abstraction
2946              
2947             Instead of dealing with "databases" that exist on "hosts" or are located via some vendor-specific addressing scheme, L<Rose::DB> deals with "logical" data sources. Each logical data source is currently backed by a single "physical" database (basically a single L<DBI> connection).
2948              
2949             Multiplexing, fail-over, and other more complex relationships between logical data sources and physical databases are not part of L<Rose::DB>. Some basic types of fail-over may be added to L<Rose::DB> in the future, but right now the mapping is strictly one-to-one. (I'm also currently inclined to encourage multiplexing functionality to exist in a layer above L<Rose::DB>, rather than within it or in a subclass of it.)
2950              
2951             The driver type of the data source determines the functionality of all methods that do vendor-specific things (e.g., L<column value parsing and formatting|"Vendor-Specific Column Value Parsing and Formatting">).
2952              
2953             L<Rose::DB> identifies data sources using a two-level namespace made of a "domain" and a "type". Both are arbitrary strings. If left unspecified, the default domain and default type (accessible via L<Rose::DB>'s L<default_domain|/default_domain> and L<default_type|/default_type> class methods) are assumed.
2954              
2955             There are many ways to use the two-level namespace, but the most common is to use the domain to represent the current environment (e.g., "development", "staging", "production") and then use the type to identify the logical data source within that environment (e.g., "report", "main", "archive")
2956              
2957             A typical deployment scenario will set the default domain using the L<default_domain|/default_domain> class method as part of the configure/install process. Within application code, L<Rose::DB> objects can be constructed by specifying type alone:
2958              
2959             $main_db = Rose::DB->new(type => 'main');
2960             $archive_db = Rose::DB->new(type => 'archive');
2961              
2962             If there is only one database type, then all L<Rose::DB> objects can be instantiated with a bare constructor call like this:
2963              
2964             $db = Rose::DB->new;
2965              
2966             Again, remember that this is just one of many possible uses of domain and type. Arbitrarily complex scenarios can be created by nesting namespaces within one or both parameters (much like how Perl uses "::" to create a multi-level namespace from single strings).
2967              
2968             The important point is the abstraction of data sources so they can be identified and referred to using a vocabulary that is entirely independent of the actual DSN (data source names) used by L<DBI> behind the scenes.
2969              
2970             =head2 Database Handle Life-Cycle Management
2971              
2972             When a L<Rose::DB> object is destroyed while it contains an active L<DBI> database handle, the handle is explicitly disconnected before destruction. L<Rose::DB> supports a simple retain/release reference-counting system which allows a database handle to out-live its parent L<Rose::DB> object.
2973              
2974             In the simplest case, L<Rose::DB> could be used for its data source abstractions features alone. For example, transiently creating a L<Rose::DB> and then retaining its L<DBI> database handle before it is destroyed:
2975              
2976             $main_dbh = Rose::DB->new(type => 'main')->retain_dbh
2977             or die Rose::DB->error;
2978              
2979             $aux_dbh = Rose::DB->new(type => 'aux')->retain_dbh
2980             or die Rose::DB->error;
2981              
2982             If the database handle was simply extracted via the L<dbh|/dbh> method instead of retained with L<retain_dbh|/retain_dbh>, it would be disconnected by the time the statement completed.
2983              
2984             # WRONG: $dbh will be disconnected immediately after the assignment!
2985             $dbh = Rose::DB->new(type => 'main')->dbh or die Rose::DB->error;
2986              
2987             =head2 Vendor-Specific Column Value Parsing and Formatting
2988              
2989             Certain semantically identical column types are handled differently in different databases. Date and time columns are good examples. Although many databases store month, day, year, hours, minutes, and seconds using a "datetime" column type, there will likely be significant differences in how each of those databases expects to receive such values, and how they're returned.
2990              
2991             L<Rose::DB> is responsible for converting the wide range of vendor-specific column values for a particular column type into a single form that is convenient for use within Perl code. L<Rose::DB> also handles the opposite task, taking input from the Perl side and converting it into the appropriate format for a specific database. Not all column types that exist in the supported databases are handled by L<Rose::DB>, but support will expand in the future.
2992              
2993             Many column types are specific to a single database and do not exist elsewhere. When it is reasonable to do so, vendor-specific column types may be "emulated" by L<Rose::DB> for the benefit of other databases. For example, an ARRAY value may be stored as a specially formatted string in a VARCHAR field in a database that does not have a native ARRAY column type.
2994              
2995             L<Rose::DB> does B<NOT> attempt to present a unified column type system, however. If a column type does not exist in a particular kind of database, there should be no expectation that L<Rose::DB> will be able to parse and format that value type on behalf of that database.
2996              
2997             =head2 High-Level Transaction Support
2998              
2999             Transactions may be started, committed, and rolled back in a variety of ways using the L<DBI> database handle directly. L<Rose::DB> provides wrappers to do the same things, but with different error handling and return values. There's also a method (L<do_transaction|/do_transaction>) that will execute arbitrary code within a single transaction, automatically handling rollback on failure and commit on success.
3000              
3001             =head1 SUBCLASSING
3002              
3003             Subclassing is B<strongly encouraged> and generally works as expected. (See the L<tutorial|Rose::DB::Tutorial> for a complete example.) There is, however, the question of how class data is shared with subclasses. Here's how it works for the various pieces of class data.
3004              
3005             =over
3006              
3007             =item B<alias_db>, B<modify_db>, B<register_db>, B<unregister_db>, B<unregister_domain>
3008              
3009             By default, all subclasses share the same data source "registry" with L<Rose::DB>. To provide a private registry for your subclass (the recommended approach), see the example in the documentation for the L<registry|/registry> method below.
3010              
3011             =item B<default_domain>, B<default_type>
3012              
3013             If called with no arguments, and if the attribute was never set for this
3014             class, then a left-most, breadth-first search of the parent classes is
3015             initiated. The value returned is taken from first parent class
3016             encountered that has ever had this attribute set.
3017              
3018             (These attributes use the L<inheritable_scalar|Rose::Class::MakeMethods::Generic/inheritable_scalar> method type as defined in L<Rose::Class::MakeMethods::Generic>.)
3019              
3020             =item B<driver_class, default_connect_options>
3021              
3022             These hashes of attributes are inherited by subclasses using a one-time, shallow copy from a superclass. Any subclass that accesses or manipulates the hash in any way will immediately get its own private copy of the hash I<as it exists in the superclass at the time of the access or manipulation>.
3023              
3024             The superclass from which the hash is copied is the closest ("least super") class that has ever accessed or manipulated this hash. The copy is a "shallow" copy, duplicating only the keys and values. Reference values are not recursively copied.
3025              
3026             Setting to hash to undef (using the 'reset' interface) will cause it to be re-copied from a superclass the next time it is accessed.
3027              
3028             (These attributes use the L<inheritable_hash|Rose::Class::MakeMethods::Generic/inheritable_hash> method type as defined in L<Rose::Class::MakeMethods::Generic>.)
3029              
3030             =back
3031              
3032             =head1 SERIALIZATION
3033              
3034             A L<Rose::DB> object may contain a L<DBI> database handle, and L<DBI> database handles usually don't survive the serialize process intact. L<Rose::DB> objects also hide database passwords inside closures, which also don't serialize well. In order for a L<Rose::DB> object to survive serialization, custom hooks are required.
3035              
3036             L<Rose::DB> has hooks for the L<Storable> serialization module, but there is an important caveat. Since L<Rose::DB> objects are blessed into a dynamically generated class (derived from the L<driver class|/driver_class>), you must load your L<Rose::DB>-derived class with all its registered data sources before you can successfully L<thaw|Storable/thaw> a L<frozen|Storable/freeze> L<Rose::DB>-derived object. Here's an example.
3037              
3038             Imagine that this is your L<Rose::DB>-derived class:
3039              
3040             package My::DB;
3041              
3042             use Rose::DB;
3043             our @ISA = qw(Rose::DB);
3044              
3045             My::DB->register_db(
3046             domain => 'dev',
3047             type => 'main',
3048             driver => 'Pg',
3049             ...
3050             );
3051              
3052             My::DB->register_db(
3053             domain => 'prod',
3054             type => 'main',
3055             driver => 'Pg',
3056             ...
3057             );
3058              
3059             My::DB->default_domain('dev');
3060             My::DB->default_type('main');
3061              
3062             In one program, a C<My::DB> object is L<frozen|Storable/freeze> using L<Storable>:
3063              
3064             # my_freeze_script.pl
3065              
3066             use My::DB;
3067             use Storable qw(nstore);
3068              
3069             # Create My::DB object
3070             $db = My::DB->new(domain => 'dev', type => 'main');
3071              
3072             # Do work...
3073             $db->dbh->db('CREATE TABLE some_table (...)');
3074             ...
3075              
3076             # Serialize $db and store it in frozen_data_file
3077             nstore($db, 'frozen_data_file');
3078              
3079             Now another program wants to L<thaw|Storable/thaw> out that C<My::DB> object and use it. To do so, it must be sure to load the L<My::DB> module (which registers all its data sources when loaded) I<before> attempting to deserialize the C<My::DB> object serialized by C<my_freeze_script.pl>.
3080              
3081             # my_thaw_script.pl
3082              
3083             # IMPORTANT: load db modules with all data sources registered before
3084             # attempting to deserialize objects of this class.
3085             use My::DB;
3086              
3087             use Storable qw(retrieve);
3088              
3089             # Retrieve frozen My::DB object from frozen_data_file
3090             $db = retrieve('frozen_data_file');
3091              
3092             # Do work...
3093             $db->dbh->db('DROP TABLE some_table');
3094             ...
3095              
3096             Note that this rule about loading a L<Rose::DB>-derived class with all its data sources registered prior to deserializing such an object only applies if the serialization was done in a different process. If you L<freeze|Storable/freeze> and L<thaw|Storable/thaw> within the same process, you don't have to worry about it.
3097              
3098             =head1 ENVIRONMENT
3099              
3100             There are two ways to alter the initial L<Rose::DB> data source registry.
3101              
3102             =over 4
3103              
3104             =item * The ROSEDB_DEVINIT file or module, which can add, modify, or remove data sources and alter the default L<domain|Rose::DB/domain> and L<type|Rose::DB/type>.
3105              
3106             =item * The ROSEDBRC file, which can modify existing data sources.
3107              
3108             =back
3109              
3110             =head2 ROSEDB_DEVINIT
3111              
3112             The C<ROSEDB_DEVINIT> file or module is used during development, usually to set up data sources for a particular developer's database or project. If the C<ROSEDB_DEVINIT> environment variable is set, it should be the name of a Perl module or file. If it is a Perl module and that module has a C<fixup()> subroutine, it will be called as a class method after the module is loaded.
3113              
3114             If the C<ROSEDB_DEVINIT> environment variable is not set, or if the specified file does not exist or has errors, then it defaults to the package name C<Rose::DB::Devel::Init::username>, where "username" is the account name of the current user.
3115              
3116             B<Note:> if the L<getpwuid()|perlfunc/getpwuid> function is unavailable (as is often the case on Windows versions of perl) then this default does not apply and the loading of the module named C<Rose::DB::Devel::Init::username> is not attempted.
3117              
3118             The C<ROSEDB_DEVINIT> file or module may contain arbitrary Perl code which will be loaded and evaluated in the context of L<Rose::DB>. Example:
3119              
3120             Rose::DB->default_domain('development');
3121              
3122             Rose::DB->modify_db(domain => 'development',
3123             type => 'main_db',
3124             database => 'main',
3125             username => 'jdoe',
3126             password => 'mysecret');
3127              
3128             1;
3129              
3130             Remember to end the file with a true value.
3131              
3132             The C<ROSEDB_DEVINIT> file or module must be read explicitly by calling the L<auto_load_fixups|/auto_load_fixups> class method.
3133              
3134             =head2 ROSEDBRC
3135              
3136             The C<ROSEDBRC> file contains configuration "fix-up" information. This file is most often used to dynamically set passwords that are too sensitive to be included directly in the source code of a L<Rose::DB>-derived class.
3137              
3138             The path to the fix-up file is determined by the C<ROSEDBRC> environment variable. If this variable is not set, or if the file it points to does not exist, then it defaults to C</etc/rosedbrc>.
3139              
3140             This file should be in YAML format. To read this file, you must have either L<YAML::Syck> or some reasonably modern version of L<YAML> installed (0.66 or later recommended). L<YAML::Syck> will be preferred if both are installed.
3141              
3142             The C<ROSEDBRC> file's contents have the following structure:
3143              
3144             ---
3145             somedomain:
3146             sometype:
3147             somemethod: somevalue
3148             ---
3149             otherdomain:
3150             othertype:
3151             othermethod: othervalue
3152              
3153             Each entry modifies an existing registered data source. Any valid L<registry entry|Rose::DB::Registry::Entry> object method can be used (in place of "somemethod" and "othermethod" in the YAML example above).
3154              
3155             This file must be read explicitly by calling the L<auto_load_fixups|/auto_load_fixups> class method I<after> setting up all your data sources. Example:
3156              
3157             package My::DB;
3158              
3159             use Rose::DB;
3160             our @ISA = qw(Rose::DB);
3161              
3162             __PACKAGE__->use_private_registry;
3163              
3164             # Register all data sources
3165             __PACKAGE__->register_db(
3166             domain => 'development',
3167             type => 'main',
3168             driver => 'Pg',
3169             database => 'dev_db',
3170             host => 'localhost',
3171             username => 'devuser',
3172             password => 'mysecret',
3173             );
3174              
3175             ...
3176              
3177             # Load fix-up files, if any
3178             __PACKAGE__->auto_load_fixups;
3179              
3180             =head1 CLASS METHODS
3181              
3182             =over 4
3183              
3184             =item B<alias_db PARAMS>
3185              
3186             Make one data source an alias for another by pointing them both to the same registry entry. PARAMS are name/value pairs that must include domain and type values for both the source and alias parameters. Example:
3187              
3188             Rose::DB->alias_db(source => { domain => 'dev', type => 'main' },
3189             alias => { domain => 'dev', type => 'aux' });
3190              
3191             This makes the "dev/aux" data source point to the same registry entry as the "dev/main" data source. Modifications to either registry entry (via L<modify_db|/modify_db>) will be reflected in both.
3192              
3193             =item B<auto_load_fixups>
3194              
3195             Attempt to load both the YAML-based L<ROSEDBRC|/ROSEDBRC> and Perl-based L<ROSEDB_DEVINIT|/ROSEDB_DEVINIT> fix-up files, if any exist, in that order. The L<ROSEDBRC|/ROSEDBRC> file will modify the data source L<registry|/registry> of the calling class. See the L<ENVIRONMENT|/ENVIRONMENT> section above for more information.
3196              
3197             =item B<db_cache [CACHE]>
3198              
3199             Get or set the L<Rose::DB::Cache>-derived object used to cache L<Rose::DB> objects on behalf of this class. If no such object exists, a new cache object of L<db_cache_class|/db_cache_class> class will be created, stored, and returned.
3200              
3201             =item B<db_cache_class [CLASS]>
3202              
3203             Get or set the name of the L<Rose::DB::Cache>-derived class used to cache L<Rose::DB> objects on behalf of this class. The default value is L<Rose::DB::Cache>.
3204              
3205             =item B<db_exists PARAMS>
3206              
3207             Returns true of the data source specified by PARAMS is registered, false otherwise. PARAMS are name/value pairs for C<domain> and C<type>. If they are omitted, they default to L<default_domain|/default_domain> and L<default_type|/default_type>, respectively. If default values do not exist, a fatal error will occur. If a single value is passed instead of name/value pairs, it is taken as the value of the C<type> parameter.
3208              
3209             =item B<default_connect_options [HASHREF | PAIRS]>
3210              
3211             Get or set the default L<DBI> connect options hash. If a reference to a hash is passed, it replaces the default connect options hash. If a series of name/value pairs are passed, they are added to the default connect options hash.
3212              
3213             The default set of default connect options is:
3214              
3215             AutoCommit => 1,
3216             RaiseError => 1,
3217             PrintError => 1,
3218             ChopBlanks => 1,
3219             Warn => 0,
3220              
3221             See the L<connect_options|/connect_options> object method for more information on how the default connect options are used.
3222              
3223             =item B<default_domain [DOMAIN]>
3224              
3225             Get or set the default data source domain. See the L<"Data Source Abstraction"> section for more information on data source domains.
3226              
3227             =item B<default_type [TYPE]>
3228              
3229             Get or set the default data source type. See the L<"Data Source Abstraction"> section for more information on data source types.
3230              
3231             =item B<driver_class DRIVER [, CLASS]>
3232              
3233             Get or set the subclass used for DRIVER. The DRIVER argument is automatically converted to lowercase. (Driver names are effectively case-insensitive.)
3234              
3235             $class = Rose::DB->driver_class('Pg'); # get
3236             Rose::DB->driver_class('pg' => 'MyDB::Pg'); # set
3237              
3238             The default mapping of driver names to class names is as follows:
3239              
3240             mysql -> Rose::DB::MySQL
3241             mariadb -> Rose::DB::MariaDB
3242             pg -> Rose::DB::Pg
3243             informix -> Rose::DB::Informix
3244             sqlite -> Rose::DB::SQLite
3245             oracle -> Rose::DB::Oracle
3246             generic -> Rose::DB::Generic
3247              
3248             The class mapped to the special driver name "generic" will be used for any driver name that does not have an entry in the map.
3249              
3250             See the documentation for the L<new|/new> method for more information on how the driver influences the class of objects returned by the constructor.
3251              
3252             =item B<default_keyword_function_calls [BOOL]>
3253              
3254             Get or set a boolean default value for the L<keyword_function_calls|/keyword_function_calls> object attribute. Defaults to the value of the C<ROSE_DB_KEYWORD_FUNCTION_CALLS> environment variable, it set to a defined value, or false otherwise.
3255              
3256             =item B<modify_db PARAMS>
3257              
3258             Modify a data source, setting the attributes specified in PARAMS, where
3259             PARAMS are name/value pairs. Any L<Rose::DB> object method that sets a L<data source configuration value|"Data Source Configuration"> is a valid parameter name.
3260              
3261             # Set new username for data source identified by domain and type
3262             Rose::DB->modify_db(domain => 'test',
3263             type => 'main',
3264             username => 'tester');
3265              
3266             PARAMS should include values for both the C<type> and C<domain> parameters since these two attributes are used to identify the data source. If they are omitted, they default to L<default_domain|/default_domain> and L<default_type|/default_type>, respectively. If default values do not exist, a fatal error will occur. If there is no data source defined for the specified C<type> and C<domain>, a fatal error will occur.
3267              
3268             =item B<prepare_cache_for_apache_fork>
3269              
3270             This is a convenience method that is equivalent to the following call:
3271              
3272             Rose::DB->db_cache->prepare_for_apache_fork()
3273              
3274             Any arguments passed to this method are passed on to the call to the L<db_cache|/db_cache>'s L<prepare_for_apache_fork|Rose::DB::Cache/prepare_for_apache_fork> method.
3275              
3276             Please read the L<Rose::DB::Cache> documentation, particularly the documentation for the L<use_cache_during_apache_startup|Rose::DB::Cache/use_cache_during_apache_startup> method for more information.
3277              
3278             =item B<register_db PARAMS>
3279              
3280             Registers a new data source with the attributes specified in PARAMS, where
3281             PARAMS are name/value pairs. Any L<Rose::DB> object method that sets a L<data source configuration value|"Data Source Configuration"> is a valid parameter name.
3282              
3283             PARAMS B<must> include a value for the C<driver> parameter. If the C<type> or C<domain> parameters are omitted or undefined, they default to the return values of the L<default_type|/default_type> and L<default_domain|/default_domain> class methods, respectively.
3284              
3285             The C<type> and C<domain> are used to identify the data source. If either one is missing, a fatal error will occur. See the L<"Data Source Abstraction"> section for more information on data source types and domains.
3286              
3287             The C<driver> is used to determine which class objects will be blessed into by the L<Rose::DB> constructor, L<new|/new>. The driver name is automatically converted to lowercase. If it is missing, a fatal error will occur.
3288              
3289             In most deployment scenarios, L<register_db|/register_db> is called early in the compilation process to ensure that the registered data sources are available when the "real" code runs.
3290              
3291             Database registration can be included directly in your L<Rose::DB> subclass. This is the recommended approach. Example:
3292              
3293             package My::DB;
3294              
3295             use Rose::DB;
3296             our @ISA = qw(Rose::DB);
3297              
3298             # Use a private registry for this class
3299             __PACKAGE__->use_private_registry;
3300              
3301             # Register data sources
3302             My::DB->register_db(
3303             domain => 'development',
3304             type => 'main',
3305             driver => 'Pg',
3306             database => 'dev_db',
3307             host => 'localhost',
3308             username => 'devuser',
3309             password => 'mysecret',
3310             );
3311              
3312             My::DB->register_db(
3313             domain => 'production',
3314             type => 'main',
3315             driver => 'Pg',
3316             database => 'big_db',
3317             host => 'dbserver.acme.com',
3318             username => 'dbadmin',
3319             password => 'prodsecret',
3320             );
3321             ...
3322              
3323             Another possible approach is to consolidate data source registration in a single module which is then C<use>ed early on in the code path. For example, imagine a mod_perl web server environment:
3324              
3325             # File: MyCorp/DataSources.pm
3326             package MyCorp::DataSources;
3327              
3328             My::DB->register_db(
3329             domain => 'development',
3330             type => 'main',
3331             driver => 'Pg',
3332             database => 'dev_db',
3333             host => 'localhost',
3334             username => 'devuser',
3335             password => 'mysecret',
3336             );
3337              
3338             My::DB->register_db(
3339             domain => 'production',
3340             type => 'main',
3341             driver => 'Pg',
3342             database => 'big_db',
3343             host => 'dbserver.acme.com',
3344             username => 'dbadmin',
3345             password => 'prodsecret',
3346             );
3347             ...
3348              
3349             # File: /usr/local/apache/conf/startup.pl
3350              
3351             use My::DB; # your Rose::DB subclass
3352             use MyCorp::DataSources; # register all data sources
3353             ...
3354              
3355             Data source registration can happen at any time, of course, but it is most useful when all application code can simply assume that all the data sources are already registered. Doing the registration as early as possible (e.g., directly in your L<Rose::DB> subclass, or in a C<startup.pl> file that is loaded from an apache/mod_perl web server's C<httpd.conf> file) is the best way to create such an environment.
3356              
3357             Note that the data source registry serves as an I<initial> source of information for L<Rose::DB> objects. Once an object is instantiated, it is independent of the registry. Changes to an object are not reflected in the registry, and changes to the registry are not reflected in existing objects.
3358              
3359             =item B<registry [REGISTRY]>
3360              
3361             Get or set the L<Rose::DB::Registry>-derived object that manages and stores the data source registry. It defaults to an "empty" L<Rose::DB::Registry> object. Remember that setting a new registry will replace the existing registry and all the data sources registered in it.
3362              
3363             Note that L<Rose::DB> subclasses will inherit the base class's L<Rose::DB::Registry> object and will therefore inherit all existing registry entries and share the same registry namespace as the base class. This may or may not be what you want.
3364              
3365             In most cases, it's wise to give your subclass its own private registry if it inherits directly from L<Rose::DB>. To do that, just set a new registry object in your subclass. Example:
3366              
3367             package My::DB;
3368              
3369             use Rose::DB;
3370             our @ISA = qw(Rose::DB);
3371              
3372             # Create a private registry for this class:
3373             #
3374             # either explicitly:
3375             # use Rose::DB::Registry;
3376             # __PACKAGE__->registry(Rose::DB::Registry->new);
3377             #
3378             # or use the convenience method:
3379             __PACKAGE__->use_private_registry;
3380             ...
3381              
3382             Further subclasses of C<My::DB> may then inherit its registry object, if desired, or may create their own private registries in the manner shown above.
3383              
3384             =item B<unregister_db PARAMS>
3385              
3386             Unregisters the data source having the C<type> and C<domain> specified in PARAMS, where PARAMS are name/value pairs. Returns true if the data source was unregistered successfully, false if it did not exist in the first place. Example:
3387              
3388             Rose::DB->unregister_db(type => 'main', domain => 'test');
3389              
3390             PARAMS B<must> include values for both the C<type> and C<domain> parameters since these two attributes are used to identify the data source. If either one is missing, a fatal error will occur.
3391              
3392             Unregistering a data source removes all knowledge of it. This may be harmful to any existing L<Rose::DB> objects that are associated with that data source.
3393              
3394             =item B<unregister_domain DOMAIN>
3395              
3396             Unregisters an entire domain. Returns true if the domain was unregistered successfully, false if it did not exist in the first place. Example:
3397              
3398             Rose::DB->unregister_domain('test');
3399              
3400             Unregistering a domain removes all knowledge of all of the data sources that existed under it. This may be harmful to any existing L<Rose::DB> objects that are associated with any of those data sources.
3401              
3402             =item B<use_cache_during_apache_startup [BOOL]>
3403              
3404             This is a convenience method that is equivalent to the following call:
3405              
3406             Rose::DB->db_cache->use_cache_during_apache_startup(...)
3407              
3408             The boolean argument passed to this method is passed on to the call to the L<db_cache|/db_cache>'s L<use_cache_during_apache_startup|Rose::DB::Cache/use_cache_during_apache_startup> method.
3409              
3410             Please read the L<Rose::DB::Cache>'s L<use_cache_during_apache_startup|Rose::DB::Cache/use_cache_during_apache_startup> documentation for more information.
3411              
3412             =item B<use_private_registry>
3413              
3414             This method is used to give a class its own private L<registry|/registry>. In other words, this:
3415              
3416             __PACKAGE__->use_private_registry;
3417              
3418             is roughly equivalent to this:
3419              
3420             use Rose::DB::Registry;
3421             __PACKAGE__->registry(Rose::DB::Registry->new);
3422              
3423             =back
3424              
3425             =head1 CONSTRUCTORS
3426              
3427             =over 4
3428              
3429             =item B<new PARAMS>
3430              
3431             Constructs a new object based on PARAMS, where PARAMS are
3432             name/value pairs. Any object method is a valid parameter name. Example:
3433              
3434             $db = Rose::DB->new(type => 'main', domain => 'qa');
3435              
3436             If a single argument is passed to L<new|/new>, it is used as the C<type> value:
3437              
3438             $db = Rose::DB->new(type => 'aux');
3439             $db = Rose::DB->new('aux'); # same thing
3440              
3441             Each L<Rose::DB> object is associated with a particular data source, defined by the L<type|/type> and L<domain|/domain> values. If these are not part of PARAMS, then the default values are used. If you do not want to use the default values for the L<type|/type> and L<domain|/domain> attributes, you should specify them in the constructor PARAMS.
3442              
3443             The default L<type|/type> and L<domain|/domain> can be set using the L<default_type|/default_type> and L<default_domain|/default_domain> class methods. See the L<"Data Source Abstraction"> section for more information on data sources.
3444              
3445             Object attributes are set based on the L<registry|/registry> entry specified by the C<type> and C<domain> parameters. This registry entry must exist or a fatal error will occur (with one exception; see below). Any additional PARAMS will override the values taken from the registry entry.
3446              
3447             If C<type> and C<domain> parameters are not passed, but a C<driver> parameter is passed, then a new "empty" object will be returned. Examples:
3448              
3449             # This is ok, even if no registered data sources exist
3450             $db = Rose::DB->new(driver => 'sqlite');
3451              
3452             The object returned by L<new|/new> will be derived from a database-specific driver class, chosen based on the L<driver|/driver> value of the selected data source. If there is no registered data source for the specified L<type|/type> and L<domain|/domain>, a fatal error will occur.
3453              
3454             The default driver-to-class mapping is as follows:
3455              
3456             pg -> Rose::DB::Pg
3457             mysql -> Rose::DB::MySQL
3458             mariadb -> Rose::DB::MariaDB
3459             informix -> Rose::DB::Informix
3460             oracle -> Rose::DB::Oracle
3461             sqlite -> Rose::DB::SQLite
3462              
3463             You can change this mapping with the L<driver_class|/driver_class> class method.
3464              
3465             =item B<new_or_cached PARAMS>
3466              
3467             Constructs or returns a L<Rose::DB> object based on PARAMS, where PARAMS are any name/value pairs that can be passed to the L<new|/new> method. If the L<db_cache|/db_cache>'s L<get_db|Rose::DB::Cache/get_db> method returns an existing L<Rose::DB> object that matches PARAMS, then it is returned. Otherwise, a L<new|/new> L<Rose::DB> object is created, L<stored|Rose::DB::Cache/set_db> in the L<db_cache|/db_cache>, then returned.
3468              
3469             See the L<Rose::DB::Cache> documentation to learn about the cache API and the default implementation.
3470              
3471             =back
3472              
3473             =head1 OBJECT METHODS
3474              
3475             =over 4
3476              
3477             =item B<begin_work>
3478              
3479             Attempt to start a transaction by calling the L<begin_work|DBI/begin_work> method on the L<DBI> database handle.
3480              
3481             If necessary, the database handle will be constructed and connected to the current data source. If this fails, undef is returned. If there is no registered data source for the current C<type> and C<domain>, a fatal error will occur.
3482              
3483             If the "AutoCommit" database handle attribute is false, the handle is assumed to already be in a transaction and L<Rose::DB::Constants::IN_TRANSACTION|Rose::DB::Constants> (-1) is returned. If the call to L<DBI>'s L<begin_work|DBI/begin_work> method succeeds, 1 is returned. If it fails, undef is returned.
3484              
3485             =item B<commit>
3486              
3487             Attempt to commit the current transaction by calling the L<commit|DBI/commit> method on the L<DBI> database handle. If the L<DBI> database handle does not exist or is not connected, 0 is returned.
3488              
3489             If the "AutoCommit" database handle attribute is true, the handle is assumed to not be in a transaction and L<Rose::DB::Constants::IN_TRANSACTION|Rose::DB::Constants> (-1) is returned. If the call to L<DBI>'s L<commit|DBI/commit> method succeeds, 1 is returned. If it fails, undef is returned.
3490              
3491             =item B<connect>
3492              
3493             Constructs and connects the L<DBI> database handle for the current data source, calling L<dbi_connect|/dbi_connect> to create a new L<DBI> database handle if none exists. If there is no registered data source for the current L<type|/type> and L<domain|/domain>, a fatal error will occur.
3494              
3495             If any L<post_connect_sql|/post_connect_sql> statement failed to execute, the database handle is disconnected and then discarded.
3496              
3497             If the database handle returned by L<dbi_connect|/dbi_connect> was originally connected by another L<Rose::DB>-derived object (e.g., if a subclass's custom implementation of L<dbi_connect|/dbi_connect> calls L<DBI>'s L<connect_cached|DBI/connect_cached> method) then the L<post_connect_sql|/post_connect_sql> statements will not be run, nor will any custom L<DBI> attributes be applied (e.g., L<Rose::DB::MySQL>'s L<mysql_enable_utf8|Rose::DB::MySQL/mysql_enable_utf8> attribute).
3498              
3499             Returns true if the database handle was connected successfully and all L<post_connect_sql|/post_connect_sql> statements (if any) were run successfully, false otherwise.
3500              
3501             =item B<connect_option NAME [, VALUE]>
3502              
3503             Get or set a single connection option. Example:
3504              
3505             $val = $db->connect_option('RaiseError'); # get
3506             $db->connect_option(AutoCommit => 1); # set
3507              
3508             Connection options are name/value pairs that are passed in a hash reference as the fourth argument to the call to L<DBI-E<gt>connect()|DBI/connect>. See the L<DBI> documentation for descriptions of the various options.
3509              
3510             =item B<connect_options [HASHREF | PAIRS]>
3511              
3512             Get or set the L<DBI> connect options hash. If a reference to a hash is passed, it replaces the connect options hash. If a series of name/value pairs are passed, they are added to the connect options hash.
3513              
3514             Returns a reference to the connect options has in scalar context, or a list of name/value pairs in list context.
3515              
3516             =item B<dbh [DBH]>
3517              
3518             Get or set the L<DBI> database handle connected to the current data source. If the database handle does not exist or was created in another process or thread, this method will discard the old database handle (if any) and L<dbi_connect|/dbi_connect> will be called to create a new one.
3519              
3520             Returns undef if the database handle could not be constructed and connected. If there is no registered data source for the current C<type> and C<domain>, a fatal error will occur.
3521              
3522             Note: when setting this attribute, you I<must> pass in a L<DBI> database handle that has the same L<driver|/driver> as the object. For example, if the L<driver|/driver> is C<mysql> then the L<DBI> database handle must be connected to a MySQL database. Passing in a mismatched database handle will cause a fatal error.
3523              
3524             =item B<dbi_connect [ARGS]>
3525              
3526             This method calls L<DBI-E<gt>connect(...)|DBI/connect>, passing all ARGS and returning all values. This method has no affect on the internal state of the object. Use the L<connect|/connect> method to create and store a new L<database handle|/dbh> in the object.
3527              
3528             Override this method in your L<Rose::DB> subclass if you want to use a different method (e.g. L<DBI-E<gt>connect_cached()|DBI/connect_cached>) to create database handles.
3529              
3530             =item B<disconnect>
3531              
3532             Decrements the reference count for the database handle and disconnects it if the reference count is zero and if the database handle was originally connected by this object. (This may not be the case if, say, a subclass's custom implementation of L<dbi_connect|/dbi_connect> calls L<DBI>'s L<connect_cached|DBI/connect_cached> method.) Regardless of the reference count, it sets the L<dbh|/dbh> attribute to undef.
3533              
3534             Returns true if all L<pre_disconnect_sql|/pre_disconnect_sql> statements (if any) were run successfully and the database handle was disconnected successfully (or if it was simply set to undef), false otherwise.
3535              
3536             The database handle will not be disconnected if any L<pre_disconnect_sql|/pre_disconnect_sql> statement fails to execute, and the L<pre_disconnect_sql|/pre_disconnect_sql> is not run unless the handle is going to be disconnected.
3537              
3538             =item B<do_transaction CODE [, ARGS]>
3539              
3540             Execute arbitrary code within a single transaction, rolling back if any of the code fails, committing if it succeeds. CODE should be a code reference. It will be called with any arguments passed to L<do_transaction|/do_transaction> after the code reference. Example:
3541              
3542             # Transfer $100 from account id 5 to account id 9
3543             $db->do_transaction(sub
3544             {
3545             my($amt, $id1, $id2) = @_;
3546              
3547             my $dbh = $db->dbh or die $db->error;
3548              
3549             # Transfer $amt from account id $id1 to account id $id2
3550             $dbh->do("UPDATE acct SET bal = bal - $amt WHERE id = $id1");
3551             $dbh->do("UPDATE acct SET bal = bal + $amt WHERE id = $id2");
3552             },
3553             100, 5, 9) or warn "Transfer failed: ", $db->error;
3554              
3555             If the CODE block threw an exception or the transaction could not be started and committed successfully, then undef is returned and the exception thrown is available in the L<error|/error> attribute. Otherwise, a true value is returned.
3556              
3557             =item B<error [MSG]>
3558              
3559             Get or set the error message associated with the last failure. If a method fails, check this attribute to get the reason for the failure in the form of a text message.
3560              
3561             =item B<has_dbh>
3562              
3563             Returns true if the object has a L<DBI> database handle (L<dbh|/dbh>), false if it does not.
3564              
3565             =item B<has_primary_key [ TABLE | PARAMS ]>
3566              
3567             Returns true if the specified table has a primary key (as determined by the L<primary_key_column_names|/primary_key_column_names> method), false otherwise.
3568              
3569             The arguments are the same as those for the L<primary_key_column_names|/primary_key_column_names> method: either a table name or name/value pairs specifying C<table>, C<catalog>, and C<schema>. The C<catalog> and C<schema> parameters are optional and default to the return values of the L<catalog|/catalog> and L<schema|/schema> methods, respectively. See the documentation for the L<primary_key_column_names|/primary_key_column_names> for more information.
3570              
3571             =item B<in_transaction>
3572              
3573             Return true if the L<dbh|/dbh> is currently in the middle of a transaction, false (but defined) if it is not. If no L<dbh|/dbh> exists, then undef is returned.
3574              
3575             =item B<init_db_info>
3576              
3577             Initialize data source configuration information based on the current values of the L<type|/type> and L<domain|/domain> attributes by pulling data from the corresponding registry entry. If there is no registered data source for the current L<type|/type> and L<domain|/domain>, a fatal error will occur. L<init_db_info|/init_db_info> is called as part of the L<new|/new> and L<connect|/connect> methods.
3578              
3579             =item B<insertid_param>
3580              
3581             Returns the name of the L<DBI> statement handle attribute that contains the auto-generated unique key created during the last insert operation. Returns undef if the current data source does not support this attribute.
3582              
3583             =item B<keyword_function_calls [BOOL]>
3584              
3585             Get or set a boolean value that indicates whether or not any string that looks like a function call (matches C</^\w+\(.*\)$/>) will be treated as a "keyword" by the various L<format_*|/"Vendor-Specific Column Value Parsing and Formatting"> methods. Defaults to the value returned by the L<default_keyword_function_calls|/default_keyword_function_calls> class method.
3586              
3587             =item B<last_insertid_from_sth STH>
3588              
3589             Given a L<DBI> statement handle, returns the value of the auto-generated unique key created during the last insert operation. This value may be undefined if this feature is not supported by the current data source.
3590              
3591             =item B<list_tables>
3592              
3593             Returns a list (in list context) or reference to an array (in scalar context) of tables in the database. The current L<catalog|/catalog> and L<schema|/schema> are honored.
3594              
3595             =item B<quote_column_name NAME>
3596              
3597             Returns the column name NAME appropriately quoted for use in an SQL statement. (Note that "appropriate" quoting may mean no quoting at all.)
3598              
3599             =item B<release_dbh>
3600              
3601             Decrements the reference count for the L<DBI> database handle, if it exists. Returns 0 if the database handle does not exist.
3602              
3603             If the reference count drops to zero, the database handle is disconnected. Keep in mind that the L<Rose::DB> object itself will increment the reference count when the database handle is connected, and decrement it when L<disconnect|/disconnect> is called.
3604              
3605             Returns true if the reference count is not 0 or if all L<pre_disconnect_sql|/pre_disconnect_sql> statements (if any) were run successfully and the database handle was disconnected successfully, false otherwise.
3606              
3607             The database handle will not be disconnected if any L<pre_disconnect_sql|/pre_disconnect_sql> statement fails to execute, and the L<pre_disconnect_sql|/pre_disconnect_sql> is not run unless the handle is going to be disconnected.
3608              
3609             See the L<"Database Handle Life-Cycle Management"> section for more information on the retain/release system.
3610              
3611             =item B<retain_dbh>
3612              
3613             Returns the connected L<DBI> database handle after incrementing the reference count. If the database handle does not exist or is not already connected, this method will do everything necessary to do so.
3614              
3615             Returns undef if the database handle could not be constructed and connected. If there is no registered data source for the current L<type|/type> and L<domain|/domain>, a fatal error will occur.
3616              
3617             See the L<"Database Handle Life-Cycle Management"> section for more information on the retain/release system.
3618              
3619             =item B<rollback>
3620              
3621             Roll back the current transaction by calling the L<rollback|DBI/rollback> method on the L<DBI> database handle. If the L<DBI> database handle does not exist or is not connected, 0 is returned.
3622              
3623             If the call to L<DBI>'s L<rollback|DBI/rollback> method succeeds or if auto-commit is enabled, 1 is returned. If it fails, undef is returned.
3624              
3625             =back
3626              
3627             =head2 Data Source Configuration
3628              
3629             Not all databases will use all of these values. Values that are not supported are simply ignored.
3630              
3631             =over 4
3632              
3633             =item B<autocommit [VALUE]>
3634              
3635             Get or set the value of the "AutoCommit" connect option and L<DBI> handle attribute. If a VALUE is passed, it will be set in both the connect options hash and the current database handle, if any. Returns the value of the "AutoCommit" attribute of the database handle if it exists, or the connect option otherwise.
3636              
3637             This method should not be mixed with the L<connect_options|/connect_options> method in calls to L<register_db|/register_db> or L<modify_db|/modify_db> since L<connect_options|/connect_options> will overwrite I<all> the connect options with its argument, and neither L<register_db|/register_db> nor L<modify_db|/modify_db> guarantee the order that its parameters will be evaluated.
3638              
3639             =item B<catalog [CATALOG]>
3640              
3641             Get or set the database catalog name. This setting is only relevant to databases that support the concept of catalogs.
3642              
3643             =item B<connect_options [HASHREF | PAIRS]>
3644              
3645             Get or set the options passed in a hash reference as the fourth argument to the call to L<DBI-E<gt>connect()|DBI/connect>. See the L<DBI> documentation for descriptions of the various options.
3646              
3647             If a reference to a hash is passed, it replaces the connect options hash. If a series of name/value pairs are passed, they are added to the connect options hash.
3648              
3649             Returns a reference to the hash of options in scalar context, or a list of name/value pairs in list context.
3650              
3651             When L<init_db_info|/init_db_info> is called for the first time on an object (either in isolation or as part of the L<connect|/connect> process), the connect options are merged with the L<default_connect_options|/default_connect_options>. The defaults are overridden in the case of a conflict. Example:
3652              
3653             Rose::DB->register_db(
3654             domain => 'development',
3655             type => 'main',
3656             driver => 'Pg',
3657             database => 'dev_db',
3658             host => 'localhost',
3659             username => 'devuser',
3660             password => 'mysecret',
3661             connect_options =>
3662             {
3663             RaiseError => 0,
3664             AutoCommit => 0,
3665             }
3666             );
3667              
3668             # Rose::DB->default_connect_options are:
3669             #
3670             # AutoCommit => 1,
3671             # ChopBlanks => 1,
3672             # PrintError => 1,
3673             # RaiseError => 1,
3674             # Warn => 0,
3675              
3676             # The object's connect options are merged with default options
3677             # since new() will trigger the first call to init_db_info()
3678             # for this object
3679             $db = Rose::DB->new(domain => 'development', type => 'main');
3680              
3681             # $db->connect_options are:
3682             #
3683             # AutoCommit => 0,
3684             # ChopBlanks => 1,
3685             # PrintError => 1,
3686             # RaiseError => 0,
3687             # Warn => 0,
3688              
3689             $db->connect_options(TraceLevel => 2); # Add an option
3690              
3691             # $db->connect_options are now:
3692             #
3693             # AutoCommit => 0,
3694             # ChopBlanks => 1,
3695             # PrintError => 1,
3696             # RaiseError => 0,
3697             # TraceLevel => 2,
3698             # Warn => 0,
3699              
3700             # The object's connect options are NOT re-merged with the default
3701             # connect options since this will trigger the second call to
3702             # init_db_info(), not the first
3703             $db->connect or die $db->error;
3704              
3705             # $db->connect_options are still:
3706             #
3707             # AutoCommit => 0,
3708             # ChopBlanks => 1,
3709             # PrintError => 1,
3710             # RaiseError => 0,
3711             # TraceLevel => 2,
3712             # Warn => 0,
3713              
3714             =item B<database [NAME]>
3715              
3716             Get or set the database name used in the construction of the DSN used in the L<DBI> L<connect|DBI/connect> call.
3717              
3718             =item B<domain [DOMAIN]>
3719              
3720             Get or set the data source domain. See the L<"Data Source Abstraction"> section for more information on data source domains.
3721              
3722             =item B<driver [DRIVER]>
3723              
3724             Get or set the driver name. The driver name can only be set during object construction (i.e., as an argument to L<new|/new>) since it determines the object class. After the object is constructed, setting the driver to anything other than the same value it already has will cause a fatal error.
3725              
3726             Even in the call to L<new|/new>, setting the driver name explicitly is not recommended. Instead, specify the driver when calling L<register_db|/register_db> for each data source and allow the L<driver|/driver> to be set automatically based on the L<domain|/domain> and L<type|/type>.
3727              
3728             The driver names for the L<currently supported database types|"DATABASE SUPPORT"> are:
3729              
3730             pg
3731             mysql
3732             mariadb
3733             informix
3734             oracle
3735             sqlite
3736              
3737             Driver names should only use lowercase letters.
3738              
3739             =item B<dsn [DSN]>
3740              
3741             Get or set the L<DBI> DSN (Data Source Name) passed to the call to L<DBI>'s L<connect|DBI/connect> method.
3742              
3743             An attempt is made to parse the new DSN. Any parts successfully extracted are assigned to the corresponding L<Rose::DB> attributes (e.g., L<host|/host>, L<port|/port>, L<database|/database>). If no value could be extracted for an attribute, it is set to undef.
3744              
3745             If the DSN is never set explicitly, it is built automatically based on the relevant object attributes.
3746              
3747             If the DSN is set explicitly, but any of L<host|/host>, L<port|/port>, L<database|/database>, L<schema|/schema>, or L<catalog|/catalog> are also provided, either in an object constructor or when the data source is registered, the explicit DSN may be ignored as a new DSN is constructed based on these attributes.
3748              
3749             =item B<handle_error [VALUE]>
3750              
3751             Get or set the value of the "HandleError" connect option and L<DBI> handle attribute. If a VALUE is passed, it will be set in both the connect options hash and the current database handle, if any. Returns the value of the "HandleError" attribute of the database handle if it exists, or the connect option otherwise.
3752              
3753             This method should not be mixed with the L<connect_options|/connect_options> method in calls to L<register_db|/register_db> or L<modify_db|/modify_db> since L<connect_options|/connect_options> will overwrite I<all> the connect options with its argument, and neither L<register_db|/register_db> nor L<modify_db|/modify_db> guarantee the order that its parameters will be evaluated.
3754              
3755             =item B<host [NAME]>
3756              
3757             Get or set the database server host name used in the construction of the DSN which is passed in the L<DBI> L<connect|DBI/connect> call.
3758              
3759             =item B<password [PASS]>
3760              
3761             Get or set the password that will be passed to the L<DBI> L<connect|DBI/connect> call.
3762              
3763             =item B<port [NUM]>
3764              
3765             Get or set the database server port number used in the construction of the DSN which is passed in the L<DBI> L<connect|DBI/connect> call.
3766              
3767             =item B<pre_disconnect_sql [STATEMENTS]>
3768              
3769             Get or set the SQL statements that will be run immediately before disconnecting from the database. STATEMENTS should be a list or reference to an array of SQL statements. Returns a reference to the array of SQL statements in scalar context, or a list of SQL statements in list context.
3770              
3771             The SQL statements are run in the order that they are supplied in STATEMENTS. If any L<pre_disconnect_sql|/pre_disconnect_sql> statement fails when executed, the subsequent statements are ignored.
3772              
3773             =item B<post_connect_sql [STATEMENTS]>
3774              
3775             Get or set the SQL statements that will be run immediately after connecting to the database. STATEMENTS should be a list or reference to an array of SQL statements. Returns a reference to the array of SQL statements in scalar context, or a list of SQL statements in list context.
3776              
3777             The SQL statements are run in the order that they are supplied in STATEMENTS. If any L<post_connect_sql|/post_connect_sql> statement fails when executed, the subsequent statements are ignored.
3778              
3779             =item B<primary_key_column_names [ TABLE | PARAMS ]>
3780              
3781             Returns a list (in list context) or reference to an array (in scalar context) of the names of the columns that make up the primary key for the specified table. If the table has no primary key, an empty list (in list context) or reference to an empty array (in scalar context) will be returned.
3782              
3783             The table may be specified in two ways. If one argument is passed, it is taken as the name of the table. Otherwise, name/value pairs are expected. Valid parameter names are:
3784              
3785             =over 4
3786              
3787             =item C<catalog>
3788              
3789             The name of the catalog that contains the table. This parameter is optional and defaults to the return value of the L<catalog|/catalog> method.
3790              
3791             =item C<schema>
3792              
3793             The name of the schema that contains the table. This parameter is optional and defaults to the return value of the L<schema|/schema> method.
3794              
3795             =item C<table>
3796              
3797             The name of the table. This parameter is required.
3798              
3799             =back
3800              
3801             Case-sensitivity of names is determined by the underlying database. If your database is case-sensitive, then you must pass names to this method with the expected case.
3802              
3803             =item B<print_error [VALUE]>
3804              
3805             Get or set the value of the "PrintError" connect option and L<DBI> handle attribute. If a VALUE is passed, it will be set in both the connect options hash and the current database handle, if any. Returns the value of the "PrintError" attribute of the database handle if it exists, or the connect option otherwise.
3806              
3807             This method should not be mixed with the L<connect_options|/connect_options> method in calls to L<register_db|/register_db> or L<modify_db|/modify_db> since L<connect_options|/connect_options> will overwrite I<all> the connect options with its argument, and neither L<register_db|/register_db> nor L<modify_db|/modify_db> guarantee the order that its parameters will be evaluated.
3808              
3809             =item B<raise_error [VALUE]>
3810              
3811             Get or set the value of the "RaiseError" connect option and L<DBI> handle attribute. If a VALUE is passed, it will be set in both the connect options hash and the current database handle, if any. Returns the value of the "RaiseError" attribute of the database handle if it exists, or the connect option otherwise.
3812              
3813             This method should not be mixed with the L<connect_options|/connect_options> method in calls to L<register_db|/register_db> or L<modify_db|/modify_db> since L<connect_options|/connect_options> will overwrite I<all> the connect options with its argument, and neither L<register_db|/register_db> nor L<modify_db|/modify_db> guarantee the order that its parameters will be evaluated.
3814              
3815             =item B<schema [SCHEMA]>
3816              
3817             Get or set the database schema name. This setting is only useful to databases that support the concept of schemas (e.g., PostgreSQL).
3818              
3819             =item B<server_time_zone [TZ]>
3820              
3821             Get or set the time zone used by the database server software. TZ should be a time zone name that is understood by L<DateTime::TimeZone>. The default value is "floating".
3822              
3823             See the L<DateTime::TimeZone> documentation for acceptable values of TZ.
3824              
3825             =item B<type [TYPE]>
3826              
3827             Get or set the data source type. See the L<"Data Source Abstraction"> section for more information on data source types.
3828              
3829             =item B<username [NAME]>
3830              
3831             Get or set the username that will be passed to the L<DBI> L<connect|DBI/connect> call.
3832              
3833             =back
3834              
3835             =head2 Value Parsing and Formatting
3836              
3837             =over 4
3838              
3839             =item B<format_bitfield BITS [, SIZE]>
3840              
3841             Converts the L<Bit::Vector> object BITS into the appropriate format for the "bitfield" data type of the current data source. If a SIZE argument is provided, the bit field will be padded with the appropriate number of zeros until it is SIZE bits long. If the data source does not have a native "bit" or "bitfield" data type, a character data type may be used to store the string of 1s and 0s returned by the default implementation.
3842              
3843             =item B<format_boolean VALUE>
3844              
3845             Converts VALUE into the appropriate format for the "boolean" data type of the current data source. VALUE is simply evaluated in Perl's scalar context to determine if it's true or false.
3846              
3847             =item B<format_date DATETIME>
3848              
3849             Converts the L<DateTime> object DATETIME into the appropriate format for the "date" (month, day, year) data type of the current data source.
3850              
3851             =item B<format_datetime DATETIME>
3852              
3853             Converts the L<DateTime> object DATETIME into the appropriate format for the "datetime" (month, day, year, hour, minute, second) data type of the current data source.
3854              
3855             =item B<format_interval DURATION>
3856              
3857             Converts the L<DateTime::Duration> object DURATION into the appropriate format for the interval (years, months, days, hours, minutes, seconds) data type of the current data source. If DURATION is undefined, a L<DateTime::Duration> object, a valid interval keyword (according to L<validate_interval_keyword|/validate_interval_keyword>), or if it looks like a function call (matches C</^\w+\(.*\)$/>) and L<keyword_function_calls|/keyword_function_calls> is true, then it is returned unmodified.
3858              
3859             =item B<format_time TIMECLOCK>
3860              
3861             Converts the L<Time::Clock> object TIMECLOCK into the appropriate format for the time (hour, minute, second, fractional seconds) data type of the current data source. Fractional seconds are optional, and the useful precision may vary depending on the data source.
3862              
3863             =item B<format_timestamp DATETIME>
3864              
3865             Converts the L<DateTime> object DATETIME into the appropriate format for the timestamp (month, day, year, hour, minute, second, fractional seconds) data type of the current data source. Fractional seconds are optional, and the useful precision may vary depending on the data source.
3866              
3867             =item B<format_timestamp_with_time_zone DATETIME>
3868              
3869             Converts the L<DateTime> object DATETIME into the appropriate format for the timestamp with time zone (month, day, year, hour, minute, second, fractional seconds, time zone) data type of the current data source. Fractional seconds are optional, and the useful precision may vary depending on the data source.
3870              
3871             =item B<parse_bitfield BITS [, SIZE]>
3872              
3873             Parse BITS and return a corresponding L<Bit::Vector> object. If SIZE is not passed, then it defaults to the number of bits in the parsed bit string.
3874              
3875             If BITS is a string of "1"s and "0"s or matches C</^B'[10]+'$/>, then the "1"s and "0"s are parsed as a binary string.
3876              
3877             If BITS is a string of numbers, at least one of which is in the range 2-9, it is assumed to be a decimal (base 10) number and is converted to a bitfield as such.
3878              
3879             If BITS matches any of these regular expressions:
3880              
3881             /^0x/
3882             /^X'.*'$/
3883             /^[0-9a-f]+$/
3884              
3885             it is assumed to be a hexadecimal number and is converted to a bitfield as such.
3886              
3887             Otherwise, undef is returned.
3888              
3889             =item B<parse_boolean STRING>
3890              
3891             Parse STRING and return a boolean value of 1 or 0. STRING should be formatted according to the data source's native "boolean" data type. The default implementation accepts 't', 'true', 'y', 'yes', and '1' values for true, and 'f', 'false', 'n', 'no', and '0' values for false.
3892              
3893             If STRING is a valid boolean keyword (according to L<validate_boolean_keyword|/validate_boolean_keyword>) or if it looks like a function call (matches C</^\w+\(.*\)$/>) and L<keyword_function_calls|/keyword_function_calls> is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "boolean" value.
3894              
3895             =item B<parse_date STRING>
3896              
3897             Parse STRING and return a L<DateTime> object. STRING should be formatted according to the data source's native "date" (month, day, year) data type.
3898              
3899             If STRING is a valid date keyword (according to L<validate_date_keyword|/validate_date_keyword>) or if it looks like a function call (matches C</^\w+\(.*\)$/>) and L<keyword_function_calls|/keyword_function_calls> is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "date" value.
3900              
3901             =item B<parse_datetime STRING>
3902              
3903             Parse STRING and return a L<DateTime> object. STRING should be formatted according to the data source's native "datetime" (month, day, year, hour, minute, second) data type.
3904              
3905             If STRING is a valid datetime keyword (according to L<validate_datetime_keyword|/validate_datetime_keyword>) or if it looks like a function call (matches C</^\w+\(.*\)$/>) and L<keyword_function_calls|/keyword_function_calls> is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "datetime" value.
3906              
3907             =item B<parse_interval STRING [, MODE]>
3908              
3909             Parse STRING and return a L<DateTime::Duration> object. STRING should be formatted according to the data source's native "interval" (years, months, days, hours, minutes, seconds) data type.
3910              
3911             If STRING is a L<DateTime::Duration> object, a valid interval keyword (according to L<validate_interval_keyword|/validate_interval_keyword>), or if it looks like a function call (matches C</^\w+\(.*\)$/>) and L<keyword_function_calls|/keyword_function_calls> is true, then it is returned unmodified. Otherwise, undef is returned if STRING could not be parsed as a valid "interval" value.
3912              
3913             This optional MODE argument determines how math is done on duration objects. If defined, the C<end_of_month> setting for each L<DateTime::Duration> object created by this column will have its mode set to MODE. Otherwise, the C<end_of_month> parameter will not be passed to the L<DateTime::Duration> constructor.
3914              
3915             Valid modes are C<wrap>, C<limit>, and C<preserve>. See the documentation for L<DateTime::Duration> for a full explanation.
3916              
3917             =item B<parse_time STRING>
3918              
3919             Parse STRING and return a L<Time::Clock> object. STRING should be formatted according to the data source's native "time" (hour, minute, second, fractional seconds) data type.
3920              
3921             If STRING is a valid time keyword (according to L<validate_time_keyword|/validate_time_keyword>) or if it looks like a function call (matches C</^\w+\(.*\)$/>) and L<keyword_function_calls|/keyword_function_calls> is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "time" value.
3922              
3923             =item B<parse_timestamp STRING>
3924              
3925             Parse STRING and return a L<DateTime> object. STRING should be formatted according to the data source's native "timestamp" (month, day, year, hour, minute, second, fractional seconds) data type. Fractional seconds are optional, and the acceptable precision may vary depending on the data source.
3926              
3927             If STRING is a valid timestamp keyword (according to L<validate_timestamp_keyword|/validate_timestamp_keyword>) or if it looks like a function call (matches C</^\w+\(.*\)$/>) and L<keyword_function_calls|/keyword_function_calls> is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "timestamp" value.
3928              
3929             =item B<parse_timestamp_with_time_zone STRING>
3930              
3931             Parse STRING and return a L<DateTime> object. STRING should be formatted according to the data source's native "timestamp with time zone" (month, day, year, hour, minute, second, fractional seconds, time zone) data type. Fractional seconds are optional, and the acceptable precision may vary depending on the data source.
3932              
3933             If STRING is a valid timestamp keyword (according to L<validate_timestamp_keyword|/validate_timestamp_keyword>) or if it looks like a function call (matches C</^\w+\(.*\)$/>) and L<keyword_function_calls|/keyword_function_calls> is true, then it is returned unmodified. Returns undef if STRING could not be parsed as a valid "timestamp with time zone" value.
3934              
3935             =item B<validate_boolean_keyword STRING>
3936              
3937             Returns true if STRING is a valid keyword for the "boolean" data type of the current data source, false otherwise. The default implementation accepts the values "TRUE" and "FALSE".
3938              
3939             =item B<validate_date_keyword STRING>
3940              
3941             Returns true if STRING is a valid keyword for the "date" (month, day, year) data type of the current data source, false otherwise. The default implementation always returns false.
3942              
3943             =item B<validate_datetime_keyword STRING>
3944              
3945             Returns true if STRING is a valid keyword for the "datetime" (month, day, year, hour, minute, second) data type of the current data source, false otherwise. The default implementation always returns false.
3946              
3947             =item B<validate_interval_keyword STRING>
3948              
3949             Returns true if STRING is a valid keyword for the "interval" (years, months, days, hours, minutes, seconds) data type of the current data source, false otherwise. The default implementation always returns false.
3950              
3951             =item B<validate_time_keyword STRING>
3952              
3953             Returns true if STRING is a valid keyword for the "time" (hour, minute, second, fractional seconds) data type of the current data source, false otherwise. The default implementation always returns false.
3954              
3955             =item B<validate_timestamp_keyword STRING>
3956              
3957             Returns true if STRING is a valid keyword for the "timestamp" (month, day, year, hour, minute, second, fractional seconds) data type of the current data source, false otherwise. The default implementation always returns false.
3958              
3959             =back
3960              
3961             =head1 DEVELOPMENT POLICY
3962              
3963             The L<Rose development policy|Rose/"DEVELOPMENT POLICY"> applies to this, and all C<Rose::*> modules. Please install L<Rose> from CPAN and then run "C<perldoc Rose>" for more information.
3964              
3965             =head1 SUPPORT
3966              
3967             Any L<Rose::DB> questions or problems can be posted to the L<Rose::DB::Object> mailing list. (If the volume ever gets high enough, I'll create a separate list for L<Rose::DB>, but it isn't an issue right now.) To subscribe to the list or view the archives, go here:
3968              
3969             L<http://groups.google.com/group/rose-db-object>
3970              
3971             Although the mailing list is the preferred support mechanism, you can also email the author (see below) or file bugs using the CPAN bug tracking system:
3972              
3973             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Rose-DB>
3974              
3975             There's also a wiki and other resources linked from the Rose project home page:
3976              
3977             L<http://rosecode.org>
3978              
3979             =head1 CONTRIBUTORS
3980              
3981             Kostas Chatzikokolakis, Peter Karman, Brian Duggan, Lucian Dragus, Ask Bjørn Hansen, Sergey Leschenko, Ron Savage, Ferry Hendrikx
3982              
3983             =head1 AUTHOR
3984              
3985             John C. Siracusa (siracusa@gmail.com)
3986              
3987             =head1 LICENSE
3988              
3989             Copyright (c) 2010 by John C. Siracusa. All rights reserved. This program is
3990             free software; you can redistribute it and/or modify it under the same terms
3991             as Perl itself.