File Coverage

blib/lib/DBIx/InterpolationBinding.pm

Criterion	Covered	Total	%
statement	54	63	85.7
branch	15	20	75.0
condition	12	21	57.1
subroutine	11	11	100.0
pod	0	1	0.0
total	92	116	79.3

#!/usr/bin/perl -w

package DBIx::InterpolationBinding;

use 5.005;
use strict;
use vars qw($VERSION $DEBUG);

use overload '""'       => \&_convert_object_to_string,
             '.'        => \&_append_item_to_object,
             'fallback' => 1;
require DBI;

$VERSION = '1.01';

$DEBUG = 0;

sub import {
	overload::constant 'q' => \&_prepare_object_from_string;

	# Bind the execute method into the DBI namespace
	# We do it twice to avoid a tedious warning
	# We would use the warnings pragma, but this is 5.005 :-)
	*DBI::db::execute = \&dbi_exec;
	*DBI::db::execute = \&dbi_exec;
}

sub unimport {
	overload::remove_constant 'q';
}

sub dbi_exec {
	my ($dbi, $sql) = @_;

	return $dbi->set_err(1,
		'\$dbh->execute can only be used with a magic string.')
		unless (ref $sql and $sql->isa(__PACKAGE__));
	($sql, my @params) = _create_sql_and_params($sql);

	print STDERR "DBI::prepare($sql)\nDBI::execute(", join(", ",
		@params) , ")\n" if $DEBUG;
	my $sth = $dbi->prepare($sql) or return;
	$sth->execute(@params) or return;
	return $sth;
}

sub _create_sql_and_params {
	my ($sql, @params) = @_;

	if (ref $sql and $sql->isa(__PACKAGE__)) {
		# We have a DBOx::InterpolationBinding string
		unshift @params, @{ $sql->{bind_params} };
		$sql = $sql->{sql_string}
	}

	return ($sql, @params);
}

sub _prepare_object_from_string {
	my (undef, $string, $mode) = @_;

	# We only want to affect double-quoted strings
	return $string unless ($mode eq "qq");

	# Make an object out of the string
	my $self = {
		string => $string,
		sql_string => $string,
		bind_params => [ ]
	};
	return bless $self => __PACKAGE__;
}

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

	# We need a string for this (eg. to print or use outside DBI)
	return $self->{string};
}

sub _append_item_to_object {
	my ($self, $string, $flipped) = @_;

	# $new_hash will become the object we return, so the old one
	# isn't mashed.
	my $new_hash = { %$self };
	$new_hash->{bind_params} = [ @{ $self->{bind_params} } ];

	# At this point, the thing that isn't $self is either an object of
	# this class, or it's a boring string. Also, we either need to append
	# the other thingy before this one, or after, depending on $flipped.
	my $string_is_this_class = ref($string) && $string->isa(__PACKAGE__);

	if ($string_is_this_class and not $flipped) {
		$new_hash->{sql_string} .= $string->{sql_string};
		$new_hash->{string} .= $string->{string};
		push @{ $new_hash->{bind_params} }, @{ $string->{bind_params} };
	}
	if ($string_is_this_class and $flipped) {
		$new_hash->{sql_string} = $string->{sql_string} .
			$new_hash->{sql_string};
		$new_hash->{string} = $string->{string} . $new_hash->{string};
		unshift @{ $new_hash->{bind_params} }, @{ $string->{bind_params} };
	}

	if ($flipped and not $string_is_this_class) {
		$new_hash->{sql_string} = "?" . $new_hash->{sql_string};
		$new_hash->{string} = $string . $new_hash->{string};
		unshift @{ $new_hash->{bind_params} }, $string;
	}
	if (not($flipped) and not $string_is_this_class) {
		$new_hash->{sql_string} .= "?";
		$new_hash->{string} .= $string;
		push @{ $new_hash->{bind_params} }, $string;
	}

	# Make the new thing an object
	return bless $new_hash => ref($self);
}

1;
__END__