File Coverage

blib/lib/DBIx/Perlish.pm

Criterion	Covered	Total	%
statement	232	347	66.8
branch	92	152	60.5
condition	57	97	58.7
subroutine	20	43	46.5
pod	14	18	77.7
total	415	657	63.1

package DBIx::Perlish;

use 5.014;
use warnings;
use strict;
use Carp;

use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS $SQL @BIND_VALUES);
require Exporter;
use base 'Exporter';
use Keyword::Pluggable;

$VERSION = '1.07';
@EXPORT = qw(sql);
@EXPORT_OK = qw(union intersect except subselect);
%EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);

use DBIx::Perlish::Parse;

sub union (&;$) {}
sub intersect (&;$) {}
sub except (&;$) {}
sub subselect (&) {}

my $default_object;
my $non_object_quirks = {};

sub optree_version
{
	return 1 if $^V lt 5.22.0;
	return 2;
}

sub lexify
{
	my ( $text, $insert ) = @_;
	$insert .= 'sub ' if $$text =~ /^\s*\{/;
	substr($$text, 0, 0, $insert);
}

sub import
{
	my $pkg = caller;
	local @EXPORT_OK = @EXPORT_OK;
	local %EXPORT_TAGS = %EXPORT_TAGS;
	if ($pkg && $pkg->can("except")) {
		# XXX maybe check prototype here
		pop @EXPORT_OK;
		%EXPORT_TAGS = (all => [@EXPORT, @EXPORT_OK]);
	}
	my @shift;
	@shift = (shift()) if @_ % 2;
	my %p = @_;
	if ($p{prefix} && $p{prefix} =~ /^[a-zA-Z_]\w*$/) {
		no strict 'refs';
		if ( $p{dbh} && ref $p{dbh} && (ref $p{dbh} eq "SCALAR" || ref $p{dbh} eq "REF")) {
			my $dbhref = $p{dbh};
			*{$pkg."::$p{prefix}_fetch"} =
			*{$pkg."::$p{prefix}_select"} =
				sub (&) { my $o = DBIx::Perlish->new(dbh => $$dbhref); $o->fetch(@_) };
			*{$pkg."::$p{prefix}_update"} =
				sub (&) { my $o = DBIx::Perlish->new(dbh => $$dbhref); $o->update(@_) };
			*{$pkg."::$p{prefix}_delete"} =
				sub (&) { my $o = DBIx::Perlish->new(dbh => $$dbhref); $o->delete(@_) };
			*{$pkg."::$p{prefix}_insert"} =
				sub { my $o = DBIx::Perlish->new(dbh => $$dbhref); $o->insert(@_) };
			return;
		}
	}

	my $prefix = delete($p{prefix}) // 'db';
	my $dbh    = delete($p{dbh}) // '$dbh';
	my $iprefix = '__' . $dbh . '_execute_perlish';
	$iprefix =~ s/\W//g;

	for (
		[fetch  => " $dbh, q(fetch), "],
		[select => " $dbh, q(fetch), "],
		[update => " $dbh, q(update), "],
		[delete => " $dbh, q(delete), "],
	) {
		my ($name, $code) = @$_;
		Keyword::Pluggable::define
			keyword    => $prefix . '_' . $name,
			code       => sub { lexify( $_[0], $iprefix.$code ) },
			expression => 1,
			package    => $pkg
		;
	}
	Keyword::Pluggable::define
		keyword    => $prefix . '_insert',
		code       => $iprefix . "_insert $dbh, ",
		expression => 1,
		package    => $pkg
	;

	{
		no strict 'refs';
		*{$pkg."::${iprefix}"} = sub ($$&) {
			my ( $dbh, $method, $sub ) = @_;
			my $o = DBIx::Perlish->new(dbh => $dbh);
			$o->$method($sub);
		};
		*{$pkg."::${iprefix}_insert"} = sub {
			my $o = DBIx::Perlish->new(dbh => shift);
			$o->insert(@_)
		};
	}
	DBIx::Perlish->export_to_level(1, @shift, %p);
}

sub init { warn "DBIx::Perlish::init is deprecated" }

sub new
{
	my ($class, %p) = @_;
	unless (UNIVERSAL::isa($p{dbh}, "DBI::db")) { # XXX maybe relax for other things?
		die "Invalid database handle supplied in the \"dbh\" parameter.\n";
	}
	my $me = bless { dbh => $p{dbh}, quirks => {} }, $class;
	if ($p{quirks} && ref $p{quirks} eq "ARRAY") {
		for my $q (@{$p{quirks}}) {
			$me->quirk(@$q);
		}
	}
	return $me;
}

sub quirk
{
	my $flavor = shift;
	my $quirks = $non_object_quirks;
	if (ref $flavor) {
		$quirks = $flavor->{quirks};
		$flavor = shift;
	}
	$flavor = lc $flavor;
	if ($flavor eq "oracle") {
		my $qtype = shift;
		if ($qtype eq "table_func_cast") {
			my ($func, $cast) = @_;
			die "table_func_cast requires a function name and a type name" unless $cast;
			$quirks->{oracle_table_func_cast}{$func} = $cast;
		} else {
			die "unknown quirk $qtype for $flavor";
		}
	} else {
		die "there are currently no quirks for $flavor";
	}
}

sub _get_flavor
{
	my ($real_dbh) = @_;
	my $dbh = tied(%$real_dbh) || $real_dbh;
	return lc $dbh->{Driver}{Name};
}

sub gen_sql_select
{
	my ($moi, $sub) = @_;
	my $me = ref $moi ? $moi : {};

	my $dbh = $me->{dbh};
	my @kf;
	my $flavor = _get_flavor($dbh);
	my $kf_convert = sub { return $_[0] };
	if ($flavor eq "pg" && $dbh->{FetchHashKeyName}) {
		if ($dbh->{FetchHashKeyName} eq "NAME_uc") {
			$kf_convert = sub { return uc $_[0] };
		} elsif ($dbh->{FetchHashKeyName} eq "NAME_lc") {
			$kf_convert = sub { return lc $_[0] };
		}
	}
	my ($sql, $bind_values, $nret, %flags) = gen_sql($sub, "select",
		flavor     => $flavor,
		dbh        => $dbh,
		quirks     => $me->{quirks} || $non_object_quirks,
		key_fields => \@kf,
		kf_convert => $kf_convert,
	);
	$flags{key_fields} = \@kf if @kf;
	return $sql, $bind_values, $nret, %flags;
}

sub query
{
	my ($moi, $sub) = @_;
	my $me = ref $moi ? $moi : {};
	my ( $sql ) = $moi->gen_sql_select($sub);
	return $sql;
}

sub fetch
{
	my ($moi, $sub) = @_;
	my $me = ref $moi ? $moi : {};

	my $nret;
	my $dbh = $me->{dbh};
	my %flags;

	($me->{sql}, $me->{bind_values}, $nret, %flags) = $me->gen_sql_select($sub);
	$SQL = $me->{sql}; @BIND_VALUES = @{$me->{bind_values}};

	if ($flags{key_fields}) {
		my @kf = @{ $flags{key_fields} // [] };
		my $kf = @kf == 1 ? $kf[0] : [@kf];
		my $r = $dbh->selectall_hashref($me->{sql}, $kf, {}, @{$me->{bind_values}}) || {};
		my $postprocess;
		if ($nret - @kf == 1) {
			# Only one field returned apart from the key field,
			# change hash reference to simple values.
			$postprocess = sub {
				my ($h, $level) = @_;
				if ($level <= 1) {
					delete @$_{@kf} for values %$h;
					$_ = (values %$_)[0] for values %$h;
				} else {
					for my $nh (values %$h) {
						$postprocess->($nh, $level-1);
					}
				}
			};
		} else {
			$postprocess = sub {
				my ($h, $level) = @_;
				if ($level <= 1) {
					delete @$_{@kf} for values %$h;
				} else {
					for my $nh (values %$h) {
						$postprocess->($nh, $level-1);
					}
				}
			};
		}
		$postprocess->($r, scalar @kf);
		return wantarray ? %$r : $r;
	} else {
		if ($nret > 1) {
			my $r = $dbh->selectall_arrayref($me->{sql}, {Slice=>{}}, @{$me->{bind_values}}) || [];
			return wantarray ? @$r : $r->[0];
		} else {
			my $r = $dbh->selectcol_arrayref($me->{sql}, {}, @{$me->{bind_values}}) || [];
			return wantarray ? @$r : $r->[0];
		}
	}
}

# XXX refactor update/delete into a single implemention if possible?
sub update
{
	my ($moi, $sub) = @_;
	my $me = ref $moi ? $moi : {};

	my $dbh = $me->{dbh};
	($me->{sql}, $me->{bind_values}) = gen_sql($sub, "update",
		flavor => _get_flavor($dbh),
		dbh    => $dbh,
		quirks => $me->{quirks} || $non_object_quirks,
	);
	$SQL = $me->{sql}; @BIND_VALUES = @{$me->{bind_values}};
	$dbh->do($me->{sql}, {}, @{$me->{bind_values}});
}

sub delete
{
	my ($moi, $sub) = @_;
	my $me = ref $moi ? $moi : {};

	my $dbh = $me->{dbh};
	($me->{sql}, $me->{bind_values}) = gen_sql($sub, "delete",
		flavor => _get_flavor($dbh),
		dbh    => $dbh,
		quirks => $me->{quirks} || $non_object_quirks,
	);
	$SQL = $me->{sql}; @BIND_VALUES = @{$me->{bind_values}};
	$dbh->do($me->{sql}, {}, @{$me->{bind_values}});
}

sub insert
{
	my ($moi, $table, @rows) = @_;
	my $me = ref $moi ? $moi : {};

	my $dbh = $me->{dbh};
	my %sth;
	for my $row (@rows) {
		my @keys = sort keys %$row;
		my $sql = "insert into $table (";
		$sql .= join ",", @keys;
		$sql .= ") values (";
		my (@v, @b);
		my $skip_prepare;
		for my $v (@$row{@keys}) {
			if (ref $v eq 'CODE') {
				push @v, scalar $v->();
				$skip_prepare = 1;
			} else {
				push @v, "?";
				push @b, $v;
			}
		}
		$sql .= join ",", @v;
		$sql .= ")";
		if ($skip_prepare) {
			return undef unless defined $dbh->do($sql, {}, @b);
		} else {
			my $k = join ";", @keys;
			$sth{$k} ||= $dbh->prepare($sql);
			return undef unless defined $sth{$k}->execute(@b);
		}
	}
	return scalar @rows;
}

sub sql ($) {
	my $self = shift;
	if (ref $self && $self->isa("DBIx::Perlish")) {
		$self->{sql};
	} else {
		sub { $self }
	}
}
sub bind_values { $_[0]->{bind_values} ? @{$_[0]->{bind_values}} : () }

sub gen_sql
{
	my ($sub, $operation, %args) = @_;

	$args{quirks} = $non_object_quirks unless $args{quirks};
	$args{inline} //= 1;

	my $S = DBIx::Perlish::Parse::init(%args, operation => $operation);
	DBIx::Perlish::Parse::parse_sub($S, $sub);
	my $sql = "";
	my $next_bit = "";
	my $nret = 9999;
	my $no_aliases;
	my $dangerous;
	my %flags;
	if ($operation eq "select") {
		my $nkf = 0;
		if ($S->{key_fields}) {
			$nkf = @{$S->{key_fields}};
			push @{$args{key_fields}}, @{$S->{key_fields}} if $args{key_fields};
		}
		$sql = "select ";
		$sql .= "distinct " if $S->{distinct};
		if ($S->{returns}) {
			$sql .= join ", ", @{$S->{returns}};
			$nret = @{$S->{returns}};
			for my $ret (@{$S->{returns}}) {
				$nret = 9999 if $ret =~ /\*/;
			}
			$flags{returns_dont_care} = 1 if
				1 == @{$S->{returns}} &&
				$S->{returns}->[0] =~ /^(.*)\.\*/ &&
				$S->{returns_dont_care}->{$1}
			;
		} else {
			$sql .= "*";
		}
		$next_bit = " from ";
		die "all returns are key fields, this is nonsensical\n" if $nkf == $nret;
	} elsif ($operation eq "delete") {
		$no_aliases = 1;
		$dangerous = 1;
		$next_bit = "delete from ";
	} elsif ($operation eq "update") {
		$no_aliases = 1;
		$dangerous = 1;
		$next_bit = "update ";
	} else {
		die "unsupported operation: $operation\n";
	}
	my %tabs;
	for my $var (keys %{$S->{vars}}) {
		$tabs{$S->{var_alias}->{$var}} =
			$no_aliases ?
				"$S->{vars}->{$var}" :
				"$S->{vars}->{$var} $S->{var_alias}->{$var}";
	}
	for my $tab (keys %{$S->{tabs}}) {
		$tabs{$S->{tab_alias}->{$tab}} =
			$no_aliases ?
				"$tab" :
				"$tab $S->{tab_alias}->{$tab}";
	}
	unless (keys %tabs) {
		if ($operation eq "select" && $S->{returns}) {
			if ($args{flavor} && $args{flavor} eq "oracle") {
				$tabs{dual} = "dual";
			} else {
				$next_bit = " ";
			}
		} else {
			die "no tables specified in $operation\n";
		}
	}
	$sql .= $next_bit;
	my %seentab;
	my $joins = "";
	for my $j ( @{$S->{joins}} ) {
		my ($join, $tab1, $tab2, $condition) = @$j;
		$condition = ( defined $condition) ? " on $condition" : '';
		die "not sure what to do with repeated tables ($tabs{$tab1} and $tabs{$tab2}) in a join\n"
			if $seentab{$tab1} && $seentab{$tab2};
		if ($seentab{$tab2}) {
			($tab1, $tab2) = ($tab2, $tab1);
			if ($join eq "left outer") {
				$join = "right outer";
			} elsif ($join eq "right outer") {
				$join = "left outer";
			}
		}
		if ($seentab{$tab1}) {
			$joins .= " " if $joins;
			$joins .= "$join join $tabs{$tab2}$condition";
		} else {
			$joins .= ", " if $joins;
			$joins .= "$tabs{$tab1} $join join $tabs{$tab2}$condition";
		}
		$seentab{$tab1}++;
		$seentab{$tab2}++;
	}
	my @joins = $joins ? ($joins) : ();
	$sql .= join ", ", @joins, map { $tabs{$_} } grep { !$seentab{$_} } sort keys %tabs;

	my @sets     = grep { $_ ne "" } @{$S->{sets}};
	my @where    = grep { $_ ne "" } @{$S->{where}};
	my @having   = grep { $_ ne "" } @{$S->{having}};
	my @group_by = grep { $_ ne "" } @{$S->{group_by}};
	my @order_by = grep { $_ ne "" } @{$S->{order_by}};

	if ($S->{autogroup_needed} && !$S->{no_autogroup} &&
		!@group_by && @{$S->{autogroup_by}})
	{
		@group_by = grep { $_ ne "" } @{$S->{autogroup_by}};
	}
	die "nothing to update\n" if $operation eq "update" && !@sets;

	$sql .= " set "      . join ", ",    @sets     if @sets;
	$sql .= " where "    . join " and ", @where    if @where;
	$sql .= " group by " . join ", ",    @group_by if @group_by;
	$sql .= " having "   . join " and ", @having   if @having;
	$sql .= " order by " . join ", ",    @order_by if @order_by;

	if ($dangerous && !@where && !$S->{seen_exec}) {
		die "unfiltered $operation is dangerous: use exec if you want it\n";
	}

	my $use_rownum = $args{flavor} && $args{flavor} eq "oracle";

	unless ($use_rownum) {
		if ($S->{limit}) {
			$sql .= " limit $S->{limit}";
		}
		if ($S->{offset}) {
			$sql .= " offset $S->{offset}";
		}
	}
	my $v = $S->{set_values};
	push @$v, @{$S->{ret_values}};
	push @$v, @{$S->{join_values}};
	push @$v, @{$S->{values}};

	for my $add (@{$S->{additions}}) {
		$sql .= " $add->{type} $add->{sql}";
		push @$v, @{$add->{vals}};
	}
	$sql =~ s/\s+$//;

	if ( $use_rownum && ( $S->{limit} || $S->{offset} )) {
		my @p;
		push @p, "ROWNUM > " . $S->{offset} if $S->{offset};
		push @p, "ROWNUM <= " . ($S->{limit} + ($S->{offset} // 0)) if $S->{limit};
		$sql = "select * from ($sql) where " . join(' and ', @p);
	}

	return ($sql, $v, $nret, %flags);
}


1;
__END__