File Coverage

blib/lib/Google/Data/JSON.pm

Criterion	Covered	Total	%
statement	28	30	93.3
branch			n/a
condition			n/a
subroutine	10	10	100.0
pod			n/a
total	38	40	95.0

package Google::Data::JSON;

use warnings;
use strict;

use version; our $VERSION = qv('0.1.10');

use File::Slurp;
use JSON::Any;
use List::MoreUtils qw( any uniq );
use Perl6::Export::Attrs;
use Storable qw(dclone);
use UNIVERSAL::require;
use XML::Simple;

## XML::Simple
my $CONFIG = {
    XMLin => {
	KeepRoot     => 1,
	ContentKey   => '$t',
	KeyAttr      => [],
	ForceArray   => 0,
	ForceContent => 1,
    },
    XMLout => {
	KeepRoot     => 1,
	ContentKey   => '$t',
	KeyAttr      => [],
	XMLDecl      => '',
	NoSort       => 1,
    }
};

use vars qw( $ERROR );

sub error {
    my $msg = $_[1] || '';
    $msg .= "\n" unless $msg =~ /\n$/;
    if (ref($_[0])) {
        $_[0]->{_errstr} = $msg;
    } else {
        $ERROR = $msg;
    }
    return;
}

sub errstr { ref($_[0]) ? $_[0]->{_errstr} : $ERROR }

