File Coverage

blib/lib/NoSQL/PL2SQL/Simple.pm

Criterion	Covered	Total	%
statement	22	253	8.7
branch	0	92	0.0
condition	0	59	0.0
subroutine	8	37	21.6
pod	13	18	72.2
total	43	459	9.3

package NoSQL::PL2SQL::Simple;

use 5.008009;
use strict;
use warnings;

# 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::Simple ':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.24' ;

use Scalar::Util ;
use base qw( NoSQL::PL2SQL ) ;
use Carp ;

my @autodestroy = () ;

my @sql = (
	[ qw( textkey textvalue 1 ) ],
	[ qw( intkey intvalue 0 ) ],
	[ qw( datekey datevalue 1 ) ],
	) ;
my %sql = map { $_->[0] => $_ } @sql ;

my %private ;

################################################################################
##
##  update() refreshes the instance after data definition changes
##
################################################################################

$private{update} = sub {
	my $self = shift ;
	my $tied = tied %$self ;
	my $package = ref $self ;

	return unless $tied->{tied} ;
	delete $tied->{tied} ;

	my $o = $package->SQLObject( $tied->{dsn}->{object}, 0 ) ;
	my %keys = map { $_ => &{ $private{recno} }( $o, $_ ) } keys %$o ;
	$tied->{keys} = \%keys ;
	} ;


################################################################################
##
##  sqlsave() rolls back the rollback
##
################################################################################

$private{sqlsave} = sub {
	my $self = shift ;
	my $tied = tied %$self ;
	delete $tied->{globals}->{rollback} ;
	} ;


################################################################################
##
##  recno() is part of the constructor.  It uses the internal structure
##  of NoSQL::PL2SQL::Object to pull out the unique recordID.
##
################################################################################

$private{recno} = sub {
	my $self = shift ;
	my $tied = tied %$self ;
	return $tied->record->{objectid} || $tied->{top} unless @_ ;

	my $key = shift ;
	return $tied->data->{$key}->{top} ;
	} ;


################################################################################
##
##  filter() takes two arrays and returns the intersection.  It is called
##  recursively by query().
##
################################################################################

$private{filter} = sub {
	my @set = @{ shift @_ } ;
	return [] unless @set ;
	return [ sort { $a <=> $b } @set ] unless @_ ;

	my @against = sort { $a <=> $b } @{ shift @_ } ;
	my @out = () ;

	while ( @set && @against ) {
		my $cmp = $set[0] <=> $against[0] ;
		shift @set if $cmp < 0 ;
		shift @against if $cmp > 0 ;
		next if $cmp ;

		push @out, shift @set ;
		shift @against ;
		}

	return \@out ;
	} ;


################################################################################
##
##  index() is the common method to addTextIndex, addNumberIndex, etc.
##
################################################################################

$private{index} = sub {
	my $self = shift ;
	my $tied = tied %$self ;
	my $package = ref $self ;

	$tied->{tied} ||= $package->SQLObject(
			$tied->{dsn}->{object}, 0 ) ;
	my $i = push @autodestroy, $tied->{tied} ;
	Scalar::Util::weaken( $autodestroy[ $i -1 ] ) ;
	return unless @_ ;

	my $type = shift ;
	map { $self->{$_} = $tied->{tied}->{$_} = $type } @_ ;
	} ;


################################################################################
##
##  matching() is commonly called by methods to query the index database.
##
################################################################################

$private{matching} = sub {
	my $self = shift ;
	my $tied = tied %$self ;
	my $package = ref $self ;

	my $name = shift ;

	my $format = defined $name?  $sql{ $self->{ $name } }: $sql{intkey} ;

	my @sql = () ;
	push @sql, [ $format->[0], defined $name?
				$tied->{keys}->{ $name }: $tied->{id}
				] ;
	unless ( @_ ) {
		my @rows = $tied->{dsn}->{index}->fetch( @sql ) ;

		return [] unless @rows ;
		return $rows[0] unless ref $rows[0] ;
		return [] unless keys %{ $rows[0] } ;

		my @out = map { $_->{objectid}
				=> $_->{ $format->[1] } } @rows ;
		return \@out ;
		}

	my $value = shift ;
	push @sql, [ $format->[1], $value, $format->[2] ] ;

	my @rows = $tied->{dsn}->{index}->fetch( @sql ) ;
	return $rows[0] if @rows && ! ref $rows[0] ;
	return [] unless keys %{ $rows[0] } ;

	my @out = map { $_->{objectid} => $_->{ $format->[1] } } @rows ;
	return \@out ;
	} ;


