JSON::DWIW - JSON converter that Does What I Want

 use JSON::DWIW;
 my $json_obj = JSON::DWIW->new;
 my $data = $json_obj->from_json($json_str);
 my $str = $json_obj->to_json($data);

 my ($data, $error_string) = $json_obj->from_json($json_str);

 my $data = JSON::DWIW::deserialize($json_str);
 my $error_str = JSON::DWIW::get_error_string();

 use JSON::DWIW qw/deserialize_json from_json/
 my $data = deserialize_json($json_str);
 my $error_str = JSON::DWIW::get_error_string();

 my $error_string = $json_obj->get_error_string;
 my $error_data = $json_obj->get_error_data;
 my $stats = $json_obj->get_stats;

 my $data = $json_obj->from_json_file($file)
 my $ok = $json_obj->to_json_file($data, $file);

 my $data = JSON::DWIW->from_json($json_str);
 my $str = JSON::DWIW->to_json($data);

 my $data = JSON::DWIW->from_json($json_str, \%options);
 my $str = JSON::DWIW->to_json($data, \%options);

 my $true_value = JSON::DWIW->true;
 my $false_value = JSON::DWIW->false;
 my $data = { var1 => "stuff", var2 => $true_value,
              var3 => $false_value, };
 my $str = JSON::DWIW->to_json($data);

 my $data = JSON::DWIW::deserialize($str, { start_depth => 1,
                                            start_depth_handler => $handler });

  my $json = '{ "a": 6.3e-10 }';
  my $cb = sub { my ($val) = @_; return "I got the number '$val'"; };

  my $data = JSON::DWIW::deserialize($json, { parse_number => $cb });

    my $str = '[ { "foo": "bar", "cat": 1 }, { "concat": 1, "lambda" : [ "one", 2, 3 ] } ]';

    my $foo = { foo => [ ] };
    my $handler = sub { push @{$foo->{foo}}, $_[0]; return 1; };

    my $data = JSON::DWIW::deserialize($str, { start_depth => 1,
                                               start_depth_handler => $handler });
    print STDERR Data::Dumper->Dump([ $foo ], [ 'foo' ]) . "\n";
    print STDERR Data::Dumper->Dump([ $data ], [ 'leftover_data' ]) . "\n";

    # Output
    $foo = {
             'foo' => [
                        {
                          'cat' => 1,
                          'foo' => 'bar'
                        },
                        {
                          'lambda' => [
                                      'one',
                                      2,
                                      3
                                    ],
                          'concat' => 1
                        }
                      ]
           };




    $leftover_data = [];

     my $json_str = JSON::DWIW->to_json($data);

     my ($json_str, $error_msg) = JSON::DWIW->to_json($data);

     my $json_str = JSON::DWIW->to_json($data, { use_exceptions => 1 });

     my $data = from_json($json_str)

     my ($data, $error_msg) = from_json($json_str)

 my ($ok, $error) = $json->to_json_file($data, $file, \%options);

 my $data = JSON::DWIW->from_json($json_str)
     or die "JSON error: " . JSON::DWIW->get_error_string;

 my $data = $json_obj->from_json($json_str)
     or die "JSON error: " . $json_obj->get_error_string;

 $error_data = {
                'byte' => 23,
                'byte_col' => 23,
                'col' => 22,
                'char' => 22,
                'version' => '0.15a',
                'line' => 1
              };

    $stats = {
               'bytes' => 78,
               'nulls' => 1,
               'max_string_bytes' => 5,
               'max_depth' => 2,
               'arrays' => 1,
               'numbers' => 6,
               'lines' => 1,
               'max_string_chars' => 5,
               'strings' => 6,
               'bools' => 1,
               'chars' => 78,
               'hashes' => 1
             };

 my $hex_bytes = JSON::DWIW->code_point_to_hex_bytes(0xe9);
 print "$hex_bytes\n"; # \xc3\xa9

