c9d8248f126842271a08f5379da286ecb8364701
[OpenSRF.git] / 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
20
21 =head1 ROUTINES
22
23 =head2 JSON2perl
24
25 =cut
26
27 sub JSON2perl {
28     my( $class, $string ) = @_;
29     my $perl = $class->rawJSON2perl($string);
30     return $class->JSONObject2Perl($perl);
31 }
32
33 =head2 perl2JSON
34
35 =cut
36
37 sub perl2JSON {
38     my( $class, $obj ) = @_;
39     my $json = $class->perl2JSONObject($obj);
40     return $class->rawPerl2JSON($json);
41 }
42
43 =head2 rawJSON2perl
44
45 =cut
46
47 sub rawJSON2perl {
48     my $class = shift;
49     my $json = shift;
50     return undef unless defined $json and $json !~ /^\s*$/o;
51     return $parser->decode($json);
52 }
53
54 =head2 perl2JSON
55
56 =cut
57
58 sub rawPerl2JSON {
59     my ($class, $perl) = @_;
60     return $parser->encode($perl);
61 }
62
63 sub JSONObject2Perl {
64     my $class = shift;
65     my $obj = shift;
66     my $ref = ref($obj);
67     if( $ref eq 'HASH' ) {
68         if( defined($obj->{$JSON_CLASS_KEY})) {
69             my $cls = $obj->{$JSON_CLASS_KEY};
70             $cls =~ s/^\s+//o;
71             $cls =~ s/\s+$//o;
72             if( $obj = $class->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) {
73                 $cls = $class->lookup_class($cls) || $cls;
74                 return bless(\$obj, $cls) unless ref($obj);
75                 return bless($obj, $cls);
76             }
77             return undef;
78         }
79         for my $k (keys %$obj) {
80             $obj->{$k} = $class->JSONObject2Perl($obj->{$k})
81               unless ref($obj->{$k}) eq 'JSON::XS::Boolean';
82         }
83     } elsif( $ref eq 'ARRAY' ) {
84         for my $i (0..scalar(@$obj) - 1) {
85             $obj->[$i] = $class->JSONObject2Perl($obj->[$i])
86               unless ref($obj->[$i]) eq 'JSON::XS::Boolean';
87         }
88     }
89     return $obj;
90 }
91
92 sub perl2JSONObject {
93     my $class = shift;
94     my $obj = shift;
95     my $ref = ref($obj);
96
97     return $obj unless $ref;
98
99     return $obj if $ref eq 'JSON::XS::Boolean';
100     my $newobj;
101
102     if(UNIVERSAL::isa($obj, 'HASH')) {
103         $newobj = {};
104         $newobj->{$_} = $class->perl2JSONObject($obj->{$_}) for (keys %$obj);
105     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
106         $newobj = [];
107         $newobj->[$_] = $class->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
108     }
109
110     if($ref ne 'HASH' and $ref ne 'ARRAY') {
111         $ref = $class->lookup_hint($ref) || $ref;
112         $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj};
113     }
114
115     return $newobj;
116 }
117
118 sub true {
119     return $parser->true();
120 }
121
122 sub false {
123     return $parser->false();
124 }
125
126 sub register_class_hint {
127     my $class = shift;
128     my %args = @_;
129     $_class_map{hints}{$args{hint}} = \%args;
130     $_class_map{classes}{$args{name}} = \%args;
131 }
132
133 sub lookup_class {
134     my $self = shift;
135     my $hint = shift;
136     return $_class_map{hints}{$hint}{name}
137 }
138
139 sub lookup_hint {
140     my $self = shift;
141     my $class = shift;
142     return $_class_map{classes}{$class}{hint}
143 }
144
145 sub _json_hint_to_class {
146     my $type = shift;
147     my $hint = shift;
148
149     return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
150
151     $type = 'hash' if ($type eq '}');
152     $type = 'array' if ($type eq ']');
153
154         OpenSRF::Utils::JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
155
156     return $hint;
157 }
158
159 1;