File Coverage

blib/lib/App/DPath.pm

Criterion	Covered	Total	%
statement	129	133	96.9
branch	67	74	90.5
condition	7	7	100.0
subroutine	16	16	100.0
pod	2	2	100.0
total	221	232	95.2

package App::DPath;
# git description: v0.11-4-gbbe97b0

our $AUTHORITY = 'cpan:SCHWIGON';
# ABSTRACT: Cmdline tool around Data::DPath
$App::DPath::VERSION = '0.12';
use 5.008; # Data::DPath requires it
use strict;
use warnings;

use Scalar::Util 'reftype';

sub read_in
{
        #my ($c, $file) = @_;
        my ($file, $intype, $yamlmod) = @_;

        $intype ||= 'yaml';
        my $data;
        my $filecontent;
        {
                local $/;
                if ($file eq '-') {
                        $filecontent = ;
                }
                else
                {
                        open (my $FH, "<", $file) or die "dpath: cannot open input file $file.\n";
                        $filecontent = <$FH>;
                        close $FH;
                }
        }

        if (not defined $filecontent or $filecontent !~ /[^\s\t\r\n]/ms) {
                die "dpath: no meaningful input to read.\n";
        }

        if ($intype eq "yaml") {
                require YAML::Any;
                if ($yamlmod) {
                        @YAML::Any::_TEST_ORDER=($yamlmod);
                } else {
                        @YAML::Any::_TEST_ORDER=(qw(YAML::XS YAML::Old YAML YAML::Tiny)); # no YAML::Syck
                }
                $data = [YAML::Any::Load($filecontent)];
        }
        elsif ($intype eq "json") {
                require JSON;
                $data = JSON::decode_json($filecontent);
        }
        elsif ($intype eq "xml")
        {
                require XML::Simple;
                my $xs = new XML::Simple;
                $data  = $xs->XMLin($filecontent, KeepRoot => 1);
        }
        elsif ($intype eq "ini") {
                require Config::INI::Serializer;
                my $ini = Config::INI::Serializer->new;
                $data = $ini->deserialize($filecontent);
        }
        elsif ($intype eq "cfggeneral") {
                require Config::General;
                my %data = Config::General->new(-String => $filecontent,
                                                -InterPolateVars => 1,
                                               )->getall;
                $data = \%data;
        }
        elsif ($intype eq "dumper") {
                eval '$data = my '.$filecontent;
        }
        elsif ($intype eq "tap") {
                require TAP::DOM;
                require TAP::Parser;
                $data = new TAP::DOM( tap => $filecontent, trim_fieldvalues => 1, noempty_tap => 1, $TAP::Parser::VERSION > 3.22 ? (version => 13) : () );
        }
        elsif ($intype eq "taparchive") {
                require TAP::DOM::Archive;
                require TAP::Parser;
                $data = new TAP::DOM::Archive( filecontent => $filecontent, trim_fieldvalues => 1, noempty_tap => 1, $TAP::Parser::VERSION > 3.22 ? (version => 13) : () );
        }
        else
        {
                die "dpath: unrecognized input format: $intype.\n";
        }
        return $data;
}

sub _format_flat_inner_scalar
{
    my ($result) = @_;

    no warnings 'uninitialized';

    return "$result";
}

sub _format_flat_inner_array
{
        my ($opt, $result) = @_;

        no warnings 'uninitialized';

        return
         join($opt->{separator},
              map {
                   # only SCALARS allowed (where reftype returns undef)
                   die "dpath: unsupported innermost nesting (".reftype($_).") for 'flat' output.\n" if defined reftype($_);
                   "".$_
                  } @$result);
}

sub _format_flat_inner_hash
{
        my ($opt, $result) = @_;

        no warnings 'uninitialized';

        return
         join($opt->{separator},
              map { my $v = $result->{$_};
                    # only SCALARS allowed (where reftype returns undef)
                    die "dpath: unsupported innermost nesting (".reftype($v).") for 'flat' output.\n" if defined reftype($v);
                    "$_=".$v
                  } keys %$result);
}