# Creation date: 2007-02-19 16:54:44
# Authors: don
#
# Copyright (c) 2007-2010 Don Owens <don@regexguy.com>.  All rights reserved.
#
# This is free software; you can redistribute it and/or modify it under
# the Perl Artistic license.  You should have received a copy of the
# Artistic license with this distribution, in the file named
# "Artistic".  You may also obtain a copy from
# http://regexguy.com/license/Artistic
#
# This program is distributed in the hope that it will be
# useful, but WITHOUT ANY WARRANTY; without even the implied
# warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
# PURPOSE.

# $Revision: 1737 $

# TODO
#   * support surrogate pairs as described in http://www.ietf.org/rfc/rfc4627.txt
#   * check for first surrogate: 0xD800 => 0xDBFF
#   * check for second surrogate: 0xDC00 => 0xDFFF
#   * take code point - 0x10000, add lower 10 bits to second surrogate, add upper 10 bits to first

use strict;
use warnings;

use 5.006_00;

use JSON::DWIW::Boolean;

package JSON::DWIW;

use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

# work around utf-8 weirdness in Perl < 5.8
use utf8;

require Exporter;
require DynaLoader;
@ISA = qw(DynaLoader);

@EXPORT = ( );
@EXPORT_OK = ();
%EXPORT_TAGS = (all => [ 'to_json', 'from_json', 'deserialize_json' ]);

Exporter::export_ok_tags('all');

# change in POD as well!
our $VERSION = '0.47';

JSON::DWIW->bootstrap($VERSION);


{
    package JSON::DWIW::Exporter;
    use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    @ISA = qw(Exporter);

    *EXPORT = \@JSON::DWIW::EXPORT;
    *EXPORT_OK = \@JSON::DWIW::EXPORT_OK;
    *EXPORT_TAGS = \%JSON::DWIW::EXPORT_TAGS;

    *deserialize_json = \&JSON::DWIW::deserialize_json;

    sub import {
        JSON::DWIW::Exporter->export_to_level(2, @_);
    }

    sub to_json {
        return JSON::DWIW->to_json(@_);
    }

    sub from_json {
        # return JSON::DWIW->from_json(@_);
        return JSON::DWIW::deserialize(@_);
    }
}

sub import {
    JSON::DWIW::Exporter::import(@_);
}

{
    # workaround for weird importing bug on some installations
    local($SIG{__DIE__}); 
    eval qq{ 
                use Math::BigInt; 
                use Math::BigFloat;
        };
} 

sub new {
    my $proto = shift;

    my $self = bless {}, ref($proto) || $proto;
    my $params = shift;
    
    return $self unless $params;

    unless (defined($params) and UNIVERSAL::isa($params, 'HASH')) {
        return $self;
    }

    foreach my $field (qw/bare_keys use_exceptions bad_char_policy dump_vars pretty
                          escape_multi_byte convert_bool detect_circular_refs
                          ascii bare_solidus minimal_escaping
                          parse_number parse_constant sort_keys start_depth start_depth_handler/) {
        if (exists($params->{$field})) {
            $self->{$field} = $params->{$field};
        }
    }

    return $self;
}

sub to_json {
    my $proto = shift;
    my $data;
    
    my $self;
    if (UNIVERSAL::isa($proto, 'JSON::DWIW')) {
        $data = shift;
        my $options = shift;
        if ($options) {
            if (ref($proto) and $proto->isa('HASH')) {
                if (UNIVERSAL::isa($options, 'HASH')) {
                    $options = { %$proto, %$options };
                }
            }

            $self = $proto->new($options, @_);
        }
        else {
            $self = ref($proto) ? $proto : $proto->new(@_);
        }
    }
    else {
        $data = $proto;
        $self = JSON::DWIW->new(@_);
    }

    my $error_msg;
    my $error_data;
    my $stats_data = { };
    my $str = _xs_to_json($self, $data, \$error_msg, \$error_data, $stats_data);

    if ($stats_data) {
        $JSON::DWIW::Last_Stats = $stats_data;
        $self->{last_stats} = $stats_data;
    }

    $JSON::DWIW::LastError = $error_msg;
    $self->{last_error} = $error_msg;

    $JSON::DWIW::LastErrorData = $error_data;
    $self->{last_error_data} = $error_data;

    if (defined($error_msg) and $self->{use_exceptions}) {
        die $error_msg;
    }
    return wantarray ? ($str, $error_msg) : $str;
}
{
    no warnings 'once';
    
    *toJson = \&to_json;
    *toJSON = \&to_json;
    *objToJson = \&to_json;
}

