OLD | NEW |
| (Empty) |
1 # Copyright (C) 2013 Google Inc. All rights reserved. | |
2 # | |
3 # Redistribution and use in source and binary forms, with or without | |
4 # modification, are permitted provided that the following conditions are | |
5 # met: | |
6 # | |
7 # * Redistributions of source code must retain the above copyright | |
8 # notice, this list of conditions and the following disclaimer. | |
9 # * Redistributions in binary form must reproduce the above | |
10 # copyright notice, this list of conditions and the following disclaimer | |
11 # in the documentation and/or other materials provided with the | |
12 # distribution. | |
13 # * Neither the name of Google Inc. nor the names of its | |
14 # contributors may be used to endorse or promote products derived from | |
15 # this software without specific prior written permission. | |
16 # | |
17 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS | |
18 # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT | |
19 # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR | |
20 # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT | |
21 # OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, | |
22 # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT | |
23 # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, | |
24 # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY | |
25 # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT | |
26 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE | |
27 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. | |
28 | |
29 | |
30 # Converts the intermediate representation of IDLs between Perl and JSON, for: | |
31 # 1. Modularity between parser and code generator; and | |
32 # 2. Piecemeal porting to Python, by letting us connect Perl and Python scripts. | |
33 | |
34 use strict; | |
35 use warnings; | |
36 | |
37 use Class::Struct; | |
38 use JSON -convert_blessed_universally; # IR contains objects (blessed reference
s) | |
39 | |
40 sub serializeJSON | |
41 { | |
42 my $document = shift; | |
43 my $json = JSON->new->utf8; | |
44 # JSON.pm defaults to dying on objects (blessed references) and returning | |
45 # keys in indeterminate order. We set options to change this: | |
46 # allow_blessed: don't die when encounter a blessed reference | |
47 # (but default to return null) | |
48 # convert_blessed: convert blessed reference as if unblessed | |
49 # (rather than returning null) | |
50 # canonical: sort keys when writing JSON, so JSON always in same order, | |
51 # so can compare output between runs or between Perl and Python | |
52 $json = $json->allow_blessed->convert_blessed->canonical(); | |
53 return $json->encode($document); | |
54 } | |
55 | |
56 sub deserializeJSON | |
57 { | |
58 my $jsonText = shift; | |
59 my $json = JSON->new->utf8; | |
60 my $jsonHash = $json->decode($jsonText); | |
61 return jsonToPerl($jsonHash); | |
62 } | |
63 | |
64 sub jsonToPerl | |
65 { | |
66 # JSON.pm serializes Perl objects as hashes (with keys CLASS::KEY), | |
67 # so we need to rebuild objects when deserializing | |
68 my $jsonData = shift; | |
69 | |
70 if (ref $jsonData eq "ARRAY") { | |
71 return [map(jsonToPerl($_), @$jsonData)]; | |
72 } | |
73 | |
74 if (ref $jsonData eq "HASH") { | |
75 my @keys = keys %$jsonData; | |
76 return {} unless @keys; | |
77 | |
78 my $class = determineClassFromKeys(@keys); | |
79 return jsonHashToPerlObject($jsonData, $class) if $class; | |
80 | |
81 # just a hash | |
82 my $hashRef = {}; | |
83 foreach my $key (@keys) { | |
84 $hashRef->{$key} = jsonToPerl($jsonData->{$key}); | |
85 } | |
86 return $hashRef; | |
87 } | |
88 | |
89 die "Unexpected reference type: " . ref $jsonData . "\n" if ref $jsonData; | |
90 | |
91 return $jsonData; | |
92 } | |
93 | |
94 sub determineClassFromKeys | |
95 { | |
96 my @keys = shift; | |
97 | |
98 # Detect objects as hashes where all keys are of the form CLASS::KEY. | |
99 my $firstKey = $keys[0]; | |
100 my $isObject = $firstKey =~ /::/; | |
101 | |
102 return unless $isObject; | |
103 | |
104 my $class = (split('::', $firstKey))[0]; | |
105 return $class; | |
106 } | |
107 | |
108 sub jsonHashToPerlObject | |
109 { | |
110 # JSON.pm serializes hash objects of class CLASS as a hash with keys | |
111 # CLASS::KEY1, CLASS::KEY2, etc. | |
112 # When deserializing, need to rebuild objects by stripping prefix | |
113 # and calling the constructor. | |
114 my $jsonHash = shift; | |
115 my $class = shift; | |
116 | |
117 my %keysValues = (); | |
118 foreach my $classAndKey (keys %{$jsonHash}) { | |
119 my $key = (split('::', $classAndKey))[1]; | |
120 $keysValues{$key} = jsonToPerl($jsonHash->{$classAndKey}); | |
121 } | |
122 my $object = $class->new(%keysValues); # Build object | |
123 return $object; | |
124 } | |
125 | |
126 1; | |
OLD | NEW |