File Coverage

blib/lib/Class/DBI/Plugin/Pager.pm

Criterion	Covered	Total	%
statement	33	149	22.1
branch	2	60	3.3
condition	0	60	0.0
subroutine	9	22	40.9
pod	9	9	100.0
total	53	300	17.6

package Class::DBI::Plugin::Pager;
use strict;
use warnings;
use Carp;

use UNIVERSAL::require;
use SQL::Abstract;

use base qw( Data::Page Class::Data::Inheritable );

use vars qw( $VERSION );

$VERSION = '0.6_4';

# D::P inherits from Class::Accessor::Chained::Fast
__PACKAGE__->mk_accessors( qw( _where abstract_attr per_page page _order_by _cdbi_app ) );

__PACKAGE__->mk_classdata( '_syntax' );
__PACKAGE__->mk_classdata( '_pager_class' );


=head1 NAME

Class::DBI::Plugin::Pager - paged queries for CDBI

=head1 DESCRIPTION

Adds a pager method to your class that can query using SQL::Abstract where clauses,
and limit the number of rows returned to a specific subset.

=head1 SYNOPSIS

    package CD;
    use base 'Class::DBI';

    use Class::DBI::Plugin::AbstractCount;      # pager needs this

    use Class::DBI::Plugin::Pager;

    # or to use a different syntax
    # use Class::DBI::Plugin::Pager::RowsTo;

    __PACKAGE__->set_db(...);


    # in a nearby piece of code...

    use CD;

    # see SQL::Abstract for how to specify the query
    my $where = { ... };

    my $order_by => [ qw( foo bar ) ];

    # bit by bit:
    my $pager = CD->pager;

    $pager->per_page( 10 );
    $pager->page( 3 );
    $pager->where( $where );
    $pager->order_by( $order_by );

    $pager->set_syntax( 'RowsTo' );

    my @cds = $pager->search_where;

    # or all at once
    my $pager = CD->pager( $where, $order_by, 10, 3 );

    my @cds = $pager->search_where;

    # or

    my $pager = CD->pager;

    my @cds = $pager->search_where( $where, $order_by, 10, 3 );

    # $pager isa Data::Page
    # @cds contains the CDs just for the current page

=head1 METHODS

=over

=item import

Loads the C method into the CDBI app.

=cut

sub import {
    my ( $class ) = @_; # the pager class or subclass

    __PACKAGE__->_pager_class( $class );

    my $caller;

    # find the app
    foreach my $level ( 0 .. 10 )
    {
        $caller = caller( $level );
        last if UNIVERSAL::isa( $caller, 'Class::DBI' )
    }

    croak( "can't find the CDBI app" ) unless $caller;

    no strict 'refs';
    *{"$caller\::pager"} = \&pager;
}

=item pager( [$where, [$abstract_attr]], [$order_by], [$per_page], [$page], [$syntax] )

Also accepts named arguments:

    where           => $where,
    abstract_attr   => $attr,
    order_by        => $order_by,
    per_page        => $per_page,
    page            => $page,
    syntax          => $syntax

Returns a pager object. This subclasses L.

Note that for positional arguments, C<$abstract_attr> can only be passed if
preceded by a C<$where> argument.

C<$abstract_attr> can contain the C<$order_by> setting (just as in
L).

=over 4

=item configuration

The named arguments all exist as get/set methods.

=over 4

=item where

A hashref specifying the query. See L.

=item abstract_attr

A hashref specifying extra options to be passed through to the
L constructor.

=item order_by

Single column name or arrayref of column names for the ORDER BY clause.
Defaults to the primary key(s) if not set.

=item per_page

Number of results per page.

Defaults to 10, b if using the positional
arguments style, and supplying the C attribute, C must also
be supplied.

=item page

The pager will retrieve results just for this page. Defaults to 1.

=item syntax

Change the way the 'limit' clause is constructed. See C. Default
is C.

=back

=back

=cut

