File Coverage

blib/lib/SOAP/Data/ComplexType.pm

Criterion	Covered	Total	%
statement	34	195	17.4
branch	0	122	0.0
condition	0	24	0.0
subroutine	12	26	46.1
pod			n/a
total	46	367	12.5

package SOAP::Data::ComplexType;
our $VERSION = 0.044;

use strict;
use warnings;
use Carp ();
use Scalar::Util;


use constant OBJ_URI 	=> undef;
use constant OBJ_TYPE	=> undef;	#format: ns:type
use constant OBJ_FIELDS => {};		#format: name=>[type, uri, attr]

use vars qw($AUTOLOAD);

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my $data = shift;	#can be HASH ref or SOAP::SOM->result object
	my $obj_fields = shift;	#href: name=>[(scalar)type, (href)attr]; or name=>[[(scalar)type, href], (href)attr]; or name=>[[(scalar)type, [(scalar)type, href]], (href)attr]; ...
	my $self = { _sdb_obj => SOAP::Data::ComplexType::Builder->new(readable=>1) };
	bless($self, $class);
	my $data_in = $self->_convert_object_to_raw($data);
	$self->_parse_obj_fields($data_in, $obj_fields, undef);
	return $self;
}

sub _convert_object_to_raw {	#recursive method: convert any object elements into perl primitives
	my $self = shift;
	my $obj = shift;
	my $ancestors = shift;

	my $addr = Scalar::Util::refaddr($obj);
	if (defined $ancestors) {
		if (grep(/^$addr$/, @{$ancestors})) {
			warn "Recursive processing halted: Circular reference with ancestor $addr detected\n";
			return undef;
		}
		push @{$ancestors}, $addr;
	}
	else {
		$ancestors = [$addr];
	}

	my $ret;
	if (UNIVERSAL::isa($obj, 'Array')) {	#special case: complex type Array is stored as a hash, needs conversion to native perl
		push @{$ret}, ref($obj->{$_}) ? $self->_convert_object_to_raw($obj->{$_}, $ancestors) : $obj->{$_} foreach (keys %{$obj});
	}
	elsif (UNIVERSAL::isa($obj, 'HASH')) {
		$ret->{$_} = ref($obj->{$_}) ? $self->_convert_object_to_raw($obj->{$_}, $ancestors) : $obj->{$_} foreach (keys %{$obj});
	}
	elsif (UNIVERSAL::isa($obj, 'ARRAY')) {
		push @{$ret}, ref($_) ? $self->_convert_object_to_raw($_, $ancestors) : $_ foreach (@{$obj});
	}
	elsif (UNIVERSAL::isa($obj, 'SCALAR')) {	#future: do we *really* want to deref scalarref?
		$ret = ref(${$obj}) ? $self->_convert_object_to_raw(${$obj}, $ancestors) : ${$obj};
	}
	else {	#base case
		$ret = $obj;
	}
	return $ret;
}

