← Index
NYTProf Performance Profile   « block view • line view • sub view »
For ddd2.pl
  Run on Tue May 25 16:52:24 2010
Reported on Tue May 25 16:56:46 2010

File /project/perl/lib/Class/DBI/Plugin/Pager.pm
Statements Executed 37
Statement Execution Time 13.1ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
111112µs160µsClass::DBI::Plugin::Pager::::importClass::DBI::Plugin::Pager::import
0000s0sClass::DBI::Plugin::Pager::::BEGINClass::DBI::Plugin::Pager::BEGIN
0000s0sClass::DBI::Plugin::Pager::::_initClass::DBI::Plugin::Pager::_init
0000s0sClass::DBI::Plugin::Pager::::_setup_pagerClass::DBI::Plugin::Pager::_setup_pager
0000s0sClass::DBI::Plugin::Pager::::auto_set_syntaxClass::DBI::Plugin::Pager::auto_set_syntax
0000s0sClass::DBI::Plugin::Pager::::pagerClass::DBI::Plugin::Pager::pager
0000s0sClass::DBI::Plugin::Pager::::retrieve_allClass::DBI::Plugin::Pager::retrieve_all
0000s0sClass::DBI::Plugin::Pager::::search_whereClass::DBI::Plugin::Pager::search_where
0000s0sClass::DBI::Plugin::Pager::::set_syntaxClass::DBI::Plugin::Pager::set_syntax
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Class::DBI::Plugin::Pager;
2387µs127µsuse strict;
# spent 27µs making 1 call to strict::import
3381µs1115µsuse warnings;
# spent 115µs making 1 call to warnings::import
4390µs1243µsuse Carp;
# spent 243µs making 1 call to Exporter::import
5
639.91ms1138µsuse UNIVERSAL::require;
# spent 138µs making 1 call to Exporter::import
73100µs1125µsuse SQL::Abstract;
# spent 125µs making 1 call to Exporter::import
8
93108µs10suse base qw( Data::Page Class::Data::Inheritable );
# spent 32.4ms making 1 call to base::import, recursion: max depth 1, time 32.4ms
10
113289µs1141µsuse vars qw( $VERSION );
# spent 141µs making 1 call to vars::import
12
1316µs$VERSION = 0.561;
14
15# D::P inherits from Class::Accessor::Chained::Fast
16153µs11.34ms__PACKAGE__->mk_accessors( qw( where abstract_attr per_page page order_by _cdbi_app ) );
# spent 1.34ms making 1 call to Class::Accessor::mk_accessors
17
18136µs160µs__PACKAGE__->mk_classdata( '_syntax' );
# spent 60µs making 1 call to Class::Data::Inheritable::mk_classdata
19126µs152µs__PACKAGE__->mk_classdata( '_pager_class' );
# spent 52µs making 1 call to Class::Data::Inheritable::mk_classdata
20
21
22=head1 NAME
23
24Class::DBI::Plugin::Pager - paged queries for CDBI
25
26=head1 DESCRIPTION
27
28Adds a pager method to your class that can query using SQL::Abstract where clauses,
29and limit the number of rows returned to a specific subset.
30
31=head1 SYNOPSIS
32
33 package CD;
34 use base 'Class::DBI';
35
36 use Class::DBI::Plugin::AbstractCount; # pager needs this
37 use Class::DBI::Plugin::Pager;
38
39 # or to use a different syntax
40 # use Class::DBI::Plugin::Pager::RowsTo;
41
42 __PACKAGE__->set_db(...);
43
44
45 # in a nearby piece of code...
46
47 use CD;
48
49 # see SQL::Abstract for how to specify the query
50 my $where = { ... };
51
52 my $order_by => [ qw( foo bar ) ];
53
54 # bit by bit:
55 my $pager = CD->pager;
56
57 $pager->per_page( 10 );
58 $pager->page( 3 );
59 $pager->where( $where );
60 $pager->order_by( $order_by );
61
62 $pager->set_syntax( 'RowsTo' );
63
64 my @cds = $pager->search_where;
65
66 # or all at once
67 my $pager = CD->pager( $where, $order_by, 10, 3 );
68
69 my @cds = $pager->search_where;
70
71 # or
72
73 my $pager = CD->pager;
74
75 my @cds = $pager->search_where( $where, $order_by, 10, 3 );
76
77 # $pager isa Data::Page
78 # @cds contains the CDs just for the current page
79
80=head1 METHODS
81
82=over
83
84=item import
85
86Loads the C<pager> method into the CDBI app.
87
88=cut
89
90
# spent 160µs (112+48) within Class::DBI::Plugin::Pager::import which was called # once (112µs+48µs) by base::import at line 10 of K2/DB2.pm
sub import {
918131µs my ( $class ) = @_; # the pager class or subclass
92
93 __PACKAGE__->_pager_class( $class );
94
95 my $caller;
96
97 # find the app - supports subclassing (My::Pager is_a CDBI::P::Pager, not_a CDBI)
98 foreach my $level ( 0 .. 10 )
99 {
100 $caller = caller( $level );
101 last if UNIVERSAL::isa( $caller, 'Class::DBI' )
# spent 22µs making 1 call to UNIVERSAL::isa
102 }
103
104 warn( "can't find the CDBI app" ), return unless $caller;
105 #croak( "can't find the CDBI app" ) unless $caller;
106
10732.20ms1101µs no strict 'refs';
# spent 101µs making 1 call to strict::unimport
108 *{"$caller\::pager"} = \&pager;
109}
110
111=item pager( [$where, [$abstract_attr]], [$order_by], [$per_page], [$page], [$syntax] )
112
113Also accepts named arguments:
114
115 where => $where,
116 abstract_attr => $attr,
117 order_by => $order_by,
118 per_page => $per_page,
119 page => $page,
120 syntax => $syntax
121
122Returns a pager object. This subclasses L<Data::Page>.
123
124Note that for positional arguments, C<$abstract_attr> can only be passed if
125preceded by a C<$where> argument.
126
127C<$abstract_attr> can contain the C<$order_by> setting (just as in
128L<SQL::Abstract|SQL::Abstract>).
129
130=over 4
131
132=item configuration
133
134The named arguments all exist as get/set methods.
135
136=over 4
137
138=item where
139
140A hashref specifying the query. See L<SQL::Abstract|SQL::Abstract>.
141
142=item abstract_attr
143
144A hashref specifying extra options to be passed through to the
145L<SQL::Abstract|SQL::Abstract> constructor.
146
147=item order_by
148
149Single column name or arrayref of column names for the ORDER BY clause.
150Defaults to the primary key(s) if not set.
151
152=item per_page
153
154Number of results per page.
155
156=item page
157
158The pager will retrieve results just for this page. Defaults to 1.
159
160=item syntax
161
162Change the way the 'limit' clause is constructed. See C<set_syntax>. Default
163is C<LimitOffset>.
164
165=back
166
167=back
168
169=cut
170
171sub pager {
172 my $cdbi = shift;
173
174 my $class = __PACKAGE__->_pager_class;
175
176 my $self = bless {}, $class;
177
178 $self->_cdbi_app( $cdbi );
179
180 # This has to come before _init, so the caller can choose to set the syntax
181 # instead. But don't auto-set if we're a subclass.
182 $self->auto_set_syntax if $class eq __PACKAGE__;
183
184 $self->_init( @_ );
185
186 return $self;
187}
188
189# _init is also called by results, so preserve any existing settings if
190# new settings are not provided
191sub _init {
192 my $self = shift;
193
194 return unless @_;
195
196 my ( $where, $abstract_attr, $order_by, $per_page, $page, $syntax );
197
198 if ( ref( $_[0] ) or $_[0] =~ /^\d+$/ )
199 {
200 $where = shift if ref $_[0]; # SQL::Abstract accepts a hashref or an arrayref
201 $abstract_attr = shift if ref $_[0] eq 'HASH';
202# $order_by = shift unless $_[0] =~ /^\d+$/;
203# $per_page = shift if $_[0] =~ /^\d+$/;
204# $page = shift if $_[0] =~ /^\d+$/;
205 $order_by = shift unless $_[0] and $_[0] =~ /^\d+$/;
206 $per_page = shift if $_[0] and $_[0] =~ /^\d+$/;
207 $page = shift if $_[0] and $_[0] =~ /^\d+$/;
208 $syntax = shift;
209 }
210 else
211 {
212 my %args = @_;
213
214 $where = $args{where};
215 $abstract_attr = $args{abstract_attr};
216 $order_by = $args{order_by};
217 $per_page = $args{per_page};
218 $page = $args{page};
219 $syntax = $args{syntax};
220 }
221
222 # Emulate AbstractSearch's search_where ordering -VV 20041209
223 $order_by = delete $$abstract_attr{order_by} if ($abstract_attr and !$order_by);
224
225 $self->per_page( $per_page ) if $per_page;
226 $self->set_syntax( $syntax ) if $syntax;
227 $self->abstract_attr( $abstract_attr )if $abstract_attr;
228 $self->where( $where ) if $where;
229 $self->order_by( $order_by ) if $order_by;
230 $self->page( $page ) if $page;
231}
232
233=item search_where
234
235Retrieves results from the pager. Accepts the same arguments as the C<pager>
236method.
237
238=cut
239
240# like CDBI::AbstractSearch::search_where, with extra limitations
241sub search_where {
242 my $self = shift;
243
244 $self->_init( @_ );
245
246 $self->_setup_pager;
247
248 my $cdbi = $self->_cdbi_app;
249
250 my $order_by = $self->order_by || [ $cdbi->primary_columns ];
251 my $where = $self->where;
252 my $syntax = $self->_syntax || $self->set_syntax;
253 my $limit_phrase = $self->$syntax;
254 my $sql = SQL::Abstract->new( %{ $self->abstract_attr || {} } );
255
256 $order_by = [ $order_by ] unless ref $order_by;
257 my ( $phrase, @bind ) = $sql->where( $where, $order_by );
258
259 # If the phrase starts with the ORDER clause (i.e. no WHERE spec), then we are
260 # emulating a { 1 => 1 } search, but avoiding the bug in Class::DBI::Plugin::AbstractCount 0.04,
261 # so we need to replace the spec - patch from Will Hawes
262 if ( $phrase =~ /^\s*ORDER\s*/i )
263 {
264 $phrase = ' 1=1' . $phrase;
265 }
266
267
268 $phrase .= ' ' . $limit_phrase;
269 $phrase =~ s/^\s*WHERE\s*//i;
270
271 return $cdbi->retrieve_from_sql( $phrase, @bind );
272}
273
274=item retrieve_all
275
276Convenience method, generates a WHERE clause that matches all rows from the table.
277
278Accepts the same arguments as the C<pager> or C<search_where> methods, except that no
279WHERE clause should be specified.
280
281Note that the argument parsing routine called by the C<pager> method cannot cope with
282positional arguments that lack a WHERE clause, so either use named arguments, or the
283'bit by bit' approach, or pass the arguments directly to C<retrieve_all>.
284
285=cut
286
287sub retrieve_all
288{
289 my $self = shift;
290
291 my $get_all = {}; # { 1 => 1 };
292
293 unless ( @_ )
294 { # already set pager up via method calls
295 $self->where( $get_all );
296 return $self->search_where;
297 }
298
299 my @args = ( ref( $_[0] ) or $_[0] =~ /^\d+$/ ) ?
300 ( $get_all, @_ ) : # send an array
301 ( where => $get_all, @_ ); # send a hash
302
303 return $self->search_where( @args );
304}
305
306sub _setup_pager
307{
308 my ( $self ) = @_;
309
310 my $where = $self->where || {};
311
312 # fix { 1 => 1 } as a special case - Class::DBI::Plugin::AbstractCount 0.04 has a bug in
313 # its column-checking code
314 if ( ref( $where ) eq 'HASH' and $where->{1} )
315 {
316 $where = {};
317 $self->where( {} );
318 }
319
320 my $per_page = $self->per_page || croak( 'no. of entries per page not specified' );
321 my $cdbi = $self->_cdbi_app;
322 my $count = $cdbi->count_search_where( $where, $self->abstract_attr );
323 my $page = $self->page || 1;
324
325 $self->total_entries( $count );
326 $self->entries_per_page( $per_page );
327 $self->current_page( $page );
328
329 croak( 'Fewer than one entry per page!' ) if $self->entries_per_page < 1;
330
331 $self->current_page( $self->first_page ) unless defined $self->current_page;
332 $self->current_page( $self->first_page ) if $self->current_page < $self->first_page;
333 $self->current_page( $self->last_page ) if $self->current_page > $self->last_page;
334}
335
336# SQL::Abstract::_recurse_where eats the WHERE clause
337#sub where {
338# my ( $self, $where_ref ) = @_;
339#
340# return $self->_where unless $where_ref;
341#
342# my $where_copy;
343#
344# if ( ref( $where_ref ) eq 'HASH' ) {
345# $where_copy = { %$where_ref };
346# }
347# elsif ( ref( $where_ref ) eq 'ARRAY' )
348# {
349# $where_copy = [ @$where_ref ];
350# }
351# else
352# {
353# die "WHERE clause [$where_ref] must be specified as an ARRAYREF or HASHREF";
354# }
355#
356# # this will get eaten, but the caller's value is now protected
357# $self->_where( $where_copy );
358#}
359
360=item set_syntax( [ $name || $class || $coderef ] )
361
362Changes the syntax used to generate the C<limit> or other phrase that restricts
363the results set to the required page.
364
365The syntax is implemented as a method called on the pager, which can be
366queried to provide the C<$rows> and C<$offset> parameters (see the subclasses
367included in this distribution).
368
369=over 4
370
371=item $class
372
373A class with a C<make_limit> method.
374
375=item $name
376
377Name of a class in the C<Class::DBI::Plugin::Pager::> namespace, which has a
378C<make_limit> method.
379
380=item $coderef
381
382Will be called as a method on the pager object, so receives the pager as its
383argument.
384
385=item (no args)
386
387Called without args, will default to C<LimitOffset>, which causes
388L<Class::DBI::Plugin::Pager::LimitOffset|Class::DBI::Plugin::Pager::LimitOffset>
389to be used.
390
391=back
392
393=cut
394
395sub set_syntax {
396 my ( $proto, $syntax ) = @_;
397
398 # pick up default from subclass, or load from LimitOffset
399 $syntax ||= $proto->can( 'make_limit' );
400 $syntax ||= 'LimitOffset';
401
402 if ( ref( $syntax ) eq 'CODE' )
403 {
404 $proto->_syntax( $syntax );
405 return $syntax;
406 }
407
408 my $format_class = $syntax =~ '::' ? $syntax : "Class::DBI::Plugin::Pager::$syntax";
409
410 $format_class->require || croak "error loading $format_class: $UNIVERSAL::require::ERROR";
411
412 my $formatter = $format_class->can( 'make_limit' ) || croak "no make_limit method in $format_class";
413
414 $proto->_syntax( $formatter );
415
416 return $formatter;
417}
418
419=item auto_set_syntax
420
421This is called automatically when you call C<pager>, and attempts to set the
422syntax automatically.
423
424If you are using a subclass of the pager, this method will not be called.
425
426Will C<die> if using Oracle or DB2, since there is no simple syntax for limiting
427the results set. DB2 has a C<FETCH> keyword, but that seems to apply to a
428cursor and I don't know if there is a cursor available to the pager. There
429should probably be others to add to the unsupported list.
430
431Supports the following drivers:
432
433 DRIVER CDBI::P::Pager subclass
434 my %supported = ( pg => 'LimitOffset',
435 mysql => 'LimitOffset', # older versions need LimitXY
436 sqlite => 'LimitOffset', # or LimitYX
437 sqlite2 => 'LimitOffset', # or LimitYX
438 interbase => 'RowsTo',
439 firebird => 'RowsTo',
440 );
441
442Older versions of MySQL should use the LimitXY syntax. You'll need to set it
443manually, either by C<use CDBI::P::Pager::LimitXY>, or by passing
444C<syntax =E<gt> 'LimitXY'> to a method call, or call C<set_syntax> directly.
445
446Any driver not in the supported or unsupported lists defaults to LimitOffset.
447
448Any additions to the supported and unsupported lists gratefully received.
449
450=cut
451
452sub auto_set_syntax {
453 my ( $self ) = @_;
454
455 # not an exhaustive list
456 my %not_supported = ( oracle => 'Oracle',
457 db2 => 'DB2',
458 );
459
460 # additions welcome
461 my %supported = ( pg => 'LimitOffset',
462 mysql => 'LimitOffset', # older versions need LimitXY
463 sqlite => 'LimitOffset', # or LimitYX
464 sqlite2 => 'LimitOffset', # or LimitYX
465 interbase => 'RowsTo',
466 firebird => 'RowsTo',
467 );
468
469 my $cdbi = $self->_cdbi_app;
470
471 my $driver = lc( $cdbi->__driver );
472
473 die __PACKAGE__ . " can't build limit clauses for $not_supported{ $driver }"
474 if $not_supported{ $driver };
475
476 #warn sprintf "Setting syntax to %s for $driver", $supported{ $driver } || 'LimitOffset';
477
478 $self->set_syntax( $supported{ $driver } || 'LimitOffset' );
479}
480
481119µs1;
482
483__END__
484
485#=for notes
486#
487#Would this work?
488#
489#with $limit and $offset defined.
490#
491#my $last = $limit + $offset
492#
493#my $order_by_str = join( ', ', @$order_by )
494#
495#$cdbi->set_sql( emulate_limit => <<'');
496# SELECT * FROM (
497# SELECT TOP $limit * FROM (
498# SELECT TOP $last __ESSENTIAL__
499# FROM __TABLE__
500# ORDER BY $order_by_str ASC
501# ) AS foo ORDER BY $order_by_str DESC
502# ) AS bar ORDER BY $order_by_str ASC
503#
504#
505#e.g. MS Access (thanks Emanuele Zeppieri)
506#
507#to add LIMIT/OFFSET to this query:
508#
509#SELECT my_column
510#FROM my_table
511#ORDER BY my_column ASC
512#
513#say with the values LIMIT=5 OFFSET=10, you have to resort to the TOP
514#clause and re-write it this way:
515#
516#SELECT * FROM (
517# SELECT TOP 5 * FROM (
518# SELECT TOP 15 my_column
519# FROM my_table
520# ORDER BY my_column ASC
521# ) AS foo ORDER BY my_column DESC
522#) AS bar ORDER BY my_column ASC
523#
524#=cut
525
526=back
527
528=head2 SUBCLASSING
529
530The 'limit' syntax can be set by using a subclass, e.g.
531
532 use Class::DBI::Plugin::Pager::RowsTo;
533
534instead of setting at runtime. A subclass looks like this:
535
536 package Class::DBI::Plugin::Pager::RowsTo;
537 use base 'Class::DBI::Plugin::Pager';
538
539 sub make_limit {
540 my ( $self ) = @_;
541
542 my $offset = $self->skipped;
543 my $rows = $self->entries_per_page;
544
545 my $last = $rows + $offset;
546
547 return "ROWS $offset TO $last";
548 }
549
550 1;
551
552You can omit the C<use base> and switch syntax by calling
553C<$pager-E<gt>set_syntax( 'RowsTo' )>. Or you can leave in the C<use base> and
554still say C<$pager-E<gt>set_syntax( 'RowsTo' )>, because in this case the class is
555C<require>d and the C<import> in the base class doesn't get called. Or something.
556At any rate, It Works.
557
558The subclasses implement the following LIMIT syntaxes:
559
560=over
561
562=item Class::DBI::Plugin::Pager::LimitOffset
563
564 LIMIT $rows OFFSET $offset
565
566This is the default if your driver is not in the list of known drivers.
567
568This should work for PostgreSQL, more recent MySQL, SQLite, and maybe some
569others.
570
571=item Class::DBI::Plugin::LimitXY
572
573 LIMIT $offset, $rows
574
575Older versions of MySQL.
576
577=item Class::DBI::Plugin::LimitYX
578
579 LIMIT $rows, $offset
580
581SQLite.
582
583=item Class::DBI::Plugin::RowsTo
584
585 ROWS $offset TO $offset + $rows
586
587InterBase, also FireBird, maybe others?
588
589=back
590
591=head1 TODO
592
593I've only used this on an older version of MySQL. Reports of this thing
594working (or not) elsewhere would be useful.
595
596It should be possible to use C<set_sql> to build the complex queries
597required by some databases to emulate LIMIT (see notes in source).
598
599=head1 CAVEATS
600
601This class can't implement the subselect mechanism required by some databases
602to emulate the LIMIT phrase, because it only has access to the WHERE clause,
603not the whole SQL statement. At the moment.
604
605Each query issues two requests to the database - the first to count the entire
606result set, the second to retrieve the required subset of results. If your
607tables are small it may be quicker to use L<Class::DBI::Pager|Class::DBI::Pager>.
608
609The C<order_by> clause means the database has to retrieve (internally) and sort
610the entire results set, before chopping out the requested subset. It's probably
611a good idea to have an index on the column(s) used to order the results. For
612huge tables, this approach to paging may be too inefficient.
613
614=head1 DEPENDENCIES
615
616L<SQL::Abstract|SQL::Abstract>,
617L<Data::Page|Data::Page>,
618L<Class::DBI::Plugin::AbstractCount|Class::DBI::Plugin::AbstractCount>,
619L<Class::Accessor|Class::Accessor>,
620L<Class::Data::Inheritable|Class::Data::Inheritable>,
621L<Carp|Carp>.
622
623=head1 SEE ALSO
624
625L<Class::DBI::Pager|Class::DBI::Pager> does a similar job, but retrieves
626the entire results set into memory before chopping out the page you want.
627
628=head1 BUGS
629
630Please report all bugs via the CPAN Request Tracker at
631L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-DBI-Plugin-Pager>.
632
633=head1 COPYRIGHT AND LICENSE
634
635Copyright 2004 by David Baird.
636
637This library is free software; you can redistribute it and/or modify
638it under the same terms as Perl itself.
639
640=head1 AUTHOR
641
642David Baird, C<cpan@riverside-cms.co.uk>
643