sub _format_flat_outer
{
        my ($opt, $result) = @_;

        no warnings 'uninitialized';

        my $output = "";
        die "dpath: can not flatten data structure (undef) - try other output format.\n" unless defined $result;

        my $A = ""; my $B = ""; if ($opt->{fb}) { $A = "["; $B = "]" }
        my $fi = $opt->{fi};

        if (!defined reftype $result) { # SCALAR
                $output .= $result."\n"; # stringify
        }
        elsif (reftype $result eq 'SCALAR') { # blessed SCALAR
                $output .= $result."\n"; # stringify
        }
        elsif (reftype $result eq 'ARRAY') {
                for (my $i=0; $i<@$result; $i++) {
                        my $entry  = $result->[$i];
                        my $prefix = $fi ? "$i:" : "";
                        if (!defined reftype $entry) { # SCALAR
                                $output .= $prefix.$A._format_flat_inner_scalar($entry)."$B\n";
                        }
                        elsif (reftype $entry eq 'ARRAY') {
                                $output .= $prefix.$A._format_flat_inner_array($opt, $entry)."$B\n";
                        }
                        elsif (reftype $entry eq 'HASH') {
                                $output .= $prefix.$A._format_flat_inner_hash($opt, $entry)."$B\n";
                        }
                        else {
                                die "dpath: can not flatten data structure (".reftype($entry).").\n";
                        }
                }
        }
        elsif (reftype $result eq 'HASH') {
                my @keys = keys %$result;
                foreach my $key (@keys) {
                        my $entry = $result->{$key};
                        if (!defined reftype $entry) { # SCALAR
                                $output .= "$key:"._format_flat_inner_scalar($entry)."\n";
                        }
                        elsif (reftype $entry eq 'ARRAY') {
                                $output .= "$key:"._format_flat_inner_array($opt, $entry)."\n";
                        }
                        elsif (reftype $entry eq 'HASH') {
                                $output .= "$key:"._format_flat_inner_hash($opt, $entry)."\n";
                        }
                        else {
                                die "dpath: can not flatten data structure (".reftype($entry).").\n";
                        }
                }
        }
        else {
                die "dpath: can not flatten data structure (".reftype($result).") - try other output format.\n";
        }

        return $output;
}

sub _format_flat
{
        my ($opt, $resultlist) = @_;

        my $output = "";
        $opt->{separator} = ";" unless defined $opt->{separator};
        $output .= _format_flat_outer($opt, $_) foreach @$resultlist;
        return $output;
}

sub write_out
{
        my ($opt, $resultlist) = @_;

        my $output = "";
        my $outtype = $opt->{outtype} || 'yaml';
        if ($outtype eq "yaml")
        {
                require YAML::Any;
                if ($opt->{'yaml-module'}) {
                        @YAML::Any::_TEST_ORDER=($opt->{'yaml-module'});
                } else {
                        @YAML::Any::_TEST_ORDER=(qw(YAML::XS YAML::Old YAML YAML::Tiny)); # no YAML::Syck
                }
                $output .= YAML::Any::Dump($resultlist);
        }
        elsif ($outtype eq "json")
        {
                eval "use JSON -convert_blessed_universally";
                my $json = JSON->new->allow_nonref->pretty->allow_blessed->convert_blessed;
                $output .= $json->encode($resultlist);
        }
        elsif ($outtype eq "ini") {
                require Config::INI::Serializer;
                my $ini = Config::INI::Serializer->new;
                $output .= $ini->serialize($resultlist);
        }
        elsif ($outtype eq "dumper")
        {
                require Data::Dumper;
                $output .= Data::Dumper::Dumper($resultlist);
        }
        elsif ($outtype eq "xml")
        {
                require XML::Simple;
                my $xs = new XML::Simple;
                $output .= $xs->XMLout($resultlist, AttrIndent => 1, KeepRoot => 1);
        }
        elsif ($outtype eq "flat") {
                $output .= _format_flat( $opt, $resultlist );
        }
        else
        {
                die "dpath: unrecognized output format: $outtype.";
        }
        return $output;
}



1;

__END__