The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
package Class::DBI::Plugin::AbstractCount;
# vim:set tabstop=2 shiftwidth=2 expandtab:

use strict;
use base 'Class::DBI::Plugin';
use SQL::Abstract;

our $VERSION = '0.08';

sub init
{
  my $class = shift;
  $class->set_sql( count_search_where => qq{
      SELECT COUNT(*)
      FROM __TABLE__
      %s
    } );
}

sub count_search_where : Plugged
{
  my $class = shift;
  my %where = ();
  my $rh_attr = {};
  if ( ref $_[0] ) {
    $class->_croak( "where-clause must be a hashref it it's a reference" )
      unless ref( $_[0] ) eq 'HASH';
    %where = %{ $_[0] };
    $rh_attr = $_[1];
  }
  else {
    $rh_attr = pop if @_ % 2;
    %where = @_;
  }
  delete $rh_attr->{order_by};

  $class->can( 'retrieve_from_sql' )
    or $class->_croak( "$class should inherit from Class::DBI >= 0.95" );
  
  my ( %columns, %accessors ) = ();
  for my $column ( $class->columns ) {
    ++$columns{ $column };
    $accessors{ $column->accessor } = $column;
  }

  COLUMN: for my $column ( keys %where ) {
    # Column names are (of course) OK
    next COLUMN if exists $columns{ $column };

    # Accessor names are OK, but replace them with corresponding column name
    $where{ $accessors{ $column }} = delete $where{ $column }, next COLUMN
      if exists $accessors{ $column };

    # SQL::Abstract keywords are OK
    next COLUMN
      if $column =~ /^-(?:and|or|nest|(?:(not_)?(?:like|between)))$/;

    # Check for functions
    if ( index( $column, '(' ) > 0
      && index( $column, ')' ) > 1 )
    {
      my @tokens = ( $column =~ /(-?\w+(?:\s*\(\s*)?|\W+)/g );
      TOKEN: for my $token ( @tokens ) {
        if ( $token !~ /\W/ ) { # must be column or accessor name
          next TOKEN if exists $columns{ $token };
          $token = $accessors{ $token }, next TOKEN
            if exists $accessors{ $token };
          $class->_croak(
            qq{"$token" is not a column/accessor of class "$class"} );
        }
      }

      my $normalized = join "", @tokens;
      $where{ $normalized } = delete $where{ $column }
        if $normalized ne $column;
      next COLUMN;
    }

    $class->_croak( qq{"$column" is not a column/accessor of class "$class"} );
  }

  my ( $phrase, @bind ) = SQL::Abstract
    -> new( %$rh_attr )
    -> where( \%where );
  $class
    -> sql_count_search_where( $phrase )
    -> select_val( @bind );
}

1;
__END__

=head1 NAME

Class::DBI::Plugin::AbstractCount - get COUNT(*) results with abstract SQL

=head1 SYNOPSIS

  use base 'Class::DBI';
  use Class::DBI::Plugin::AbstractCount;
  
  my $count = Music::Vinyl->count_search_where(
    { artist   => 'Frank Zappa'
    , title    => { like    => '%Shut Up 'n Play Yer Guitar%' }
    , released => { between => [ 1980, 1982 ] }
    });

=head1 DESCRIPTION

This Class::DBI plugin combines the functionality from
Class::DBI::Plugin::CountSearch (counting objects without having to use an
array or an iterator), and Class::DBI::AbstractSearch, which allows complex
where-clauses a la SQL::Abstract.

=head1 METHODS

=head2 count_search_where

Takes a hashref with the abstract where-clause. An additional attribute hashref
can be passed to influence the default behaviour: arrayrefs are OR'ed, hashrefs
are AND'ed.

=head1 TODO

More tests, more doc.

=head1 SEE ALSO

=over

=item SQL::Abstract for details about the where-clause and the attributes.

=item Class::DBI::AbstractSearch

=item Class::DBI::Plugin::CountSearch

=back

=head1 AUTHOR

Jean-Christophe Zeus, E<lt>mail@jczeus.comE<gt> with some help from
Tatsuhiko Myagawa and Todd Holbrook.

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2004 by Jean-Christophe Zeus

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut