File Coverage

blib/lib/NoSQL/PL2SQL.pm

Criterion	Covered	Total	%
statement	24	96	25.0
branch	0	42	0.0
condition	0	22	0.0
subroutine	8	20	40.0
pod	0	12	0.0
total	32	192	16.6

package NoSQL::PL2SQL;

use 5.008009;
use strict;
use warnings;

use Scalar::Util ;
use Carp ;
use NoSQL::PL2SQL::Node ;
use NoSQL::PL2SQL::Object ;
use NoSQL::PL2SQL::Perldata ;

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 ':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 = '1.21';

require XSLoader;
XSLoader::load('NoSQL::PL2SQL', $VERSION);

# Preloaded methods go here.

our @members = qw( perldata sqltable globals ) ;
my @errors = qw(
		BlessedCaller InvalidDataSource
		InvalidObjectID UnconnectedDataSource
		DuplicateObject ObjectNotFound CorruptData
		TableLockFailure
		) ;
my %errors = () ;

sub SQLError {
	return sqlerror( @_ ) ;
	}

sub sqlerror {
	my $package = shift ;
	my @nvp = () ;
	push @nvp, [ splice @_, 0, 2 ] while @_ ;

	foreach my $a ( @nvp ) {
		my $k = join '::', $package, $a->[0] ;
		$errors{ $k } = $a->[1] ;
		}

	return @errors if wantarray ;
	return [ keys %errors ] ;
	}

sub SQLCarp {
	return sqlcarp( @_ ) ;
	}

sub sqlcarp {
	my $package = shift ;
	my $key = shift ;
	my $error = shift ;
	$error->{Error} = $key ;

	my $k = join '::', $package, $key ;
	return &{ $errors{$k} }( $package, $error, @_ )
			if exists $errors{$k} && ref $errors{$k} eq 'CODE' ;
	carp( $_[-1] ) ;
	return undef ;
	}

sub SQLObjectID {
	return sqlobjectid( @_ ) ;
	}

sub sqlobjectid {
	my $self = shift ;
	my $tied = NoSQL::PL2SQL::Object::item( $self )->[1] ;
	return $tied unless defined $tied ;
	return $tied->record->{objectid} ;
	}

sub SQLObject {
	return sqlobject( @_ ) ;
	}

sub sqlobject {
	my $package = shift ;
	my @args = @_ ;
	my $dsn = shift ;
	my $objectid = @_ && ! ref $_[0]? shift( @_ ): undef ;
	my $object = @_ && ref $_[0]? shift( @_ ): undef ;

	return sqlcarp( $package, $errors[0], {}, @args,
			'SQLObject must be called as a static method.' )
			if ref $package ;
	return sqlcarp( $package, $errors[1], {}, @args,
			'Missing or invalid data source.' )
			unless eval { $dsn->db } ;
	return sqlcarp( $package, $errors[2], {}, @args,
			'Fetch requires an objectid.' ) or return undef
			unless defined $objectid || defined $object ;
	return sqlcarp( $package, $errors[3], {}, @args,
			'SQLObject requires a connected database.'
		  	  .'Use NoSQL::PL2SQL::Node::factory for testing.' )
			unless $dsn->dbconnected ;

	if ( defined $objectid && defined $object ) {
		my $perldata = $dsn->fetch( [ objectid => $objectid, 0 ],
				[ objecttype => $package, 1 ] ) ;
		return sqlcarp( $package, $errors[4],
				  { $errors[4] => $perldata },
				  @args, "Duplicate object $objectid." )
				if scalar values %$perldata ;
		}

	## write to database
	$objectid = NoSQL::PL2SQL::Node->factory( $dsn, $objectid,
			bless( $object, $package ), $package )
			if defined $object ;

 	my $self = bless { sqltable => $dsn }, 'NoSQL::PL2SQL::Clone' ;
	$self->{perldata} = $dsn->fetch( [ objectid => $objectid ],
			  [ objecttype => $package, 1 ] ) ;
	return sqlcarp( $package, $errors[5], {}, @args,
			"Object not found for object $objectid." )
			unless scalar values %{ $self->{perldata} } ;

 	my $perlnode = $self->record( $objectid ) || { id => 0 } ;
	( $perlnode ) = grep $_->{reftype} eq 'perldata',
			  values %{ $self->{perldata} }
			unless exists $self->{perldata}->{$objectid}
			  && $self->{perldata}->{$objectid}->{reftype}
			  eq 'perldata' ;

	return sqlcarp( $package, $errors[6], { $errors[6] => $self }, @args,
			'Missing perldata node- possible data corruption.' )
			unless $perlnode->{id} ;

	$self->{top} = $self->record( $perlnode->{id} )->{refto} ;
	$self->{package} = $package ;
	$self->{reftype} = $self->record->{reftype} ;
	$self->{globals} = { memory => {},
			scalarrefs => {},
			top => $self->{top},
			header => $perlnode,
			} ;
	$self->{globals}->{clone} = $self ;

	if ( $self->{reftype} eq 'hashref' ) {
		tie my( %out ), $self ;
		return $self->memorymap( $self->mybless( \%out ) ) ;
		}
	elsif ( $self->{reftype} eq 'arrayref' ) {
		tie my( @out ), $self ;
		return $self->memorymap( $self->mybless( \@out ) ) ;
		}
	elsif ( $self->{reftype} eq 'scalarref' ) {
		$self->loadscalarref( $self->{top} ) ;
		tie my( $out ), $self ;
		return $self->memorymap( $self->mybless( \$out ) ) ;
		}
	else {
		return $self->sqlclone ;
		}
	}

sub SQLClone {
	return sqlclone( @_ ) ;
	}

sub sqlclone {
	my $tied = shift ;
	$tied = $tied->sqlobject( @_ ) if @_ >= 2 ;

	my $self = NoSQL::PL2SQL::Object::item( $tied )->[1] ;
	return $tied unless defined $self ;
	return $self->sqlclone ;
	}

sub SQLRollback {
	return sqlrollback( @_ ) ;
	}

sub sqlrollback {
	my $self = shift ;
	my $tied = NoSQL::PL2SQL::Object::item( $self )->[1] ;
	return $tied unless defined $tied ;
	$tied->{globals}->{rollback} = 1 ;
	}

1;
__END__