File Coverage

blib/lib/Class/DBI.pm
Criterion Covered Total %
statement 549 600 91.5
branch 178 220 80.9
condition 61 97 62.9
subroutine 122 137 89.1
pod n/a
total 910 1054 86.3


line stmt bran cond sub pod time code
1             package Class::DBI::__::Base;
2              
3             require 5.006;
4              
5 24     24   866 use Class::Trigger 0.07;
  24         906  
  24         376  
6 24     24   501 use base qw(Class::Accessor Class::Data::Inheritable Ima::DBI);
  24         961  
  24         615  
7              
8             package Class::DBI;
9              
10 24     24   1316 use version; $VERSION = qv('3.0.16');
  24         327  
  24         408  
11              
12 24     24   1590 use strict;
  24         219  
  24         630  
13 24     24   378 use warnings;
  24         216  
  24         398  
14              
15 24     24   420 use base "Class::DBI::__::Base";
  24         265  
  24         369  
16              
17 24     24   1037 use Class::DBI::ColumnGrouper;
  24         266  
  24         914  
18 24     24   1061 use Class::DBI::Query;
  24         262  
  24         1515  
19 24     24   465 use Carp ();
  24         217  
  24         227  
20 24     24   390 use List::Util;
  24         215  
  24         973  
21 24     24   1329 use Clone ();
  24         259  
  24         293  
22 24     24   18450 use UNIVERSAL::moniker;
  24         469  
  24         572  
23              
24 24     24   418 use vars qw($Weaken_Is_Available);
  24         304  
  24         502  
25              
26             BEGIN {
27 24     24   333 $Weaken_Is_Available = 1;
28 24         235 eval {
29 24         401 require Scalar::Util;
30 24         614 import Scalar::Util qw(weaken);
31             };
32 24 50       1124 if ($@) {
33 0         0 $Weaken_Is_Available = 0;
34             }
35             }
36              
37             use overload
38 28     28   3627 '""'     => sub { shift->stringify_self },
39 692     692   13731 bool     => sub { not shift->_undefined_primary },
40 24     24   1072 fallback => 1;
  24         232  
  24         386  
