File Coverage

blib/lib/Object/InsideOut/Dump.pm

Criterion	Covered	Total	%
statement	93	105	88.5
branch	39	54	72.2
condition	7	17	41.1
subroutine	5	6	83.3
pod			n/a
total	144	182	79.1

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 '4.03')
    or die("Version mismatch\n");

# EOF