sub serialize {
    my $data = shift;
    my $options = shift || { };

    my $error_msg;
    my $error_data;
    my $stats_data = { };
    my $str = _xs_to_json($options, $data, \$error_msg, \$error_data, $stats_data);

    if ($stats_data) {
        $JSON::DWIW::Last_Stats = $stats_data;
    }

    $JSON::DWIW::LastError = $error_msg;

    $JSON::DWIW::LastErrorData = $error_data;

    return $str;
}

# total process size in pages
sub get_proc_size {
    if ($^O eq 'linux') {
        my $statm_path = "/proc/$$/statm";
        if (-e $statm_path) {
            open(my $in_fh, '<', $statm_path) or return undef;
            my $statm = <$in_fh>;
            close $in_fh;
            
            my @fields = split /\s+/, $statm;
            
            return $fields[0];
        }
    }

    return undef;
}

sub from_json {
    my $proto = shift;
    my $json;
    my $self;

    if (UNIVERSAL::isa($proto, 'JSON::DWIW')) {
        $json = shift;
        my $options = shift;
        if ($options) {
            if (ref($proto) and $proto->isa('HASH')) {
                if (UNIVERSAL::isa($options, 'HASH')) {
                    $options = { %$proto, %$options };
                }
            }

            $self = $proto->new($options, @_);
        }
        else {
            $self = ref($proto) ? $proto : $proto->new(@_);
        }
    }
    else {
        $json = $proto;
        $self = JSON::DWIW->new(@_);
    }

    my $data;
    if (%$self) {
        $data = JSON::DWIW::deserialize($json, $self);
    }
    else {
        $data = JSON::DWIW::deserialize($json);
    }

    $self->{last_error} = $JSON::DWIW::LastError;
    $self->{last_error_data} = $JSON::DWIW::LastErrorData;
    $self->{last_stats} = $JSON::DWIW::Last_Stats;

    if (defined($JSON::DWIW::LastError) and $self->{use_exceptions}) {
        die $JSON::DWIW::LastError;
    }

    return wantarray ? ($data, $JSON::DWIW::LastError) : $data;
}

{
    no warnings 'once';
    *jsonToObj = \&from_json;
    *fromJson = \&from_json;
    *fromJSON = \&from_json;
}

sub from_json_file {
    my $proto = shift;
    my $file;
    my $self;
        
    if (UNIVERSAL::isa($proto, 'JSON::DWIW')) {
        $file = shift;
        my $options = shift;
        if ($options) {
            if (ref($proto) and $proto->isa('HASH')) {
                if (UNIVERSAL::isa($options, 'HASH')) {
                    $options = { %$proto, %$options };
                }
            }

            $self = $proto->new($options, @_);
        }
        else {
            $self = ref($proto) ? $proto : $proto->new(@_);
        }
    }
    else {
        $file = $proto;
        $self = JSON::DWIW->new(@_);
    }

    my $data;
    if (%$self) {
        $data = JSON::DWIW::deserialize_file($file, $self);
    }
    else {
        $data = JSON::DWIW::deserialize_file($file);
    }

    $self->{last_error} = $JSON::DWIW::LastError;
    $self->{last_error_data} = $JSON::DWIW::LastErrorData;
    $self->{last_stats} = $JSON::DWIW::Last_Stats;

    if (defined($JSON::DWIW::LastError) and $self->{use_exceptions}) {
        die $JSON::DWIW::LastError;
    }

    return wantarray ? ($data, $JSON::DWIW::LastError) : $data;
}

