File Coverage

blib/lib/DBIx/NamedQuery.pm

Criterion	Covered	Total	%
statement	57	100	57.0
branch	10	30	33.3
condition			n/a
subroutine	11	16	68.7
pod	4	5	80.0
total	82	151	54.3

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__