File Coverage

blib/lib/NoSQL/PL2SQL/DBI.pm

Criterion	Covered	Total	%
statement	13	19	68.4
branch			n/a
condition			n/a
subroutine	5	7	71.4
pod			n/a
total	18	26	69.2

package NoSQL::PL2SQL::DBI::Null ;

sub AUTOLOAD {
	my $self = shift ;
	my $sql = shift ;
	return $sql ;
	}

sub DESTROY {}

package NoSQL::PL2SQL::DBI ;

use 5.008009;
use strict;
use warnings;
use DBI ;
use XML::Parser::Nodes ;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use NoSQL::PL2SQL::Node ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw() ] ) ;

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ) ;

our @EXPORT = qw() ;

our $VERSION = '0.12';

# Preloaded methods go here.

my @sqllog ;
my $nulldbi = bless \( my $null = 'NoSQL::PL2SQL::DBI::Null' ),
			'NoSQL::PL2SQL::DBI::Null' ;

## I started looking for an XML based schema that is implementation
## independent.  This one, my own invention and based on MySQL, was
## originally a placeholder.  Suffice that it remains a TODO...

my $xmlschema =<<'endschema' ;


     




52




 





 





 





 





 





 



        




53




 





 





 





 





 





 



 	   




54




 





 





 





 





 





 



 	   




55




 





 





 





 





 





 



 	   




56




 





 





 





 





 





 



        




57




 





 





 





 





 





 



        




58




 





 





 





 





 





 



        




59




 





 





 





 





 





 



        




60




 





 





 





 





 





 



        




61




 





 





 





 





 





 



        




62




 





 





 





 





 





 



        




63




 





 





 





 





 





 



        




64




 





 





 





 





 





 



        




65




 





 





 





 





 





 



        




66




 





 





 





 





 





 



        




67




 





 





 





 





 





 



 	   




68




 





 





 





 





 





 



        




69




 





 





 





 





 





 



        




70




 





 





 





 





 





 



 	   




71




 





 





 





 





 





 



        




72




 





 





 





 





 





 



        




73




 





 





 





 





 





 



 	   




74




 





 





 





 





 





 



        




75




 





 





 





 





 





 



        




76




 





 





 





 





 





 



 	   




77




 





 





 





 





 





 



        




78




 





 





 





 





 





 



        




79




 





 





 





 





 





 



        




80






































endschema

my $indexschema =<<'endschema' ;


     




96




 





 





 





 





 





 



        




97




 





 





 





 





 





 



        




98




 





 





 





 





 





 



        




99




 





 





 





 





 





 



        




100




 





 





 





 





 





 



        




101




 





 





 





 





 





 



        




102




 





 





 





 





 





 



        




103





















endschema

sub schema {
	my $self = shift ;
	my $package = ref $self || $self ;
	my $schema = @_? shift( @_ ): $xmlschema ;

	my $nodes = bless XML::Parser::Nodes->new( $schema ),
			join( '::', $package, 'Schema' ) ;

	return $nodes->schema ;
	}

## indexschema is used by NoSQL::PL2SQL::Simple.  No one has expressed
## an intention of another DBI implementation.  Since I can get away with
## it, I'm arbitrarily extending this definition, and I really shouldn't.
## In the future apps, will have to create their own database specific
## subclasses:  NoSQL::PL2SQL::Simple::MySQL, etc.

sub indexschema {
	return $indexschema ;
	}

sub sqldump {
	shift @_ ;
	@sqllog = () if @_ ;
	return @sqllog ;
	}

sub debug {
	push @sqllog, $_[-1] if @_ ;
	}

sub sqlstatement {
	my $self = shift ;
	my $sprintf = shift ;

	my $ct = 0 ;
	$ct++ while $sprintf =~ /%s/g ;
	return sprintf $sprintf, ( $self->[1] ) x$ct ;
	}

sub do  {
	my $self = shift ;
	push @sqllog, my $sql = $self->sqlstatement( @_ ) ;
	return $self->db->do( $sql ) ;
	}

