File Coverage

blib/lib/NoSQL/PL2SQL/Node.pm

Criterion	Covered	Total	%
statement	9	147	6.1
branch	0	90	0.0
condition	0	60	0.0
subroutine	3	15	20.0
pod	0	12	0.0
total	12	324	3.7

package NoSQL::PL2SQL::Node ;

use 5.008009;
use strict;
use warnings;

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.07';

# Preloaded methods go here.

## The objectid is optional.  If objectid is assigned automatically,
## objectid = recno of perldata element.  Which is otherwise the last
## element to be inserted.
sub factory {
	shift @_ if $_[0] eq __PACKAGE__ ;
	my $dsn = shift ;
	my $objectid = ! defined $_[0]? shift( @_ ):
			ref $_[0]? undef: shift( @_ ) ;
	my $o = shift ;
	my $ref = @_? shift( @_ ): '' ;

	my $globals = { objecttype => $ref || ref $o } ;
	$globals->{objectid} = $objectid if defined $objectid ;
	my @nodes = xml2sql( XML::Parser::Nodes->pl2xml( $o ), $globals ) ;
	return @nodes unless $dsn && $dsn->dbconnected ;

	unless ( defined $objectid ) {
		$nodes[-1]->sql( $dsn ) ;
		$objectid = $nodes[-1]->{sql}->{id} ;
		map { $_->{sql}->{objectid} = $objectid } @nodes ;
		}

	insertall( $dsn, combine( @nodes ) ) ;
	return $objectid ;
	}

sub xml2sql {
	shift @_ if $_[0] eq __PACKAGE__ ;
	my $parent = undef ;

	$parent = pop if @_ > 3 ;			## ARRAY
	my $globals = pop if ref $_[-1] eq 'HASH' ;	## HASH
	my $node = pop ;				## XML::Parser::Nodes
	my $key = pop ;					## scalar

	$globals ||= {} ;

	my $child = [ $key, $node ] ;
	my @out = map { xml2sql( @$_, $globals, $child ) }
			$node->childnodes() ;
	push @out, new( __PACKAGE__, @$child, $parent, $globals ) if $parent ;
	return @out ;
	}

my @nok ;	## debugging artifact

my %typemap = (
	integer => "intdata",
	double => "doubledata",
	string => "stringdata",
	) ;

## From the schema
my @strings = qw(
	stringdata
	textkey
	objecttype
	blesstype
	reftype
	stringrepr
	) ;

my %strings = map { $_ => 1 } @strings ;

sub typemap {
	my @rv = map { $typemap{ typeis( $_ ) } || '' } @_ ;
	return wantarray? @rv: $rv[0] ;
	}

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

	$self->{key} = shift ;
	$self->{xml} = shift ;
	my $parent = shift ;
	my $globals = shift ;

	$self->{parenttype} = $parent->[0] ;
	$self->{parentid} = $parent->[1]->getattributes->{memory_address}
			|| $parent->[0] || $self->{key} ;

	my $attribs = $self->{xml}->getattributes ;

	$self->{sql} = { %$globals } ;
	my @strings = ( $self ) ;
	my @text = $self->{xml}->gettext ;

## Needs to be a reliable detection of legitimate XML data
#	if ( grep $_ eq $self->{key}, qw( item string scalar scalarref ) ) {
	if ( @text == 1 ) {
		my $sv = $text[0] ;
		my $svtype = typemap( $text[0] ) ;

		if ( $svtype eq 'stringdata' ) {
			my @buff = stringsplit( $text[0] ) ;
			$self->{sql}->{$svtype} = shift @buff ;

			push @strings, map { stringfactory( $self,
					reftype => 'string',
					defined => 1,
					$svtype => $_,
					%$globals ) } @buff ;
			}
		elsif ( $svtype ) {
			$self->{sql}->{$svtype} = $text[0] ;
			}
		else {
			push @nok, $text[0] ;
			}

		my $text = $self->{xml}->gettext ;
		$text =~ s/'/\\'/sg ;
		$self->{sql}->{stringrepr} = $text ;
		}

	$self->{sql}->{reftype} = $self->{key} ;
	$self->{sql}->{blesstype} = $attribs->{blessed_package}
			if $attribs->{blessed_package} ;

	$self->{sql}->{textkey} = $attribs->{key}
			if ! exists $self->{sql}->{textkey}
			&& exists $attribs->{key}
			&& $self->{parenttype} eq 'hashref' ;
	$self->{sql}->{intkey} = $attribs->{key}
			if ! exists $self->{sql}->{intkey}
			&& exists $attribs->{key}
			&& $self->{parenttype} eq 'arrayref' ;
	$self->{sql}->{defined} = ! ( exists $attribs->{defined}
			&& $attribs->{defined} eq 'false' ) ;

	map { bless $_, $package } @strings ;
	return reverse @strings ;
	}