41              
42             sub stringify_self {
43 27     27   250 my $self = shift;
44 27 100 33     301 return (ref $self || $self) unless $self; # empty PK
45 26         818 my @cols = $self->columns('Stringify');
46 26 100       384 @cols = $self->primary_columns unless @cols;
47 26         381 return join "/", $self->get(@cols);
48             }
49              
50             sub _undefined_primary {
51 784     784   11520 my $self = shift;
52 784         23895 return grep !defined, $self->_attrs($self->primary_columns);
53             }
54              
55             #----------------------------------------------------------------------
56             # Deprecations
57             #----------------------------------------------------------------------
58              
59             __PACKAGE__->mk_classdata('__hasa_rels' => {});
60              
61             {
62             my %deprecated = (
63             # accessor_name => 'accessor_name_for', # 3.0.7
64             # mutator_name => 'accessor_name_for', # 3.0.7
65               );
66              
67 24     24   497 no strict 'refs';
  24         221  
  24         349  
68             while (my ($old, $new) = each %deprecated) {
69             *$old = sub {
70             my @caller = caller;
71             warn
72             "Use of '$old' is deprecated at $caller[1] line $caller[2]. Use '$new' instead\n";
73             goto &$new;
74             };
75             }
76             }
77              
78             #----------------------------------------------------------------------
79             # Our Class Data
80             #----------------------------------------------------------------------
81             __PACKAGE__->mk_classdata('__AutoCommit');
82             __PACKAGE__->mk_classdata('__hasa_list');
83             __PACKAGE__->mk_classdata('_table');
84             __PACKAGE__->mk_classdata('_table_alias');
85             __PACKAGE__->mk_classdata('sequence');
86             __PACKAGE__->mk_classdata('__grouper'   => Class::DBI::ColumnGrouper->new());
87             __PACKAGE__->mk_classdata('__data_type' => {});
88             __PACKAGE__->mk_classdata('__driver');
89             __PACKAGE__->mk_classdata('iterator_class' => 'Class::DBI::Iterator');
90             __PACKAGE__->mk_classdata('purge_object_index_every' => 1000);
91             __PACKAGE__->add_searcher(search => "Class::DBI::Search::Basic",);
92              
93             __PACKAGE__->add_relationship_type(
94             has_a      => "Class::DBI::Relationship::HasA",
95             has_many   => "Class::DBI::Relationship::HasMany",
96             might_have => "Class::DBI::Relationship::MightHave",
97             );
98             __PACKAGE__->mk_classdata('__meta_info' => {});
99              
100             #----------------------------------------------------------------------
101             # SQL we'll need
102             #----------------------------------------------------------------------
103             __PACKAGE__->set_sql(MakeNewObj => <<'');
104             INSERT INTO __TABLE__ (%s)
105             VALUES (%s)
106            
107             __PACKAGE__->set_sql(update => <<"");
108             UPDATE __TABLE__
109             SET %s
110             WHERE __IDENTIFIER__
111            
112             __PACKAGE__->set_sql(Nextval => <<'');
113             SELECT NEXTVAL ('%s')
114            
115             __PACKAGE__->set_sql(SearchSQL => <<'');
116             SELECT %s
117             FROM %s
118             WHERE %s
119            
120             __PACKAGE__->set_sql(RetrieveAll => <<'');
121             SELECT __ESSENTIAL__
122             FROM __TABLE__
123            
124             __PACKAGE__->set_sql(Retrieve => <<'');
125             SELECT __ESSENTIAL__
126             FROM __TABLE__
127             WHERE %s
128            
129             __PACKAGE__->set_sql(Flesh => <<'');
130             SELECT %s
131             FROM __TABLE__
132             WHERE __IDENTIFIER__
133            
134             __PACKAGE__->set_sql(single => <<'');
135             SELECT %s
136             FROM __TABLE__
137            
138             __PACKAGE__->set_sql(DeleteMe => <<"");
139             DELETE
140             FROM __TABLE__
141             WHERE __IDENTIFIER__
142            
143              
144             __PACKAGE__->mk_classdata('sql_transformer_class');
145             __PACKAGE__->sql_transformer_class('Class::DBI::SQL::Transformer');
146              
147             # Override transform_sql from Ima::DBI to provide some extra
148             # transformations
149             sub transform_sql {
150 443     443   9450 my ($self, $sql, @args) = @_;
151 443         13581 my $tclass = $self->sql_transformer_class;
152 443         17485 $self->_require_class($tclass);
153 443         11610 my $T = $tclass->new($self, $sql, @args);
154 443         12083 return $self->SUPER::transform_sql($T->sql => $T->args);
155             }
156              
157             #----------------------------------------------------------------------
158             # EXCEPTIONS
159             #----------------------------------------------------------------------
160              
161             sub _carp {
162 9     9   101 my ($self, $msg) = @_;
163 9   33     131 Carp::carp($msg || $self);
164 8         217 return;
165             }
166              
167             sub _croak {
168 48     48   1012 my ($self, $msg) = @_;
169 48   66     1971 Carp::croak($msg || $self);
170             }
171              
172             sub _db_error {
173 1     1   41 my ($self, %info) = @_;
174 1         744 my $msg = delete $info{msg};
175 1         66 return $self->_croak($msg, %info);
176             }
177              
178             #----------------------------------------------------------------------
179             # SET UP
180             #----------------------------------------------------------------------
181              
182             sub connection {
183 20     20   207 my $class = shift;
184 20         389 $class->set_db(Main => @_);
185             }
186              
187             {
188             my %Per_DB_Attr_Defaults = (
189             pg     => { AutoCommit => 0 },
190             oracle => { AutoCommit => 0 },
191             );
192              
193             sub _default_attributes {
194 20     20   197 my $class = shift;
195             return (
196 20 50       252 $class->SUPER::_default_attributes,
197             FetchHashKeyName   => 'NAME_lc',
198             ShowErrorStatement => 1,
199             AutoCommit         => 1,
200             ChopBlanks         => 1,
201 20         808 %{ $Per_DB_Attr_Defaults{ lc $class->__driver } || {} },
202             );
203             }
204             }
205              
206             sub set_db {
207 20     20   255 my ($class, $db_name, $data_source, $user, $password, $attr) = @_;
208              
209             # 'dbi:Pg:dbname=foo' we want 'Pg'. I think this is enough.
210 20         323 my ($driver) = $data_source =~ /^dbi:(\w+)/i;
211 20         349 $class->__driver($driver);
212 20         1767 $class->SUPER::set_db('Main', $data_source, $user, $password, $attr);
213             }
214              
215             sub table {
216 511     511   10013 my ($proto, $table, $alias) = @_;
217 511   66     9751 my $class = ref $proto || $proto;
218 511 100       8742 $class->_table($table)      if $table;
219 511 50       5175 $class->table_alias($alias) if $alias;
220 511   66     14978 return $class->_table || $class->_table($class->table_alias);
221             }
222              
223             sub table_alias {
224 31     31   627 my ($proto, $alias) = @_;
225 31   33     409 my $class = ref $proto || $proto;
226 31 100       316 $class->_table_alias($alias) if $alias;
227 31   66     2048 return $class->_table_alias || $class->_table_alias($class->moniker);
228             }
229              
230             sub columns {
231 206     206   6138 my $proto = shift;
232 206   66     5066 my $class = ref $proto || $proto;
233 206   100     3758 my $group = shift || "All";
234 206 100       9204 return $class->_set_columns($group => @_) if @_;
235 78 100       1332 return $class->all_columns if $group eq "All";
236 43 100       502 return $class->primary_column if $group eq "Primary";
237 37 100       478 return $class->_essential if $group eq "Essential";
238 30         421 return $class->__grouper->group_cols($group);
239             }
240              
241 227     227   15271 sub _column_class { 'Class::DBI::Column' }
242              
243             sub _set_columns {
244 128     128   5487 my ($class, $group, @columns) = @_;
245              
246 128 100       15736 my @cols = map ref $_ ? $_ : $class->_column_class->new($_), @columns;
247              
248             # Careful to take copy
249 128         11382 $class->__grouper(Class::DBI::ColumnGrouper->clone($class->__grouper)
250             ->add_group($group => @cols));
251 128         6260 $class->_mk_column_accessors(@cols);
252 128         9087 return @columns;
253             }
254              
255 157     157   2417 sub all_columns { shift->__grouper->all_columns }
256              
257             sub id {
258 256     256   4791 my $self = shift;
259 256 100       6347 my $class = ref($self)
260             or return $self->_croak("Can't call id() as a class method");
261              
262             # we don't use get() here because all objects should have
263             # exisitng values for PK columns, or else loop endlessly
264 255         2791 my @pk_values = $self->_attrs($self->primary_columns);
265 255   66     11726 UNIVERSAL::can($_ => 'id') and $_ = $_->id for @pk_values;
  255         7800  
266 255 100       4815 return @pk_values if wantarray;
267 64 50       765 $self->_croak(
268             "id called in scalar context for class with multiple primary key columns")
269             if @pk_values > 1;
270 64         906 return $pk_values[0];
271             }
272              
273             sub primary_column {
274 1931     1931   27764 my $self = shift;
275 1931         35918 my @primary_columns = $self->__grouper->primary;
276 1931 100       34775 return @primary_columns if wantarray;
277 6 50       71 $self->_carp(
278             ref($self)
279             . " has multiple primary columns, but fetching in scalar context")
280             if @primary_columns > 1;
281 6         107 return $primary_columns[0];
282             }
283             *primary_columns = \&primary_column;
284              
285 144     144   2124 sub _essential { shift->__grouper->essential }
286              
287             sub find_column {
288 1094     1094   15034 my ($class, $want) = @_;
289 1094         41243 return $class->__grouper->find_column($want);
290             }
291              
292             sub _find_columns {
293 321     321   3142 my $class = shift;
294 321         6957 my $cg = $class->__grouper;
295 321         13698 return map $cg->find_column($_), @_;
296             }
297              
298             sub has_real_column { # is really in the database
299 342     342   9335 my ($class, $want) = @_;
300 342   33     4415 return ($class->find_column($want) || return)->in_database;
301             }
302              
303             sub data_type {
304 0     0   0 my $class = shift;
305 0         0 my %datatype = @_;
306 0         0 while (my ($col, $type) = each %datatype) {
307 0         0 $class->_add_data_type($col, $type);
308             }
309             }
310              
311             sub _add_data_type {
312 0     0   0 my ($class, $col, $type) = @_;
313 0         0 my $datatype = $class->__data_type;
314 0         0 $datatype->{$col} = $type;
315 0         0 $class->__data_type($datatype);
316             }
317              
318             # Make a set of accessors for each of a list of columns. We construct
319             # the method name by calling accessor_name_for() and mutator_name_for()
320             # with the normalized column name.
321              
322             # mutator name will be the same as accessor name unless you override it.
323              
324             # If both the accessor and mutator are to have the same method name,
325             # (which will always be true unless you override mutator_name_for), a
326             # read-write method is constructed for it. If they differ we create both
327             # a read-only accessor and a write-only mutator.
328              
329             sub _mk_column_accessors {
330 128     128   1224 my $class = shift;
331 128         1285 foreach my $col (@_) {
332              
333 228         9136 my $default_accessor = $col->accessor;
334              
335 228         8504 my $acc = $class->accessor_name_for($col);
336 228         5491 my $mut = $class->mutator_name_for($col);
337              
338 228         7351 my %method = ();
339              
340 228 100 100     8831 if (
341             ($acc    eq $mut) # if they are the same
342             or ($mut eq $default_accessor)
343             ) { # or only the accessor was customized
344 190         6681 %method = ('_' => $acc); # make the accessor the mutator too
345 190         2228 $col->accessor($acc);
346 190         3283 $col->mutator($acc);
347             } else {
348 38         472 %method = (
349             _ro_ => $acc,
350             _wo_ => $mut,
351             );
352 38         471 $col->accessor($acc);
353 38         555 $col->mutator($mut);
354             }
355              
356 228         5710 foreach my $type (keys %method) {
357 266         7058 my $name = $method{$type};
358 266         8372 my $acc_type = "make${type}accessor";
359 266         9964 my $accessor = $class->$acc_type($col->name_lc);
360 266         23681 $class->_make_method($_, $accessor) for ($name, "_${name}_accessor");
  266         8351  
361             }
362             }
363             }
364              
365             sub _make_method {
366 1270     1270   55612 my ($class, $name, $method) = @_;
367 1270 100       33998 return if defined &{"$class\::$name"};
  1270         81850  
368 738 100 66     124284 $class->_carp("Column '$name' in $class clashes with built-in method")
      100        
369             if Class::DBI->can($name)
370             and not($name eq "id" and join(" ", $class->primary_columns) eq "id");
371 24     24   766 no strict 'refs';
  24         305  
  24         485  
372 738         15144 *{"$class\::$name"} = $method;
  738         31181  
373 738         40424 $class->_make_method(lc $name => $method);
374             }
375              
376             sub accessor_name_for {
377 207     207   9189 my ($class, $column) = @_;
378 207 100       21402   if ($class->can('accessor_name')) {
379 7         68 warn "Use of 'accessor_name' is deprecated. Use 'accessor_name_for' instead\n";
380 7         158 return $class->accessor_name($column)
381             }
382 200         12365 return $column->accessor;
383             }
384              
385             sub mutator_name_for {
386 183     183   13267 my ($class, $column) = @_;
387 183 50       17854   if ($class->can('mutator_name')) {
388 0         0 warn "Use of 'mutator_name' is deprecated. Use 'mutator_name_for' instead\n";
389 0         0 return $class->mutator_name($column)
390             }
391 183         5623 return $column->mutator;
392             }
393              
394             sub autoupdate {
395 45     45   467 my $proto = shift;
396 45 100       804 ref $proto ? $proto->_obj_autoupdate(@_) : $proto->_class_autoupdate(@_);
397             }
398              
399             sub _obj_autoupdate {
400 42     42   391 my ($self, $set) = @_;
401 42         407 my $class = ref $self;
402 42 100       2645 $self->{__AutoCommit} = $set if defined $set;
403 42 100       1589 defined $self->{__AutoCommit}
404             ? $self->{__AutoCommit}
405             : $class->_class_autoupdate;
406             }
407              
408             sub _class_autoupdate {
409 37     37   402 my ($class, $set) = @_;
410 37 100       442 $class->__AutoCommit($set) if defined $set;
411 37         587 return $class->__AutoCommit;
412             }
413              
414             sub make_read_only {
415 2     2   51 my $proto = shift;
416 5     5   64 $proto->add_trigger("before_$_" => sub { _croak "$proto is read only" })
417 2         18 foreach qw/create delete update/;
  2         46  
418 2         20442 return $proto;
419             }
420              
421             sub find_or_create {
422 2     2   50 my $class = shift;
423 2 100       31 my $hash = ref $_[0] eq "HASH" ? shift: {@_};
424 2         25 my ($exists) = $class->search($hash);
425 2 100       93 return defined($exists) ? $exists : $class->insert($hash);
426             }
427              
428             sub insert {
429 106     106   4721 my $class = shift;
430 106 100       1513 return $class->_croak("insert needs a hashref") unless ref $_[0] eq 'HASH';
431 103         2249 my $info = { %{ +shift } }; # make sure we take a copy
  103         2117  
432              
433 103         1033 my $data;
434 103         1509 while (my ($k, $v) = each %$info) {
435             my $col = $class->find_column($k)
436 61     61   1197 || (List::Util::first { $_->mutator eq $k } $class->columns)
437 274   100 37   17399 || (List::Util::first { $_->accessor eq $k } $class->columns)
  37   100     591  
      66        
438             || $class->_croak("$k is not a column of $class");
439 271         3330 $data->{$col} = $v;
440             }
441              
442 100         10181 $class->normalize_column_values($data);
443 100         1978 $class->validate_column_values($data);
444 96         1959 return $class->_insert($data);
445             }
446              
447             *create = \&insert;
448              
449             #----------------------------------------------------------------------
450             # Low Level Data Access
451             #----------------------------------------------------------------------
452              
453             sub _attrs {
454 1841     1841   29965 my ($self, @atts) = @_;
455 1841         20587 return @{$self}{@atts};
  1841         41952  
456             }
457             *_attr = \&_attrs;
458              
459             sub _attribute_store {
460 531     531   9717 my $self = shift;
461 531 100       18745 my $vals = @_ == 1 ? shift: {@_};
462 531         13305 my (@cols) = keys %$vals;
463 531         8744 @{$self}{@cols} = @{$vals}{@cols};
  531         12586  
  531         10292  
464             }
465              
466             # If you override this method, you must use the same mechanism to log changes
467             # for future updates, as other parts of Class::DBI depend on it.
468             sub _attribute_set {
469 38     38   2740 my $self = shift;
470 38 50       430 my $vals = @_ == 1 ? shift: {@_};
471              
472             # We increment instead of setting to 1 because it might be useful to
473             # someone to know how many times a value has changed between updates.
474 38         898 for my $col (keys %$vals) { $self->{__Changed}{$col}++; }
  38         1473  
475 38         1573 $self->_attribute_store($vals);
476             }
477              
478             sub _attribute_delete {
479 119     119   3924 my ($self, @attributes) = @_;
480 119         1121 delete @{$self}{@attributes};
  119         1683  
481             }
482              
483             sub _attribute_exists {
484 1251     1251   40047 my ($self, $attribute) = @_;
485 1251         23956 exists $self->{$attribute};
486             }
487              
488             #----------------------------------------------------------------------
489             # Live Object Index (using weak refs if available)
490             #----------------------------------------------------------------------
491              
492             my %Live_Objects;
493             my $Init_Count = 0;
494              
495             sub _init {
496 325     325   6073 my $class = shift;
497 325   100     5983 my $data = shift || {};
498 325         4062 my $key = $class->_live_object_key($data);
499 325   100     12701 return $Live_Objects{$key} || $class->_fresh_init($key => $data);
500             }
501              
502             sub _fresh_init {
503 216     216   3046 my ($class, $key, $data) = @_;
504 216         69696 my $obj = bless {}, $class;
505 216         12920 $obj->_attribute_store(%$data);
506              
507             # don't store it unless all keys are present
508 216 100 66     5949 if ($key && $Weaken_Is_Available) {
509 195         15160 weaken($Live_Objects{$key} = $obj);
510              
511             # time to clean up your room?
512 195 50       5601 $class->purge_dead_from_object_index
513             if ++$Init_Count % $class->purge_object_index_every == 0;
514             }
515 216         17248 return $obj;
516             }
517              
518             sub _live_object_key {
519 353     353   11063 my ($me, $data) = @_;
520 353   66     6044 my $class = ref($me) || $me;
521 353         5811 my @primary = $class->primary_columns;
522              
523             # no key unless all PK columns are defined
524 353 100       10655 return "" unless @primary == grep defined $data->{$_}, @primary;
525              
526             # create single unique key for this object
527 332         3924 return join "\030", $class, map $_ . "\032" . $data->{$_}, sort @primary;
528             }
529              
530             sub purge_dead_from_object_index {
531 0     0   0 delete @Live_Objects{ grep !defined $Live_Objects{$_}, keys %Live_Objects };
532             }
533              
534             sub remove_from_object_index {
535 29     29   309 my $self = shift;
536 29         446 my $obj_key = $self->_live_object_key({ $self->_as_hash });
537 28         942 delete $Live_Objects{$obj_key};
538             }
539              
540             sub clear_object_index {
541 31     31   660 %Live_Objects = ();
542             }
543              
544             #----------------------------------------------------------------------
545              
546             sub _prepopulate_id {
547 20     20   603 my $self = shift;
548 20         253 my @primary_columns = $self->primary_columns;
549 20 50       248 return $self->_croak(
550             sprintf "Can't create %s object with null primary key columns (%s)",
551             ref $self, $self->_undefined_primary)
552             if @primary_columns > 1;
553 20 50       290 $self->_attribute_store($primary_columns[0] => $self->_next_in_sequence)
554             if $self->sequence;
555             }
556              
557             sub _insert {
558 96     96   2388 my ($proto, $data) = @_;
559 96   66     4402 my $class = ref $proto || $proto;
560              
561 96         1344 my $self = $class->_init($data);
562 96         5233 $self->call_trigger('before_create');
563 94         36893 $self->call_trigger('deflate_for_create');
564              
565 92 100       33900 $self->_prepopulate_id if $self->_undefined_primary;
566              
567             # Reinstate data
568 92         7120 my ($real, $temp) = ({}, {});
569 92         1468 foreach my $col (grep $self->_attribute_exists($_), $self->all_columns) {
570 247 50       9126 ($class->has_real_column($col) ? $real : $temp)->{$col} =
571             $self->_attrs($col);
572             }
573 92         4689 $self->_insert_row($real);
574              
575 92         3752 my @primary_columns = $class->primary_columns;
576 92 50       1293 $self->_attribute_store(
577             $primary_columns[0] => $real->{ $primary_columns[0] })
578             if @primary_columns == 1;
579              
580 92         4725 delete $self->{__Changed};
581              
582 92         4841 my %primary_columns;
583 92         1218 @primary_columns{@primary_columns} = ();
584 92         5954 my @discard_columns = grep !exists $primary_columns{$_}, keys %$real;
585 92         6721 $self->call_trigger('create', discard_columns => \@discard_columns); # XXX
586              
587             # Empty everything back out again!
588 92         62885 $self->_attribute_delete(@discard_columns);
589 92         1372 $self->call_trigger('after_create');
590 92         50516 return $self;
591             }
592              
593             sub _next_in_sequence {
594 0     0   0 my $self = shift;
595 0         0 return $self->sql_Nextval($self->sequence)->select_val;
596             }
597              
598             sub _auto_increment_value {
599 20     20   1500 my $self = shift;
600 20         288 my $dbh = $self->db_Main;
601              
602             # Try to do this in a standard method. Fall back to MySQL/SQLite
603             # specific versions. TODO remove these when last_insert_id is more
604             # widespread.
605             # Note: I don't believe the last_insert_id can be zero. We need to
606             # switch to defined() checks if it can.
607             my $id = $dbh->last_insert_id(undef, undef, $self->table, undef) # std
608             || $dbh->{mysql_insertid} # mysql
609 20 50 33     283 || eval { $dbh->func('last_insert_rowid') }
  0   33     0  
610             or $self->_croak("Can't get last insert id");
611 20         222 return $id;
612             }
613              
614             sub _insert_row {
615 92     92   860 my $self = shift;
616 92         818 my $data = shift;
617 92         3226 eval {
618 92         1320 my @columns = keys %$data;
619 92         1979 my $sth = $self->sql_MakeNewObj(
620             join(', ', @columns),
621             join(', ', map $self->_column_placeholder($_), @columns),
622             );
623 92         8282 $self->_bind_param($sth, \@columns);
624 92         2636 $sth->execute(values %$data);
625 92         12136 my @primary_columns = $self->primary_columns;
626 92 100 66     2597 $data->{ $primary_columns[0] } = $self->_auto_increment_value
627             if @primary_columns == 1
628             && !defined $data->{ $primary_columns[0] };
629             };
630 92 50       4994 if ($@) {
631 0         0 my $class = ref $self;
632 0         0 return $self->_db_error(
633             msg    => "Can't insert new $class: $@",
634             err    => $@,
635             method => 'insert'
636             );
637             }
638 92         964 return 1;
639             }
640              
641             sub _bind_param {
642 117     117   9295 my ($class, $sth, $keys) = @_;
643 117 50       2043 my $datatype = $class->__data_type or return;
644 117         7127 for my $i (0 .. $#$keys) {
645 276 50       7495 if (my $type = $datatype->{ $keys->[$i] }) {
646 0         0 $sth->bind_param($i + 1, undef, $type);
647             }
648             }
649             }
650              
651             sub retrieve {
652 63     63   1959 my $class = shift;
653 63 100       867 my @primary_columns = $class->primary_columns
654             or return $class->_croak(
655             "Can't retrieve unless primary columns are defined");
656 62         608 my %key_value;
657 62 100 66     1131 if (@_ == 1 && @primary_columns == 1) {
658 60         549 my $id = shift;
659 60 50       603 return unless defined $id;
660 60 100       601 return $class->_croak("Can't retrieve a reference") if ref($id);
661 59         709 $key_value{ $primary_columns[0] } = $id;
662             } else {
663 2         23 %key_value = @_;
664 2 100       26 $class->_croak(
665             "$class->retrieve(@_) parameters don't include values for all primary key columns (@primary_columns)"
666             )
667             if keys %key_value < @primary_columns;
668             }
669 60         4067 my @rows = $class->search(%key_value);
670 60 50       1752 $class->_carp("$class->retrieve(@_) selected " . @rows . " rows")
671             if @rows > 1;
672 60         2275 return $rows[0];
673             }
674              
675             # Get the data, as a hash, but setting certain values to whatever
676             # we pass. Used by copy() and move().
677             # This can take either a primary key, or a hashref of all the columns
678             # to change.
679             sub _data_hash {
680 1     1   9 my $self = shift;
681 1         17 my %data = $self->_as_hash;
682 1         17 my @primary_columns = $self->primary_columns;
683 1         11 delete @data{@primary_columns};
684 1 50       65 if (@_) {
685 1         10 my $arg = shift;
686 1 50       14 unless (ref $arg) {
687 0 0       0 $self->_croak("Need hash-ref to edit copied column values")
688             unless @primary_columns == 1;
689 0         0 $arg = { $primary_columns[0] => $arg };
690             }
691 1         15 @data{ keys %$arg } = values %$arg;
692             }
693 1         16 return \%data;
694             }
695              
696             sub _as_hash {
697 30     30   272 my $self = shift;
698 30         403 my @columns = $self->all_columns;
699 30         359 my %data;
700 30         503 @data{@columns} = $self->get(@columns);
701 29         3541 return %data;
702             }
703              
704             sub copy {
705 1     1   10 my $self = shift;
706 1         20 return $self->insert($self->_data_hash(@_));
707             }
708              
709             #----------------------------------------------------------------------
710             # CONSTRUCT
711             #----------------------------------------------------------------------
712              
713             sub construct {
714 193     193   4098 my ($proto, $data) = @_;
715 193   33     3349 my $class = ref $proto || $proto;
716 193         2576 my $self = $class->_init($data);
717 193         8270 $self->call_trigger('select');
718 193         60685 return $self;
719             }
720              
721             sub move {
722 0     0   0 my ($class, $old_obj, @data) = @_;
723 0         0 $class->_carp("move() is deprecated. If you really need it, "
724             . "you should tell me quickly so I can abandon my plan to remove it.");
725 0 0 0     0 return $old_obj->_croak("Can't move to an unrelated class")
726             unless $class->isa(ref $old_obj)
727             or $old_obj->isa($class);
728 0         0 return $class->insert($old_obj->_data_hash(@data));
729             }
730              
731             sub delete {
732 26     26   3299 my $self = shift;
733 26 100       339 return $self->_search_delete(@_) if not ref $self;
734 25         355 $self->remove_from_object_index;
735 24         403 $self->call_trigger('before_delete');
736              
737 21         8904 eval { $self->sql_DeleteMe->execute($self->id) };
  21         402  
738 21 50       590 if ($@) {
739 0         0 return $self->_db_error(
740             msg    => "Can't delete $self: $@",
741             err    => $@,
742             method => 'delete'
743             );
744             }
745 21         379 $self->call_trigger('after_delete');
746 21         21493 undef %$self;
747 21         593 bless $self, 'Class::DBI::Object::Has::Been::Deleted';
748 21         471 return 1;
749             }
750              
751             sub _search_delete {
752 1     1   13 my ($class, @args) = @_;
753 1         19 $class->_carp(
754             "Delete as class method is deprecated. Use search and delete_all instead."
755             );
756 1         48 my $it = $class->search_like(@args);
757 1         16 while (my $obj = $it->next) { $obj->delete }
  2         58  
758 1         22 return 1;
759             }
760              
761             # Return the placeholder to be used in UPDATE and INSERT queries.
762             # Overriding this is deprecated in favour of
763             # __PACKAGE__->find_column('entered')->placeholder('IF(1, CURDATE(), ?));
764              
765             sub _column_placeholder {
766 276     276   9300 my ($self, $column) = @_;
767 276         6078 return $self->find_column($column)->placeholder;
768             }
769              
770             sub update {
771 40     40   463 my $self = shift;
772 40 100       2998 my $class = ref($self)
773             or return $self->_croak("Can't call update as a class method");
774              
775 39         1237 $self->call_trigger('before_update');
776 36 100       12265 return -1 unless my @changed_cols = $self->is_changed;
777 25         384 $self->call_trigger('deflate_for_update');
778 25         11713 my @primary_columns = $self->primary_columns;
779 25         441 my $sth = $self->sql_update($self->_update_line);
780 25         1855 $class->_bind_param($sth, \@changed_cols);
781 25         283 my $rows = eval { $sth->execute($self->_update_vals, $self->id); };
  25         468  
782 25 100       600 if ($@) {
783 1         11 return $self->_db_error(
784             msg    => "Can't update $self: $@",
785             err    => $@,
786             method => 'update'
787             );
788             }
789              
790             # enable this once new fixed DBD::SQLite is released:
791 24         486 if (0 and $rows != 1) { # should always only update one row
792             $self->_croak("Can't update $self: row not found") if $rows == 0;
793             $self->_croak("Can't update $self: updated more than one row");
794             }
795              
796 24         1491 $self->call_trigger('after_update', discard_columns => \@changed_cols);
797              
798             # delete columns that changed (in case adding to DB modifies them again)
799 24         7441 $self->_attribute_delete(@changed_cols);
800 24         743 delete $self->{__Changed};
801 24         367 return 1;
802             }
803              
804             sub _update_line {
805 25     25   235 my $self = shift;
806 25         360 join(', ', map "$_ = " . $self->_column_placeholder($_), $self->is_changed);
807             }
808              
809             sub _update_vals {
810 25     25   237 my $self = shift;
811 25         288 $self->_attrs($self->is_changed);
812             }
813              
814             sub DESTROY {
815 189     189   2911 my ($self) = shift;
816 189 100       4384 if (my @changed = $self->is_changed) {
817 2         21 my $class = ref $self;
818 2         58 $self->_carp("$class $self destroyed without saving changes to "
819             . join(', ', @changed));
820             }
821             }
822              
823             sub discard_changes {
824 2     2   70 my $self = shift;
825 2 50       31 return $self->_croak("Can't discard_changes while autoupdate is on")
826             if $self->autoupdate;
827 2         79 $self->_attribute_delete($self->is_changed);
828 2         27 delete $self->{__Changed};
829 2         22 return 1;
830             }
831              
832             # We override the get() method from Class::Accessor to fetch the data for
833             # the column (and associated) columns from the database, using the _flesh()
834             # method. We also allow get to be called with a list of keys, instead of
835             # just one.
836              
837             sub get {
838 321     321   10211 my $self = shift;
839 321 100       8516 return $self->_croak("Can't fetch data as class method") unless ref $self;
840              
841 320         4523 my @cols = $self->_find_columns(@_);
842 320 50       14971 return $self->_croak("Can't get() nothing!") unless @cols;
843              
844 320 100       8855 if (my @fetch_cols = grep !$self->_attribute_exists($_), @cols) {
845 110         6186 $self->_flesh($self->__grouper->groups_for(@fetch_cols));
846             }
847              
848 319         17115 return $self->_attrs(@cols);
849             }
850              
851             sub _flesh {
852 111     111   5335 my ($self, @groups) = @_;
853 111         3107 my @real = grep $_ ne "TEMP", @groups;
854 111 100       1271 if (my @want = grep !$self->_attribute_exists($_),
855             $self->__grouper->columns_in(@real)) {
856 109         11552 my %row;
857 109         3671 @row{@want} = $self->sql_Flesh(join ", ", @want)->select_row($self->id);
858 108         9684 $self->_attribute_store(\%row);
859 108         3963 $self->call_trigger('select');
860             }
861 110         41237 return 1;
862             }
863              
864             # We also override set() from Class::Accessor so we can keep track of
865             # changes, and either write to the database now (if autoupdate is on),
866             # or when update() is called.
867             sub set {
868 38     38   4574 my $self = shift;
869 38         1235 my $column_values = {@_};
870              
871 38         600 $self->normalize_column_values($column_values);
872 38         555 $self->validate_column_values($column_values);
873              
874 37         790 while (my ($column, $value) = each %$column_values) {
875 37 50       631 my $col = $self->find_column($column) or die "No such column: $column\n";
876 37         1572 $self->_attribute_set($col => $value);
877              
878             # $self->SUPER::set($column, $value);
879              
880 37         644 eval { $self->call_trigger("after_set_$column") }; # eg inflate
  37         558  
881 37 100       5753 if ($@) {
882 1         21 $self->_attribute_delete($column);
883 1         16 return $self->_croak("after_set_$column trigger error: $@", err => $@);
884             }
885             }
886              
887 36 100       628 $self->update if $self->autoupdate;
888 33         965 return 1;
889             }
890              
891             sub is_changed {
892 277     277   20891 my $self = shift;
893 277         6390 grep $self->has_real_column($_), keys %{ $self->{__Changed} };
  277         8693  
894             }
895              
896 0     0   0 sub any_changed { keys %{ shift->{__Changed} } }
  0         0  
