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

   1 package OpenSRF::Utils::JSON;
   2 use JSON::XS;
   3 use vars qw/%_class_map/;
   4
   5 my $parser = JSON::XS->new;
   6 $parser->ascii(1); # output \u escaped strings
   7 $parser->allow_nonref(1);
   8
   9 sub true {
  10     return $parser->true();
  11 }
  12
  13 sub false {
  14     return $parser->false();
  15 }
  16
  17 sub register_class_hint {
  18         my $class = shift;
  19         my %args = @_;
  20         $_class_map{hints}{$args{hint}} = \%args;
  21         $_class_map{classes}{$args{name}} = \%args;
  22 }
  23
  24 sub lookup_class {
  25         my $self = shift;
  26         my $hint = shift;
  27         return $_class_map{hints}{$hint}{name}
  28 }
  29
  30 sub lookup_hint {
  31         my $self = shift;
  32         my $class = shift;
  33         return $_class_map{classes}{$class}{hint}
  34 }
  35
  36 sub _json_hint_to_class {
  37         my $type = shift;
  38         my $hint = shift;
  39
  40         return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
  41
  42         $type = 'hash' if ($type eq '}');
  43         $type = 'array' if ($type eq ']');
  44
  45         OpenSRF::Utils::JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
  46
  47         return $hint;
  48 }
  49
  50
  51 my $JSON_CLASS_KEY = '__c';
  52 my $JSON_PAYLOAD_KEY = '__p';
  53
  54 sub JSON2perl {
  55         my( $class, $string ) = @_;
  56         my $perl = $class->rawJSON2perl($string);
  57         return $class->JSONObject2Perl($perl);
  58 }
  59
  60 sub perl2JSON {
  61         my( $class, $obj ) = @_;
  62         my $json = $class->perl2JSONObject($obj);
  63         return $class->rawPerl2JSON($json);
  64 }
  65
  66 sub JSONObject2Perl {
  67         my $class = shift;
  68         my $obj = shift;
  69         my $ref = ref($obj);
  70         if( $ref eq 'HASH' ) {
  71                 if( defined($obj->{$JSON_CLASS_KEY})) {
  72                         my $cls = $obj->{$JSON_CLASS_KEY};
  73             $cls =~ s/^\s+//o;
  74             $cls =~ s/\s+$//o;
  75                         if( $obj = $class->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) {
  76                                 $cls = $class->lookup_class($cls) || $cls;
  77                                 return bless(\$obj, $cls) unless ref($obj);
  78                                 return bless($obj, $cls);
  79                         }
  80                         return undef;
  81                 }
  82         for my $k (keys %$obj) {
  83             $obj->{$k} = $class->JSONObject2Perl($obj->{$k})
  84                 unless ref($obj->{$k}) eq 'JSON::XS::Boolean';
  85         }
  86         } elsif( $ref eq 'ARRAY' ) {
  87                 for my $i (0..scalar(@$obj) - 1) {
  88                     $obj->[$i] = $class->JSONObject2Perl($obj->[$i])
  89                 unless ref($obj->[$i]) eq 'JSON::XS::Boolean';
  90         }
  91         }
  92         return $obj;
  93 }
  94
  95 sub perl2JSONObject {
  96         my $class = shift;
  97         my $obj = shift;
  98         my $ref = ref($obj);
  99
 100         return $obj unless $ref;
 101
 102     return $obj if $ref eq 'JSON::XS::Boolean';
 103         my $newobj;
 104
 105     if(UNIVERSAL::isa($obj, 'HASH')) {
 106         $newobj = {};
 107         $newobj->{$_} = $class->perl2JSONObject($obj->{$_}) for (keys %$obj);
 108     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
 109         $newobj = [];
 110         $newobj->[$_] = $class->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
 111     }
 112
 113     if($ref ne 'HASH' and $ref ne 'ARRAY') {
 114                 $ref = $class->lookup_hint($ref) || $ref;
 115                 $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj};
 116     }
 117
 118         return $newobj;
 119 }
 120
 121
 122 sub rawJSON2perl {
 123         my $class = shift;
 124     my $json = shift;
 125     return undef unless defined $json and $json !~ /^\s*$/o;
 126     return $parser->decode($json);
 127 }
 128
 129 sub rawPerl2JSON {
 130         my ($class, $perl) = @_;
 131     return $parser->encode($perl);
 132 }
 133
 134 1;