File Coverage

blib/lib/Data/Abridge.pm

Criterion	Covered	Total	%
statement	112	116	96.5
branch	31	44	70.4
condition	3	3	100.0
subroutine	29	30	96.6
pod	4	4	100.0
total	179	197	90.8

package Data::Abridge;
BEGIN {
  $Data::Abridge::VERSION = '0.03.01';
}

use strict;
use warnings;

use Exporter qw( import );
use Scalar::Util qw( blessed reftype refaddr );
use overload ();

use Carp;

our @EXPORT_OK = qw(
    abridge_item      abridge_items
    abridge_recursive abridge_items_recursive
);


use constant BLESSED_REGEXP => blessed qr/foo/;
use constant REFTYPE_REGEXP => reftype qr/foo/;

# Munge a thing for nice serialization

# Object     -> {  'Package::Name' =>  };
# Code Ref   -> '\&subname'
#            -> '\&__ANON__'
# Scalar Ref -> { SCALAR => $scalar }
# Glob Ref   -> '\*main:glob'

my %SLOB_DISPATCH = (
    SCALAR  => \&_process_scalar,
    REF     => \&_process_ref,
    HASH    => \&_passthrough,
    ARRAY   => \&_passthrough,
    GLOB    => \&_process_glob,
    CODE    => \&_process_code,
    BLESSED => \&_process_object,
    REGEXP  => \&_process_regexp,
);

my %COPY_DISPATCH = (
    SCALAR  => \&_process_scalar,
    REF     => \&_process_ref,
    HASH    => \&_process_hash,
    ARRAY   => \&_process_array,
    GLOB    => \&_process_glob,
    CODE    => \&_process_code,
    REGEXP  => \&_process_regexp,
);

my %RECURSE_DISPATCH = (
    REF     => \&_recurse_ref,
    HASH    => \&_recurse_hash,
    ARRAY   => \&_recurse_array,
    BLESSED => \&_recurse_object,
);

our $HONOR_STRINGIFY = 1;

our %SEEN;  # Global hash for tracking self-referential structures.
            # Should be localized by entry to recursive abridge functions.
our @PATH;  # Also localized for tracking the current path to any given entry
            # in the abridged structure.

sub _passthrough    { return $_ }
sub _process_ref    { return { SCALAR => $$_ } }
sub _process_glob   { return { GLOB => '\\'.*$_ } }
sub _process_hash   { return {%$_} }
sub _process_array  { return [@$_] }
sub _process_scalar { return { SCALAR => $$_} }
sub _process_regexp { return { Regexp => "$_" } }

sub _process_object {
    my $obj = $_;

    my $class = blessed $obj;
    return unless defined $class;

    if( $HONOR_STRINGIFY && overload::Method($obj, '""') ) {
        # overloads String ?
        return "$obj";
    }
    else {
        # Shallow Copy
        my $type = _is_Regexp( $obj )
                 ? 'REGEXP'
                 : reftype $obj;

        my $value = exists $COPY_DISPATCH{$type}
                  ? $COPY_DISPATCH{$type}->()
                  : _unsupported_type( $obj );

        return { $class => $value };
    }
}

sub _process_code {
    require B;
    my $cv = B::svref_2object($_);
    $cv->isa('B::CV') or return;

    # bail out if GV is undefined
    $cv->GV->isa('B::SPECIAL') and return;

    my $subname =  join "::", $cv->GV->STASH->NAME, $cv->GV->NAME;
    return {CODE => "\\&$subname"};
}

sub _unsupported_type {
    my $item = shift;
    my $type = reftype $item;

    return "Unsupported type: '$type' for $item";
}

sub _is_Regexp {
    require B;
    my $sv = B::svref_2object($_);
    $sv->isa('B::PVMG') or return;
    my $m = $sv->MAGIC or return;

    return $m->TYPE eq 'r';
}

sub abridge_items {
    return [ map abridge_item($_), @_ ];
}

sub abridge_item {
    my $item = shift;

    my $type = reftype $item;

    return $item unless $type;

    my $blessed = blessed $item;
    if( $blessed ) {
        $type = $blessed eq BLESSED_REGEXP ? 'REGEXP' : 'BLESSED';
    }

    my $slobd = $SLOB_DISPATCH{$type};
   $slobd = \&_unsupported_type unless defined $slobd;;

    return  $slobd->($_) for $item;
}


sub _recurse_ref {
    my $processed_ref = shift;

    my $val = $processed_ref->{SCALAR};

    push @PATH, 'SCALAR';
    $processed_ref->{SCALAR} = _abridge_recursive($val);
    pop @PATH;

    return $processed_ref;
}

sub _recurse_array {
    my $processed_array = shift;

    my @result = map {
        push @PATH, $_;
        my @a = _abridge_recursive($processed_array->[$_]);
        pop @PATH;
        @a;
    } 0 .. $#$processed_array;

    return \@result;
}

sub _recurse_hash {
    my $processed_hash = shift;

    my %new_hash;
    for my $k ( keys %$processed_hash ) {
        push @PATH, $k;
        $new_hash{$k} = _abridge_recursive( $processed_hash->{$k} );
        pop @PATH;
    }

    return \%new_hash;
}

sub _recurse_object {
    my $processed_object = shift;

    return unless ref $processed_object;
    return unless reftype $processed_object eq 'HASH';

    my ( $key, $value ) = each %$processed_object;
    my $type = reftype $value;
    $type = '' unless defined $type;


    push @PATH, $key;

    $value = $RECURSE_DISPATCH{$type}->( $value )
        if exists $RECURSE_DISPATCH{$type};

    pop @PATH;

    my %new_obj = ( $key => $value );

    return \%new_obj;
}


sub abridge_recursive {
    local %SEEN;
    local @PATH;
    &_abridge_recursive;
}

sub _abridge_recursive {
    my $item = shift;

    my $type = reftype $item;
    $type = 'BLESSED' if blessed $item;
    $type = '' unless defined $type;

    my $repl = abridge_item($item);

    # repl may have become a plain old scalar.
    # Can't recurse that.
    my $repl_type = reftype $repl;
    return $repl unless defined $repl_type;

    if ( exists $RECURSE_DISPATCH{$type} ) {
        my $id = refaddr $item;
        $id = '' unless defined $id;

            return { SEEN => [ @{$SEEN{$id}} ] }
            if exists $SEEN{$id};

        $SEEN{$id} =  [@PATH];
        $repl = $RECURSE_DISPATCH{$type}->($repl);

    }

    return $repl;
}

sub abridge_items_recursive {
    local %SEEN;
    &_abridge_items_recursive;
}

sub _abridge_items_recursive {
    return _abridge_recursive([@_]);
}

1;

# ABSTRACT: Simplify data structures for naive serialization.

__END__