cgi-bin/LJ/JSON.pm

   1 package LJ::JSON;
   2 use strict;
   3
   4 my $wrap;
   5
   6 sub to_json {
   7     my ($class, @args) = @_;
   8
   9     return $wrap->encode(@args);
  10 }
  11
  12 sub from_json {
  13     my ($class, $dump) = @_;
  14
  15     return unless $dump;
  16     return $wrap->decode($dump);
  17 }
  18
  19 sub class {
  20     return ref $wrap;
  21 }
  22
  23 sub true  { $wrap->true  };
  24 sub false { $wrap->false };
  25
  26 sub to_boolean {
  27     my ( $class, $what ) = @_;
  28     return $what ? $wrap->true : $wrap->false;
  29 }
  30
  31 sub to_number {
  32     my ( $class, $what ) = @_;
  33
  34     # not using int deliberately because we may be handling floats here
  35     return $what + 0;
  36 }
  37
  38 foreach my $class (qw(LJ::JSON::XS LJ::JSON::JSONv2 LJ::JSON::JSONv1)) {
  39     if ($class->can_load) {
  40         $wrap = $class->new;
  41         last;
  42     }
  43 }
  44 die unless $wrap;
  45
  46 1;
  47
  48 package LJ::JSON::Wrapper;
  49
  50 use Encode qw();
  51
  52 sub traverse {
  53     my ($class, $what, $sub) = @_;
  54
  55     my $type = ref $what;
  56
  57     # simple scalar
  58     if ($type eq '') {
  59         return $sub->($what);
  60     }
  61
  62     # hashref
  63     if ($type eq 'HASH') {
  64         my %ret;
  65         foreach my $k (keys %$what) {
  66             $ret{$sub->($k)} = $class->traverse($what->{$k}, $sub);
  67         }
  68         return \%ret;
  69     }
  70
  71     # arrayref
  72     if ($type eq 'ARRAY') {
  73         my @ret;
  74         foreach my $v (@$what) {
  75             push @ret, $class->traverse($v, $sub);
  76         }
  77         return \@ret;
  78     }
  79
  80     # unknown type; let the subclass decode it to a scalar
  81     # (base class function defaults to plain stringification)
  82     return $sub->($class->decode_unknown_type($what));
  83 }
  84
  85 sub traverse_fix_encoding {
  86     my ($class, $what) = @_;
  87
  88     return $class->traverse($what, sub {
  89         my ($scalar) = @_;
  90
  91         return $scalar unless Encode::is_utf8($scalar);
  92
  93         # if the string does indeed contain wide characters (which happens
  94         # in case the source string literals contained chars specified as
  95         # '\u041c'), encode stuff as utf8
  96         if ($scalar =~ /[^\x01-\xff]/) {
  97             return Encode::encode("utf8", $scalar);
  98         }
  99
 100         return Encode::encode("iso-8859-1", $scalar);
 101     });
 102 }
 103
 104 sub decode_unknown_type {
 105     my ($class, $what) = @_;
 106
 107     return "$what";
 108 }
 109
 110 sub clean_after_encode {
 111     my ($class, $encoded) = @_;
 112
 113     unless (Encode::is_utf8($encoded)) {
 114         $encoded = Encode::decode('utf8', $encoded);
 115     }
 116
 117     # Perl 5.10 do not understand \x{00ad} sequence as Unicode char in the regexp s/...|\x{00ad}|.../, therefore we used char class.
 118     # Dangerous symbols, that were tested on the Chrome and were a reason of its crush: \r \n \x{2028} \x{2029}
 119     $encoded =~ s/[\r\n\x{0000}\x{0085}\x{00ad}\x{2028}\x{2029}\x{0600}-\x{0604}\x{070f}\x{17b4}\x{17b5}\x{200c}-\x{200f}\x{202a}-\x{202f}\x{2060}-\x{206f}\x{feff}\x{fff0}-\x{ffff}]//gs;
 120
 121     return Encode::encode('utf8', $encoded);
 122 }
 123
 124 package LJ::JSON::XS;
 125
 126 our @ISA;
 127 BEGIN { @ISA = qw(LJ::JSON::Wrapper JSON::XS); }
 128
 129 sub can_load {
 130     eval { require JSON::XS; JSON::XS->import; };
 131     return !$@;
 132 }
 133
 134 sub new {
 135     my ($class) = @_;
 136     return $class->SUPER::new->latin1;
 137 }
 138
 139 sub encode {
 140     my $class = shift;
 141     my $encoded = $class->SUPER::encode(@_);
 142     return $class->clean_after_encode($encoded);
 143 }
 144
 145 sub decode {
 146     my ($class, $dump) = @_;
 147
 148     my $decoded = $class->SUPER::decode($dump);
 149     $decoded = $class->traverse_fix_encoding($decoded);
 150     return $decoded;
 151 }
 152
 153 sub decode_unknown_type {
 154     my ($class, $what) = @_;
 155
 156     # booleans get converted to undef for false and 1 for true
 157     return $what ? 1 : undef if JSON::XS::is_bool($what);
 158
 159     # otherwise, stringify
 160     return "$what";
 161 }
 162
 163 1;
 164
 165 package LJ::JSON::JSONv2;
 166
 167 our @ISA;
 168 BEGIN { @ISA = qw(LJ::JSON::Wrapper JSON); }
 169
 170 sub can_load {
 171     eval { require JSON };
 172     return !$@ && $JSON::VERSION ge 2;
 173 }
 174
 175 sub new {
 176     my ($class) = @_;
 177     return $class->SUPER::new->latin1;
 178 }
 179
 180 sub decode {
 181     my ($class, $dump) = @_;
 182
 183     my $decoded = $class->SUPER::decode($dump);
 184     $decoded = $class->traverse_fix_encoding($decoded);
 185     return $decoded;
 186 }
 187
 188 sub decode_unknown_type {
 189     my ($class, $what) = @_;
 190
 191     # booleans get converted to undef for false and 1 for true
 192     return $what ? 1 : undef if JSON::is_bool($what);
 193
 194     # otherwise, stringify
 195     return "$what";
 196 }
 197
 198 1;
 199
 200 package LJ::JSON::JSONv1;
 201
 202 our @ISA;
 203 BEGIN { @ISA = qw(LJ::JSON::Wrapper JSON); }
 204
 205 sub can_load {
 206     eval { require JSON };
 207     return !$@ && $JSON::VERSION ge 1;
 208 }
 209
 210 *encode = \&JSON::objToJson;
 211 *decode = \&JSON::jsonToObj;
 212
 213 1;