sub _parse_obj_fields {	#recursive method
	my $self = shift;
	my $data = shift;
	my $obj_fields = shift;
	my $parent_obj = shift;
	my $parent_obj_is_arraytype = shift;

	### validate parameters ###
	unless (UNIVERSAL::isa($data, 'HASH')) {
		Carp::confess "Input data not expected ref type: HASH";
	}
	unless (UNIVERSAL::isa($obj_fields, 'HASH') && scalar keys %{$obj_fields} > 0) {
		Carp::confess "Object field definitions invalid or undefined.";
	}

	### generate data structures ###
	foreach my $key (keys %{$obj_fields}) {
		my $key_regex = quotemeta $key;
		if ($parent_obj_is_arraytype) {	#array special case: define child object that becomes parent of array values
			my ($type, $uri, $attributes) = @{$obj_fields->{$key}};
			my $value = $data;
#			if ($required) {
#				Carp::cluck "Warning: Required field '$key' is null" && next unless (UNIVERSAL::isa($value, 'HASH') && scalar keys %{$value}) || (UNIVERSAL::isa($value, 'ARRAY') && @{$value});
#			}
			my ($c_type, $c_fields);
			if (UNIVERSAL::isa($type, 'ARRAY')) {
				($c_type, $c_fields) = @{$type};
			}
			my $obj = $self->{_sdb_obj}->add_elem(
				name		=> $key,
				value		=> undef,
				type		=> defined $c_type ? $c_type : $type,	#if array of complex type, else array of simple type
				uri			=> $uri,
				attributes	=> $attributes,
				parent		=> $parent_obj
			);
			my @values = UNIVERSAL::isa($value, 'ARRAY') ? @{$value} : ($value);
			foreach my $val (@values) {
				if (UNIVERSAL::isa($type, 'ARRAY')) {	#recursion case: complex subtype up to N levels deep
					if (UNIVERSAL::isa($val, 'HASH')) { $self->_parse_obj_fields($val, $c_fields, $obj, $c_type =~ m/(^|.+:)Array$/o ? 1 : 0); }
					else { Carp::cluck "Warning: Expected hash ref value for key '$key', found scalar. Ignoring data value '$val'" if defined $val; }
				}
				else {	#base case
					$self->{_sdb_obj}->add_elem(
						name		=> $key,
						value		=> $val,
						type		=> $type,
						uri			=> $uri,
						attributes	=> $attributes,
						parent		=> $obj
					);
				}
			}
		}
		elsif (grep(/^$key_regex$/, keys %{$data})) {	#base object processing
			my ($type, $uri, $attributes) = @{$obj_fields->{$key}};
			my $value = $data->{$key};
#			if ($required) {
#				Carp::cluck "Warning: Required field '$key' is null" && next unless (UNIVERSAL::isa($value, 'HASH') && scalar keys %{$value}) || (UNIVERSAL::isa($value, 'ARRAY') && @{$value});
#			}
			if (UNIVERSAL::isa($type, 'ARRAY')) {
				my ($c_type, $c_fields) = @{$type};
				my $array_obj;
				if ($c_type =~ m/(^|.+:)Array$/o) {	#complex array
					$array_obj = $self->{_sdb_obj}->add_elem(
						name		=> $key,
						value		=> undef,
						type		=> $c_type,
						uri			=> $uri,
						attributes	=> $attributes,
						parent		=> $parent_obj
					);
				}
				my @values = UNIVERSAL::isa($value, 'ARRAY') ? @{$value} : ($value);
				foreach my $val (@values) {
					my $obj = $c_type =~ m/(^|.+:)Array$/o
						? $array_obj	#complex array
						: $self->{_sdb_obj}->add_elem(	#simple array
							name		=> $key,
							value		=> undef,
							type		=> $c_type,
							uri			=> $uri,
							attributes	=> $attributes,
							parent		=> $parent_obj
						);
#warn "Added element $key\n";
					if (UNIVERSAL::isa($val, 'HASH')) { $self->_parse_obj_fields($val, $c_fields, $obj, $c_type =~ m/(^|.+:)Array$/o ? 1 : 0); }
					else { Carp::cluck "Warning: Expected hash ref value for key '$key', found scalar. Ignoring data value '$val'" if defined $val; }
				}
			}
			else {	#base case
#				if ($required) {
#					Carp::cluck "Warning: Required field '$key' is null" && next unless defined $value;
#				}
				my @values = UNIVERSAL::isa($value, 'ARRAY') ? @{$value} : ($value);
				$self->{_sdb_obj}->add_elem(
					name		=> $key,
					value		=> $_,
					type		=> $type,
					uri			=> $uri,
					attributes	=> $attributes,
					parent		=> $parent_obj
				) foreach (@values);
#warn "Added element $key=$value\n";
			}
		}
	}
}

sub DESTROY {}
sub CLONE {}

sub AUTOLOAD {
	my $self = shift;
	my $class = ref($self) || Carp::confess "'$self' is not an object";
	my $name = $AUTOLOAD;
	my $value = shift;
	$name =~ s/.*://o;   # strip fully-qualified portion
	my $elem;
	my @res = defined $value ? $self->set($name, $value) : $self->get($name);
	return wantarray ? @res : $res[0];
}

sub get_elem {
	my $self = shift;
	my $class = ref($self) || Carp::confess "'$self' is not an object";
	my $name = shift;
	my $elem;
	unless (defined ($elem = $self->{_sdb_obj}->get_elem($name))) {
		Carp::cluck "Can't access '$name' element object in class $class";
	}
	return $elem;
}

sub get {
	my $self = shift;
	my $class = ref($self) || Carp::confess "'$self' is not an object";
	my $name = shift;
	my $elem;
	return wantarray ? () : undef unless defined ($elem = $self->get_elem($name));
	my $res = $elem->value();
	if ($elem->{type} =~ m/(^|.+:)Array$/o) {
		return wantarray ? @{$res} : scalar @{$res} if defined $res;
		return wantarray ? () : 0;
	}
	else {
		return defined $res ? $res->[0] : undef;
	}
}

