File Coverage

blib/lib/DBIx/DataModel/Statement.pm
Criterion Covered Total %
statement 340 373 91.1
branch 150 200 75.0
condition 30 57 52.6
subroutine 49 56 87.5
pod 0 28 0.0
total 569 714 79.6


line stmt bran cond sub pod time code
1             #----------------------------------------------------------------------
2             package DBIx::DataModel::Statement;
3             #----------------------------------------------------------------------
4             # see POD doc at end of file
5              
6 13     13   7474 use warnings;
  13         33  
  13         481  
7 13     13   84 use strict;
  13         35  
  13         350  
8 13     13   76 use List::MoreUtils qw/firstval any/;
  13         28  
  13         158  
9 13     13   10504 use Scalar::Util qw/weaken dualvar/;
  13         28  
  13         834  
10 13     13   2805 use POSIX qw/LONG_MAX/;
  13         36151  
  13         166  
11 13     13   13665 use Clone qw/clone/;
  13         5412  
  13         780  
12 13     13   95 use Carp::Clan qw[^(DBIx::DataModel::|SQL::Abstract)];
  13         29  
  13         183  
13 13     13   1313 use Try::Tiny qw/try catch/;
  13         37  
  13         821  
14 13     13   85 use Module::Load qw/load/;
  13         34  
  13         129  
15 13     13   934 use mro qw/c3/;
  13         28  
  13         109  
16              
17 13     13   412 use DBIx::DataModel;
  13         27  
  13         105  
18 13     13   82 use DBIx::DataModel::Meta::Utils qw/define_readonly_accessors does/;
  13         39  
  13         845  
19 13     13   103 use namespace::clean;
  13         30  
  13         125  
20              
21             #----------------------------------------------------------------------
22             # internals
23             #----------------------------------------------------------------------
24              
25             use overload
26              
27             # overload the stringification operator so that Devel::StackTrace is happy;
28             # also useful to show the SQL (if in sqlized state)
29             '""' => sub {
30 0     0   0 my $self = shift;
31 0     0   0 my $string = try {my ($sql, @bind) = $self->sql;
32 0         0 __PACKAGE__ . "($sql // " . join(", ", @bind) . ")"; }
33 0   0     0 || overload::StrVal($self);
34             }
35 13     13   6783 ;
  13         33  
  13         115  
36              
37              
38             # sequence of states. Stored as dualvars for both ordering and printing
39             use constant {
40 13         70696 NEW => dualvar(1, "new" ),
41             REFINED => dualvar(2, "refined" ),
42             SQLIZED => dualvar(3, "sqlized" ),
43             PREPARED => dualvar(4, "prepared"),
44             EXECUTED => dualvar(5, "executed"),
45 13     13   1676 };
  13         30  