897              
898             # By default do nothing. Subclasses should override if required.
899             #
900             # Given a hash ref of column names and proposed new values,
901             # edit the values in the hash if required.
902             # For insert $self is the class name (not an object ref).
903             sub normalize_column_values {
904 138     138   1661 my ($self, $column_values) = @_;
905             }
906              
907             # Given a hash ref of column names and proposed new values
908             # validate that the whole set of new values in the hash
909             # is valid for the object in relation to its current values
910             # For insert $self is the class name (not an object ref).
911             sub validate_column_values {
912 138     138   1841 my ($self, $column_values) = @_;
913 138         1237 my @errors;
914 138         1938 foreach my $column (keys %$column_values) {
915 301         8263 eval {
916 301         6963 $self->call_trigger("before_set_$column", $column_values->{$column},
917             $column_values);
918             };
919 301 100       105142 push @errors, $column => $@ if $@;
920             }
921 138 100       2098 return unless @errors;
922 5         133 $self->_croak(
923             "validate_column_values error: " . join(" ", @errors),
924             method => 'validate_column_values',
925             data   => {@errors}
926             );
927             }
928              
929             # We override set_sql() from Ima::DBI so it has a default database connection.
930             sub set_sql {
931 258     258   2882 my ($class, $name, $sql, $db, @others) = @_;
932 258   50     3331 $db ||= 'Main';
933 258         6342 $class->SUPER::set_sql($name, $sql, $db, @others);
934 258 100       3566 $class->_generate_search_sql($name) if $sql =~ /select/i;
935 258         2568 return 1;
936             }
937              
938             sub _generate_search_sql {
939 148     148   5610 my ($class, $name) = @_;
940 148         1468 my $method = "search_$name";
941 148 50       1271 defined &{"$class\::$method"}
  148         2172  
942             and return $class->_carp("$method() already exists");
943 148         1490 my $sql_method = "sql_$name";
944 24     24   909 no strict 'refs';
  24         291  
  24         483  
945 148         2588 *{"$class\::$method"} = sub {
946 4     4   50 my ($class, @args) = @_;
947 4         73 return $class->sth_to_objects($name, \@args);
948 148         2585 };
949             }
950              
951 0     0   0 sub dbi_commit { my $proto = shift; $proto->SUPER::commit(@_); }
  0         0  