sub pager {
    my $cdbi = shift;

    my $class = __PACKAGE__->_pager_class;

    my $self = bless {}, $class;

    $self->_cdbi_app( $cdbi );

    # This has to come before _init, so the caller can choose to set the syntax
    # instead. But don't auto-set if we're a subclass.
    $self->auto_set_syntax if $class eq __PACKAGE__;

    $self->_init( @_ );

    return $self;
}

# _init is also called by results, so preserve any existing settings if
# new settings are not provided
sub _init {
    my $self = shift;

    return unless @_;

    my ( $where, $abstract_attr, $order_by, $per_page, $page, $syntax, $named_args );

    # I wish I'd never implemented positional arguments in the first place!
    # Does anyone use this?

    if ( @_ % 2 == 0 )
    {   # _might_ be named args
        my %args = @_;

        $where          = $args{where};
        $abstract_attr  = $args{abstract_attr};
        $order_by       = $args{order_by};
        $per_page       = $args{per_page};
        $page           = $args{page};
        $syntax         = $args{syntax};

        $named_args = $where || $abstract_attr || $order_by
                            || $per_page || $page || $syntax;
    }

    #if ( ref( $_[0] ) or $_[0] =~ /^\d+$/ )
    unless ( $named_args )
    {
        $where          = shift if ref $_[0]; # SQL::Abstract accepts a hashref or an arrayref
        $abstract_attr  = shift if ref $_[0] eq 'HASH';
        $order_by       = shift if ( @_ and $_[0] !~ /^\d+$/ );
        $per_page       = shift if ( @_ and $_[0] =~ /^\d+$/ );
        $page           = shift if ( @_ and $_[0] =~ /^\d+$/ );
        $syntax         = shift;
    }

    # Emulate AbstractSearch's search_where ordering -VV 20041209
    $order_by = delete $$abstract_attr{order_by} if ($abstract_attr and !$order_by);

    $per_page ||= $self->per_page;
    $page     ||= $self->page;

    $self->per_page( $per_page || 10 ); # if $per_page;
    $self->set_syntax( $syntax )          if $syntax;
    $self->abstract_attr( $abstract_attr )if $abstract_attr;
    $self->where( $where )                if $where;
    $self->order_by( $order_by )          if $order_by;
    $self->page( $page || 1 ); # if $page;
}

=item where( [ $where ] )

Translates accessor names into column names (or is it vice versa?). The
original C<$where> can be retrieved via C<_where()>.

=cut

sub where {
    my ( $self, $where ) = @_;

    $where ||= $self->_where;

    $self->_where( $where );

    my %columns = $self->_real_col_names( keys %$where );

    # keys are candidates, values are real names
    my %munged_where = map { $columns{ $_ } => $where->{ $_ } } keys %columns;

    return \%munged_where;
}

=item order_by( [ $order_by ] )

Does the same translation as C.

=cut

sub order_by {
    my ( $self, $order_by ) = @_;

    $order_by ||= $self->_order_by;

    $self->_order_by( $order_by );

    my @candidates = ref( $order_by ) ? @$order_by :
                        $order_by ? ( $order_by ) : ();

    my %columns = $self->_real_col_names( @candidates );

    return [ map { "$_" } values %columns ];
}

sub _real_col_names {
    my ( $self, @candidates ) = @_;

    my $cdbi = $self->_cdbi_app;

    my %cols = ();

    foreach my $candidate ( @candidates )
    {
        # lifted from Class::DBI::Plugin::CountSearch
        my $column = $cdbi->find_column( $candidate )
            || ( List::Util::first { $_->accessor eq $candidate } $cdbi->columns )
            || $cdbi->_croak("'$candidate' is not a column of $cdbi");

        $cols{ $candidate } = $column;
    }

    return %cols;
}

=item add_attr( %attributes )

Add to (or override) the L attributes:

    $pager->add_attr( cmp => 'like' );

=cut

sub add_attr {
    my ( $self, %attr ) = @_;

    my $abs_attr = $self->abstract_attr;

    $abs_attr->{ $_ } = $attr{ $_ } for keys %attr;

    $self->abstract_attr( $abs_attr );
}


=item search_where

Retrieves results from the pager. Accepts the same arguments as the C
method.

=cut

