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