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 $class = shift;
  37     my %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 $self = shift;
  48     my $hint = shift;
  49     return $_class_map{hints}{$hint}{name}
  50 }
  51
  52 =head2 lookup_hint
  53
  54 =cut
  55
  56 sub lookup_hint {
  57     my $self = shift;
  58     my $class = shift;
  59     return $_class_map{classes}{$class}{hint}
  60 }
  61
  62 =head2 JSON2perl
  63
  64 =cut
  65
  66 sub JSON2perl {
  67     my( $class, $string ) = @_;
  68     my $perl = $class->rawJSON2perl($string);
  69     return $class->JSONObject2Perl($perl);
  70 }
  71
  72 =head2 perl2JSON
  73
  74 =cut
  75
  76 sub perl2JSON {
  77     my( $class, $obj ) = @_;
  78     my $json = $class->perl2JSONObject($obj);
  79     return $class->rawPerl2JSON($json);
  80 }
  81
  82 =head2 rawJSON2perl
  83
  84 =cut
  85
  86 sub rawJSON2perl {
  87     my $class = shift;
  88     my $json = shift;
  89     return undef unless defined $json and $json !~ /^\s*$/o;
  90     return $parser->decode($json);
  91 }
  92
  93 =head2 rawPerl2JSON
  94
  95 =cut
  96
  97 sub rawPerl2JSON {
  98     my ($class, $perl) = @_;
  99     return $parser->encode($perl);
 100 }
 101
 102 =head2 JSONObject2Perl
 103
 104 =cut
 105
 106 sub JSONObject2Perl {
 107     my $class = shift;
 108     my $obj = shift;
 109     my $ref = ref($obj);
 110     if( $ref eq 'HASH' ) {
 111         if( defined($obj->{$JSON_CLASS_KEY})) {
 112             my $cls = $obj->{$JSON_CLASS_KEY};
 113             $cls =~ s/^\s+//o;
 114             $cls =~ s/\s+$//o;
 115             if( $obj = $class->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) {
 116                 $cls = $class->lookup_class($cls) || $cls;
 117                 return bless(\$obj, $cls) unless ref($obj);
 118                 return bless($obj, $cls);
 119             }
 120             return undef;
 121         }
 122         for my $k (keys %$obj) {
 123             $obj->{$k} = $class->JSONObject2Perl($obj->{$k})
 124               unless ref($obj->{$k}) eq 'JSON::XS::Boolean';
 125         }
 126     } elsif( $ref eq 'ARRAY' ) {
 127         for my $i (0..scalar(@$obj) - 1) {
 128             $obj->[$i] = $class->JSONObject2Perl($obj->[$i])
 129               unless ref($obj->[$i]) eq 'JSON::XS::Boolean';
 130         }
 131     }
 132     return $obj;
 133 }
 134
 135 =head2 perl2JSONObject
 136
 137 =cut
 138
 139 sub perl2JSONObject {
 140     my $class = shift;
 141     my $obj = shift;
 142     my $ref = ref($obj);
 143
 144     return $obj unless $ref;
 145
 146     return $obj if $ref eq 'JSON::XS::Boolean';
 147     my $newobj;
 148
 149     if(UNIVERSAL::isa($obj, 'HASH')) {
 150         $newobj = {};
 151         $newobj->{$_} = $class->perl2JSONObject($obj->{$_}) for (keys %$obj);
 152     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
 153         $newobj = [];
 154         $newobj->[$_] = $class->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
 155     }
 156
 157     if($ref ne 'HASH' and $ref ne 'ARRAY') {
 158         $ref = $class->lookup_hint($ref) || $ref;
 159         $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj};
 160     }
 161
 162     return $newobj;
 163 }
 164
 165 =head2 true
 166
 167 =cut
 168
 169 sub true {
 170     return $parser->true();
 171 }
 172
 173 =head2 false
 174
 175 =cut
 176
 177 sub false {
 178     return $parser->false();
 179 }
 180
 181 1;