File Coverage

blib/lib/SQL/Concrete.pm

Criterion	Covered	Total	%
statement	112	113	99.1
branch	53	60	88.3
condition	12	15	80.0
subroutine	23	23	100.0
pod	2	5	40.0
total	202	216	93.5

use 5.006; use strict; use warnings;

package SQL::Concrete;

our $VERSION = '1.004';

use Exporter::Tidy
	core    => [ qw( sql_render ) ],
	util    => [ qw( sql ) ],
	clauses => [ qw( sql_values sql_set sql_select ) ],
	CLAUSES => [ qw( VALUES SET SELECT ) ],
	all     => [ qw( :core :util :CLAUSES ) ],
	_map    => { VALUES => 'sql_values', SET => 'sql_set', SELECT => 'sql_select' },
	noncore => [ qw( :util :clauses :CLAUSES ) ]; # used internally by SQL::Concrete::Dollars

sub sql_render { SQL::Concrete::Renderer->new->render( @_ ) }
sub sql        { my @stuff = @_; bless sub { $_[0]->render_sql( @stuff ) }, __PACKAGE__ }
sub sql_set    { my @stuff = @_; bless sub { $_[0]->render_set( @stuff ) }, __PACKAGE__ }
sub sql_values { my @stuff = @_; bless sub { $_[0]->render_values( @stuff ) }, __PACKAGE__ }
sub sql_select { my @stuff = @_; bless sub { $_[0]->render_select( @stuff ) }, __PACKAGE__ }

package SQL::Concrete::Renderer;

our $VERSION = '1.004';

use Object::Tiny::Lvalue qw( alias_id prev_item bind );

# our code references are blessed into this package
# so that we can distinguish them from other code references
sub _CODE_() { 'SQL::Concrete' }

sub new { my $class = shift; bless { @_ }, $class }

sub render {
	my $self = shift;
	local $self->{'bind'} = [];
	local $self->{'alias_id'} = 0;
	my $sql = $self->render_sql( @_ );
	return ( $sql, @{ $self->bind } );
}

sub render_sql {
	my $self = shift;

	my $sql = '';
	my $bind = $self->bind;
	local $self->{'prev_item'};

	for my $item ( @_ ) {
		my $type = ref $item;

		my $append
			= ( not $type )         ? $self->prev_item = $item
			: ( 'SCALAR' eq $type ) ? $self->render_bind( $$item )
			: ( 'ARRAY'  eq $type ) ? ( @$item ? join ', ', $self->bind_or_render_values( @$item ) : $self->error( 'empty array' ) )
			: ( _CODE_   eq $type ) ? $item->( $self )
			: ( 'HASH'   eq $type ) ? ( keys %$item ? undef : '1=1' ) # further handled below
			: $self->error( "unrecognized $type value in interpolation" );

		if ( not defined $append ) { # 'twas a non-empty hash
			$append = join ' AND ', map {
				my $lft = $_;
				my $rgt = $item->{ $lft };
				my $type = ref $rgt;
				my $term
					= ( not defined $rgt )  ? $lft . ' IS NULL'
					: ( not $type )         ? join( '=', $lft, $self->bind_or_render_values( $rgt ) )
					: ( _CODE_  eq $type )  ? $lft . '=' . $rgt->( $self )
					: ( 'ARRAY' eq $type )  ? do {
						my $list = @$rgt && join ', ', $self->bind_or_render_values( @$rgt );
						@$rgt ? "$lft IN ($list)" : '1 IN (0)';
					}
					: $self->error( "unrecognized $type value for key '$lft' in hash" );
				$term;
			} sort keys %$item;
			$append = "($append)" if keys %$item > 1;
		}

		$sql .= '1 IN (1)', next if '1 IN (0)' eq $append and $sql =~ s/\bNOT\s*\z//i;
		$sql .= ' ' if $sql =~ /\S/ and $append !~ /\A\s/ and $sql !~ /=\z/;
		$sql .= $append;
	}

	return $sql;
}

sub bind_or_render_values {
	my $self = shift;
	map {
		my $type = ref;
		$self->error( "unrecognized $type value in aggregate" ) if $type and _CODE_ ne $type;
		$type ? $_->( $self ) : $self->render_bind( $_ );
	} @_;
}

sub render_bind { push @{ $_[0]{'bind'} }, $_[1]; '?' }

sub render_set {
	my $self = shift;
	$self->error( 'empty SET' ) if not @_;
	my %h = @_;
	my @k = sort keys %h;
	my @v = $self->bind_or_render_values( @h{ @k } );
	my $list = join ', ', map { "$k[$_]=$v[$_]" } 0 .. $#k;
	"SET $list";
}

sub render_values {
	my $self = shift;
	my ( $item ) = @_;
	my $type = ref $item;
	my $columns = '';
	my @value
		= 'ARRAY'  eq $type ? $self->bind_or_render_values( @$item )
		: 'HASH'   eq $type ? do {
			my @key = sort keys %$item;
			$columns = join ', ', @key;
			$columns = "($columns) ";
			$self->bind_or_render_values( @$item{ @key } );
		}
		: $self->error( "unrecognized $type value in VALUES" );
	my $list = join ', ', @value;
	"${columns}VALUES($list)";
}

sub render_select {
	my $self = shift;
	my @alias = ref $_[0] ? () : shift @_;

	$self->error( 'empty SELECT' ) if not @_;

	my $row0  = shift @_;
	my $type0 = ref $row0;

	my @select;

	if ( 'ARRAY' eq $type0 ) {
		$self->error( 'empty first row in SELECT' ) if not @$row0; # improve?
		@select = map { join ', ', $self->bind_or_render_values( @$_ ) } $row0, @_;
	}
	elsif ( 'HASH' eq $type0 ) {
		$self->error( 'empty first row in SELECT' ) if not keys %$row0; # improve?
		my @k = sort keys %$row0;
		my @v = $self->bind_or_render_values( @$row0{ @k } );
		@select = (
			( join ', ', map { "$v[$_] AS $k[$_]" } 0 .. $#k ),
			map { join ', ', $self->bind_or_render_values( @$_{ @k } ) } @_,
		);
	}
	else { $self->error( "unrecognized first row '$row0' in SELECT" ) }

	my $sql = join ' UNION ALL ', map "SELECT $_", @select;
	$sql = "($sql)";

	if ( @alias ) {
		$sql .= ' AS ';
		$sql .= defined $alias[0] ? $alias[0] : 'tbl'.$self->alias_id++;
	}

	$sql;
}

sub error {
	my $self = shift;
	my $prev = $self->prev_item;
	push @_, " (somewhere past '$prev')" if defined $prev;
	require Carp;
	local $Carp::Internal{ (_CODE_) } = 1;
	local $Carp::Internal{ (__PACKAGE__) } = 1;
	Carp::croak( 'SQL::Concrete: ', @_ );
}

1;

__END__