# like CDBI::AbstractSearch::search_where, with extra limitations
sub search_where {
    my $self = shift;

    $self->_init( @_ );

    $self->_setup_pager;

    my $cdbi = $self->_cdbi_app;

    my $order_by      = $self->order_by || [ $cdbi->primary_columns ];
    my $where         = $self->where;
    my $syntax        = $self->_syntax || $self->set_syntax;
    my $limit_phrase  = $self->$syntax;
    my $sql           = SQL::Abstract->new( %{ $self->abstract_attr  || {} } );

    $order_by = [ $order_by ] unless ref $order_by;
    my ( $phrase, @bind ) = $sql->where( $where, $order_by );

    $phrase .= ' ' . $limit_phrase;
    $phrase =~ s/^\s*WHERE\s*//i;

    return $cdbi->retrieve_from_sql( $phrase, @bind );
}

=item retrieve_all

Convenience method, generates a WHERE clause that matches all rows from the table.

Accepts the same arguments as the C or C methods, except that no
WHERE clause should be specified.

Note that the argument parsing routine called by the C method cannot cope with
positional arguments that lack a WHERE clause, so either use named arguments, or the
'bit by bit' approach, or pass the arguments directly to C.

=cut

sub retrieve_all {
        my $self = shift;

        my $get_all = { 1 => 1 };

    unless ( @_ )
        {   # already set pager up via method calls
                $self->where( $get_all );
                return $self->search_where;
        }

    my @args = ( ref( $_[0] ) or $_[0] =~ /^\d+$/ ) ?
                ( $get_all, @_ ) :          # send an array
                ( where => $get_all, @_ );  # send a hash

        return $self->search_where( @args );
}

=item retrieve_all_sorted_by( $order )

Useful for L.

=cut

sub retrieve_all_sorted_by {
    my ( $self, $order ) = @_;

    return $self->retrieve_all( { order_by => $order } );
}

sub _setup_pager {
    my ( $self ) = @_;

    my $where    = $self->where    || croak( 'must set a query before retrieving results' );
    my $per_page = $self->per_page || croak( 'no. of entries per page not specified' );
    my $cdbi     = $self->_cdbi_app;
    my $count    = $cdbi->count_search_where( $where, $self->abstract_attr );
    #my $count    = $self->_get_count;
    my $page     = $self->page || 1;

    $self->total_entries( $count );
    $self->entries_per_page( $per_page );
    $self->current_page( $page );

    croak( 'Fewer than one entry per page!' ) if $self->entries_per_page < 1;

    $self->current_page( $self->first_page ) unless defined $self->current_page;
    $self->current_page( $self->first_page ) if $self->current_page < $self->first_page;
    $self->current_page( $self->last_page  ) if $self->current_page > $self->last_page;
}



#sub _get_count {
#    my ( $self ) = @_;
#
#    my $where = $self->where || croak( 'must set a query before retrieving results' );
#    my $cdbi  = $self->_cdbi_app;
#
#    # Class::DBI::Plugin::AbstractCount can handle SQL::Abstract attributes
#    return $cdbi->count_search_where( $where, $self->abstract_attr )
#        if $cdbi->can( 'count_search_where' );
#
#    # Class::DBI::Plugin::CountSearch correctly handles aliased column accessors
#    # (i.e. accessors for columns where the accessor has a different name from the
#    # column). But it can't handle SQL::Abstract attributes.
#    croak( 'no way to count total entries' ) unless $cdbi->can( 'count_search' );
#
#    croak( 'Class::DBI::Plugin::CountSearch does not handle SQL::Abstract attributes - '
#            . 'use Class::DBI::Plugin::AbstractCount instead' )
#        if $self->abstract_attr;
#
#    my @cols = keys %$where;
#
#    croak('no keys in where clause') unless @cols > 0;
#
#    # unqualified count
#    return $cdbi->count_search if ( @cols == 1 and $cols[0] eq '1' );
#
#    # count with search fields
#    my @args;
#
#    foreach my $col ( @cols )
#    {
#        my $expr = $where->{$col};
#
#        croak( "code doesn't handle anything but 'like'!" )
#            unless keys %$expr == 1 and $expr->{like};
#
#        push @args, $col => $expr->{like};
#    }
#
#    return $cdbi->count_search_like( @args );
#}