46              
47              
48              
49             #----------------------------------------------------------------------
50             # PUBLIC METHODS
51             #----------------------------------------------------------------------
52              
53             sub new {
54 172     172 0 541 my ($class, $source, %other_args) = @_;
55              
56             # check $source
57 172 50 33     1721 $source
58             && $source->isa('DBIx::DataModel::Source')
59             or croak "invalid source for DBIx::DataModel::Statement->new()";
60              
61             # build the object
62 172         1029 my $self = bless {status => NEW,
63             args => {},
64             pre_bound_params => {},
65             bound_params => [],
66             source => $source}, $class;
67              
68             # add placeholder_regex
69 172         824 my $prefix = $source->schema->{placeholder_prefix};
70 172         1613 $self->{placeholder_regex} = qr/^\Q$prefix\E(.+)/;
71              
72             # parse remaining args, if any
73 172 100       604 $self->refine(%other_args) if %other_args;
74              
75 172         555 return $self;
76             }
77              
78              
79             # accessors
80             define_readonly_accessors( __PACKAGE__, qw/source status/);
81              
82             # proxy methods
83 495     495 0 1290 sub meta_source {shift->{source}->metadm}
84 1261     1261 0 3396 sub schema {shift->{source}->schema}
85              
86              
87             # back to the original state
88             sub reset {
89 0     0 0 0 my ($self, %other_args) = @_;
90              
91 0         0 my $new = (ref $self)->new($self->{source}, %other_args);
92 0         0 %$self = (%$new);
93              
94 0         0 return $self;
95             }
96              
97              
98             sub arg {
99 159     159 0 352 my ($self, $arg_name) = @_;
100              
101 159   50     488 my $args = $self->{args} || {};
102 159         584 return $args->{$arg_name};
103             }
104              
105              
106              
107             #----------------------------------------------------------------------
108             # PUBLIC METHODS IN RELATION WITH SELECT()
109             #----------------------------------------------------------------------
110              
111              
112             sub sql {
113 13     13 0 36 my ($self) = @_;
114              
115 13 50       34 $self->status >= SQLIZED
116             or croak "can't call sql() when in status ". $self->status;
117              
118 12         82 return wantarray ? ($self->{sql}, @{$self->{bound_params}})
119 13 100       60 : $self->{sql};
120             }
121              
122              
123             sub bind {
124 173     173 0 481 my ($self, @args) = @_;
125              
126             # arguments can be a list, a hashref or an arrayref
127 173 100       522 if (@args == 1) {
    100          
    50          
128 151 50       617 if (does $args[0], 'HASH') {
    0          
129 151         1374 @args = %{$args[0]};
  151         480  
130             }
131             elsif (does $args[0], 'ARRAY') {
132 0         0 my $i = 0; @args = map {($i++, $_)} @{$args[0]};
  0         0  
  0         0  
  0         0  
133             }
134             else {
135 0         0 croak "unexpected arg type to bind()";
136             }
137             }
138             elsif (@args == 3) { # name => value, \%datatype (see L)
139             # transform into ->bind($name => [$value, \%datatype])
140 1         3 @args = ($args[0], [$args[1], $args[2]]);
141             }
142             elsif (@args % 2 == 1) {
143 0         0 croak "odd number of args to bind()";
144             }
145              
146             # do bind (different behaviour according to status)
147 173         506 my %args = @args;
148 173 100       557 if ($self->status < SQLIZED) {
149 26         114 while (my ($k, $v) = each %args) {
150 34         129 $self->{pre_bound_params}{$k} = $v;
151             }
152             }
153             else {
154 147         573 while (my ($k, $v) = each %args) {
155 49 100       192 my $indices = $self->{param_indices}{$k}
156             or next; # silently ignore that binding (named placeholder unused)
157 30         169 $self->{bound_params}[$_] = $v foreach @$indices;
158             }
159             }
160              
161             # THINK : probably we should check here that $args{__schema}, if present,
162             # is the same as $self->schema (same database connection) ... but how
163             # to check for "sameness" on database handles ?
164              
165 173         438 return $self;
166             }
167              
168              
169             sub refine {
170 113     113 0 489 my ($self, %more_args) = @_;
171              
172 113 50       332 $self->status <= REFINED
173             or croak "can't refine() when in status " . $self->status;
174 113         263 $self->{status} = REFINED;
175              
176 113         211 my $args = $self->{args};
177              
178 113         412 while (my ($k, $v) = each %more_args) {
179              
180             SWITCH:
181 181         350 for ($k) {
182              
183             # -where : combine with previous 'where' clauses in same statement
184 181 100       514 /^-where$/ and do {
185 60         138 my $sqla = $self->schema->sql_abstract;
186 60         294 $args->{-where} = $sqla->merge_conditions($args->{-where}, $v);
187 60         2443 last SWITCH;
188             };
189              
190             # -fetch : special select() on primary key
191 121 100       304 /^-fetch$/ and do {
192             # build a -where clause on primary key
193 7 100       25 my $primary_key = ref($v) ? $v : [$v];
194 7         20 my @pk_columns = $self->meta_source->primary_key;
195             @pk_columns
196 7 50       23 or croak "fetch: no primary key in source " . $self->meta_source;
197 7 50       23 @pk_columns == @$primary_key
198             or croak sprintf "fetch from %s: primary key should have %d values",
199             $self->meta_source, scalar(@pk_columns);
200 7 100   7   53 List::MoreUtils::all {defined $_} @$primary_key
  7         23  
201             or croak "fetch from " . $self->meta_source . ": "
202             . "undefined val in primary key";
203              
204 6         23 my %where = ();
205 6         20 @where{@pk_columns} = @$primary_key;
206 6         16 my $sqla = $self->schema->sql_abstract;
207 6         31 $args->{-where} = $sqla->merge_conditions($args->{-where}, \%where);
208              
209             # want a single record as result
210 6         221 $args->{-result_as} = "firstrow";
211              
212 6         32 last SWITCH;
213             };
214              
215             # -columns : store in $self->{args}{-columns}; can restrict previous list
216 114 100       324 /^-columns$/ and do {
217 36 100       132 my @cols = does($v, 'ARRAY') ? @$v : ($v);
218 36 50       425 if (my $old_cols = $args->{-columns}) {
219 0 0 0     0 unless (@$old_cols == 1 && $old_cols->[0] eq '*' ) {
220 0         0 foreach my $col (@cols) {
221 0 0   0   0 any {$_ eq $col} @$old_cols
  0         0  
222             or croak "can't restrict -columns on '$col' (was not in the) "
223             . "previous -columns list";
224             }
225             }
226             }
227 36         89 $args->{-columns} = \@cols;
228 36         157 last SWITCH;
229             };
230              
231              
232             # other args are just stored, they will be used later
233             /^-( order_by | group_by | having | for
234             | union(?:_all)? | intersect | except | minus
235             | result_as | post_SQL | pre_exec | post_exec | post_bless
236             | limit | offset | page_size | page_index
237             | column_types | prepare_attrs | dbi_prepare_method
238             | _left_cols | where_on | join_with_USING
239             )$/x
240 78 50       409 and do {$args->{$k} = $v; last SWITCH};
  78         213  
  78         325  
241              
242             # TODO : this hard-coded list of args should be more abstract
243              
244             # otherwise
245 0         0 croak "invalid arg : $k";
246              
247             } # end SWITCH
248             } # end while
249              
250 112         306 return $self;
251             }
252              
253              
254              
255              
256             sub sqlize {
257 144     144 0 323 my ($self, @args) = @_;
258              
259 144 50       308 $self->status < SQLIZED
260             or croak "can't sqlize() when in status ". $self->status;
261              
262             # merge new args into $self->{args}
263 144 50       360 $self->refine(@args) if @args;
264              
265             # shortcuts
266 144         260 my $args = $self->{args};
267 144         282 my $meta_source = $self->meta_source;
268 144         316 my $source_where = $meta_source->{where};
269 144         294 my $sql_abstract = $self->schema->sql_abstract;
270 144   100     517 my $result_as = $args->{-result_as} || "";
271              
272             # build arguments for SQL::Abstract::More
273 144 100       340 $self->refine(-where => $source_where) if $source_where;
274 144         585 my @args_to_copy = qw/-columns -where
275             -union -union_all -intersect -except -minus
276             -order_by -group_by -having
277             -limit -offset -page_size -page_index/;
278 144         443 my %sqla_args = (-from => clone($self->source->db_from),
279             -want_details => 1);
280 144   66     1957 defined $args->{$_} and $sqla_args{$_} = $args->{$_} for @args_to_copy;
281 144   66     841 $sqla_args{-columns} ||= $meta_source->default_columns;
282 144 100 50     477 $sqla_args{-limit} ||= 1
      100        
283             if $result_as eq 'firstrow' && $self->schema->autolimit_firstrow;
284              
285             # "-for" (e.g. "update", "read only")
286 144 100       350 if ($result_as ne 'subquery') {
287 141 100       557 if ($args->{-for}) {
    50          
288 2         10 $sqla_args{-for} = $args->{-for};
289             }
290             elsif (!exists $args->{-for}) {
291 139         337 $sqla_args{-for} = $self->schema->select_implicitly_for;
292             }
293             }
294              
295             # "where_on" : conditions to be added in joins
296 144 100       532 if (my $where_on = $args->{-where_on}) {
297             # check proper usage
298 3 100       10 does $sqla_args{-from}, 'ARRAY'
299             or croak "datasource for '-where_on' was not a join";
300              
301             # retrieve components of the join and check again for proper usage
302 2         20 my ($join_op, $first_table, @other_join_args) = @{$sqla_args{-from}};
  2         7  
303 2 50       7 $join_op eq '-join'
304             or croak "datasource for '-where_on' was not a join";
305              
306             # reverse index (table_name => $join_hash)
307 2         7 my %by_dest_table = reverse @other_join_args;
308              
309             # insert additional conditions into appropriate places
310 2         9 while (my ($table, $additional_cond) = each %$where_on) {
311 4 50       10 my $join_cond = $by_dest_table{$table}
312             or croak "-where_on => {'$table' => ..}: this table is not in the join";
313             $join_cond->{condition}
314             = $sql_abstract->merge_conditions($join_cond->{condition},
315 4         12 $additional_cond);
316 4         129 delete $join_cond->{using};
317             }
318              
319             # TODO: should be able to use paths and aliases as keys, instead of
320             # database table names.
321             # TOCHECK: is this stuff still compatible with the bind() method ?
322             }
323              
324             # adjust join conditions for ON clause or for USING clause
325 143 100       425 if (does $sqla_args{-from}, 'ARRAY') {
326 43 50       480 $sqla_args{-from}[0] eq '-join'
327             or croak "datasource is an arrayref but does not start with -join";
328             my $join_with_USING
329             = exists $args->{-join_with_USING} ? $args->{-join_with_USING}
330 43 100       122 : $self->schema->{join_with_USING};
331 43         96 for (my $i = 2; $i < @{$sqla_args{-from}}; $i += 2) {
  115         264  
332 72         121 my $join_cond = $sqla_args{-from}[$i];
333 72 100       127 if ($join_with_USING) {
334 4 50       15 delete $join_cond->{condition} if $join_cond->{using};
335             }
336             else {
337 68         167 delete $join_cond->{using};
338             }
339             }
340             }
341              
342             # generate SQL
343 143         1468 my $sqla_result = $sql_abstract->select(%sqla_args);
344              
345             # maybe post-process the SQL
346 143 50       139362 if ($args->{-post_SQL}) {
347 0         0 ($sqla_result->{sql}, @{$sqla_result->{bind}})
348 0         0 = $args->{-post_SQL}->($sqla_result->{sql}, @{$sqla_result->{bind}});
  0         0  
349             }
350              
351             # keep $sql / @bind / aliases in $self, and set new status
352 143         419 $self->{bound_params} = $sqla_result->{bind};
353 143         873 $self->{$_} = $sqla_result->{$_} for qw/sql aliased_tables aliased_columns/;
354 143         332 $self->{status} = SQLIZED;
355              
356             # analyze placeholders, and replace by pre_bound params if applicable
357 143 50       428 if (my $regex = $self->{placeholder_regex}) {
358 143         312 for (my $i = 0; $i < @{$self->{bound_params}}; $i++) {
  303         786  
359             $self->{bound_params}[$i] =~ $regex
360 160 100       754 and push @{$self->{param_indices}{$1}}, $i;
  30         211  
361             }
362             }
363 143 50       669 $self->bind($self->{pre_bound_params}) if $self->{pre_bound_params};
364              
365             # compute callback to apply to data rows
366 143         283 my $callback = $self->{args}{-post_bless};
367 143         555 weaken(my $weak_self = $self); # weaken to avoid a circular ref in closure
368             $self->{row_callback} = sub {
369 114     114   174 my $row = shift;
370 114         338 $weak_self->bless_from_DB($row);
371 114 50       277 $callback->($row) if $callback;
372 143         661 };
373              
374 143         802 return $self;
375             }
376              
377              
378              
379             sub prepare {
380 137     137 0 295 my ($self, @args) = @_;
381              
382 137         396 my $meta_source = $self->meta_source;
383              
384 137 50 33     542 $self->sqlize(@args) if @args or $self->status < SQLIZED;
385              
386 136 50       381 $self->status == SQLIZED
387             or croak "can't prepare() when in status " . $self->status;
388              
389             # log the statement and bind values
390 136         366 $self->schema->_debug("PREPARE $self->{sql} / @{$self->{bound_params}}");
  136         1125  
391              
392             # call the database
393 136 50       354 my $dbh = $self->schema->dbh or croak "Schema has no dbh";
394             my $method = $self->{args}{-dbi_prepare_method}
395 136   33     644 || $self->schema->dbi_prepare_method;
396 136         385 my @prepare_args = ($self->{sql});
397 136 50       356 if (my $prepare_attrs = $self->{args}{-prepare_attrs}) {
398 0         0 push @prepare_args, $prepare_attrs;
399             }
400 136         1199 $self->{sth} = $dbh->$method(@prepare_args);
401              
402             # new status and return
403 136         25062 $self->{status} = PREPARED;
404 136         359 return $self;
405             }
406              
407              
408             sub sth {
409 502     502 0 1003 my ($self) = @_;
410              
411 502 50       1300 $self->prepare if $self->status < PREPARED;
412 502         1750 return $self->{sth};
413             }
414              
415              
416              
417             sub execute {
418 137     137 0 437 my ($self, @bind_args) = @_;
419              
420             # if not prepared yet, prepare it
421 137 100       326 $self->prepare if $self->status < PREPARED;
422              
423             # TODO: DON'T REMEMBER why the line below was here. Keep it around for a while ...
424 136 50       466 push @bind_args, offset => $self->{offset} if $self->{offset};
425              
426 136 100       383 $self->bind(@bind_args) if @bind_args;
427              
428             # shortcuts
429 136         266 my $args = $self->{args};
430 136         405 my $sth = $self->sth;
431              
432             # previous row_count, row_num and reuse_row are no longer valid
433 136         350 delete $self->{reuse_row};
434 136         279 delete $self->{row_count};
435 136         375 $self->{row_num} = $self->offset;
436              
437             # pre_exec callback
438 136 100       428 $args->{-pre_exec}->($sth) if $args->{-pre_exec};
439              
440             # check that all placeholders were properly bound to values
441 136         271 my @unbound;
442 136 100       236 while (my ($k, $indices) = each %{$self->{param_indices} || {}}) {
  166         939  
443 30 50       114 exists $self->{bound_params}[$indices->[0]] or push @unbound, $k;
444             }
445             not @unbound
446 136 50       427 or croak "unbound placeholders (probably a missing foreign key) : "
447             . CORE::join(", ", @unbound);
448              
449             # bind parameters and execute
450 136         343 my $sqla = $self->schema->sql_abstract;
451 136         268 $sqla->bind_params($sth, @{$self->{bound_params}});
  136         731  
452 136         9025 $sth->execute;
453              
454             # post_exec callback
455 136 100       16844 $args->{-post_exec}->($sth) if $args->{-post_exec};
456              
457 136         330 $self->{status} = EXECUTED;
458 136         307 return $self;
459             }
460              
461              
462              
463              
464              
465             my %cache_result_class;
466              
467             sub select {
468 145     145 0 281 my $self = shift;
469              
470 145 100       647 $self->refine(@_) if @_;
471              
472 143   100     478 my $arg_result_as = $self->arg(-result_as) || 'rows';
473              
474 143 100       504 SWITCH:
475             my ($result_as, @subclass_args)
476             = does($arg_result_as, 'ARRAY') ? @$arg_result_as : ($arg_result_as);
477              
478             # historically,some kinds of results accepted various aliases
479 143         1328 $result_as =~ s/^flat(?:_array|)$/flat_arrayref/;
480 143         266 $result_as =~ s/^arrayref$/rows/;
481 143         228 $result_as =~ s/^fast-statement$/fast_statement/;
482              
483 143         323 for ($result_as) {
484 143 50 100     640 my $subclass = $cache_result_class{$_}
485             ||= $self->_find_result_class($_)
486             or croak "didn't find any ResultAs subclass to implement -result_as => '$_'";
487 142         838 my $result_maker = $subclass->new(@subclass_args);
488 142         501 return $result_maker->get_result($self);
489             }
490             }
491              
492              
493             sub row_count {
494 6     6 0 25895 my ($self) = @_;
495              
496 6 50       23 if (! exists $self->{row_count}) {
497 6 100       21 $self->sqlize if $self->status < SQLIZED;
498 6         20 my ($sql, @bind) = $self->sql;
499              
500             # get syntax used for LIMIT clauses ...
501 6         58 my $sqla = $self->schema->sql_abstract;
502 6         24 my ($limit_sql, undef, undef) = $sqla->limit_offset(0, 0);
503 6         140 $limit_sql =~ s/([()?*])/\\$1/g;
504              
505             # ...and use it to remove the LIMIT clause and associated bind vals, if any
506 6 100       89 if ($limit_sql =~ /ROWNUM/) { # special case for Oracle syntax, complex ...
    100          
507             # see source code of SQL::Abstract::More
508 2         18 $limit_sql =~ s/%s/(.*)/;
509 2 100       40 if ($sql =~ s/^$limit_sql/$1/) {
510 1         4 splice @bind, -2;
511             }
512             }
513             elsif ($sql =~ s[\b$limit_sql][]i) { # regular LIMIT/OFFSET syntaxes
514 3         9 splice @bind, -2;
515             }
516              
517             # decide if the SELECT COUNT should wrap the original SQL in a subquery;
518             # this is needed with clauses like below that change the number of rows
519 6         36 my $should_wrap = $sql =~ /\b(UNION|INTERSECT|MINUS|EXCEPT|DISTINCT)\b/i;
520              
521             # if no wrap required, attempt to directly substitute COUNT(*) for the
522             # column names ...but if it fails, wrap anyway
523 6   66     38 $should_wrap ||= ! ($sql =~ s[^SELECT\b.*?\bFROM\b][SELECT COUNT(*) FROM]i);
524              
525             # wrap SQL if needed, using a subquery alias because it's required for
526             # some DBMS (like PostgreSQL)
527 6 100       24 $should_wrap and $sql = "SELECT COUNT(*) FROM "
528             . $sqla->table_alias("( $sql )", "count_wrapper");
529              
530             # log the statement and bind values
531 6         122 $self->schema->_debug("PREPARE $sql / @bind");
532              
533             # call the database
534 6 50       15 my $dbh = $self->schema->dbh or croak "Schema has no dbh";
535 6         16 my $method = $self->schema->dbi_prepare_method;
536 6         40 my $sth = $dbh->$method($sql);
537 6         903 $sth->execute(@bind);
538 6         705 ($self->{row_count}) = $sth->fetchrow_array;
539 6         229 $sth->finish;
540             }
541              
542 6         191 return $self->{row_count};
543             }
544              
545              
546             sub row_num {
547 132     132 0 277 my ($self) = @_;
548 132         328 return $self->{row_num};
549             }
550              
551              
552             sub next {
553 180     180 0 395 my ($self, $n_rows) = @_;
554              
555 180 100       478 $self->execute if $self->status < EXECUTED;
556              
557 179 50       431 my $sth = $self->sth or croak "absent sth in statement";
558 179 50       492 my $callback = $self->{row_callback} or croak "absent callback in statement";
559              
560 179 100       447 if (not defined $n_rows) { # if user wants a single row
561             # fetch a single record, either into the reusable row, or into a fresh hash
562             my $row = $self->{reuse_row} ? ($sth->fetch ? $self->{reuse_row} : undef)
563 85 100       412 : $sth->fetchrow_hashref;
    100          
564 85 100       5843 if ($row) {
565 51         129 $callback->($row);
566 51         95 $self->{row_num} +=1;
567             }
568 85         278 return $row;
569             }
570             else { # if user wants an arrayref of size $n_rows
571 94 50       237 $n_rows > 0 or croak "->next() : invalid argument, $n_rows";
572 94 50       271 not $self->{reuse_row} or croak "reusable row, cannot retrieve several";
573 94         161 my @rows;
574 94         256 while ($n_rows--) {
575 157 100       578 my $row = $sth->fetchrow_hashref or last;
576 63         4980 push @rows, $row;
577             }
578 94         5643 $callback->($_) foreach @rows;
579 94         189 $self->{row_num} += @rows;
580 94         295 return \@rows;
581             }
582              
583             # NOTE: ->next() returns a $row, while ->next(1) returns an arrayref of 1 row
584             }
585              
586              
587             sub all {
588 95     95 0 236 my ($self) = @_;
589              
590             # just call next() with a huge number
591 95         251 return $self->_next_and_finish(POSIX::LONG_MAX);
592             }
593              
594              
595 135 100   135 0 655 sub page_size { shift->{args}{-page_size} || POSIX::LONG_MAX }
596 135 100   135 0 740 sub page_index { shift->{args}{-page_index} || 1 }
597              
598             sub offset {
599 269     269 0 522 my ($self) = @_;
600              
601 269 100       693 if (!exists $self->{offset}) {
602             # compute on demand -- will default to 0 if there is no pagination
603             $self->{offset} = exists $self->{args}{-offset} ? $self->{args}{-offset}
604 136 100       534 : ($self->page_index - 1) * $self->page_size;
605             }
606              
607 269         704 return $self->{offset};
608             }
609              
610              
611              
612             sub page_count {
613 0     0 0 0 my ($self) = @_;
614              
615 0 0       0 my $row_count = $self->row_count or return 0;
616 0   0     0 my $page_size = $self->page_size || 1;
617              
618 0         0 return int(($row_count - 1) / $page_size) + 1;
619             }
620              
621              
622             sub page_boundaries {
623 1     1 0 6 my ($self) = @_;
624              
625 1         4 my $first = $self->offset + 1;
626 1         4 my $last = $self->offset + $self->nb_fetched_rows;
627              
628 1         6 return ($first, $last);
629             }
630              
631              
632             sub page_rows {
633 0     0 0 0 my ($self) = @_;
634 0         0 return $self->_next_and_finish($self->page_size);
635             }
636              
637              
638             sub bless_from_DB {
639 135     135 0 281 my ($self, $row) = @_;
640              
641             # inject ref to $schema if in multi-schema mode or if temporary
642             # db_schema is set
643 135         309 my $schema = $self->schema;
644             $row->{__schema} = $schema unless $schema->{is_singleton}
645 135 100 66     634 && !$schema->{db_schema};
646              
647             # bless into appropriate class
648 135         317 bless $row, $self->meta_source->class;
649             # apply handlers
650 135 100       523 $self->{from_DB_handlers} or $self->_compute_from_DB_handlers;
651 135         232 while (my ($column_name, $handler)
652 392         1176 = each %{$self->{from_DB_handlers}}) {
653             exists $row->{$column_name}
654 257 100       690 and $handler->($row->{$column_name}, $row, $column_name, 'from_DB');
655             }
656              
657 135         450 return $row;
658             }
659              
660              
661             sub headers {
662 22     22 0 40 my $self = shift;
663              
664 22 50       58 $self->status == EXECUTED
665             or $self->execute(@_);
666              
667 22   50     48 my $hash_key_name = $self->sth->{FetchHashKeyName} || 'NAME';
668 22         58 return @{$self->sth->{$hash_key_name}};
  22         43  
669             }
670              
671              
672             sub finish {
673 131     131 0 242 my $self = shift;
674              
675 131         336 $self->{nb_fetched_rows} = $self->row_num - $self->offset;
676 131         318 $self->sth->finish;
677             }
678              
679              
680             sub nb_fetched_rows {
681 2     2 0 9 my ($self) = @_;
682              
683             exists $self->{nb_fetched_rows}
684 2 50       7 or croak "->nb_fetched_rows() can only be called on a finished statement";
685              
686 2         10 return $self->{nb_fetched_rows};
687             }
688              
689              
690              
691              
692             sub make_fast {
693 11     11 0 41 my ($self) = @_;
694              
695 11 50       37 $self->status == EXECUTED
696             or croak "cannot make_fast() when in state " . $self->status;
697              
698             # create a reusable hash and bind_columns to it (see L)
699 11         31 my %row;
700 11         29 $self->sth->bind_columns(\(@row{$self->headers}));
701 11         1205 $self->{reuse_row} = \%row;
702             }
703              
704              
705             #----------------------------------------------------------------------
706             # PRIVATE METHODS IN RELATION WITH SELECT()
707             #----------------------------------------------------------------------
708              
709             sub _forbid_callbacks {
710 5     5   15 my ($self, $subclass) = @_;
711              
712 5         19 my $callbacks = CORE::join ", ", grep {$self->arg($_)}
  15         29  
713             qw/-pre_exec -post_exec -post_bless/;
714 5 50       23 if ($callbacks) {
715 0         0 $subclass =~ s/^.*:://;
716 0         0 croak "$callbacks incompatible with -result_as=>'$subclass'";
717             }
718             }
719              
720              
721              
722             sub _next_and_finish {
723 113     113   179 my $self = shift;
724 113         312 my $row_or_rows = $self->next( @_ ); # pass original parameters
725 112         382 $self->finish;
726 112         4118 return $row_or_rows;
727             }
728              
729             sub _compute_from_DB_handlers {
730 61     61   155 my ($self) = @_;
731 61         133 my $meta_source = $self->meta_source;
732 61         141 my $meta_schema = $self->schema->metadm;
733 61         296 my %handlers = $meta_source->_consolidate_hash('column_handlers');
734 61         284 my %aliased_tables = $meta_source->aliased_tables;
735              
736             # iterate over aliased_columns
737 61 100       144 while (my ($alias, $column) = each %{$self->{aliased_columns} || {}}) {
  82         436  
738 21         40 my $table_name;
739 21 100       116 $column =~ s{^([^()]+) # supposed table name (without parens)
740             \. # followed by a dot
741             (?=[^()]+$) # followed by supposed col name (without parens)
742             }{}x
743             and $table_name = $1;
744 21 100       56 if (!$table_name) {
745 12         37 $handlers{$alias} = $handlers{$column};
746             }
747             else {
748 9   66     38 $table_name = $aliased_tables{$table_name} || $table_name;
749              
750             my $table = $meta_schema->table($table_name)
751 16     16   84 || (firstval {($_->{db_name} || '') eq $table_name}
752             ($meta_source, $meta_source->ancestors))
753 0     0   0 || (firstval {uc($_->{db_name} || '') eq uc($table_name)}
754 9 50 33     31 ($meta_source, $meta_source->ancestors))
755             or croak "unknown table name: $table_name";
756              
757 9         38 $handlers{$alias} = $table->{column_handlers}->{$column};
758             }
759             }
760              
761             # handlers may be overridden from args{-column_types}
762 61 100       251 if (my $col_types = $self->{args}{-column_types}) {
763 1         5 while (my ($type_name, $columns) = each %$col_types) {
764 1 50       6 $columns = [$columns] unless does $columns, 'ARRAY';
765 1 50       16 my $type = $self->schema->metadm->type($type_name)
766             or croak "no such column type: $type_name";
767 1         8 $handlers{$_} = $type->{handlers} foreach @$columns;
768             }
769             }
770              
771             # just keep the "from_DB" handlers
772 61         123 my $from_DB_handlers = {};
773 61         207 while (my ($column, $col_handlers) = each %handlers) {
774 161 100       452 my $from_DB_handler = $col_handlers->{from_DB} or next;
775 113         321 $from_DB_handlers->{$column} = $from_DB_handler;
776             }
777 61         164 $self->{from_DB_handlers} = $from_DB_handlers;
778              
779 61         156 return $self;
780             }
781              
782             sub _find_result_class {
783 35     35   77 my $self = shift;
784 35         112 my $name = ucfirst shift;
785 35         104 my $schema = $self->schema;
786 35   33     138 my $schema_class = ref $schema || $schema;
787              
788             # try to find subclass $name within namespace of schema or ancestors
789 35         95 foreach my $namespace (@{$schema->resultAs_classes}) {
  35         168  
790 68         219 my $class = "${namespace}::ResultAs::${name}";
791              
792             # see if that class is already loaded (by checking for a 'get_result' method)
793 68         110 my $is_loaded = defined &{$class."::get_result"};
  68         369  
794              
795             # otherwise, try to load the module
796 68     68   3771 $is_loaded ||= try {load $class; 1}
  34         1051  
797 68 100 66 34   744 catch {die $_ if $_ !~ /^Can't locate(?! object method)/};
  34         1397  
798              
799 67 100       1140 return $class if $is_loaded; # true : class is found, exit loop
800             }
801              
802 0           return; # false : class not found
803             }
804              
805              
806              
807             1; # End of DBIx::DataModel::Statement
808              
809             __END__