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

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