################################################################################
##
##  indexmap() creates the structures to create the SQL insert statements
##  for the index table
##
################################################################################

$private{indexmap} = sub {
	my $self = shift ;
	my $tied = tied %$self ;
	my $keys = shift ;
	my $value = shift ;
	my $orderid = shift ;
	my $format = $sql{ $self->{ $keys->[1] } } ;

	my @index = () ;
	push @index, [ $format->[0], $tied->{keys}->{ $keys->[1] } ] ;
	push @index, [ $format->[1], $value->{ $keys->[0] },
			$format->[2] ] ;
	push @index, [ objectid => $orderid ] ;
	return \@index ;
	} ;

################################################################################
##
##  getinstance() returns null for passed instances
##  distinguishes between instances and objects
##
################################################################################

$private{getinstance} = sub {
	my $self = shift ;
	my $tied = tied %$self ;
	return $tied->{parent} ;
	} ;

################################################################################
##
##  A tied hash is used to hide internal properties by overloading access
##  methods.
##
################################################################################

sub TIEHASH {
	my $package = shift ;
	my $self = shift ;
	return bless $self, $package ;
	}

sub CLEAR {
	my $self = shift ;
	undef $self->{clone} ;
	}

sub FETCH {
	my $self = shift ;
	my $key = shift ;
	return $self->{clone}->{$key} ;
	}

sub EXISTS {
	my $self = shift ;
	my $key = shift ;
	return exists $self->{clone}->{$key} ;
	}

sub DELETE {
	my $self = shift ;
	my $key = shift ;
	return delete $self->{clone}->{$key} ;
	}

sub STORE {
	my $self = shift ;
	my $key = shift ;
	my $value = shift ;
	return $self->{clone}->{$key} = $value ;
	}

sub FIRSTKEY {
	my $self = shift ;
	$self->{nextkey} = [ keys %{ $self->{clone} } ] ;
	return $self->NEXTKEY ;
	}

sub NEXTKEY {
	my $self = shift ;
	return shift @{ $self->{nextkey} } ;
	}

sub new {
	return db( @_ ) ;
	}

sub db {
	my $package = shift ;
	my $self = {} ;

	my @dsn = ( @_, $package->dsn ) ;
	carp( "Missing data sources" ) and return undef unless @dsn ;

	my $dsn = {} ;
	$dsn->{object} = shift @dsn ;
	$dsn->{index} = shift @dsn ;

	$package->SQLError( ObjectNotFound => \&newobject ) ;

	my $o = $package->SQLObject( $dsn->{object}, 0 ) ;
	$self->{id} = &{ $private{recno} }( $o ) ;
	$self->{clone} = $o->SQLClone() ;
	$self->{dsn} = $dsn ;

	my %keys = map { $_ => &{ $private{recno} }( $o, $_ ) } keys %$o ;
	$self->{keys} = \%keys ;
	tie my %out, __PACKAGE__, $self ;

	return bless \%out, $package ;
	}

sub loadschema {
	my $package = shift @_ unless ref $_[0] ;
	my ( $dsn, $index ) = $package->dsn if defined $package ;

	$dsn ||= shift @_ ;
	my $table = shift @_ if @_ && ! ref $_[0] ;
	$index ||= shift @_ if @_ ;
	$index ||= $dsn->table( $table ) if $dsn && $table ;
	carp( "Missing data sources" ) and return
			unless defined $dsn && defined $index ;

	$dsn->loadschema ;
	$index->loadschema( $dsn->indexschema ) ;
	}

sub dsn {
	my $package = shift ;
	return () ;
	}

sub addTextIndex {
	my $self = shift ;
	return &{ $private{index} }( $self, $sql[0][0], @_ ) ;
	}

sub addNumberIndex {
	my $self = shift ;
	return &{ $private{index} }( $self, $sql[1][0], @_ ) ;
	}

sub addDateIndex {
	my $self = shift ;
	return &{ $private{index} }( $self, $sql[2][0], @_ ) ;
	}

