package DBIx::NamedQuery;
# $Id: NamedQuery.pm 23 2006-06-14 13:21:39Z BoleslavB $

use 5.006;
use strict;
use warnings;

use Carp ();
use Exporter ();
use FileHandle ();


################################################################################


# History
# 0.10 (2006-06-14) - Initial internal release
# 0.11 (2006-06-26) - Fixes in code and in documentation


################################################################################
# Global variables

our @EXPORT_OK = qw(load_named_queries load_named_queries_from_file
		get_named_query set_named_query prepare_named_query
		execute_named_query select_row_from_named_query
		);

our $VERSION = '0.11';

our %NAMED_QUERY = ();


################################################################################
# Named query manipulation

sub load_named_queries
{
	my ($stream_handle) = (@_);
	if (not defined $stream_handle) {
		# By default use DATA stream from main program
		$stream_handle = \*main::DATA;
	} elsif (eof($stream_handle)) {
		Carp::carp("Not an open filehandle: <$stream_handle>");
		return undef;
	}
	# Load complete contents of the stream and preprocess it
	my $stream_contents;
	eval {
		no warnings;
		local $/ = undef;
		$stream_contents = <$stream_handle>;
		close($stream_handle);
	};
	if (not defined $stream_contents) {
		return undef;
	}
	# Preprocess the loaded text
	$stream_contents =~ s/^\s*#.*?\n//gm;
	$stream_contents =~ s/\s+\n/\n/gm;
	# Divide stream into headers and bodies
	my @parts = split(/^(--\[.*?\])\s*$/m, $stream_contents);
	undef($stream_contents);
	my $actual_label = undef;
	foreach my $part (@parts) {
		if ($part =~ /^--\[\s*(.*?)\s*\]\s*$/) {
			# Header part found, begin a new named query
			$actual_label = $1;
			next;
		}
		next unless defined $actual_label;
		# Process body part following the header
		$part =~ s/(?:\A\s*)|(?:\s*\z)//g;
		$NAMED_QUERY{$actual_label} = $part;
		undef($actual_label);
	}
	my $query_count = scalar keys %NAMED_QUERY;
	return $query_count;
}


sub load_named_queries_from_file
{
	my ($filename) = @_;
	my $stream = FileHandle->new($filename, '<');
	if (not defined $stream) {
		return undef;
	}
	return load_named_queries($stream);
}


sub get_named_query
{
	my ($query_name) = @_;
	if (not exists $NAMED_QUERY{$query_name}) {
		return undef;
	}
	return $NAMED_QUERY{$query_name};
}


sub set_named_query
{
	while (my @pair = splice(@_, 0, 2)) {
		last if 2 != scalar @pair;
		my ($query_name, $query_text) = @pair;
		$NAMED_QUERY{$query_name} = $query_text;
	}
}


################################################################################
# Initialization operations

sub import
{
	my ($package, @params) = @_;
	my @new_params = ();
	foreach my $param (@params) {
		if ($param eq 'EXTEND_DBI') {
			extend_DBI_interface();
			next;
		}
		push(@new_params, $param);
	}
	Exporter::import($package, @new_params);
}


sub extend_DBI_interface
{
	# DBI database class infiltration (inserts new methods), but without
	# direct namespace changes
	push(@DBI::db::ISA, 'DBIx::NamedQuery::db');
}


################################################################################
# Named query usage

package DBIx::NamedQuery::db;

sub prepare_named_query
{
	my $db_handle = shift;
	my ($query_name, $prepare_attr) = @_;
	if (not exists $DBIx::NamedQuery::NAMED_QUERY{$query_name}) {
		$db_handle->set_err(1, "Named query '$query_name' has not "
				. 'been defined'
				);
		return undef;
	}
	my $query_text = $DBIx::NamedQuery::NAMED_QUERY{$query_name};
	my $query_handle = $db_handle->prepare($query_text, $prepare_attr);
	if (not defined $query_handle) {
		return undef;
	}
	return $query_handle;
}


sub execute_named_query
{
	my $db_handle = shift;
	my ($query_name, @bind_values) = @_;
	my $statement = $db_handle->prepare_named_query($query_name);
	if (not defined $statement) {
		return undef;
	}
	my $executed = $statement->execute(@bind_values);
	if (not $executed) {
		return undef;
	}
	return $statement;
}


sub select_row_from_named_query
{
	my $db_handle = shift;
	my ($query_name, @bind_values) = @_;
	my $statement = $db_handle->prepare_named_query($query_name);
	if (not defined $statement) {
		return undef;
	}
	my $executed = $statement->execute(@bind_values);
	if (not $executed) {
		return undef;
	}
	my $first_row_arrayref = $statement->fetchrow_arrayref();
	$statement->finish();
	return $first_row_arrayref;
}


################################################################################

1;

__END__

=head1 NAME

DBIx::NamedQuery - Utilities for decoupling of Perl code and SQL statements

=head1 SYNOPSIS

  use DBIx::NamedQuery qw(EXTEND_DBI);

  DBIx::NamedQuery::load_named_queries(*DATA);
  DBIx::NamedQuery::load_named_queries_from_file('customers.sql');
  
  $DBI_statement = $DBI_database_handle->prepare_named_query('invoice');
  
  $DBI_statement = $DBI_database_handle->execute_named_query(
                        'customer_address', $customer_id
                        );

=head1 DESCRIPTION

DBIx::NamedQuery decouples the logic of Perl program and SQL queries. Perl
program references only symbolic names (labels) of queries. The SQL source
can be a separate file or embedded in the program under DATA section.

To reduce the amount of coding, the library can (on demand via import flag
C<EXTEND_DBI>) extend the interface of DBI library, namely the methods of
database object.

=head1 QUERY SOURCE FORMAT

The format of SQL source is suitable for editing in database administration
tools, such as TOAD. The label is (from the SQL point of view) just a
comment.

  --[invoice]
  SELECT * FROM invoice WHERE invoice_id=?
  
  --[customer_address]
  SELECT cust_name, cust_street, cust_street_no, cust_city
  FROM customers
  WHERE cust_id = ?

=head1 STANDARD FUNCTIONS

=over 4

=item load_named_queries (HANDLE)

Loads a set of named queries from open filehandle. Returns number of loaded
queries or C<undef> in case of error.

=item load_named_queries_from_file (FILENAME)

Loads a set of named queries from a file. Returns number of loaded queries or
C<undef> in case of error.

=item get_named_query (LABEL)

Returns a SQL query associated with a given label. If there is no such label,
returns C<undef>.

=item set_named_query (LABEL1 =E<gt> SQL1, ...)

Allows to add/replace one or more named queries in the current set.

=back

=head1 DBI EXTENSION (DATABASE HANDLE METHODS)

=over 4

=item $DB-E<gt>execute_named_query (LABEL [, BIND_VALUES])

Prepares and executes SQL query associated with the label. Placeholders in
SQL are bound with remaining parameters. Returns DBI statement handle or
C<undef> in case of error.

=item $DB-E<gt>select_row_from_named_query (LABEL [, BIND_VALUES])

Executes (most likely C<SELECT>) SQL statement identified by the label
and returns the first row of data as an array reference. In case of error,
C<undef> is returned instead.

=item $DB-E<gt>prepare_named_query (LABEL [, PREPARE_OPTIONS])

Prepares SQL statement identified by the label. Prepare options are passed
to standard DBI method C<$DB-E<gt>prepare()> as additional parameters.

=back

=head1 SEE ALSO

L<DBI>

=head1 AUTHOR

Boleslav Bobcik, E<lt>boleslav.bobcik@ys.czE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006 by Boleslav Bobcik

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

=cut