File Coverage

blib/lib/DBIx/DataModel/Schema.pm
Criterion Covered Total %
statement 189 206 91.7
branch 56 84 66.6
condition 15 27 55.5
subroutine 45 47 95.7
pod 5 8 62.5
total 310 372 83.3


line stmt bran cond sub pod time code
1             #----------------------------------------------------------------------
2             package DBIx::DataModel::Schema;
3             #----------------------------------------------------------------------
4              
5             # see POD doc at end of file
6             # version : see DBIx::DataModel
7              
8 18     18   8240 use warnings;
  18         45  
  18         653  
9 18     18   100 use strict;
  18         38  
  18         470  
10 18     18   98 use DBIx::DataModel::Meta::Utils qw/does/;
  18         32  
  18         884  
11 18     18   9395 use DBIx::DataModel::Source::Table;
  18         51  
  18         642  
12              
13 18     18   131 use Scalar::Util qw/blessed/;
  18         44  
  18         1050  
14 18     18   9616 use Data::Structure::Util; # for calling unbless(), fully qualified
  18         61460  
  18         1043  
15 18     18   143 use Module::Load qw/load/;
  18         54  
  18         133  
16 18         1409 use Params::Validate qw/validate_with SCALAR ARRAYREF CODEREF UNDEF
17 18     18   1448 OBJECT BOOLEAN/;
  18         44  
18              
19 18     18   118 use Carp::Clan qw[^(DBIx::DataModel::|SQL::Abstract)];
  18         89  
  18         160  
20              
21 18     18   1755 use SQL::Abstract::More 1.39;
  18         519  
  18         150  
22 18     18   806 use Try::Tiny;
  18         40  
  18         1178  
23 18     18   130 use mro qw/c3/;
  18         55  
  18         164  
24              
25 18     18   631 use namespace::clean;
  18         42  
  18         131  