sub set {
	my $self = shift;
	my $class = ref($self) || Carp::confess "'$self' is not an object";
	my $name = shift;
	my $value = shift;

	### validate input is valid object or list of objects ###
	if (ref $value) {
		if (ref($value) eq 'ARRAY') {
			foreach (@{$value}) {
				Carp::cluck "Value ".ref($_)." is not a valid SOAP::Data::ComplexType::Builder::Element object" if ref($_) && UNIVERSAL::isa($_, 'SOAP::Data::ComplexType::Builder::Element');
				return wantarray ? () : undef;
			}
		} else {
			Carp::cluck "Value ".ref($_)." is not a valid SOAP::Data::ComplexType::Builder::Element object" unless UNIVERSAL::isa($value, 'SOAP::Data::ComplexType::Builder::Element');
			return wantarray ? () : undef;
		}
	}

	my $elem;
	return wantarray ? () : undef unless ($elem = $self->get_elem($name));
	my $res = $elem->value(ref($value) eq 'ARRAY' ? $value : [$value]);
	if ($elem->{type} =~ m/(^|.+:)Array$/o) {
		return wantarray ? @{$res} : scalar @{$res} if defined $res;
		return wantarray ? () : 0;
	}
	else {
		return defined $res ? $res->[0] : undef;
	}
}

sub as_soap_data {
	my $self = shift;
	return @_ ? $self->{_sdb_obj}->get_elem($_[0])->get_as_data : $self->{_sdb_obj}->to_soap_data;
}

sub as_soap_data_instance {
	my $self = shift;
	my $class = ref($self);
	my %args = @_;
	no strict 'refs';
	return SOAP::Data->new(
		exists $args{name} ? (name	=> $args{name}) : (),
		type	=> exists $args{type} ? $args{type} : &{"$class\::OBJ_TYPE"},
		uri		=> exists $args{uri} ? $args{uri} : &{"$class\::OBJ_URI"},
		attr 	=> exists $args{attr} ? $args{attr} : {},
		value	=> \SOAP::Data->value($self->as_soap_data)
	);
}

sub as_xml_data {
	return shift->{_sdb_obj}->serialise(@_);
}

sub as_xml_data_instance {
	my $self = shift;
	my $serialized = SOAP::Serializer->autotype($self->{_sdb_obj}->autotype)->readable($self->{_sdb_obj}->readable)->serialize( $self->as_soap_data_instance(@_) );
}

sub as_raw_data {
	my $self = shift;
	my $data;
	if (@_) {
		$data = eval { $self->{_sdb_obj}->get_elem($_[0])->get_as_raw; };
		warn $@ if $@;
		$data = $data->{(keys %{$data})[0]} if ref($data) eq 'HASH' && scalar keys %{$data} == 1;	#remove parent key in this case
	}
	else {
		$data = $self->{_sdb_obj}->to_raw_data;
	}
	return $data;
}

package SOAP::Data::ComplexType::Builder;
#adds type, uri field to Builder object

use strict;
use warnings;
use SOAP::Data::Builder 0.8;
use vars qw(@ISA);
@ISA = qw(SOAP::Data::Builder);

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;
	my $self = $class->SUPER::new(@_);
	return bless($self, $class);
}

sub add_elem {
	my ($self,%args) = @_;
	my $elem = SOAP::Data::ComplexType::Builder::Element->new(%args);
	if ( defined $args{parent} ) {
		my $parent = $args{parent};
		unless (UNIVERSAL::isa($parent, 'SOAP::Data::ComplexType::Builder::Element')) {
			$parent = $self->get_elem($args{parent});
		}
		$parent->add_elem($elem);
	} else {
		push(@{$self->{elements}},$elem);
	}
	return $elem;
}

sub find_elem {
	my ($self,$elem,$key,@keys) = @_;
	return UNIVERSAL::isa($elem, 'SOAP::Data::ComplexType::Builder::Element') ? $elem->find_elem($key,@keys) : undef;
}

sub get_as_data {
	my $self = shift;
	my $elem = shift;
	return UNIVERSAL::isa($elem, 'SOAP::Data::ComplexType::Builder::Element') ? $elem->get_as_data() : undef;
}