# SQL::Abstract::_recurse_where eats the WHERE clause
#sub where {
#	my ( $self, $where_ref ) = @_;
#
#	return $self->_where unless $where_ref;
#
#	my $where_copy;
#
#	if ( ref( $where_ref ) eq 'HASH' ) {
#		$where_copy = { %$where_ref };
#	}
#	elsif ( ref( $where_ref ) eq 'ARRAY' )
#	{
#		$where_copy = [ @$where_ref ];
#	}
#	else
#	{
#		die "WHERE clause [$where_ref] must be specified as an ARRAYREF or HASHREF";
#	}
#
#	# this will get eaten, but the caller's value is now protected
#	$self->_where( $where_copy );
#}

=item set_syntax( [ $name || $class || $coderef ] )

Changes the syntax used to generate the C or other phrase that restricts
the results set to the required page.

The syntax is implemented as a method called on the pager, which can be
queried to provide the C<$rows> and C<$offset> parameters (see the subclasses
included in this distribution).

=over 4

=item $class

A class with a C method.

=item $name

Name of a class in the C namespace, which has a
C method.

=item $coderef

Will be called as a method on the pager object, so receives the pager as its
argument.

=item (no args)

Called without args, will default to C, which causes
L
to be used.

=back

=cut

sub set_syntax {
    my ( $proto, $syntax ) = @_;

    # pick up default from subclass, or load from LimitOffset
    $syntax ||= $proto->can( 'make_limit' );
    $syntax ||= 'LimitOffset';

    if ( ref( $syntax ) eq 'CODE' )
    {
        $proto->_syntax( $syntax );
        return $syntax;
    }

    my $format_class = $syntax =~ '::' ? $syntax : "Class::DBI::Plugin::Pager::$syntax";

    $format_class->require || croak "error loading $format_class: $UNIVERSAL::require::ERROR";

    my $formatter = $format_class->can( 'make_limit' ) || croak "no make_limit method in $format_class";

    $proto->_syntax( $formatter );

    return $formatter;
}

=item auto_set_syntax

This is called automatically when you call C, and attempts to set the
syntax automatically.

If you are using a subclass of the pager, this method will not be called.

Will C if using Oracle or DB2, since there is no simple syntax for limiting
the results set. DB2 has a C keyword, but that seems to apply to a
cursor and I don't know if there is a cursor available to the pager. There
should probably be others to add to the unsupported list.

Supports the following drivers:

                    DRIVER        CDBI::P::Pager subclass
    my %supported = ( pg        => 'LimitOffset',
                    mysql     => 'LimitOffset', # older versions need LimitXY
                    sqlite    => 'LimitOffset', # or LimitYX
                    interbase => 'RowsTo',
                    firebird  => 'RowsTo',
                    );

Older versions of MySQL should use the LimitXY syntax. You'll need to set it
manually, either by C, or by passing
C 'LimitXY'> to a method call, or call C directly.

Any driver not in the supported or unsupported lists defaults to LimitOffset.

Any additions to the supported and unsupported lists gratefully received.

=cut

sub auto_set_syntax {
    my ( $self ) = @_;

    # not an exhaustive list
    my %not_supported = ( oracle => 'Oracle',
                        db2    => 'DB2',
                        );

    # additions welcome
    my %supported = ( pg        => 'LimitOffset',
                    mysql     => 'LimitOffset', # older versions need LimitXY
                    sqlite    => 'LimitOffset', # or LimitYX
                    interbase => 'RowsTo',
                    firebird  => 'RowsTo',
                    );

    my $cdbi = $self->_cdbi_app;

    my $driver = lc( $cdbi->__driver );

    die __PACKAGE__ . " can't build limit clauses for $not_supported{ $driver }"
        if $not_supported{ $driver };

    $self->set_syntax( $supported{ $driver } || 'LimitOffset' );
}

1;

__END__