26              
27              
28             my $spec = {
29             dbh => {type => OBJECT|ARRAYREF, optional => 1},
30             debug => {type => OBJECT|SCALAR, optional => 1},
31             sql_abstract => {type => OBJECT,
32             isa => 'SQL::Abstract::More',
33             optional => 1},
34             dbi_prepare_method => {type => SCALAR, default => 'prepare'},
35             placeholder_prefix => {type => SCALAR, default => '?:'},
36             select_implicitly_for => {type => SCALAR, default => ''},
37             autolimit_firstrow => {type => BOOLEAN, optional => 1},
38             db_schema => {type => SCALAR, optional => 1},
39             resultAs_classes => {type => ARRAYREF, optional => 1},
40             };
41              
42              
43              
44             sub new {
45 17     17 0 160 my $class = shift;
46              
47             not $class->metadm->{singleton}
48 17 50       63 or croak "$class is already used in single-schema mode, can't call new()";
49              
50             # validate params
51 17         731 my %params = validate_with(
52             params => \@_,
53             spec => $spec,
54             allow_extra => 0,
55             );
56              
57             # instantiate and call 'setter' methods for %params
58 17         131 my $self = bless {}, $class;
59 17         135 while (my ($method, $arg) = each %params) {
60 56         340 $self->$method($arg);
61             }
62              
63             # default SQLA
64 17   66     200 $self->{sql_abstract} ||= SQL::Abstract::More->new;
65              
66             # default resultAs_classes
67 17   33     4622 $self->{resultAs_classes} ||= mro::get_linear_isa($class);
68              
69             # from now on, singleton mode will be forbidden
70 17         85 $class->metadm->{singleton} = undef;
71              
72 17         83 return $self;
73             }
74              
75              
76             # proxy methods, forwarded to the meta-schema
77             foreach my $method (qw/Table View Association Composition Type/) {
78 18     18   12286 no strict 'refs';
  18         48  
  18         10217  
79             *{$method} = sub {
80 86     86   16869 my $class = shift;
81 86 50       236 not ref $class or croak "$method() is a class method";
82 86         271 $class->metadm->$method(@_);
83             }
84             }
85              
86              
87             sub singleton {
88 827     827 1 11680 my $class = shift;
89 827         2073 my $metadm = $class->metadm;
90              
91 827 100       2867 if (!$metadm->{singleton}) {
    50          
92             not exists $metadm->{singleton}
93 16 50       68 or croak "attempt to call a class method in single-schema mode after "
94             . "Schema::new() has been called; instead, use an instance "
95             . "method : \$schema->table(\$name)->method(...)";
96 16         111 $metadm->{singleton} = $class->new(@_);
97 16         48 $metadm->{singleton}{is_singleton} = 1;
98             }
99             elsif (@_) {
100 0         0 croak "can't pass args to ->singleton(..) after first call";
101             }
102 827         3209 return $metadm->{singleton};
103             }
104              
105              
106              
107             #----------------------------------------------------------------------
108             # RUNTIME METHODS
109             #----------------------------------------------------------------------
110              
111             sub dbh {
112 335     335 1 55107 my ($self, $dbh, %dbh_options) = @_;
113              
114 335 100       955 ref $self or $self = $self->singleton;
115              
116             # if some args, then this is a "setter" (updating the dbh)
117 335 100       895 if (@_ > 1) {
118              
119             # also support syntax ->dbh([$dbh, %dbh_options])
120 26 100 66     115 ($dbh, %dbh_options) = @$dbh
121             if does($dbh, 'ARRAY') && ! keys %dbh_options;
122              
123             # forbid change of dbh while doing a transaction
124             not $self->{dbh} or $self->{dbh}[0]{AutoCommit}
125 26 50 66     1940 or croak "cannot change dbh(..) while in a transaction";
126              
127 26 100       240 if ($dbh) {
128             # $dbh must be a database handle
129 24 50       191 $dbh->isa('DBI::db')
130             or croak "invalid dbh argument";
131              
132             # only accept $dbh with RaiseError set
133             $dbh->{RaiseError}
134 24 50       379 or croak "arg to dbh(..) must have RaiseError=1";
135              
136             # default values for $dbh_options{returning_through}
137 24 50       909 if (not exists $dbh_options{returning_through}) {
138 24         144 for ($dbh->{Driver}{Name}) {
139 24 50       691 /^Oracle/ and do {$dbh_options{returning_through} = 'INOUT'; last};
  0         0  
  0         0  
140 24 50       130 /^Pg/ and do {$dbh_options{returning_through} = 'FETCH'; last};
  0         0  
  0         0  
141             }
142             }
143              
144             # store the dbh
145 24         146 $self->{dbh} = [$dbh, %dbh_options];
146             }
147             else {
148             # $dbh was explicitly undef, so remove previous dbh
149 2         8 delete $self->{dbh};
150             }
151             }
152              
153 335   100     876 my $return_dbh = $self->{dbh} || [];
154 335 100       2192 return wantarray ? @$return_dbh : $return_dbh->[0];
155             }
156              
157              
158              
159             # some rw setters/getters
160             my @accessors = qw/debug select_implicitly_for dbi_prepare_method
161             sql_abstract placeholder_prefix autolimit_firstrow
162             db_schema resultAs_classes/;
163             foreach my $accessor (@accessors) {
164 18     18   147 no strict 'refs';
  18         100  
  18         12854  
165             *$accessor = sub {
166 1471     1471   2566 my $self = shift;
167 1471 50       3150 ref $self or $self = $self->singleton;
168              
169 1471 100       2972 if (@_) {
170 62         293 $self->{$accessor} = shift;
171             }
172 1471         5562 return $self->{$accessor};
173             };
174             }
175              
176              
177             sub with_db_schema {
178 0     0 0 0 my ($self, $db_schema) = @_;
179 0 0       0 ref $self or $self = $self->singleton;
180              
181             # return a shallow copy of $self with db_schema set to the given arg
182 0         0 return bless { %$self, db_schema => $db_schema}, ref $self;
183             }
184              
185              
186             my @default_state_components = qw/dbh debug select_implicitly_for
187             dbi_prepare_method db_schema/;
188              
189             sub localize_state {
190 3     3 1 13 my ($self, @components) = @_;
191 3 100       34 ref $self or $self = $self->singleton;
192              
193 3 100       37 @components = @default_state_components unless @components;
194              
195 3         10 my %saved_state;
196 3         19 $saved_state{$_} = $self->{$_} foreach @components;
197              
198 3         48 return DBIx::DataModel::Schema::_State->new($self, \%saved_state);
199             }
200              
201              
202              
203              
204             sub do_after_commit {
205 3     3 0 491 my ($self, $coderef) = @_;
206 3 50       14 ref $self or $self = $self->singleton;
207              
208             $self->{transaction_dbhs}
209 3 50       8 or croak "do_after_commit() called outside of a transaction";
210 3         6 push @{$self->{after_commit_callbacks}}, $coderef;
  3         11  
211             }
212              
213              
214             sub do_transaction {
215 25     25 1 6447 my ($self, $coderef, @new_dbh) = @_;
216 25 50       104 ref $self or $self = $self->singleton;
217              
218 25 50       98 does($coderef, 'CODE')
219             or croak 'first arg to $schema->do_transaction(...) should be a coderef';
220              
221 25   100     309 my $transaction_dbhs = $self->{transaction_dbhs} ||= [];
222              
223             # localize the dbh and its options, if so requested.
224             my $local_state = $self->localize_state(qw/dbh/)
225             and
226 25 100 33     77 delete($self->{dbh}), # cheat so that dbh() does not complain
227             $self->dbh(@new_dbh) # and now update the dbh
228             if @new_dbh; # postfix "if" because $local_state must not be in a block
229              
230             # check that we have a dbh
231 25 50       62 my $dbh = $self->dbh
232             or croak "no database handle for transaction";
233              
234             # how to call and how to return will depend on context
235 25 100       82 my $want = wantarray ? "array" : defined(wantarray) ? "scalar" : "void";
    100          
236             my $in_context = {
237 25         34 array => do {my @array;
238 8     8   25 {call => sub {@array = $coderef->()},
239 25     8   168 return => sub {return @array}}},
  8         253  
240 25         45 scalar => do {my $scalar;
241 12     12   36 {call => sub {$scalar = $coderef->()},
242 25     12   240 return => sub {return $scalar}}},
  12         94  
243 5     5   17 void => {call => sub {$coderef->()},
244 0     0   0 return => sub {return}}
245 25         43 }->{$want};
246              
247              
248             my $begin_work_and_exec = sub {
249             # make sure dbh is in transaction mode
250 25 100   25   134 if ($dbh->{AutoCommit}) {
251 15         302 $dbh->begin_work; # will set AutoCommit to false
252 15         5830 push @$transaction_dbhs, $dbh;
253             }
254              
255             # do the real work
256 25         251 $in_context->{call}->();
257 25         233 };
258              
259 25 100       80 if (@$transaction_dbhs) { # if in a nested transaction, just exec
260 12         27 $begin_work_and_exec->();
261             }
262             else { # else try to execute and commit in an eval block
263              
264             # support for DBIx::RetryOverDisconnects: decide how many retries
265 13         24 my $n_retries = 1;
266 13 50       106 if ($dbh->isa('DBIx::RetryOverDisconnects::db')) {
267 0         0 $n_retries = $dbh->{DBIx::RetryOverDisconnects::PRIV()}{txn_retries};
268             }
269              
270             # try to do the transaction, maybe several times in cas of disconnection
271             RETRY:
272 13         42 for my $retry (1 .. $n_retries) {
273 18     18   152 no warnings 'exiting'; # because "last/next" are in Try::Tiny subroutines
  18         87  
  18         9414  
274             try {
275             # check AutoCommit state
276             $dbh->{AutoCommit}
277 13 50   13   705 or croak "dbh was not in Autocommit mode before initial transaction";
278              
279             # execute the transaction
280 13         357 $begin_work_and_exec->();
281              
282             # commit all dbhs and then reset the list of dbhs
283 8         78 $_->commit foreach @$transaction_dbhs;
284 8         3513 delete $self->{transaction_dbhs};
285              
286 8         304 last RETRY; # transaction successful, get out of the loop
287             }
288             catch {
289 5     5   135 my $err = $_;
290              
291             # if this was a disconnection ..
292 5 50 33     46 if ($dbh->isa('DBIx::RetryOverDisconnects::db')
293             # $dbh->can() is broken on DBI handles, so use ->isa() instead
294             && $dbh->is_trans_disconnect) {
295 0         0 $transaction_dbhs = [];
296 0 0       0 next RETRY if $retry < $n_retries; # .. try again
297 0         0 $self->exc_conn_trans_fatal->throw; # .. or no hope (and no rollback)
298             }
299              
300             # otherwise, for regular SQL errors, try to rollback and then throw
301 5         11 my @rollback_errs;
302 5         13 foreach my $dbh (reverse @$transaction_dbhs) {
303 5         265 try {$dbh->rollback}
304 5         32 catch {push @rollback_errs, $_};
  0         0  
305             }
306 5         1886 delete $self->{transaction_dbhs};
307 5         12 delete $self->{after_commit_callbacks};
308 5         28 DBIx::DataModel::Schema::_Exception->throw($err, @rollback_errs);
309 13         128 };
310             }
311             }
312              
313             # execute the after_commit callbacks
314 20   100     642 my $callbacks = delete $self->{after_commit_callbacks} || [];
315 20         75 $_->() foreach @$callbacks;
316              
317 20         55 return $in_context->{return}->();
318             }
319              
320              
321             sub unbless {
322 32     32 1 108 my $class = shift;
323 32         146 Data::Structure::Util::unbless($_) foreach @_;
324              
325 32 100       407 return wantarray ? @_ : $_[0];
326             }
327              
328              
329             # accessors to connected sources (tables or joins) from the current schema
330             # local method metadm method
331             # ============ =============
332             my %accessor_map = (table => 'table',
333             join => 'define_join',
334             db_table => 'db_table');
335             while (my ($local, $remote) = each %accessor_map) {
336 18     18   151 no strict 'refs';
  18         44  
  18         6910  
337             *$local = sub {
338 103     103   490169 my $self = shift;
339 103 100       526 ref $self or $self = $self->singleton;
340              
341 103 100       322 my $meta_source = $self->metadm->$remote(@_) or return;
342 100         533 my $obj = bless {__schema => $self}, $meta_source->class;
343 100         1162 return $obj;
344             }
345             }
346              
347             #----------------------------------------------------------------------
348             # UTILITY FUNCTIONS (PRIVATE)
349             #----------------------------------------------------------------------
350              
351              
352             sub _debug { # internal method to send debug messages
353 208     208   505 my ($self, $msg) = @_;
354 208         622 my $debug = $self->debug;
355 208 50       640 if ($debug) {
356 0 0 0     0 if (ref $debug && $debug->can('debug')) { $debug->debug($msg) }
  0         0  
357 0         0 else { carp $msg; }
358             }
359             }
360              
361              
362              
363              
364              
365             #----------------------------------------------------------------------
366             # PRIVATE CLASS FOR LOCALIZING STATE (see L method
367             #----------------------------------------------------------------------
368              
369             package
370             DBIx::DataModel::Schema::_State;
371              
372             sub new {
373 3     3   10 my ($class, $schema, $state) = @_;
374 3         54 bless [$schema, $state], $class;
375             }
376              
377              
378             sub DESTROY { # called when the guard goes out of scope
379 3     3   34 my ($self) = @_;
380              
381             # localize $@, in case we were called while dying - see L
382 3         9 local $@;
383              
384 3         15 my ($schema, $previous_state) = @$self;
385              
386             # must cleanup dbh so that ->dbh(..) does not complain if in a transaction
387 3 50       12 if (exists $previous_state->{dbh}) {
388 3         11 delete $schema->{dbh};
389             }
390              
391             # invoke "setter" method on each state component
392 3         25 $schema->$_($previous_state->{$_}) foreach keys %$previous_state;
393             }
394              
395              
396             #----------------------------------------------------------------------
397             # PRIVATE CLASS FOR TRANSACTION EXCEPTIONS
398             #----------------------------------------------------------------------
399              
400             package
401             DBIx::DataModel::Schema::_Exception;
402 18     18   145 use strict;
  18         52  
  18         630  
403 18     18   113 use warnings;
  18         48  
  18         2235  
404              
405             use overload '""' => sub {
406 4     4   119 my $self = shift;
407 4         12 my $err = $self->initial_error;
408 4         11 my @rollback_errs = $self->rollback_errors;
409 4 50       22 my $rollback_status = @rollback_errs ? join(", ", @rollback_errs) : "OK";
410 4         43 return "FAILED TRANSACTION: $err (rollback: $rollback_status)";
411 18     18   140 };
  18         52  
  18         283  
412              
413              
414             sub throw {
415 5     5   11 my $class = shift;
416 5         15 my $self = bless [@_], $class;
417 5         38 die $self;
418             }
419              
420             sub initial_error {
421 6     6   43 my $self = shift;
422 6         30 return $self->[0];
423             }
424              
425             sub rollback_errors {
426 6     6   13 my $self = shift;
427 6         12 return @$self[1..$#{$self}];
  6         26  
428             }
429              
430              
431             1;
432              
433             __END__