src/perl/lib/OpenSRF/Utils/JSON.pm

   1 package OpenSRF::Utils::JSON;
   2 use strict; use warnings;
   3 use JSON::XS;
   4
   5 our $parser = JSON::XS->new;
   6 $parser->ascii(1);        # output \u escaped strings for any char with a value over 127
   7 $parser->allow_nonref(1); # allows non-reference values to equate to themselves (see perldoc)
   8
   9 our %_class_map = ();
  10 our $JSON_CLASS_KEY = '__c';
  11 our $JSON_PAYLOAD_KEY = '__p';
  12
  13
  14 =head1 NAME
  15
  16 OpenSRF::Utils::JSON - Bucket-o-Routines for JSON
  17
  18 =head1 SYNOPSIS
  19
  20 C<O::U::JSON> is a functional-style package which exports nothing. All
  21 calls to routines must use the fully-qualified name, and expect an
  22 invocant, as in
  23
  24     OpenSRF::Utils::JSON->JSON2perl($string);
  25
  26 Most routines are straightforward data<->JSON transformation wrappers
  27 around L<JSON::XS>, but some (like L</register_class_hint>) provide
  28 OpenSRF functionality.
  29
  30 =head1 ROUTINES
  31
  32 =head2 register_class_hint
  33
  34 =cut
  35
  36 sub register_class_hint {
  37     my ($pkg, %args) = @_;
  38     $_class_map{hints}{$args{hint}} = \%args;
  39     $_class_map{classes}{$args{name}} = \%args;
  40 }
  41
  42 =head2 lookup_class
  43
  44 =cut
  45
  46 sub lookup_class {
  47     my ($pkg, $hint) = @_;
  48     return $_class_map{hints}{$hint}{name}
  49 }
  50
  51 =head2 lookup_hint
  52
  53 =cut
  54
  55 sub lookup_hint {
  56     my ($pkg, $class) = @_;
  57     return $_class_map{classes}{$class}{hint}
  58 }
  59
  60 =head2 JSON2perl
  61
  62 =cut
  63
  64 sub JSON2perl {
  65     my( $pkg, $string ) = @_;
  66     my $perl = $pkg->rawJSON2perl($string);
  67     return $pkg->JSONObject2Perl($perl);
  68 }
  69
  70 =head2 perl2JSON
  71
  72 =cut
  73
  74 sub perl2JSON {
  75     my( $pkg, $obj ) = @_;
  76     my $json = $pkg->perl2JSONObject($obj);
  77     return $pkg->rawPerl2JSON($json);
  78 }
  79
  80 =head2 rawJSON2perl
  81
  82 Internal routine used by L</JSON2Perl>. Wrapper around
  83 L<JSON::XS::decode>.
  84
  85 =cut
  86
  87 sub rawJSON2perl {
  88     my ($class, $json) = @_;
  89     return undef unless defined $json and $json !~ /^\s*$/o;
  90     return $parser->decode($json);
  91 }
  92
  93 =head2 rawPerl2JSON
  94
  95 Internal routine used by L</Perl2JSON>. Wrapper around
  96 L<JSON::XS::encode>.
  97
  98 =cut
  99
 100 sub rawPerl2JSON {
 101     my ($class, $perl) = @_;
 102     return $parser->encode($perl);
 103 }
 104
 105 =head2 JSONObject2Perl
 106
 107 =cut
 108
 109 sub JSONObject2Perl {
 110     my ($pkg, $obj) = @_;
 111     my $ref = ref $obj;
 112     if( $ref eq 'HASH' ) {
 113         if( defined($obj->{$JSON_CLASS_KEY})) {
 114             my $class = $obj->{$JSON_CLASS_KEY};
 115             $class =~ s/^\s+//o;
 116             $class =~ s/\s+$//o;
 117             if( $obj = $pkg->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) {
 118                 $class = $pkg->lookup_class($class) || $class;
 119                 return bless(\$obj, $class) unless ref($obj);
 120                 return bless($obj, $class);
 121             }
 122             return undef;
 123         }
 124         for my $k (keys %$obj) {
 125             $obj->{$k} = $pkg->JSONObject2Perl($obj->{$k})
 126               unless ref($obj->{$k}) eq 'JSON::XS::Boolean';
 127         }
 128     } elsif( $ref eq 'ARRAY' ) {
 129         for my $i (0..scalar(@$obj) - 1) {
 130             $obj->[$i] = $pkg->JSONObject2Perl($obj->[$i])
 131               unless ref($obj->[$i]) eq 'JSON::XS::Boolean';
 132         }
 133     }
 134     return $obj;
 135 }
 136
 137 =head2 perl2JSONObject
 138
 139 =cut
 140
 141 sub perl2JSONObject {
 142     my $class = shift;
 143     my $obj = shift;
 144     my $ref = ref($obj);
 145
 146     return $obj unless $ref;
 147
 148     return $obj if $ref eq 'JSON::XS::Boolean';
 149     my $newobj;
 150
 151     if(UNIVERSAL::isa($obj, 'HASH')) {
 152         $newobj = {};
 153         $newobj->{$_} = $class->perl2JSONObject($obj->{$_}) for (keys %$obj);
 154     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
 155         $newobj = [];
 156         $newobj->[$_] = $class->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
 157     }
 158
 159     if($ref ne 'HASH' and $ref ne 'ARRAY') {
 160         $ref = $class->lookup_hint($ref) || $ref;
 161         $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj};
 162     }
 163
 164     return $newobj;
 165 }
 166
 167 =head2 true
 168
 169 Wrapper for JSON::XS::true. J::X::true and J::X::false, according to
 170 its documentation, "are JSON atoms become JSON::XS::true and
 171 JSON::XS::false, respectively. They are overloaded to act almost
 172 exactly like the numbers 1 and 0"
 173
 174 =cut
 175
 176 sub true { return $parser->true }
 177
 178 =head2 false
 179
 180 See L</true>
 181
 182 =cut
 183
 184 sub false { return $parser->false }
 185
 186 1;