sub to_raw_data {
	my $self = shift;
	my @data = ();
	foreach my $elem ( $self->elems ) {
		my $raw = $self->get_as_raw($elem);
		push(@data,ref($raw) eq 'HASH' ? %{$raw} : ref($raw) eq 'ARRAY' ? @{$raw} : $raw);
	}
	return {@data};
}

sub get_as_raw {
	my $self = shift;
	my $elem = shift;
	return UNIVERSAL::isa($elem, 'SOAP::Data::ComplexType::Builder::Element') ? $elem->get_as_raw() : undef;
}

sub serialise {
	my $self = shift;
	my $data = @_
		? eval { SOAP::Data->value( $self->get_elem($_[0])->get_as_data ); }
		: SOAP::Data->name('SOAP:ENV' => \SOAP::Data->value( $self->to_soap_data ) );
	warn $@ if $@;
	my $serialized = SOAP::Serializer->autotype($self->autotype)->readable($self->readable)->serialize( $data );
}

package SOAP::Data::ComplexType::Builder::Element;
#supports type and uri; correctly handles '0' data value

use strict;
use warnings;
use SOAP::Data::Builder::Element;
use vars qw(@ISA);
@ISA = qw(SOAP::Data::Builder::Element);
use Carp ();
use Scalar::Util;

use vars qw($AUTOLOAD);

sub new {
	my ($class,%args) = @_;
	my $self = {};
	bless ($self,ref $class || $class);
	foreach my $key (keys %args) {
		$self->{lc $key} = defined $args{$key} ? $args{$key} : undef;
	}
	if ($args{parent}) {
		Scalar::Util::weaken($self->{parent}) if ref $args{parent};
		$self->{fullname} = (ref $args{parent} ? $args{parent}->{fullname} : $args{parent})."/$args{name}";
	}
	$self->{fullname} ||= $args{name};
	$self->{VALUE} = defined $args{value} ? [ $args{value} ] : [];
	return $self;
}

sub DESTROY {}
sub CLONE {}

sub AUTOLOAD {
	my $self = shift;
	my $class = ref($self) || Carp::confess "'$self' is not an object";
	my $name = $AUTOLOAD;
	my $value = shift;
	$name =~ s/.*://o;   # strip fully-qualified portion
	my $elem;
	my @res = defined $value ? $self->set($name, $value) : $self->get($name);
	return wantarray ? @res : $res[0];
}

