File Coverage

blib/lib/DBIx/DataModel/Source/Table.pm
Criterion Covered Total %
statement 258 289 89.2
branch 76 118 64.4
condition 40 67 59.7
subroutine 26 27 96.3
pod 3 5 60.0
total 403 506 79.6


line stmt bran cond sub pod time code
1             ## TODO: -returning => [], meaning return a list of arrayrefs containing primKeys
2              
3              
4             package DBIx::DataModel::Source::Table;
5              
6 18     18   129 use warnings;
  18         37  
  18         658  
7 18     18   112 no warnings 'uninitialized';
  18         42  
  18         637  
8 18     18   101 use strict;
  18         52  
  18         574  
9 18     18   111 use parent 'DBIx::DataModel::Source';
  18         38  
  18         119  
10 18     18   1418 use Module::Load qw/load/;
  18         49  
  18         109  
11 18     18   1157 use List::MoreUtils qw/none/;
  18         60  
  18         150  
12 18     18   12866 use Params::Validate qw/validate_with HASHREF/;
  18         43  
  18         1124  
13 18     18   187 use DBIx::DataModel::Meta::Utils qw/does/;
  18         48  
  18         967  
14 18     18   122 use Carp::Clan qw[^(DBIx::DataModel::|SQL::Abstract)];
  18         60  
  18         160  
15              
16 18     18   1683 use namespace::clean;
  18         40  
  18         140  
