File Coverage

blib/lib/Data/Tabular/Dumper.pm

Criterion	Covered	Total	%
statement	160	179	89.3
branch	55	78	70.5
condition	11	15	73.3
subroutine	17	19	89.4
pod	5	7	71.4
total	248	298	83.2

# $Id: Dumper.pm 456 2009-04-15 12:20:59Z fil $
package Data::Tabular::Dumper;

use strict;
use vars qw( $VERSION @ISA @EXPORT_OK );

use Carp;

$VERSION="0.08";

require Exporter;
@ISA = qw( Exporter );
@EXPORT_OK = qw( Dump );


###########################################################
sub open
{
    my($package, %writers)=@_;
    my $self=bless {writers=>{}, fields=>[]}, $package;

    $self->{master_key} = delete $writers{master_key};
    $self->{master_key} = '' unless defined $self->{master_key};

    my($object, $one);
    WRITER:
    foreach my $p1 (keys %writers) {
        foreach my $p2 ($p1, __PACKAGE__.'::'.$p1) {
            if($p2->can('open') and $p2->can('close') and $p2->can('write')) {
                $package=$p2 ;
                eval {
                    $object=$package->open($writers{$p1});
                };
                carp $@ if $@;
                if($object) {
                    $self->{writers}{$package}=$object;
                    $one=1;
                }
                next WRITER;
            }
        }
        carp "Could not find a valid package for $p1 (".__PACKAGE__."::$p1)";
    }
    return unless $one;
    return $self;
}

###########################################################
sub master_key
{
    my( $self, $new_master ) = @_;
    my $ret = $self->{master_key};
    $self->{master_key} = $new_master if 2 == @_;
    return $ret;
}

###########################################################
# Perform $name->() on all the writers.
sub _doall
{
    my($name)=@_;
    return sub {
        my $self=shift @_;
        my $n;
        foreach my $o (values %{$self->{writers}}) {
            my $code=$o->can($name);
            if($code) {
                $code->($o, @_);
                $n++ unless $@;
            } else {
                carp "Object $o can not do $name";
            }
            carp $@ if $@;
        }
        return $n;
    };
}

###########################################################
*fields=_doall('fields');
*write=_doall('write');
*page_start=_doall('page_start');
*page_end=_doall('page_end');

###########################################################
sub close
{
    my( $self )= @_;

    my @ret;
    foreach my $o ( values %{$self->{writers}} ) {
        next unless $o->can( 'close' );
        push @ret, $o->close();
    }
    return @ret;
}


###########################################################
sub DESTROY
{
    $_[0]->close;
}


###########################################################
sub available
{
    my($package)=@_;

    my(%res, $yes);
    foreach my $p (qw(CSV XML Excel)) {
        $yes=0;
        $yes=1 if exists $INC{"Data/Tabular/Dumper/$p.pm"};
        unless($yes) {
            local $SIG{__DIE__}='DEFAULT';
            local $SIG{__WARN__}='IGNORE';
            $yes=eval "require Data::Tabular::Dumper::$p; 1;";
            # warn $@ if $@ and $ENV{PERL_DL_NONLAZY};
        };
        $res{$p}=$yes;
    }
    return \%res unless wantarray;
    return grep {$res{$_}} keys %res;
}

###########################################################
sub Dump
{
    return __PACKAGE__->dump( @_ );
}

###########################################################
sub dump
{
    my( $self, $data ) = @_;

    my $ret;
    unless( ref $self ) {
        require Data::Tabular::Dumper::String;
        $self = $self->open( String => \$ret, master_key=>'KEY' );
    }

    my $state = $self->analyse( $data );
    unless( $state->{pages} ) {
        $self->__dump( $state );
    }

    my $q1=1;
    foreach my $p ( @{ $state->{pages} } ) {
        my $name = "Page $q1";
        $q1++;
        $name = $p->{name} if exists $p->{name};
        $self->page_start( $name );
        $self->__dump( $p );
        $self->page_end( $name );
    }
    return $ret;
}

###########################################################
sub __dump
{
    my( $self, $data ) = @_;

    $self->fields( $data->{fields} ) if $data->{fields};
    foreach my $d ( @{ $data->{data} } ) {
        $self->write( $d->{data} );
    }
}


###########################################################
# Convert a 2- or 3-dimensional data structure into something we can
# easily use.
# Lowest-level structure is {data=>[ ...scalars...], fields=>[ ...names...]}
#    Other possible : maxdepth, depth (internal use)
# We either have an array of those in {data} (2-D)
#   { data=>[ ...lower-level ], fields=>[....names...] }
#   Otehr possible keys : name (if it's a part of {pages})
# OR we have an array of 2-D structures in {pages}
sub analyse
{
    my( $self, $data ) = @_;

    my $master = { maxdepth=>0, depth=>0 };
    my $state = $self->__analyse( $master, $data);

    if( $master->{maxdepth} == 4 ) {
        $state->{pages} = delete $state->{data};
    }
    die "ARG!" if $master->{__fields};

    return $state;
}