sub get_elem {
    my ($self,$name) = (@_,'');
    my ($a,$b);
    my @keys = split (/\//,$name);
    foreach my $elem ( $self->get_children()) {
		next unless ref $elem;
		if ($elem->name eq $keys[0]) {
		    $a = $elem;
		    $b = shift(@keys);
		    last;
		}
    }

	Carp::cluck "Can't access '$name' element object in class ".ref($self) unless defined $a;
    my $elem = $a;
    $b = shift(@keys);
    if ($b) {
		$elem = $elem->find_elem($b,@keys);
    }

	Carp::cluck "Can't access '$name' element object in class ".ref($self) unless defined $elem;
    return $elem;
}

sub find_elem {
    my ($self,$key,@keys) = @_;
    my ($a,$b);
	foreach my $elem ( $self->get_children()) {
		next unless ref $elem;
		if ($elem->{name} eq $key) {
			$a = $elem;
			$b = $key;
			last;
		}
	}

    my $elem = $a;
    undef($b);
    while ($b = shift(@keys) ) {
        $elem = $elem->find_elem($b,@keys);
    }
    return $elem;
}

sub get {
	my $self = shift;
	my $class = ref($self) || Carp::confess "'$self' is not an object";
	my $name = shift;
	my $elem;
	return wantarray ? () : undef unless defined ($elem = $self->get_elem($name));
	my $res = $elem->value();
	if ($elem->{type} =~ m/(^|.+:)Array$/o) {
		return wantarray ? @{$res} : scalar @{$res} if defined $res;
		return wantarray ? () : 0;
	}
	else {
		return defined $res ? $res->[0] : undef;
	}
}

sub set {
	my $self = shift;
	my $class = ref($self) || Carp::confess "'$self' is not an object";
	my $name = shift;
	my $value = shift;

	### validate input is valid object or list of objects ###
	if (ref $value) {
		if (ref($value) eq 'ARRAY') {
			foreach (@{$value}) {
				Carp::cluck "Value ".ref($_)." is not a valid SOAP::Data::ComplexType::Builder::Element object" if ref($_) && UNIVERSAL::isa($_, 'SOAP::Data::ComplexType::Builder::Element');
				return wantarray ? () : undef;
			}
		} else {
			Carp::cluck "Value ".ref($_)." is not a valid SOAP::Data::ComplexType::Builder::Element object" unless UNIVERSAL::isa($value, 'SOAP::Data::ComplexType::Builder::Element');
			return wantarray ? () : undef;
		}
	}

	my $elem;
	return wantarray ? () : undef unless ($elem = $self->get_elem($name));
	my $res = $elem->value(ref($value) eq 'ARRAY' ? $value : [$value]);
	if ($elem->{type} =~ m/(^|.+:)Array$/o) {
		return wantarray ? @{$res} : scalar @{$res} if defined $res;
		return wantarray ? () : 0;
	}
	else {
		return defined $res ? $res->[0] : undef;
	}
}

sub add_elem {
    my $self = shift;
    my $elem;
    if (UNIVERSAL::isa($_[0], __PACKAGE__)) {
		$elem = $_[0];
		push(@{$self->{VALUE}},$elem);
    } else {
    	my $class = ref $self;
		push(@{$self->{VALUE}},$class->new(@_));
    }
    return $elem;
}

sub name {
	my $self = shift;
	my $value = shift;
	if (defined $value) {
		$self->{name} = $value;
	} else {
		$value = $self->{name};
	}
	return $value;
}

sub value {
	my $self = shift;
	my $value = shift;
	my $last_value;
	if (defined $value) {
		if (ref $value) {
			$last_value = $self->{VALUE};
			$self->{VALUE} = $value;
		} else {
			$last_value = $self->{VALUE};
			$self->{VALUE} = defined $value ? [$value] : [];
		}
	} else {
		$last_value = $value = $self->{VALUE};
	}
	return $last_value;
}

sub get_as_data {
	my $self = shift;
	my @values;
	foreach my $value ( @{$self->{VALUE}} ) {
		next unless (defined $value);
		if (ref $value) {
			push(@values,$value->get_as_data())
		} else {
			push(@values,$value);
		}
	}

	my @data = ();

	if (ref $values[0]) {
		$data[0] = \SOAP::Data->value( @values );
	} else {
		@data = @values;
	}

	my %attributes = %{$self->attributes()};
	my $arrayTypeAttr = (grep(/(^|.+:)arrayType$/, keys %attributes))[0];
	$attributes{$arrayTypeAttr} = $attributes{$arrayTypeAttr}.'['.(scalar @values).']' if defined $arrayTypeAttr;
	if ($self->{header}) {
		$data[0] = SOAP::Header->name($self->{name} => $data[0])->attr(\%attributes)->type($self->{type})->uri($self->{uri});
	} else {
		if ($self->{isMethod}) {
			@data = ( SOAP::Data->name($self->{name})->attr(\%attributes)->type($self->{type})->uri($self->{uri})
				=> SOAP::Data->value(@values)->type($self->{type})->uri($self->{uri}) );
		} else {
			$data[0] = SOAP::Data->name($self->{name} => $data[0])->attr(\%attributes)->type($self->{type})->uri($self->{uri});
		}
	}

	return @data;
}

sub get_as_raw {
	my $self = shift;
	my $is_parent_arraytype = shift;
	my @values;
	foreach my $value ( @{$self->{VALUE}} ) {
		if (ref $value) {	#ref => object
			push(@values,$value->get_as_raw($self->{type} =~ m/(^|.+:)Array$/o ? 1 : 0))
		} else {
			push(@values,$value);
		}
	}
	push @values, undef unless @values;	#insure undef value has the value undef
	my $data;
	if ($self->{type} =~ m/(^|.+:)Array$/o) {
		$data->{$self->{name}} = \@values;
	}
	else {
		foreach my $value (@values) {
			if ($is_parent_arraytype) {
				if (ref $value eq 'HASH') {
					$data->{$_} = $value->{$_} foreach keys %{$value};
				} else {
					$data = $value;
				}
			} else {
				if (ref $value eq 'HASH') {
					$data->{$self->{name}}->{$_} = $value->{$_} foreach keys %{$value};
				} else {
					$data->{$self->{name}} = $value;
				}
			}
		}
	}

	return $data;
}

1;

__END__