17              
18              
19             #------------------------------------------------------------
20             # insert
21             #------------------------------------------------------------
22              
23             sub insert {
24 23     23 1 61738 my $self = shift;
25              
26 23 50       104 $self->_is_called_as_class_method
27             or croak "insert() should be called as a class method";
28 23   66     117 my $class = ref $self || $self;
29              
30             # end of list may contain options, recognized because option name is a scalar
31 23         176 my $options = $self->_parse_ending_options(\@_, qr/^-returning$/);
32 23         149 my $want_subhash = does($options->{-returning}, 'HASH');
33              
34             # records to insert
35 23         265 my @records = @_;
36 23 50       67 @records or croak "insert(): no record to insert";
37              
38 23         76 my $got_records_as_arrayrefs = does($records[0], 'ARRAY');
39              
40             # if data is received as arrayrefs, transform it into a list of hashrefs.
41             # NOTE : this is a bit stupid; a more efficient implementation
42             # would be to prepare one single DB statement and then execute it on
43             # each data row, or even SQL like INSERT ... VALUES(...), VALUES(..), ...
44             # (supported by some DBMS), but that would require some refactoring
45             # of _singleInsert and _rawInsert.
46 23 100       226 if ($got_records_as_arrayrefs) {
47 2         5 my $header_row = shift @records;
48 2         4 my $n_headers = @$header_row;
49 2         6 foreach my $data_row (@records) {
50 6 50       15 does($data_row, 'ARRAY')
51             or croak "data row after a header row should be an arrayref";
52 6         46 my $n_vals = @$data_row;
53 6 50       14 $n_vals == $n_headers
54             or croak "insert([\@headers],[\@row1],...): "
55             ."got $n_vals values for $n_headers headers";
56 6         10 my %real_record;
57 6         16 @real_record{@$header_row} = @$data_row;
58 6         15 $data_row = \%real_record;
59             }
60             }
61              
62             # insert each record, one by one
63 23         39 my @results;
64 23         79 my $meta_source = $self->metadm;
65 23         112 my %no_update_column = $meta_source->no_update_column;
66 23         113 my %auto_insert_column = $meta_source->auto_insert_column;
67 23         88 my %auto_update_column = $meta_source->auto_update_column;
68              
69 23         88 my $schema = $self->schema;
70 23         86 while (my $record = shift @records) {
71              
72             # TODO: shallow copy in order not to perturb the caller
73             # BUT : if the insert injects a primary key, we want to retrieve it !
74             # SO => contradiction
75             # $record = {%$record} unless $got_records_as_arrayrefs;
76              
77             # bless, apply column handers and remove unwanted cols
78 31         70 bless $record, $class;
79 31         158 $record->apply_column_handler('to_DB');
80 31         145 delete $record->{$_} foreach keys %no_update_column;
81 31         130 while (my ($col, $handler) = each %auto_insert_column) {
82 2         9 $record->{$col} = $handler->($record, $class);
83             }
84 31         123 while (my ($col, $handler) = each %auto_update_column) {
85 4         17 $record->{$col} = $handler->($record, $class);
86             }
87              
88             # inject schema
89 31         84 $record->{__schema} = $schema;
90              
91             # remove subtrees (they will be inserted later)
92 31         140 my $subrecords = $record->_weed_out_subtrees;
93              
94             # do the insertion. The result depends on %$options.
95 31         138 my @single_result = $record->_singleInsert(%$options);
96              
97             # NOTE: at this point, $record is expected to hold its own primary key
98              
99             # insert the subtrees into DB, and keep the return vals if $want_subhash
100 31 100       435 if ($subrecords) {
101 4         42 my $subresults = $record->_insert_subtrees($subrecords, %$options);
102 4 100       36 if ($want_subhash) {
103 2 50       23 does($single_result[0], 'HASH')
104             or die "_single_insert(..., -returning => {}) "
105             . "did not return a hashref";
106 2         34 $single_result[0]{$_} = $subresults->{$_} for keys %$subresults;
107             }
108             }
109              
110 31         133 push @results, @single_result;
111             }
112              
113             # choose what to return according to context
114 23 100       92 return @results if wantarray; # list context
115 17 100       88 return if not defined wantarray; # void context
116 6 50       19 carp "insert({...}, {...}, ..) called in scalar context" if @results > 1;
117 6         33 return $results[0]; # scalar context
118             }
119              
120              
121             sub _singleInsert {
122 31     31   83 my ($self, %options) = @_;
123              
124             # check that this is called as instance method
125 31 50       106 my $class = ref $self or croak "_singleInsert called as class method";
126              
127             # get dbh option
128 31         90 my ($dbh, %dbh_options) = $self->schema->dbh;
129 31   50     145 my $returning_through = $dbh_options{returning_through} || '';
130              
131             # check special case "-returning => {}", not to be handled in _rawInsert
132 31   100     113 my $ref_returning = ref $options{-returning} || '';
133             my $wants_consolidated_hash = $ref_returning eq 'HASH'
134 31   66     104 && ! keys %{$options{-returning}};
135 31 100       81 delete $options{-returning} if $wants_consolidated_hash;
136              
137             # do we need to retrieve the primary key ourselves ?
138 31         132 my @prim_key_cols = $class->primary_key;
139 31         55 my @prim_key_vals;
140 31     31   155 my $should_retrieve_prim_key = (none {defined $self->{$_}} @prim_key_cols)
141 31   66     217 && ! exists $options{-returning};
142              
143             # add a RETURNING clause if needed, to later retrieve the primary key
144 31 100       134 if ($should_retrieve_prim_key) {
145 27 50       112 if ($returning_through eq 'INOUT') { # example: Oracle
    50          
146 0         0 @prim_key_vals = (undef) x @prim_key_cols;
147 0         0 my %returning;
148 0         0 @returning{@prim_key_cols} = \(@prim_key_vals);
149 0         0 $options{-returning} = \%returning;
150             }
151             elsif ($returning_through eq 'FETCH') { # example: PostgreSQL
152 0         0 $options{-returning} = \@prim_key_cols;
153             }
154             # else : do nothing, we will use "last_insert_id"
155             }
156              
157             # call database insert
158 31         134 my $sth = $self->_rawInsert(%options);
159              
160             # get back the "returning" values, if any
161 31         64 my @returned_vals;
162 31 50 33     157 if ($options{-returning} && !does($options{-returning}, 'HASH')) {
163 0         0 @returned_vals = $sth->fetchrow_array;
164 0         0 $sth->finish;
165             }
166              
167             # if needed, retrieve the primary key
168 31 100       85 if ($should_retrieve_prim_key) {
169 27 50       88 if ($returning_through eq 'INOUT') { # example: Oracle
    50          
170 0         0 @{$self}{@prim_key_cols} = @prim_key_vals;
  0         0  
171             }
172             elsif ($returning_through eq 'FETCH') { # example: PostgreSQL
173 0         0 @{$self}{@prim_key_cols} = @returned_vals;
  0         0  
174             }
175             else {
176 27         49 my $n_columns = @prim_key_cols;
177 27 50       71 not ($n_columns > 1)
178             or croak "cannot ask for last_insert_id: primary key in $class "
179             . "has $n_columns columns";
180 27         46 my $pk_col = $prim_key_cols[0];
181 27         101 $self->{$pk_col} = $self->_get_last_insert_id($pk_col);
182             }
183             }
184              
185             # return value
186 31 100       100 if ($wants_consolidated_hash) {
    50          
187 6         14 my %result;
188 6         23 $result{$_} = $self->{$_} for @prim_key_cols;
189 6         65 return \%result;
190             }
191             elsif (@returned_vals) {
192 0         0 return @returned_vals;
193             }
194             else {
195 25         50 return @{$self}{@prim_key_cols};
  25         176  
196             }
197             }
198              
199              
200             sub _rawInsert {
201 31     31   70 my ($self, %options) = @_;
202 31 50       89 my $class = ref $self or croak "_rawInsert called as class method";
203              
204             # clone $self as mere unblessed hash (for SQLA) and extract ref to $schema
205 31         138 my %values = %$self;
206 31         129 my $schema = delete $values{__schema};
207             # THINK: this cloning %values = %$self is inefficient because data was
208             # already cloned in Statement::insert(). But it is quite hard to improve :-((
209              
210              
211             # cleanup $options
212 31 50       93 if ($options{-returning}) {
213 0 0 0     0 if (does($options{-returning}, 'HASH') && !keys %{$options{-returning}}) {
  0         0  
214 0         0 delete $options{-returning};
215             }
216             }
217              
218             # perform the insertion
219 31         89 my $sqla = $schema->sql_abstract;
220 31         106 my ($sql, @bind) = $sqla->insert(
221             -into => $self->db_from,
222             -values => \%values,
223             %options,
224             );
225              
226 18     18   28181 $schema->_debug(do {no warnings 'uninitialized';
  18         53  
  18         37730  
  31         14130  
227 31         210 $sql . " / " . CORE::join(", ", @bind);});
228 31         87 my $method = $schema->dbi_prepare_method;
229 31         102 my $sth = $schema->dbh->$method($sql);
230 31         4752 $sqla->bind_params($sth, @bind);
231 31         3759 $sth->execute();
232              
233 31         4912 return $sth;
234             }
235              
236              
237             sub _get_last_insert_id {
238 27     27   56 my ($self, $col) = @_;
239 27         56 my $class = ref $self;
240 27         99 my ($dbh, %dbh_options) = $self->schema->dbh;
241 27         76 my $table = $self->db_from;
242              
243             my $id
244             # either callback given by client ...
245             = $dbh_options{last_insert_id} ?
246             $dbh_options{last_insert_id}->($dbh, $table, $col)
247              
248             # or catalog and/or schema given by client ...
249             : (exists $dbh_options{catalog} || exists $dbh_options{schema}) ?
250             $dbh->last_insert_id($dbh_options{catalog}, $dbh_options{schema},
251 27 50 33     228 $table, $col)
    50          
252              
253             # or plain call to last_insert_id() with all undefs
254             : $dbh->last_insert_id(undef, undef, undef, undef);
255              
256 27         197 return $id;
257             }
258              
259              
260              
261             sub _weed_out_subtrees {
262 31     31   74 my ($self) = @_;
263 31         72 my $class = ref $self;
264              
265             # which "components" were declared through Schema->Composition(...)
266 31         98 my %is_component = map {($_ => 1)} $class->metadm->components;
  19         86  
267              
268 31         70 my %subrecords;
269 31         83 my $sqla = $self->schema->sql_abstract;
270              
271             # deal with references
272 31         118 foreach my $k (keys %$self) {
273 121 100       330 next if $k eq '__schema';
274 90         156 my $v = $self->{$k};
275 90 100       248 if (ref $v) {
276              
277             # if the reference is a component name, do a nested insert
278 9 100 66     44 if ($is_component{$k}) {
    50 100        
      33        
      66        
279 4         10 $subrecords{$k} = $v;
280 4         12 delete $self->{$k};
281             }
282              
283             # various cases where the ref will be handled by SQL::Abstract::More
284             elsif (
285             # an arrayref which is an array of values or a "bind value with type"
286             # -- see L
287             (does($v, 'ARRAY') && ($sqla->{array_datatypes} ||
288             $sqla->is_bind_value_with_type($v)))
289             ||
290             # literal SQL in the form $k => \ ["FUNC(?)", $v]
291             (ref $v eq 'REF' && does($$v, 'ARRAY'))
292             ){
293             # do nothing (pass the ref to SQL::Abstract::More)
294             }
295              
296             # otherwise it is probably wrong data
297             else {
298 0         0 carp "unexpected reference $k in record, deleted";
299 0         0 delete $self->{$k};
300             }
301             }
302             }
303              
304 31 100       231 return keys %subrecords ? \%subrecords : undef;
305             }
306              
307              
308              
309             sub _insert_subtrees {
310 4     4   17 my ($self, $subrecords, %options) = @_;
311 4         10 my $class = ref $self;
312 4         8 my %results;
313              
314 4         20 while (my ($role, $arrayref) = each %$subrecords) {
315 4 50       18 does $arrayref, 'ARRAY'
316             or croak "Expected an arrayref for component role $role in $class";
317 4 50       47 next if not @$arrayref;
318              
319             # insert via the "insert_into_..." method
320 4         12 my $meth = "insert_into_$role";
321 4         21 $results{$role} = [$self->$meth(@$arrayref, %options)];
322              
323             # also reinject in memory into source object
324 4         25 $self->{$role} = $arrayref;
325             }
326              
327 4         14 return \%results;
328             }
329              
330              
331             #------------------------------------------------------------
332             # delete
333             #------------------------------------------------------------
334              
335             my $delete_spec = {
336             -where => {type => HASHREF, optional => 0},
337             };
338              
339              
340             sub _parse_delete_args {
341 5     5   11 my $self = shift;
342              
343 5         16 my @pk_cols = $self->metadm->primary_key;
344 5         19 my $where;
345             my @cascaded;
346              
347 5 100       20 if ($self->_is_called_as_class_method) {
348             # parse arguments
349 3 50       9 @_ or croak "delete() as class method: not enough arguments";
350              
351 3   66     17 my $uses_named_args = ! ref $_[0] && $_[0] =~ /^-/;
352 3 100       8 if ($uses_named_args) {
353 1         26 my %args = validate_with(params => \@_,
354             spec => $delete_spec,
355             allow_extra => 0);
356 1         7 $where = $args{-where};
357             }
358             else { # uses positional args
359 2 50       11 if (does $_[0], 'HASH') { # called as: delete({fields})
360 0         0 my $hash = shift;
361 0         0 @{$where}{@pk_cols} = @{$hash}{@pk_cols};
  0         0  
  0         0  
362 0 0       0 !@_ or croak "delete() : too many arguments";
363             }
364             else { # called as: delete(@primary_key)
365 2         22 my ($n_vals, $n_keys) = (scalar(@_), scalar(@pk_cols));
366 2 50       7 $n_vals == $n_keys
367             or croak "delete(): got $n_vals cols in primary key, expected $n_keys";
368 2         4 @{$where}{@pk_cols} = @_;
  2         9  
369             }
370 2         7 my $missing = join ", ", grep {!defined $where->{$_}} @pk_cols;
  2         9  
371 2 50       8 croak "delete(): missing value for $missing" if $missing;
372             }
373             }
374             else { # called as instance method
375              
376             # build $where from primary key
377 2         6 @{$where}{@pk_cols} = @{$self}{@pk_cols};
  2         23  
  2         8  
378              
379             # cascaded delete
380             COMPONENT_NAME:
381 2         39 foreach my $component_name ($self->metadm->components) {
382 2 50       21 my $components = $self->{$component_name} or next COMPONENT_NAME;
383 0 0       0 does($components, 'ARRAY')
384             or croak "delete() : component $component_name is not an arrayref";
385 0         0 push @cascaded, @$components;
386             }
387             }
388              
389 5         20 return ($where, \@cascaded);
390             }
391              
392              
393             sub delete {
394 5     5 0 7865 my $self = shift;
395              
396 5         19 my $schema = $self->schema;
397 5         33 my ($where, $cascaded) = $self->_parse_delete_args(@_);
398              
399             # perform cascaded deletes for components within $self
400 5         14 $_->delete foreach @$cascaded;
401              
402             # perform this delete
403 5         20 my ($sql, @bind) = $schema->sql_abstract->delete(
404             -from => $self->db_from,
405             -where => $where,
406             );
407 5         1607 $schema->_debug($sql . " / " . CORE::join(", ", @bind) );
408 5         17 my $method = $schema->dbi_prepare_method;
409 5         18 my $sth = $schema->dbh->$method($sql);
410 5         741 $sth->execute(@bind);
411             }
412              
413              
414             #------------------------------------------------------------
415             # update
416             #------------------------------------------------------------
417              
418             my $update_spec = {
419             -set => {type => HASHREF, optional => 0},
420             -where => {type => HASHREF, optional => 0},
421             };
422              
423              
424             sub _parse_update_args { # returns ($schema, $to_set, $where)
425 30     30   63 my $self = shift;
426              
427 30         61 my ($to_set, $where);
428              
429 30 100       117 if ($self->_is_called_as_class_method) {
430             @_
431 25 50       85 or croak "update() as class method: not enough arguments";
432              
433 25   100     135 my $uses_named_args = ! ref $_[0] && $_[0] =~ /^-/;
434 25 100       66 if ($uses_named_args) {
435 3         97 my %args = validate_with(params => \@_,
436             spec => $update_spec,
437             allow_extra => 0);
438 3         29 ($to_set, $where) = @args{qw/-set -where/};
439             }
440             else { # uses positional args: update([@primary_key], {fields_to_update})
441 22 50       131 does $_[-1], 'HASH'
442             or croak "update(): expected a hashref as last argument";
443 22         262 $to_set = { %{pop @_} }; # shallow copy
  22         130  
444 22         103 my @pk_cols = $self->metadm->primary_key;
445 22 100       91 if (@_) {
446 9         34 my ($n_vals, $n_keys) = (scalar(@_), scalar(@pk_cols));
447 9 50       32 $n_vals == $n_keys
448             or croak "update(): got $n_vals cols in primary key, expected $n_keys";
449 9         25 @{$where}{@pk_cols} = @_;
  9         44  
450             }
451             else {
452             # extract primary key from hashref
453 13         35 @{$where}{@pk_cols} = delete @{$to_set}{@pk_cols};
  13         43  
  13         35  
454             }
455             }
456             }
457             else { # called as instance method
458 5         33 my %clone = %$self;
459              
460             # extract primary key from object
461 5         25 $where->{$_} = delete $clone{$_} foreach $self->metadm->primary_key;
462              
463 5 100       29 if (!@_) { # if called as $obj->update()
    50          
464 4         11 delete $clone{__schema};
465 4         14 $to_set = \%clone;
466             }
467             elsif (@_ == 1) { # if called as $obj->update({field => $val, ...})
468 1 50       20 does $_[0], 'HASH'
469             or croak "update() as instance method: unexpected argument";
470 1         14 $to_set = $_[0];
471             }
472             else {
473 0         0 croak "update() as instance method: too many arguments";
474             }
475             }
476              
477 30         114 return ($to_set, $where);
478             }
479              
480              
481             sub _apply_handlers_for_update {
482 30     30   68 my ($self, $to_set, $where) = @_;
483              
484             # class of the invocant
485 30   66     126 my $class = ref $self || $self;
486              
487             # apply no_update and auto_update
488 30         126 my %no_update_column = $self->metadm->no_update_column;
489 30         184 delete $to_set->{$_} foreach keys %no_update_column;
490 30         101 my %auto_update_column = $self->metadm->auto_update_column;
491 30         134 while (my ($col, $handler) = each %auto_update_column) {
492 8         31 $to_set->{$col} = $handler->($to_set, $class);
493             }
494              
495             # apply 'to_DB' handlers. Need temporary bless as an object
496 30         150 my $schema = $self->schema;
497 30         78 $to_set->{__schema} = $schema; # in case the handlers need it
498 30         66 bless $to_set, $class;
499 30         152 $to_set->apply_column_handler('to_DB');
500 30         69 delete $to_set->{__schema};
501 30         152 $schema->unbless($to_set);
502              
503              
504             # detect references to foreign objects
505 30         106 my $sqla = $schema->sql_abstract;
506 30         67 my @sub_refs;
507 30         93 foreach my $key (keys %$to_set) {
508 58         125 my $val = $to_set->{$key};
509 58 100       140 next if !ref $val;
510             push @sub_refs, $key
511             if does($val, 'HASH')
512             ||( does($val, 'ARRAY')
513             && !$sqla->{array_datatypes}
514 5 100 100     23 && !$sqla->is_bind_value_with_type($val) );
      66        
      66        
515             # reftypes SCALAR or REF are OK; they are used by SQLA for verbatim SQL
516             }
517              
518             # remove references to foreign objects
519 30 100       248 if (@sub_refs) {
520 1         17 carp "data passed to update() contained nested references : ",
521             CORE::join ", ", sort @sub_refs;
522 1         207 delete @{$to_set}{@sub_refs};
  1         18  
523             }
524              
525             # THINK : instead of removing references to foreign objects, one could
526             # maybe perform recursive updates (including insert/update/delete of child
527             # objects)
528             }
529              
530              
531              
532              
533             sub update {
534 30     30 1 72043 my $self = shift;
535              
536             # prepare datastructures for generating the SQL
537 30         132 my ($to_set, $where) = $self->_parse_update_args(@_);
538 30         152 $self->_apply_handlers_for_update($to_set, $where);
539              
540             # database request
541 30         94 my $schema = $self->schema;
542 30         107 my $sqla = $schema->sql_abstract;
543 30         132 my ($sql, @bind) = $sqla->update(
544             -table => $self->db_from,
545             -set => $to_set,
546             -where => $where,
547             );
548 18     18   168 $schema->_debug(do {no warnings 'uninitialized';
  18         42  
  18         7764  
  30         17764  
549 30         203 $sql . " / " . CORE::join(", ", @bind);});
550 30         112 my $prepare_method = $schema->dbi_prepare_method;
551 30         93 my $sth = $schema->dbh->$prepare_method($sql);
552 30         4680 $sqla->bind_params($sth, @bind);
553 30         3903 return $sth->execute(); # will return the number of updated records
554             }
555              
556              
557             #------------------------------------------------------------
558             # utility methods
559             #------------------------------------------------------------
560              
561             sub db_from {
562 194     194 1 370 my $self = shift;
563              
564 194         474 my $db_from = $self->metadm->db_from;
565 194         487 my $db_schema = $self->schema->db_schema;
566              
567             # prefix table with $db_schema if non-empty and there is no hardwired db_schema
568 194 50 33     1695 return $db_schema && $db_from !~ /\./ ? "$db_schema.$db_from" : $db_from;
569             }
570              
571             sub has_invalid_columns {
572 0     0 0 0 my ($self) = @_;
573 0         0 my $results = $self->apply_column_handler('validate');
574 0         0 my @invalid; # names of invalid columns
575 0         0 while (my ($k, $v) = each %$results) {
576 0 0 0     0 push @invalid, $k if defined($v) and not $v;
577             }
578 0 0       0 return @invalid ? \@invalid : undef;
579             }
580              
581             sub _parse_ending_options {
582 23     23   72 my ($class_or_self, $args_ref, $regex) = @_;
583              
584             # end of list may contain options, recognized because option name is a
585             # scalar matching the given regex
586 23         46 my %options;
587 23   100     163 while (@$args_ref >= 2 && !ref $args_ref->[-2]
      66        
      33        
588             && $args_ref->[-2] && $args_ref->[-2] =~ $regex) {
589 4         20 my ($opt_val, $opt_name) = (pop @$args_ref, pop @$args_ref);
590 4         20 $options{$opt_name} = $opt_val;
591             }
592 23         62 return \%options;
593             }
594              
595              
596             1; # End of DBIx::DataModel::Source::Table
597              
598             __END__