sub to_json_file {
    my $proto = shift;
    my $file;
    my $data;
    my $self;
        
    if (UNIVERSAL::isa($proto, 'JSON::DWIW')) {
        $data = shift;
        $file = shift;
        my $options = shift;
        if ($options) {
            if (ref($proto) and $proto->isa('HASH')) {
                if (UNIVERSAL::isa($options, 'HASH')) {
                    $options = { %$proto, %$options };
                }
            }

            $self = $proto->new($options, @_);
        }
        else {
            $self = ref($proto) ? $proto : $proto->new(@_);
        }
    }
    else {
        $data = $proto;
        $file = shift;
        $self = JSON::DWIW->new(@_);
    }

    my $out_fh;
    unless (open($out_fh, '>', $file)) {
        my $msg = "JSON::DWIW v$VERSION - couldn't open output file $file";
        if ($self->{use_exceptions}) {
            die $msg;
        } else {
            return wantarray ? ( undef, $msg ) : undef;
        }
    }

    if ($] >= 5.008) {
        binmode($out_fh, 'utf8');
    }

    my $error_msg;
    my $error_data;
    my $stats_data = { };
    my $str = _xs_to_json($self, $data, \$error_msg, \$error_data, $stats_data);

    if ($stats_data) {
        $JSON::DWIW::Last_Stats = $stats_data;
        $self->{last_stats} = $stats_data;
    }

    $JSON::DWIW::LastError = $error_msg;
    $self->{last_error} = $error_msg;

    $JSON::DWIW::LastErrorData = $error_data;
    $self->{last_error_data} = $error_data;


    if (defined($error_msg) and $self->{use_exceptions}) {
        die $error_msg;
    }

    if ($error_msg) {
        return wantarray ? (undef, $error_msg) : undef;
    }

    print $out_fh $str;
    close $out_fh;

    return wantarray ? (1, $error_msg) : 1;
}

sub parse_mmap_file {
    my $proto = shift;
    my $file = shift;

    my $error_msg;
    my $self = $proto->new;

    my $data = _parse_mmap_file($self, $file, \$error_msg);
    if ($error_msg) {
        return wantarray ? (undef, $error_msg) : undef;
    }
}

sub get_error_string {
    my $self = shift;

    if (ref($self)) {
        return $self->{last_error};
    }
    
    return $JSON::DWIW::LastError;
}
*get_err_str = \&get_error_string;
*errstr = \&get_error_string;

sub get_error_data {
    my $self = shift;

    if (ref($self)) {
        return $self->{last_error_data};
    }

    return $JSON::DWIW::LastErrorData;
}
*get_error = \&get_error_data;
*error = \&get_error_data;

sub get_stats {
    my $self = shift;
    if (ref($self)) {
        return $self->{last_stats};
    }

    return $JSON::DWIW::Last_Stats;
}
*stats = \&get_stats;

sub true {
    return JSON::DWIW::Boolean->true;
}

sub false {
    return JSON::DWIW::Boolean->false;
}

sub _escape_xml_body {
    my ($text) = @_;
    return undef unless defined $text;

    # FIXME: benchmark this and test fully
    #         $text =~ s/([&<>"'])/$Escape_Map->{$1}/eg;
    #         return $text;
        
    $text =~ s/\&/\&amp;/g;
    $text =~ s/</\&lt;/g;
    $text =~ s/>/\&gt;/g;

    return $text;
}

sub _escape_xml_attr {
    my ($text) = @_;
    return undef unless defined $text;

    # FIXME: benchmark this and test fully
    #         $text =~ s/([&<>"'])/$Escape_Map->{$1}/eg;
    #         return $text;
        
    $text =~ s/\&/\&amp;/g;
    $text =~ s/</\&lt;/g;
    $text =~ s/>/\&gt;/g;
    $text =~ s/\"/\&quot;/g;

    return $text;
}

