DBIx::Librarian::Statement - an active SQL statement in a Librarian

    SELECT*	return zero or more rows as an array
    SELECT?	return zero or one rows as a scalar
    SELECT1	return exactly one row as a scalar

  my $stmt = new DBIx::Librarian::Statement ($dbh, $sql);

  $stmt->execute($data);

package DBIx::Librarian::Statement;

require 5.005;
use strict;
use base qw(Class::Virtual);
use vars qw($VERSION);
$VERSION = '0.4';

use Carp;
use Time::HiRes qw( gettimeofday tv_interval );

use Log::Channel;
{
    my $execlog = new Log::Channel "exec";
    sub execlog { $execlog->(@_) }
    my $perflog = new Log::Channel "perf";
    sub perflog { $perflog->(@_) }
    my $rowlog = new Log::Channel "rows";
    sub rowlog { $rowlog->(@_) }
    my $bindlog = new Log::Channel "bind";
    sub bindlog { $bindlog->(@_) }
}

__PACKAGE__->virtual_methods(qw(fetch));

my %select_mode = (
		   "*"	=> "SelectMany",
		   "?"	=> "SelectOne",
		   "1"	=> "SelectExactlyOne",
		   ""	=> "SelectMany",
		  );

sub new {
    my ($proto, $dbh, $sql, %config) = @_;

    my $class = ref ($proto) || $proto;
    my $self = {
		DBH => $dbh
	       };
    while (my ($key, $val) = each %config) {
	$self->{$key} = $val;
    }


    # WARNING: Oracle does not like ? placeholders inside comments.
    #   If Statement thinks that the ? in the comment is a bind value
    #   and includes a value for it in the execute() list, Oracle receives
    #   more values than it expects.
    #   mysql seems to handle this correctly.
    #   May need to strip comments from SQL before converting placeholders.
    #   Yuck.  Is there a cross-platform way to do this?


    my @bindvars = $sql =~ /[^A-Za-z0-9:]:([[:word:].]+)/mog;
    if (@bindvars) {
	$sql =~ s/([^A-Za-z0-9:]):[[:word:].]+/$1?/og;
    }
    $self->{BINDVARS} = \@bindvars;

    if ($sql =~ /^select/io) {
	my ($mode) = $sql =~ /^select(\S*)/io;

	croak "Unrecognized select mode $mode in\n$sql\n"
	  unless $select_mode{$mode};

	# delegate SELECT processing based on expected rows returned

	$class = __PACKAGE__ . "::$select_mode{$mode}";
	my $classpath = $class;
	$classpath =~ s{::}{/}g;
	require "$classpath.pm";

	$sql =~ s/^select\S*/select/io;

	$self->{IS_SELECT} = 1;
    }


    bless ($self, $class);


    my @directvars;
    if ($sql =~ /\$\w+/o) {
	# requires on-demand parsing
	@directvars = $sql =~ /\$(\w+)/og;
	$self->{DIRECTVARS} = \@directvars;
#	$self->{SQL} = $sql;
    }
    else {
	# can prepare in advance
	$self->_prepare($sql);
    }

    $self->{SQL} = $sql;

    return $self;
}


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

    execlog "PREPARE SQL:\n", $sql, "\n====================\n";

    my $sth = $self->{DBH}->prepare($sql);
    if (!$sth) {
	croak $self->{DBH}->errstr;
    }
    $self->{STH} = $sth;
}

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

    execlog "EXECUTE SQL:\n", $self->{SQL}, "\n==========\n";

    $self->_substitutions($data);

    my @bindlist = $self->_bind($data);

    if ($self->{IS_SELECT} && !$data) {
	# caller(0) gives this line here in Statement.pm
	# caller(1) gives line in _execute() in Librarian.pm
	# caller(2) gives line in execute() in Librarian.pm
	# caller(3) gives the application code invoking Librarian::execute()
	my (undef, $filename, $line) = caller(3);
	croak "Missing required data parameter for SQL execute(\"$self->{NAME}\")\n at $filename line $line\n";
    }

    my $t0 = [ gettimeofday ];

    if (! $self->{STH}->execute(@bindlist)) {
	croak $self->{DBH}->errstr. " in SQL\n$self->{STH}->{Statement}\n";
    }

    my $elapsed = tv_interval ($t0, [ gettimeofday ]);
    perflog "ELAPSED TIME: ", $elapsed, "\n";

    my $rows;
    if ($self->{IS_SELECT}) {
	$rows = $self->fetch($data);
	rowlog "ROWS RETRIEVED: ", $rows, "\n";
    }
    else {
	rowlog "ROWS ALTERED: ", $self->{STH}->rows, "\n";
	$rows = $self->{STH}->rows;
    }

    return $rows;
}


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

    return unless $self->{DIRECTVARS};

    # The SQL contains "$parameter" substitutions.
    # Must be re-prepared before every execution.

    my $sql = $self->{SQL};
    foreach my $directvar (@{$self->{DIRECTVARS}}) {
	my $val;
	if ($self->{ALLARRAYS}) {
	    $val = $data->{$directvar}[0];
	} else {
	    croak "Expected scalar for $directvar" if ref($data->{$directvar});
	    $val = $data->{$directvar};
	}
	bindlog sprintf ("\tSUB \$%s = %s\n",
			 $directvar,
			 $val || '(null)');
	$sql =~ s/\$$directvar(\W|$)/$val$1/g;
    }

    my $sth = $self->{DBH}->prepare($sql);
    if (!$sth) {
	croak $self->{DBH}->errstr . " in SQL\n$sql\n";
    }
    $self->{STH} = $sth;
}


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

    return unless $self->{BINDVARS};

    # The SQL contains ":parameter" placeholders, which have already
    # been converted to standard ? markers by prepare().  Pull the
    # list of bind variables.

    my @bindlist;

    foreach my $bindvar (@{$self->{BINDVARS}}) {
	my $val;
	my $node = $data;
	my $key = $bindvar;
	while ($key =~ /\./) {
	    # drill down into the hierarchy as needed to find sub-elements
	    my ($base, $subkey) = $key =~ /(.*?)\.(.*)/;
	    croak "Expected scalar for $key" if !defined $node->{$base} || !ref($node->{$base});
	    $node = $node->{$base};
	    $key = $subkey;
	}
	if ($self->{ALLARRAYS}) {
	    $val = $node->{$key}[0];
	} else {
	    croak "Expected scalar for $key" if ref($data->{$key});
	    $val = $node->{$key};
	}

	bindlog sprintf ("\tBIND :%s = %s\n",
			 $bindvar,
			 $val || '(null)');
	push @bindlist, $val;
    }

    return @bindlist;
}

1;