sub stringsplit {
	shift @_ if $_[0] eq __PACKAGE__ ;
	my $text = shift ;

	my @buff = () ;
	push @buff, $1 while $text =~ s/^(.{512})//s ;
	push @buff, $text if length $text ;
	return @buff? @buff: ('') ;
	}

sub stringfactory {
	my $self = shift ;
	my $out = { key => 'string', xml => $self->{xml}, sql => { @_ } } ;
	return bless $out, ref $self ;
	}

sub reference {
	my $self = shift ;
	my $sql = shift ;

	map { $self->{sql}->{$_} = $sql->{$_} }
			qw( blesstype reftype )
			if ref $sql ;
	return $self->{sql}->{reftype} ;
	}

sub memory {
	my $self = shift ;
	return undef unless $self->{xml} ;
	return $self->{xml}->getattributes->{memory_address} ;
	}

sub parentid {
	my $self = shift ;
	return 'string' if exists $self->{key} && $self->{key} eq 'string' ;
	return $self->{combine}?
			$self->{combine}->{parentid}:
			$self->{parentid} ;
	}

sub sql {
	my $self = shift ;
	my $dsn = shift ;

	return warn unless $dsn ;

	my $combine = exists $self->{combine}?
			$self->{combine}->{sql}: {} ;

	my @nvp = @_ ;
	push @nvp, map { $_ => exists $combine->{$_}?
			$combine->{$_}:
			$self->{sql}->{$_}
			} keys %$combine, keys %{ $self->{sql} } ;

	my %nvp = @nvp ;
	$nvp{reftype} = $self->{sql}->{reftype}
			if exists $self->{sql}->{reftype} ;
	my $id = exists $nvp{id}? $nvp{id}: undef ;

	@nvp = %nvp ;
	my @nvpargs = () ;
	push @nvpargs, [ splice @nvp, 0, 2 ] while @nvp ;
	map { push @$_, $strings{ $_->[0] } || 0 } @nvpargs ;

	my $results = $dsn->update( $id, @nvpargs ) ;
	$self->{sql}->{id} = $results->{id} ;
	return $results->{sqlresults} ;
	}

sub combine {
	shift @_ if $_[0] eq __PACKAGE__ ;
	my @records = @_ ;
	my @out = () ;

	while ( @records ) {
		push @out, shift @records ;

		last unless @records ;
		next unless $records[0]{key} eq 'item' ;

		my @gd = $records[0]{xml}->getdata ;
		next unless @gd ;
		die if @gd > 1 ;

		$out[-1]{combine} = shift @records ;
		}

	return @out ;
	}

sub insertall {
	shift @_ if $_[0] eq __PACKAGE__ ;
	my $dsn = shift ;
	my %ids = () ;
	my %refs = () ;
	my %scalars = () ;

	foreach my $self ( @_ ) {
		my $pid = $self->parentid || '' ;

		if ( $self->memory && exists $refs{ $self->memory } ) {
			$self->{key} = $self->reference(
					$refs{ $self->memory }
					) ;
			}
		$self->{key} ||= '' ;

		$self->{sql}->{refto} ||= $ids{ $self->memory }
				|| $scalars{ $self->memory }
				|| 0 if $self->memory ;

		$self->{sql}->{item} = $ids{ $pid } || 0
				if exists $ids{ $pid }
				  && $self->{key}
				  && $self->{key} ne 'string'
				  && $self->{key} ne 'scalar' ;

		if ( $self->{key} eq 'perldata' ) {
			$self->{sql}->{intdata} = 0 ;
			$self->{sql}->{deleted} = 0 ;
			$self->{sql}->{refto} = delete $self->{sql}->{item} ;
			}

		$self->{sql}->{chainedstring} = $ids{string}
				if exists $self->{sql}->{stringdata} ;

		$self->sql( $dsn ) ;

		$scalars{ $self->memory } ||= $self->{sql}->{id}
				if $self->memory
				&& $self->{key} eq 'scalarref' ;
		$ids{string} = undef unless $self->{key} eq 'string' ;
		$ids{ $pid } = $self->{sql}->{id} ;
		$refs{ $self->memory } = $self->{sql} if $self->memory ;
		}

	return $dsn->lastinsertid, \%refs ;
	}

1;
__END__