sub rows_hash {
	my $self = shift ;
	push @sqllog, my $sql = $self->sqlstatement( @_ ) ;
	my $st = $self->db->prepare( $sql ) ;
	$st->execute ;
	my @out = () ;
	my $o ;
	push @out, { %$o } while $o = $st->fetchrow_hashref ;
	return $out[0] unless wantarray ;
	return @out ;
	}

sub rows_array {
	my $self = shift ;
	push @sqllog, my $sql = $self->sqlstatement( @_ ) ;
	my $st = $self->db->prepare( $sql ) ;
	$st->execute ;
	my @out = () ;
	my $o ;
	push @out, [ @$o ] while $o = $st->fetchrow_arrayref ;
	return $out[0] unless wantarray ;
	return @out ;
	}

sub new {
	my $package = shift ;
	my $tablename = shift( @_ ) || '%s' ;

	if ( ref $package ) {
		$tablename = $package->table ;
		$package = ref $package ;
		}

	return bless [ $nulldbi, $tablename ], $package ;
	}

sub connect {
	my $self = shift ;
	my $ref = $self ;
	$ref = $ref->[0] while ref $ref eq ref $self
				&& ref $ref->[0] eq ref $self ;
	$ref->[0] = DBI->connect( @_ ) ;
	return $self ;
	}

sub table {
	my $self = shift ;
	return $self->[1] unless @_ ;

	my $package = ref $self ;
	my $out = $package->new( @_ ) ;
	$out->[0] = $self ;
	return $out ;
	}

sub db {
	my $self = shift ;
	return ref $self->[0] eq ref $self? $self->[0]->db: $self->[0] ;
	}

sub dbconnected {
	my $self = shift ;
	my $db = $self->db ;
	my $unconnected = $db->isa('SCALAR') && $$db eq ref $db ;
	return ! $unconnected ;
	}

## Implementation Specific
## optionally pass a scalar integer- otherwise same arguments as fetch()
sub delete {
	my $self = shift ;
	my @delete = ref $_[0]? @_: ( [ id => $_[0] ] ) ;
	return $self->fetch( 'DELETE FROM %s WHERE', @delete ) ;
	}

## Implementation Specific
sub lastinsertid {
	my $self = shift ;
	my $db = $self->db ;
	return ! $self->dbconnected? 0:
			$db->last_insert_id(
			  undef, undef, $self->table, 'id' ) ;
	}

## Implementation Specific
sub sqlupdate {
	my $self = shift ;
	my $nvp = shift ;
	my $sql = sprintf 'UPDATE %s SET %s WHERE', '%s', $nvp ;
	return $self->fetch( $sql, @_ ) ;
	}

## update() method is used for SQL "INSERT" and "UPDATE" constructions.
## Implementation Specific.  Default method is MySQL syntax.
sub update {
	my $self = shift ;
	my $id = shift ;

##	Each subsequent argument is an NVP array reference.  An optional
##	third element, if true, indicates a string value

	my @pairsf = ( '%s=%s', '%s="%s"', '%s=NULL' ) ;
	my @termsf = ( '%s', '"%s"', 'NULL' ) ;

	my $keys = join ',', map { $_->[0] } @_ ;
	my $values = join ',', map {
			sprintf $termsf[ defined $_->[1]?
			  $_->[2] || length $_->[1] == 0: 2 ],
			$self->stringencode( $_->[1], ! $_->[2] ) ;
			} @_ ;
	my $nvp = join ',', map {
			sprintf $pairsf[ defined $_->[1]?
			  $_->[2] || length $_->[1] == 0: 2 ],
			$_->[0], $self->stringencode( $_->[1], ! $_->[2] )
			} @_ ;

	## User data should never be passed to sqlstatement()
	my $update = $self->sqlstatement( 'UPDATE %s' ) ;
	my $insert = $self->sqlstatement( 'INSERT INTO %s' ) ;
	my $sql = defined $id?
			"$update SET $nvp WHERE id=$id":
			"$insert ($keys) VALUES ($values)" ;
	$self->debug( $sql ) if $self->dbconnected ;
	my $sqlresults = $self->db->do( $sql ) ;	## do not combine
	return { id => $id || $self->lastinsertid,
			sqlresults => $sqlresults,
			nvp => $nvp
			} ;
	}

sub insert {
	my $self = shift ;
	return $self->update( undef, @_ ) ;
	}

