package Object::InsideOut; {
use strict;
use warnings;
no warnings 'redefine';
# Installs object dumper and loader methods
sub dump
{
my ($GBL, $call, @args) = @_;
push(@{$$GBL{'export'}}, 'dump');
$$GBL{'init'} = 1;
*Object::InsideOut::dump = sub
{
my $self = shift;
my $d_flds = $$GBL{'dump'}{'fld'};
# Extract field info from any :InitArgs hashes
while (my $pkg = shift(@{$$GBL{'dump'}{'args'}})) {
my $p_args = $$GBL{'args'}{$pkg};
foreach my $name (keys(%{$p_args})) {
my $val = $$p_args{$name};
next if (ref($val) ne 'HASH');
if (my $field = $$val{'_F'}) {
$$d_flds{$pkg} ||= {};
if (add_dump_field('InitArgs', $name, $field, $$d_flds{$pkg}) eq 'conflict') {
OIO::Code->die(
'message' => 'Cannot dump object',
'Info' => "In class '$pkg', '$name' refers to two different fields set by 'InitArgs' and '$$d_flds{$pkg}{$name}{'src'}'");
}
}
}
}
# Must call ->dump() as an object method
if (! Scalar::Util::blessed($self)) {
OIO::Method->die('message' => q/'dump' called as a class method/);
}
# Gather data from the object's class tree
my %dump;
my $fld_refs = $$GBL{'fld'}{'ref'};
my $dumpers = $$GBL{'dump'}{'dumper'};
my $weak = $$GBL{'fld'}{'weak'};
foreach my $pkg (@{$$GBL{'tree'}{'td'}{ref($self)}}) {
# Try to use a class-supplied dumper
if (my $dumper = $$dumpers{$pkg}) {
local $SIG{'__DIE__'} = 'OIO::trap';
$dump{$pkg} = $self->$dumper();
} elsif ($$fld_refs{$pkg}) {
# Dump the data ourselves from all known class fields
my @fields = @{$$fld_refs{$pkg}};
# Fields for which we have names
foreach my $name (keys(%{$$d_flds{$pkg}})) {
my $field = $$d_flds{$pkg}{$name}{'fld'};
if (ref($field) eq 'HASH') {
if (exists($$field{$$self})) {
$dump{$pkg}{$name} = $$field{$$self};
}
} else {
if (defined($$field[$$self])) {
$dump{$pkg}{$name} = $$field[$$self];
}
}
if ($$weak{$field} && exists($dump{$pkg}{$name})) {
Scalar::Util::weaken($dump{$pkg}{$name});
}
@fields = grep { $_ != $field } @fields;
}
# Fields for which names are not known
foreach my $field (@fields) {
if (ref($field) eq 'HASH') {
if (exists($$field{$$self})) {
$dump{$pkg}{$field} = $$field{$$self};
}
} else {
if (defined($$field[$$self])) {
$dump{$pkg}{$field} = $$field[$$self];
}
}
if ($$weak{$field} && exists($dump{$pkg}{$field})) {
Scalar::Util::weaken($dump{$pkg}{$field});
}
}
}
}
# Package up the object's class and its data
my $output = [ ref($self), \%dump ];
# Create a string version of dumped data if arg is true
if ($_[0]) {
require Data::Dumper;
local $Data::Dumper::Indent = 1;
$output = Data::Dumper::Dumper($output);
chomp($output);
$output =~ s/^\$VAR1 = //; # Remove leading '$VAR1 = '
$output =~ s/;$//s; # Remove trailing semi-colon
}
# Done - send back the dumped data
return ($output);
};
*Object::InsideOut::pump = sub
{
my $input = shift;
# Check usage
if ($input) {
if ($input eq 'Object::InsideOut') {
$input = shift; # Called as a class method
} elsif (Scalar::Util::blessed($input)) {
OIO::Method->die('message' => q/'pump' called as an object method/);
}
}
# Must have an arg
if (! $input) {
OIO::Args->die('message' => 'Missing argument to pump()');
}
# Convert string input to array ref, if needed
if (! ref($input)) {
my @errs;
local $SIG{'__WARN__'} = sub { push(@errs, @_); };
my $array_ref;
eval "\$array_ref = $input";
if ($@ || @errs) {
my ($err) = split(/ at /, $@ || join(" | ", @errs));
OIO::Args->die(
'message' => 'Failure converting dump string back to hash ref',
'Error' => $err,
'Arg' => $input);
}
$input = $array_ref;
}
# Check input
if (ref($input) ne 'ARRAY') {
OIO::Args->die('message' => 'Argument to pump() is not an array ref');
}
# Extract class name and object data
my ($class, $dump) = @{$input};
if (! defined($class) || ref($dump) ne 'HASH') {
OIO::Args->die('message' => 'Argument to pump() is invalid');
}
# Create a new 'bare' object
my $self = _obj($class);
# Store object data
foreach my $pkg (keys(%{$dump})) {
if (! exists($$GBL{'tree'}{'td'}{$pkg})) {
OIO::Args->die('message' => "Unknown class: $pkg");
}
my $data = $$dump{$pkg};
# Try to use a class-supplied pumper
if (my $pumper = $$GBL{'dump'}{'pumper'}{$pkg}) {
local $SIG{'__DIE__'} = 'OIO::trap';
$self->$pumper($data);
} else {
# Pump in the data ourselves
foreach my $fld_name (keys(%{$data})) {
my $value = $$data{$fld_name};
if (my $field = $$GBL{'dump'}{'fld'}{$pkg}{$fld_name}{'fld'}) {
$self->set($field, $value);
} else {
if ($fld_name =~ /^(?:HASH|ARRAY)/) {
OIO::Args->die(
'message' => "Unnamed field encounted in class '$pkg'",
'Arg' => "$fld_name => $value");
} else {
OIO::Args->die(
'message' => "Unknown field name for class '$pkg': $fld_name");
}
}
}
}
}
# Done - return the object
return ($self);
};
# Do the original call
@_ = @args;
goto &$call;
}
} # End of package's lexical scope
# Ensure correct versioning
($Object::InsideOut::VERSION eq '3.98')
or die("Version mismatch\n");
# EOF