package POOF::Encoder;
use 5.007;
use strict;
use base qw(POOF);
use Tie::IxHash;
use Class::ISA;
use Carp qw(confess);
our $VERSION = '1.0';
sub _init : Method Protected
{
my $obj = shift;
my %args = @_;
my @dkeys = grep { defined $args{$_} } $obj->pGroup('Init');
@$obj{ @dkeys } = @args{ @dkeys };
}
sub Object : Property Protected
{
{
'type' => 'POOF',
'groups' => [qw(Init)],
}
}
sub SeenProps : Property Public
{
{
'type' => 'hash',
'default' => {},
}
}
sub SeenGroups : Property Public
{
{
'type' => 'hash',
'default' => {},
}
}
sub CreateEncodedKeysForGroups : Method Public
{
my ($obj,@groups) = @_;
# reset the seen
$obj->{'SeenProps'} = {};
$obj->{'SeenGroups'} = {};
my $p = 0;
return
(
grep
{
++$p % 2
}
$obj->CreateEncodingMap
(
$obj->{'Object'},
[@groups]
)
);
}
sub CreateEncodedKeysAndTypesForGroups : Method Public
{
my ($obj,@groups) = @_;
# reset the seen
$obj->{'SeenProps'} = {};
$obj->{'SeenGroups'} = {};
tie (my %fullmap, 'Tie::IxHash');
%fullmap = $obj->CreateEncodingMap
(
$obj->{'Object'},
[@groups]
);
my @tuples;
map
{
push
(
@tuples,
{
'key' => $_,
'obj' => $fullmap{$_}
}
)
} keys %fullmap;
return @tuples;
}
sub CreateEncodingMap : Method Protected
{
my ($obj,$ref,$groups,$parent) = @_;
tie (my %map, 'Tie::IxHash');
# preventing warnings
$parent ||= '';
my @contained;
foreach my $group (@{$groups})
{
# let's make sure we only process once
next if $obj->{'SeenGroups'}->{ $parent ? "$parent-$group" : $group }++;
my @props = eval { ($ref->pGroup($group)) };
if($@)
{
warn "Error in Encoder: parent $parent\n$@\n";
warn "ref: ",Dumper($ref),"\n";
}
foreach my $prop (@props)
{
# let's make sure we only process once if they are in multiple groups
next if $obj->{'SeenProps'}->{ $parent ? "$parent-$prop" : $prop }++;
if ($obj->_Relationship(ref($ref->{$prop}),'POOF::Collection') =~ /^(?:self|child)$/o)
{
# deal with the collection
for(my $i=0; $i<= $#{$ref->{$prop}}; $i++)
{
push
(
@contained,
[
$ref->{$prop}->[$i], # new ref
$groups, # groups to look at
"$parent-$prop-$i", # new parent
]
)
}
# let's instantiate one to have a place holder for new ones on the form
push
(
@contained,
[
$ref->{$prop}->[0]->pReInstantiateSelf
(
RaiseException=>$POOF::RAISE_EXCEPTION
), # new ref
$groups, # groups to look at
"$parent-$prop-|", # new parent
]
);
}
elsif($obj->IsPOOFObj($ref->{$prop},$prop) || ref($ref->{$prop}) eq 'HASH')
{
# deal with the nested object
push
(
@contained,
[
$ref->{$prop}, # new ref
$groups, # groups to look at
(
$parent
? "$parent-$prop"
: $prop
), # new parent
]
);
}
elsif(not ref($ref->{$prop}))
{
# simple prop
my $key = $parent ? "$parent-$prop" : $prop;
$map{ $key } =
{
'object' => $ref,
'name' => $prop,
'value' => $ref->{$prop},
'class' => ref($ref),
'type' => $ref->pPropertyDefinition($prop)->{'type'},
'poof' => $obj->IsPOOFObj($ref,$prop),
'error' => $ref->pGetErrors->{$prop}
};
}
else
{
warn "Error: $prop is not a simple property and I don't know what do to with it\n";
}
}
# now let's recurse
foreach my $args (@contained)
{
%map =
(
%map,
$obj->CreateEncodingMap(@{$args})
);
}
}
return %map;
}
sub _Relationship
{
my $obj = shift;
my ($class1,$class2) = map { $_ ? ref $_ ? ref $_ : $_ : '' } @_;
return 'self' if $class1 eq $class2;
my %family1 = map { $_ => 1 } Class::ISA::super_path( $class1 );
my %family2 = map { $_ => 1 } Class::ISA::super_path( $class2 );
return
exists $family1{ $class2 }
? 'child'
: exists $family2{ $class1 }
? 'parent'
: 'unrelated';
}
sub IsPOOFObj
{
my ($obj,$ref,$prop) = @_;
return
$obj->_Relationship($ref, 'POOF') =~ /^(?:self|child)$/
? 1
: 0;
}
1;
__END__
=head1 NAME
POOF::Encoder - Utility class used by POOF.
=head1 SYNOPSIS
It is not meant to be used directly.
=head1 SEE ALSO
POOF man page.
=head1 AUTHOR
Benny Millares <bmillares@cpan.org>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2007 by Benny Millares
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.
=cut