sub new {
    my $class  = shift;
    my ($type, $stream);
    if (@_ > 1) {
        ($type, $stream) = @_;
        if ($type eq 'file') {
            $stream = read_file $stream;
            $type = get_type_as_dwim($stream);
        }
    }
    else {
        warn 'DWIM-style constructor is DEPRECATED';
        ($stream) = @_;
        $stream = read_file $stream if $stream !~ /[\r\n]/ && -f $stream;
        $type = get_type_as_dwim($stream);
    }
    return __PACKAGE__->error("Bad type: $type")
        unless $type eq 'xml' || $type eq 'json' || $type eq 'hash' || $type eq 'atom';
    return __PACKAGE__->error("Bad stream: $type => $stream")
        if ($type eq 'xml'  && $stream !~ /^
        || ($type eq 'json' && $stream !~ /^\{/)
        || ($type eq 'hash' && !UNIVERSAL::isa($stream, 'HASH'))
        || ($type eq 'atom' && !UNIVERSAL::isa($stream, 'XML::Atom::Base'));
    bless { $type => $stream }, $class;
}

sub get_type_as_dwim {
    my ($stream) = @_;
    return UNIVERSAL::isa($stream, 'XML::Atom::Base') ? 'atom'
         : UNIVERSAL::isa($stream, 'HASH')            ? 'hash'
         : $stream  =~ /^\{/                          ? 'json'
         : $stream  =~ /^
         : __PACKAGE__->error("Bad stream: $stream");
}

sub gdata :Export { __PACKAGE__->new(@_) }

sub as_xml {
    my $self = shift;
    if ( $self->{xml} ) {
	return $self->{xml};
    }
    elsif ( $self->{atom} ) {
	return $self->{xml} = atom_to_xml( $self->{atom} );
    }
    elsif ( $self->{hash} ) {
	return $self->{xml} = hash_to_xml( $self->{hash} );
    }
    elsif ( $self->{json} ) {
	$self->{hash} = json_to_hash( $self->{json} );
	return $self->{xml} = hash_to_xml( $self->{hash} );
    }
}

sub as_atom {
    my $self = shift;
    if ( $self->{atom} ) {
	return $self->{atom};
    }
    elsif ( $self->{xml} ) {
	return $self->{atom} = xml_to_atom( $self->{xml} );
    }
    elsif ( $self->{hash} ) {
	$self->{xml} = hash_to_xml( $self->{hash} );
	return $self->{atom} = xml_to_atom( $self->{xml} );
    }
    elsif ( $self->{json} ) {
	$self->{hash} = json_to_hash( $self->{json} );
	$self->{xml} = hash_to_xml( $self->{hash} );
	return $self->{atom} = xml_to_atom( $self->{xml} );
    }
}

sub as_hash {
    my $self = shift;
    if ( $self->{hash} ) {
	return $self->{hash};
    }
    elsif ( $self->{json} ) {
	return $self->{hash} = json_to_hash( $self->{json} );
    }
    elsif ( $self->{xml} ) {
	return $self->{hash} = xml_to_hash( $self->{xml} );
    }
    elsif ( $self->{atom} ) {
	$self->{xml} = atom_to_xml( $self->{atom} );
	return $self->{hash} = xml_to_hash( $self->{xml} );
    }
}

sub as_json {
    my $self = shift;
    if ( $self->{json} ) {
	return $self->{json};
    }
    elsif ( $self->{hash} ) {
	return $self->{json} = hash_to_json( $self->{hash} );
    }
    elsif ( $self->{xml} ) {
	$self->{hash} = xml_to_hash( $self->{xml} );
	return $self->{json} = hash_to_json( $self->{hash} );
    }
    elsif ( $self->{atom} ) {
	$self->{xml} = atom_to_xml( $self->{atom} );
	$self->{hash} = xml_to_hash( $self->{xml} );
	return $self->{json} = hash_to_json( $self->{hash} );
    }
}

sub xml_to_atom :Export {
    my ($xml) = shift;
    my ($root) = $xml =~ /<\?xml[^>]+?\?>\s*<(?:\w+:)?(\w+)/ms;
    my $module = 'XML::Atom::' . ucfirst($root);
    "$module"->require or return __PACKAGE__->error($@);
    return $module->new(\$xml);
}

sub xml_to_hash :Export { fix_ns( XMLin( $_[0], %{ $CONFIG->{XMLin} } ) ) }

sub xml_to_json :Export { hash_to_json( xml_to_hash(@_) ) }

sub atom_to_xml :Export { $_[0]->as_xml }

sub atom_to_hash :Export { xml_to_hash( atom_to_xml(@_) ) }

sub atom_to_json :Export { xml_to_json( atom_to_xml(@_) ) }

sub hash_to_xml :Export { XMLout( fix_ns2(dclone $_[0]), %{ $CONFIG->{XMLout} } ) }

sub hash_to_atom :Export { xml_to_atom( hash_to_xml(@_) ) }

sub hash_to_json :Export { JSON::Any->objToJson( $_[0] ) }

sub json_to_xml :Export { hash_to_xml( json_to_hash(@_) ) }

sub json_to_atom :Export { hash_to_atom( json_to_hash(@_) ) }

sub json_to_hash :Export { JSON::Any->jsonToObj( $_[0] ) }

sub as_hashref {
    warn 'as_hashref is DEPRECATED and renamed to as_hash';
    $_[0]->as_hash;
}

sub xml_to_hashref :Export {
    warn 'xml_to_hashref is DEPRECATED and renamed to xml_to_hash';
    xml_to_hash(@_);
}

sub atom_to_hashref :Export {
    warn 'xml_to_hashref is DEPRECATED and renamed to atom_to_hash';
    atom_to_hash(@_);
}

sub json_to_hashref :Export {
    warn 'xml_to_hashref is DEPRECATED and renamed to json_to_hash';
    json_to_hash(@_);
}

sub fix_ns {
    my ($h) = shift;
    for my $k (keys %$h) {
        if (UNIVERSAL::isa($h->{$k}, 'HASH')) {
            $h->{$k} = fix_ns($h->{$k});
        }
        elsif (UNIVERSAL::isa($h->{$k}, 'ARRAY')) {
            $h->{$k} = [ map fix_ns($_), @{ $h->{$k} } ];
        }
        if ($k =~ /(.+):(.+)/) {
            $h->{"$1\$$2"} = $h->{$k};
            delete $h->{$k};
        }
    }
    return $h;
}

sub fix_ns2 {
    my ($h) = shift;
    for my $k (keys %$h) {
        if (UNIVERSAL::isa($h->{$k}, 'HASH')) {
            $h->{$k} = fix_ns2($h->{$k});
        }
        elsif (UNIVERSAL::isa($h->{$k}, 'ARRAY')) {
            $h->{$k} = [ map fix_ns2($_), @{ $h->{$k} } ];
        }
        if ($k =~ /(.+)\$(.+)/) {
            $h->{"$1:$2"} = $h->{$k};
            delete $h->{$k};
        }
    }
    return $h;
}

1; # Magic true value required at end of module
__END__