sub recordID {
	my $array = shift ;
	my @args = @$array ;
	my $self = shift @args ;
	return $args[0] unless wantarray ;
	return @args ;
	}

sub records {
	my $array = shift ;
	my @args = @$array ;
	my $self = shift @args ;

	my @out = map { $self->record( $_ ) } @args ;
	return $out[0] if @out && ! wantarray ;
	return @out ;
	}

sub record {
	my $self = shift ;
	return $self->records if $self->isa('ARRAY') ;

	my $tied = tied %$self ;
	my $package = ref $self ;

	return undef unless @_ ;

	&{ $private{update} }( $self ) ;

	my @args = ( shift @_ ) ;
	push @args, ( @_ && ref $_[0] )? shift @_: undef ;
	my ( $objectid, $value ) =
			ref $args[0]? ( undef, $args[0] ): @args[0,1] ;

	my $argid = $objectid ;
	my $dsn = $tied->{dsn}->{object} ;
	my $index = $tied->{dsn}->{index} ;
	my $out = {} ;

	if ( ! defined $objectid && $value
			&& ref $value eq ref $self
			&& $value->SQLObjectID ) {
		$objectid = $value->SQLObjectID ;

		return $self->record( $objectid, $args[1], @_ )
				if defined $args[1] ;
		$out = tied %$value ;
		}

	my %index = @_ ;
	my @index = () ;
	if ( $value ) {
		map { push @index, [ $_ => $index{$_} ] }
				grep exists $self->{ $index{$_} },
				keys %index ;
		map { push @index, [ $_ => $_ ] }
				grep exists $value->{$_},
				keys %$self ;
		}

	while ( defined $value && defined $objectid ) {
		my $archive = $self->{archive}?
				$package->SQLClone( $dsn, $objectid ):
				undef ;

		$index->delete( [ objectid => $objectid ] ) ;

		if ( $out->{clone} && ! defined $argid ) {
			&{ $private{sqlsave} }( $out->{clone} ) ;
			}
		else {
			delete $out->{clone} ;
			$dsn->delete( [ objectid => $argid ] ) ;
			$out->{clone} = $package->SQLObject(
					$dsn, $argid, $value
					) ;
			}

		last unless defined $archive ;

		my $archiveid = &{ $private{recno} }(
				$package->SQLObject( $dsn, $archive )
				) ;
		$index->insert(
				[ intkey => $tied->{keys}->{archive} ],
				[ intvalue => $objectid ],
				[ objectid => $archiveid ]
				) ;

		last ;
		}

	delete $out->{clone} ;
	$out->{clone} = defined $objectid?
			  $package->SQLObject( $dsn, $objectid ):
			defined $value?
			  $package->SQLObject( $dsn, $value ):
			undef ;

	return undef unless $out->{clone} ;
	$out->{clone}->SQLRollback ;
	$out->{id} = $out->{clone}->sqlobjectid ;	## lc method name
	$out->{parent} = $self ;

	map { $index->update( undef, @$_ ) }
			map { &{ $private{indexmap} }(
			  $self, $_, $out->{clone}, $out->{id} )
			  } @index ;

	$index->update( undef,
			[ intkey => $tied->{id} ],
			[ intvalue => $out->{id} ],
			[ objectid => $out->{id} ]
			) if $value ;

	tie my %out, __PACKAGE__, $out ;
	return bless \%out, $package ;
	}

sub save {
	my $self = shift ;
	my $tied = tied %$self ;

	return $self->record( @_ ) unless $tied->{parent} ;
	return $tied->{parent}->record( $self, @_ ) ;
	}

sub reindex {
	my $self = shift ;
	my $tied = tied %$self ;
	my $parent = $tied->{parent} ;
	$tied = tied %$parent ;
	my $index = $tied->{dsn}->{index} ;
	my $objectid = $self->SQLObjectID ;

	return "reindex() requires an index name" unless @_ ;
	my $propkey = shift ;
	my $indexkey = @_? shift @_: $propkey ;

	return "unknown index: $indexkey" unless $parent->{ $indexkey } ;

	my $format = $sql{ $parent->{ $indexkey } } ;
	my $key = $tied->{keys}->{ $indexkey } ;

	$index->delete( [ $format->[0] => $key ],
			[ objectid => $objectid ] ) ;
	$index->update( undef, [ $format->[0] => $key ],
			[ $format->[1] => $self->{ $propkey }, $format->[2] ],
			[ objectid => $objectid ] ) ;
	return undef ;
	}