sub exclude {
	shift @_ ;
	my $package = join '::', __PACKAGE__, 'exclude' ;
	my @out = map { bless $_, $package } @_ ;
	return wantarray? @out: $out[0] ;
	}

## Implementation Specific.  Default method is MySQL syntax.
sub fetch {
	my $self = shift ;
	my $delete = ( @_ && ! ref $_[0] )? shift( @_ ): undef ;

	my @pairsf = ( '%s=%s', '%s="%s"', '%s=NULL' ) ;
	my @invert = ( '%s!=%s', '%s!="%s"', '%s NOT NULL' ) ;

	my $exclude = ref $self->exclude( [] ) ;

	my @terms = () ;
	foreach ( @_ ) {
		my @how = ref $_ eq $exclude? @invert: @pairsf ;
		push @terms, sprintf
				$how[ defined $_->[1]?
				  $_->[2] || length $_->[1] == 0: 2 ],
				$_->[0],
				$self->stringencode( $_->[1], ! $_->[2] ) ;
		}

	my $sql = join ' ', $delete || 'SELECT * FROM %s WHERE',
			join ' AND ', @terms ;
	return $self->do( $sql ) if defined $delete || ! $self->dbconnected ;

	my @out = $self->rows_hash( $sql ) ;
	return wantarray? @out: { map { $_->{id} => $_ } @out } ;
	}

## Implementation Specific.  Default method is MySQL syntax.
sub stringencode {
	my $self = shift ;
	my $text = shift ;
	return $text unless defined $text ;
	return $text if @_ && $_[0] ;
	$text =~ s/"/""/gs ;
	$text =~ s/\\/\\\\/gs ;
	return $text ;
	}

sub AUTOLOAD {
	my $self = shift ;
	my $sql = shift ;
	my $package = ref $self ;

	use vars qw( $AUTOLOAD ) ;
	my $func = $AUTOLOAD ;
	$func =~ s/^${package}::// ;
	return if $func eq 'DESTROY' ;

	my $cmd = sprintf '$self->db->%s( sprintf $sql || "", $self->table )',
			$func ;
	return eval $cmd ;
	}

sub loadschema {
	my $self = shift ;
	return map { $self->do( $_ ) } $self->schema( @_ ) ;
	}


package NoSQL::PL2SQL::DBI::Schema ;
use base qw( XML::Parser::Nodes ) ;

sub schema {
	shift @_ unless ref $_[0] ;
	my $self = shift ;

	my @mysql = $self->childnode('mysql') ;
	return map { $self->new( $_ )->schema }
			@mysql? $mysql[0]->childnodes: $self->childnodes ;
	}

sub new {
	my $self = shift ;
	my $nodechild = shift ;
	my $package = ref $self ;
	my @package = () ;

	my @nodenames = () ;
	my @refself = split /::/, $package ;
	push @nodenames, pop @refself
			while @refself && $refself[-1] ne 'Schema' ;

	push @package, join '::', $package, $nodechild->[0] ;
	return bless $nodechild->[1], $package[-1]
			if eval join '', '@', $package[-1], '::ISA' ;

	push @package, join '::', __PACKAGE__, @nodenames, $nodechild->[0] ;
	return bless $nodechild->[1], $package[-1]
			if eval join '', '@', $package[-1], '::ISA' ;

	return bless $nodechild->[1], join '::', @refself ;
	}

sub command {
	my $self = shift ;
	my $command = $self->getattributes->{command} || '' ;

	return eval sprintf '$self->%s()', $command if $command ;
	}

## Example Base Node Schemas
#
# package NoSQL::PL2SQL::DBI::Schema::table ;
# use base qw( NoSQL::PL2SQL::DBI::Schema ) ;
#
# sub schema {
# 	shift @_ unless ref $_[0] ;
# 	my $self = shift ;
#
# 	## default table definition
# 	}
#
# package NoSQL::PL2SQL::DBI::Schema::index ;
# use base qw( NoSQL::PL2SQL::DBI::Schema ) ;
#
# sub schema {
# 	shift @_ unless ref $_[0] ;
# 	my $self = shift ;
#
# 	## default index definition
# 	}
#
1;
__END__