###########################################################
# Do the heavy lifting.
# Recurse over a data structure
sub __analyse
{
    my( $self, $parent, $data ) = @_;
    my $r = ref $data;
    return $data unless $r;

    die "Only 2-d and 3-d data is supported" if $parent->{depth} > 2;


    my $state = { depth=>$parent->{depth}+1 };
    $state->{maxdepth} = $state->{depth};

    if( $r eq 'ARRAY' ) {
        $self->__analyse_array( $parent, $data, $state );
    }
    elsif( $r eq 'HASH' ) {
        $self->__analyse_hash( $parent, $data, $state );
    }
    else {
        die "Don't know how to handle $r at level $state->{depth}";
    }

    $self->__analyse_rehash( $state, $data, $parent ) if $state->{__fields};
    $self->__analyse_depth( $state, $parent );

    return $state;
}

###########################################################
# Turns out $data was a HoH or LoH. So we have to change all the
# sub-hashes.
sub __analyse_rehash
{
    my( $self, $state, $data, $parent ) = @_;
    ## If we are here, $data is a LoH...
    my @fields = sort keys %{ delete $state->{__fields} };

    # use Data::Denter;
    # warn "Rehashing ", Denter $data, $state->{data};
    my $first_name;
    unless( 'ARRAY' eq ref $data ) {
        my @names;
        if( $state->{data}[0]{name} ) {         # 3-D
            @names = map { $_->{name} } @{ $state->{data} };
        }
        else {                                  # HoH
            @names = map { $_->{data}[0] } @{ $state->{data} };
        }
        $data = [ map { { %{$data->{$_}} } } @names ];
        $first_name = 1;

        unshift @fields, 'HONK__TITLE__HONK';
        for( my $q=0; $q <= $#$data ; $q++ ) {
            $data->[$q]{$fields[0]} = $names[$q];
        }
    }

    $state->{data} = [];
    foreach my $hash ( @$data ) {
        push @{ $state->{data} },
                    { depth=>$parent->{depth}+2, data=>[ @{$hash}{@fields} ] };
    }

    $fields[0] = $self->{master_key} if $first_name;
    $state->{fields} = \@fields;
    return;
}

###########################################################
# Make sure {maxdepth} of the parent is as big as can be
sub __analyse_depth
{
    my( $self, $state, $parent ) = @_;
    if( $state->{depth} > $parent->{maxdepth} ) {
        $parent->{maxdepth} = $state->{depth};
    }

    if( $state->{maxdepth} > $parent->{maxdepth} ) {
        $parent->{maxdepth} = $state->{maxdepth};
    }
}


###########################################################
# Recurse over an arrayref
sub __analyse_array
{
    my( $self, $parent, $data, $state ) = @_;
    $state->{data} = [];

    foreach my $s ( @$data ) {
        my $sub = $self->__analyse( $state, $s );

        if( @{ $state->{data} } ) {
            my $err = (!!ref $state->{data}[0] ^ !!ref $sub);
            $err = 1 if not $err and
                      ref $state->{data}[0] and
                      ref $state->{data}[0]{data} ne
                      ref $sub->{data};
            # $err = 1 if $state->{fields};
            if( $err ) {
                die "Non-uniform data references at a level $state->{depth}";
            }
        }
        elsif( ref $sub ) {
            $parent->{maxdepth}++;
        }
        push @{ $state->{data} }, $sub
    }
}

###########################################################
# Recurse over a hashref
sub __analyse_hash
{
    my( $self, $parent, $data, $state ) = @_;
    $state->{data} = [];

    if( $parent->{fields} ) {
        foreach my $k ( @{ $parent->{fields} } ) {
            push @{ $state->{data} }, $data->{$k};
        }
        return;
    }

    foreach my $k ( sort keys %$data ) {
        my $sub = $self->__analyse( $state, $data->{$k} );

        unless( ref $sub ) {                # $data is a hash
            $parent->{__fields}{$k} = 1;
            # $fields{$k}=1;
        }
        elsif( $sub->{maxdepth}==3 ) {             # $data is a HoLoL
            $sub->{name} = $k;
        }
        else {
            my $r = ref $sub->{data};
            if( $r eq 'ARRAY' ) {               # $data is a HoL
                unshift @{$sub->{data}}, $k;
            }
            elsif( $r eq 'HASH' ) {             # $data is a HoH
                $sub->{name}=$k;
            }
        }
        if( 0== @{ $state->{data} } and ref $sub ) {
            $parent->{maxdepth}++;
        }
        push @{$state->{data}}, $sub;
    }
}

1;
__END__