sub SQLObjectID {
	my $self = shift ;
	my $tied = tied %$self ;
	return $tied->{id} ;
	}

sub keyValues {
	my $self = shift ;
	my $indexid = shift ;

	my $instance = &{ $private{getinstance} }( $self ) ;
	carp "Argument is not an object" and return () unless $instance ;

	my $tied = tied %$instance ;
	my $dsn = $tied->{dsn}->{index} ;
	my $format = $sql{ $instance->{$indexid} } ;
	my @sql = ( [ objectid => $self->SQLObjectID ],
			[ $format->[0], $tied->{keys}->{$indexid} ]
			) ;

	if ( @_ == 0 ) {
		return bless [ $dsn,
				[ $format->[1], undef, $format->[2] ],
				@sql ], __PACKAGE__ .'::keyValues'
				unless wantarray ;

		return map { $_->{ $format->[1] } } $dsn->fetch( @sql ) ;
		}

	map { $dsn->insert( @sql, [ $format->[1], $_, $format->[2] ] ) } @_ ;
	}

sub NoSQL::PL2SQL::Simple::keyValues::clear {
	my $args = shift ;
	my $dsn = shift @$args ;

	shift @$args unless @_ ;
	$args->[0]->[1] = shift @_ if @_ ;
	return $dsn->delete( @$args ) ;
	}

sub delete {
	my $self = shift ;
	my $tied = tied %$self ;
	my $package = ref $self ;
	my $recno = shift if @_ ;

	if ( $tied->{parent} ) {
		$recno = $self ;
		$tied = tied %{ $tied->{parent} } ;
		}

	return undef unless $recno ;
	$recno = $recno->SQLObjectID if ref $recno ;

	my @sql = () ;
	push @sql, [ $sql{intkey}->[0], $tied->{id} ] ;
	push @sql, [ $sql{intkey}->[1], $recno ] ;
	$tied->{dsn}->{index}->delete( @sql ) ;
	return $recno ;
	}

sub querytest {
	return &{ $private{matching} }( @_ ) ;
	}

## double check how empty sets are returned
sub query {
	my $self = shift ;
	my $package = ref $self ;

	my @key = () ;
	push @key, [ shift @_ ] if @_ == 1 ;

	my @nvp = () ;
	push @nvp, @key ;
	push @nvp, [ splice @_, 0, 2 ] while @_ ;

	my @error = grep @$_ && ! exists $self->{ $_->[0] }, @nvp ;
	carp sprintf( "Unknown data definition %s", $error[0][0] )
			and return () if @error ;
	my $archive = @nvp && $nvp[0][0] eq 'archive' ;

	my $all = &{ $private{matching} }( $self ) ;
	my $out = @nvp == 0? $all:
			&{ $private{matching} }( $self, @{ shift @nvp } ) ;
	return $out unless ref $out ;

	$all ||= [] ;
	my $save = &{ $private{filter} }( [ keys %{ { @$all } } ] ) ;
	$save = &{ $private{filter} }(
			$archive? (): ( $save ),
			[ keys %{ { @$out } } ]
			) if $out != $all ;

	while ( @nvp ) {
		$out = &{ $private{matching} }( $self, @{ pop @nvp } ) || [] ;
		$save = &{ $private{filter} }(
				$save, [ keys %{ { @$out } } ] ) ;
		}

	return wantarray? @$save:
			bless [ $self, @$save ], $package
			unless @key ;

	my %out = @$out ;
	return map { $_ => $out{$_} } @$save ;
	}

sub DESTROY {}

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

	use vars qw( $AUTOLOAD ) ;
	my $func = $AUTOLOAD ;
	$func =~ s/^${package}::// ;
	return exists $self->{$func}? $self->query( $func, @_ ): undef ;
	}

sub newobject {
	my $package = shift ;
	my $error = shift ;
	my $errortext = pop ;

	return carp( $errortext ) && undef if $_[-1] ;
	return $package->SQLObject( @_, {} ) ;
	}

sub END {
	undef @autodestroy ;
	}


# Preloaded methods go here.

1;
__END__