952 0     0   0 sub dbi_rollback { my $proto = shift; $proto->SUPER::rollback(@_); }
  0         0  
953              
954             #----------------------------------------------------------------------
955             # Constraints / Triggers
956             #----------------------------------------------------------------------
957              
958             sub constrain_column {
959 4     4   123 my $class = shift;
960 4 50       50 my $col = $class->find_column(+shift)
961             or return $class->_croak("constraint_column needs a valid column");
962 4 50       107 my $how = shift
963             or return $class->_croak("constrain_column needs a constraint");
964 4 100       63 if (ref $how eq "ARRAY") {
    100          
    100          
965 1         11 my %hash = map { $_ => 1 } @$how;
  5         54  
966 1     2   2597 $class->add_constraint(list => $col => sub { exists $hash{ +shift } });
  2         32  
967             } elsif (ref $how eq "Regexp") {
968 1     5   21 $class->add_constraint(regexp => $col => sub { shift =~ $how });
  5         2549  
969             } elsif (ref $how eq "CODE") {
970             $class->add_constraint(
971 1     2   22 code => $col => sub { local $_ = $_[0]; $how->($_) });
  2         20  
  2         26  
972             } else {
973 1         21 my $try_method = sprintf '_constrain_by_%s', $how->moniker;
974 1 50       81 if (my $dispatch = $class->can($try_method)) {
975 1         14 $class->$dispatch($col => ($how, @_));
976             } else {
977 0         0 $class->_croak("Don't know how to constrain $col with $how");
978             }
979             }
980             }
981              
982             sub add_constraint {
983 11     11   955 my $class = shift;
984 11 50       122 $class->_invalid_object_method('add_constraint()') if ref $class;
985 11 100       319 my $name = shift or return $class->_croak("Constraint needs a name");
986 10 100       136 my $column = $class->find_column(+shift)
987             or return $class->_croak("Constraint $name needs a valid column");
988 8 100       199 my $code = shift
989             or return $class->_croak("Constraint $name needs a code reference");
990 7 100       96 return $class->_croak("Constraint $name '$code' is not a code reference")
991             unless ref($code) eq "CODE";
992              
993 6         78 $column->is_constrained(1);
994             $class->add_trigger(
995             "before_set_$column" => sub {
996 17     17   12101 my ($self, $value, $column_values) = @_;
997 17 100       288 $code->($value, $self, $column, $column_values)
998             or return $self->_croak(
999             "$class $column fails '$name' constraint with '$value'",
1000             method         => "before_set_$column",
1001             exception_type => 'constraint_failure',
1002             data           => {
1003             column          => $column,
1004             value           => $value,
1005             constraint_name => $name,
1006             }
1007             );
1008             }
1009 6         60 );
1010             }
1011              
1012             sub add_trigger {
1013 105     105   2679 my ($self, $name, @args) = @_;
1014 105 100       12880 return $self->_croak("on_setting trigger no longer exists")
1015             if $name eq "on_setting";
1016 104 100 100     2074 $self->_carp(
1017             "$name trigger deprecated: use before_$name or after_$name instead")
1018             if ($name eq "create" or $name eq "delete");
1019 104         1977 $self->SUPER::add_trigger($name => @args);
1020             }
1021              
1022             #----------------------------------------------------------------------
1023             # Inflation
1024             #----------------------------------------------------------------------
1025              
1026             sub add_relationship_type {
1027 25     25   518 my ($self, %rels) = @_;
1028 25         485 while (my ($name, $class) = each %rels) {
1029 73         1083 $self->_require_class($class);
1030 24     24   639 no strict 'refs';
  24         241  
  24         461  
1031 73         2123 *{"$self\::$name"} = sub {
1032 33     33   1092 my $proto = shift;
1033 33         812 $class->set_up($name => $proto => @_);
1034 73         2317 };
1035             }
1036             }
1037              
1038             sub _extend_meta {
1039 30     30   333 my ($class, $type, $subtype, $val) = @_;
1040 30   50     289 my %hash = %{ Clone::clone($class->__meta_info || {}) };
  30         594  
1041 30         862 $hash{$type}->{$subtype} = $val;
1042 30         607 $class->__meta_info(\%hash);
1043             }
1044              
1045             sub meta_info {
1046 176     176   6808 my ($class, $type, $subtype) = @_;
1047 176         4796 my $meta = $class->__meta_info;
1048 176 100       5959 return $meta unless $type;
1049 175 100       4998 return $meta->{$type} unless $subtype;
1050 164         5001 return $meta->{$type}->{$subtype};
1051             }
1052              
1053             sub _simple_bless {
1054 36     36   4000 my ($class, $pri) = @_;
1055 36         518 return $class->_init({ $class->primary_column => $pri });
1056             }
1057              
1058             sub _deflated_column {
1059 157     157   3883 my ($self, $col, $val) = @_;
1060 157 100 33     2371 $val ||= $self->_attrs($col) if ref $self;
1061 157 100       3528 return $val unless ref $val;
1062 34 100       426 my $meta = $self->meta_info(has_a => $col) or return $val;
1063 32         836 my ($a_class, %meths) = ($meta->foreign_class, %{ $meta->args });
  32         1396  
1064 32 100       806 if (my $deflate = $meths{'deflate'}) {
1065 3 100       48 $val = $val->$deflate(ref $deflate eq 'CODE' ? $self : ());
1066 3 100       103 return $val unless ref $val;
1067             }
1068 30 100       452 return $self->_croak("Can't deflate $col: $val is not a $a_class")
1069             unless UNIVERSAL::isa($val, $a_class);
1070 28 50       577 return $val->id if UNIVERSAL::isa($val => 'Class::DBI');
1071 0         0 return "$val";
1072             }
1073              
1074             #----------------------------------------------------------------------
1075             # SEARCH
1076             #----------------------------------------------------------------------
1077              
1078 8     8   123 sub retrieve_all { shift->sth_to_objects('RetrieveAll') }
1079              
1080             sub retrieve_from_sql {
1081 2     2   51 my ($class, $sql, @vals) = @_;
1082 2         27 $sql =~ s/^\s*(WHERE)\s*//i;
1083 2         30 return $class->sth_to_objects($class->sql_Retrieve($sql), \@vals);
1084             }
1085              
1086             sub add_searcher {
1087 24     24   300 my ($self, %rels) = @_;
1088 24         538 while (my ($name, $class) = each %rels) {
1089 24         320 $self->_require_class($class);
1090 24 50       731 $self->_croak("$class is not a valid Searcher")
1091             unless $class->can('run_search');
1092 24     24   692 no strict 'refs';
  24         266  
  24         402  
1093 24         524 *{"$self\::$name"} = sub {
1094 103     103   1726 $class->new(@_)->run_search;
1095 24         358 };
1096             }
1097             }
1098              
1099             # This should really be its own Search subclass. But the _do_search
1100             # version has been publicised as the way to do this. We need to
1101             # deprecate this eventually.
1102              
1103 3     3   69 sub search_like { shift->_do_search(LIKE => @_) }
1104              
1105             sub _do_search {
1106 3     3   40 my ($class, $type, @args) = @_;
1107 3         38 $class->_require_class('Class::DBI::Search::Basic');
1108 3         42 my $search = Class::DBI::Search::Basic->new($class, @args);
1109 3         42 $search->type($type);
1110 3         89 $search->run_search;
1111             }
1112              
1113             #----------------------------------------------------------------------
1114             # CONSTRUCTORS
1115             #----------------------------------------------------------------------
1116              
1117             sub add_constructor {
1118 11     11   199 my ($class, $method, $fragment) = @_;
1119 11 100       133 return $class->_croak("constructors needs a name") unless $method;
1120 24     24   461 no strict 'refs';
  24         235  
  24         336  
1121 10         119 my $meth = "$class\::$method";
1122 10 50       152 return $class->_carp("$method already exists in $class")
1123             if *$meth{CODE};
1124             *$meth = sub {
1125 7     7   160 my $self = shift;
1126 7         108 $self->sth_to_objects($self->sql_Retrieve($fragment), \@_);
1127 10         183 };
1128             }
1129              
1130             sub sth_to_objects {
1131 134     134   1989 my ($class, $sth, $args) = @_;
1132 134 50       3184 $class->_croak("sth_to_objects needs a statement handle") unless $sth;
1133 134 100       2916 unless (UNIVERSAL::isa($sth => "DBI::st")) {
1134 12         166 my $meth = "sql_$sth";
1135 12         207 $sth = $class->$meth();
1136             }
1137 134         2877 my (%data, @rows);
1138 134         1395 eval {
1139 134 100       4067 $sth->execute(@$args) unless $sth->{Active};
1140 134         60950 $sth->bind_columns(\(@data{ @{ $sth->{NAME_lc} } }));
  134         2073  
1141 134         11456 push @rows, {%data} while $sth->fetch;
1142             };
1143 134 50       2182 return $class->_croak("$class can't $sth->{Statement}: $@", err => $@)
1144             if $@;
1145 134         2629 return $class->_ids_to_objects(\@rows);
1146             }
1147             *_sth_to_objects = \&sth_to_objects;
1148              
1149             sub _my_iterator {
1150 29     29   268 my $self = shift;
1151 29         455 my $class = $self->iterator_class;
1152 29         838 $self->_require_class($class);
1153 29         466 return $class;
1154             }
1155              
1156             sub _ids_to_objects {
1157 134     134   2003 my ($class, $data) = @_;
1158 134 50       3648 return $#$data + 1 unless defined wantarray;
1159 134 100       2380 return map $class->construct($_), @$data if wantarray;
1160 29         472 return $class->_my_iterator->new($class => $data);
1161             }
1162              
1163             #----------------------------------------------------------------------
1164             # SINGLE VALUE SELECTS
1165             #----------------------------------------------------------------------
1166              
1167             sub _single_row_select {
1168 0     0   0 my ($self, $sth, @args) = @_;
1169 0         0 Carp::confess("_single_row_select is deprecated in favour of select_row");
1170 0         0 return $sth->select_row(@args);
1171             }
1172              
1173             sub _single_value_select {
1174 0     0   0 my ($self, $sth, @args) = @_;
1175 0         0 $self->_carp("_single_value_select is deprecated in favour of select_val");
1176 0         0 return $sth->select_val(@args);
1177             }
1178              
1179 0     0   0 sub count_all { shift->sql_single("COUNT(*)")->select_val }
1180              
1181             sub maximum_value_of {
1182 0     0   0 my ($class, $col) = @_;
1183 0         0 $class->sql_single("MAX($col)")->select_val;
1184             }
1185              
1186             sub minimum_value_of {
1187 0     0   0 my ($class, $col) = @_;
1188 0         0 $class->sql_single("MIN($col)")->select_val;
1189             }
1190              
1191             sub _unique_entries {
1192 0     0   0 my ($class, %tmp) = shift;
1193 0         0 return grep !$tmp{$_}++, @_;
1194             }
1195              
1196             sub _invalid_object_method {
1197 1     1   10 my ($self, $method) = @_;
1198 1         17 $self->_carp(
1199             "$method should be called as a class method not an object method");
1200             }
1201              
1202             #----------------------------------------------------------------------
1203             # misc stuff
1204             #----------------------------------------------------------------------
1205              
1206             sub _extend_class_data {
1207 29     29   899 my ($class, $struct, $key, $value) = @_;
1208 29 100       268 my %hash = %{ $class->$struct() || {} };
  29         634  
1209 29         543 $hash{$key} = $value;
1210 29         680 $class->$struct(\%hash);
1211             }
1212              
1213             my %required_classes; # { required_class => class_that_last_required_it, ... }
1214              
1215             sub _require_class {
1216 613     613   8279 my ($self, $load_class) = @_;
1217 613   33     14115 $required_classes{$load_class} ||= my $for_class = ref($self) || $self;
      100        
1218              
1219             # return quickly if class already exists
1220 24     24   831 no strict 'refs';
  24         318  
  24         554  
1221 613 100       17018 return if exists ${"$load_class\::"}{ISA};
  613         11514  
1222 568         22334 (my $load_module = $load_class) =~ s!::!/!g;
1223 568 100       8595 return if eval { require "$load_module.pm" };
  568         19121  
1224              
1225             # Only ignore "Can't locate" errors for the specific module we're loading
1226 1 50       46 return if $@ =~ /^Can't locate \Q$load_module\E\.pm /;
1227              
1228             # Other fatal errors (syntax etc) must be reported (as per base.pm).
1229 0           chomp $@;
1230              
1231             # This error message prefix is especially handy when dealing with
1232             # classes that are being loaded by other classes recursively.
1233             # The final message shows the path, e.g.:
1234             # Foo can't load Bar: Bar can't load Baz: syntax error at line ...
1235 0           $self->_croak("$for_class can't load $load_class: $@");
1236             }
1237              
1238             sub _check_classes { # may automatically call from CHECK block in future
1239 0     0     while (my ($load_class, $by_class) = each %required_classes) {
1240 0 0         next if $load_class->isa("Class::DBI");
1241 0           $by_class->_croak(
1242             "Class $load_class used by $by_class has not been loaded");
1243             }
1244             }
1245              
1246             1;
1247              
1248             __END__
1249            
1250             =head1 NAME
1251            
1252             Class::DBI - Simple Database Abstraction
1253            
1254             =head1 SYNOPSIS
1255            
1256             package Music::DBI;
1257             use base 'Class::DBI';
1258             Music::DBI->connection('dbi:mysql:dbname', 'username', 'password');
1259            
1260             package Music::Artist;
1261             use base 'Music::DBI';
1262             Music::Artist->table('artist');
1263             Music::Artist->columns(All => qw/artistid name/);
1264             Music::Artist->has_many(cds => 'Music::CD');
1265            
1266             package Music::CD;
1267             use base 'Music::DBI';
1268             Music::CD->table('cd');
1269             Music::CD->columns(All => qw/cdid artist title year reldate/);
1270             Music::CD->has_many(tracks => 'Music::Track');
1271             Music::CD->has_a(artist => 'Music::Artist');
1272             Music::CD->has_a(reldate => 'Time::Piece',
1273             inflate => sub { Time::Piece->strptime(shift, "%Y-%m-%d") },
1274             deflate => 'ymd',
1275             );
1276            
1277             Music::CD->might_have(liner_notes => LinerNotes => qw/notes/);
1278            
1279             package Music::Track;
1280             use base 'Music::DBI';
1281             Music::Track->table('track');
1282             Music::Track->columns(All => qw/trackid cd position title/);
1283            
1284             #-- Meanwhile, in a nearby piece of code! --#
1285            
1286             my $artist = Music::Artist->insert({ artistid => 1, name => 'U2' });
1287            
1288             my $cd = $artist->add_to_cds({
1289             cdid => 1,
1290             title => 'October',
1291             year => 1980,
1292             });
1293            
1294             # Oops, got it wrong.
1295             $cd->year(1981);
1296             $cd->update;
1297            
1298             # etc.
1299