sub _to_xml {
    my ($data, $level, $params, $parent_tag) = @_;

    return '' unless defined $data;
    
    $params = { } unless $params and UNIVERSAL::isa($params, 'HASH');
    $level ||= 0;
    
    my $xml = '';

    my $ref = ref($data);

    unless ($ref) {
        # string
        return _escape_xml_body($data);
    }

    my $indent = $params->{pretty} ? ('  ' x $level) : '';
    my $nl = $params->{pretty} ? "\n" : '';
    my $start = ($params->{pretty} and $level) ? "\n" : '';
    my $end = ($params->{pretty} and $level >= 2) ? ('  ' x ($level - 1)) : '';
    my $first = 1;

    if ($ref eq 'ARRAY') {
        foreach my $e (@$data) {
            $xml .= "$start$indent<$parent_tag>";
            $xml .= _to_xml($e, $level + 1, $params, $parent_tag);
            $xml .= "</$parent_tag>$nl$end";
        }
        continue {
            $first = 0;
        }

        return $xml;
    }
    elsif ($ref eq 'HASH') {
        foreach my $k (sort keys %$data) {
            $start = '' unless $first;
            (my $tag = $k) =~ s/[^\w-]/_/g;
            my $this_ref = ref($data->{$k});
            if ($this_ref and $this_ref eq 'ARRAY') {
                $xml .= _to_xml($data->{$k}, $level, $params, $tag);
                next;
            }
            
            $xml .= "$start$indent<$tag>";
            $xml .= _to_xml($data->{$k}, $level + 1, $params, $tag);
            $xml .= "</$tag>$nl$end";
        }
        continue {
            $first = 0;
        }

        return $xml;
    }
    else {
        # make sure objects are stringified, e.g., Math::BigInt
        return _escape_xml_body($data . '');
    }

    return $xml;
}

sub _data_to_xml {
    my ($data, $params) = @_;
    
    return _to_xml($data, 0, $params);
}

sub json_to_xml {
    my ($json, $params) = @_;

    my $data;
    if ($params) {
        $data = JSON::DWIW::deserialize($json, $params);
    }
    else {
        $data = JSON::DWIW::deserialize($json);
    }

    my $ref = ref($data);
    if ($ref and $ref eq 'ARRAY') {
        warn "top level of data must be an object/hash ref in json_to_xml() call";
        return undef;
    }

    return _data_to_xml($data, $params);
}

sub jsonml_to_xml {
    my ($jsonml) = @_;

    my $elements = JSON::DWIW::deserialize($jsonml);
    return undef unless defined $elements;

    return _jsonml_xml($elements);
}

sub _jsonml_xml {
    my ($elements) = @_;

    unless (ref($elements)) {
        # string
        return _escape_xml_body($elements);
    }

    my $name = $elements->[0];
    my $attrs = $elements->[1];
    my $attr_str = '';

    my @rest;
    if (defined $attrs and UNIVERSAL::isa($attrs, 'HASH')) {
        my @keys = sort keys %$attrs;
        my @pairs = map { qq{$_="} . _escape_xml_attr($attrs->{$_}) . qq{"} } @keys;
        $attr_str = ' ' . join(' ', @pairs);
        @rest = @$elements[2 .. $#$elements];
    }
    else {
        $attrs = undef;
        @rest = @$elements[1 .. $#$elements];
    }
    
    my $xml = "<$name$attr_str";

    if (@rest) {
        $xml .= '>';
        foreach my $e (@rest) {
            $xml .= _jsonml_xml($e);
        }
        $xml .= "</$name>";
    }
    else {
        $xml .= '/>';
    }

    return $xml;
}

# used from XS code to sort keys in Perl < 5.8.0 where we don't have
# access to sortsv() from XS
sub _sort_keys {
    return [ sort keys %{ $_[0] } ]
}

1;

# Local Variables: #
# mode: perl #
# tab-width: 4 #
# indent-tabs-mode: nil #
# cperl-indent-level: 4 #
# perl-indent-level: 4 #
# End: #
# vim:set ai si et sta ts=4 sw=4 sts=4: