json: dynamically select tl internal or external json mode

git-svn-id: svn://tug.org/texlive/trunk@45745 c570f23f-e606-0410-a88d-b1316a301751

4 files changed, 157 insertions, 91 deletions

diff --git a/Master/texmf-dist/scripts/texlive/tlmgr.pl b/Master/texmf-dist/scripts/texlive/tlmgr.pl
index d266ddea84a..e74eff61c44 100755
--- a/Master/texmf-dist/scripts/texlive/tlmgr.pl
+++ b/Master/texmf-dist/scripts/texlive/tlmgr.pl
@@ -86,9 +86,6 @@ BEGIN {
 
   # make Perl find our packages first:
   unshift (@INC, "$Master/tlpkg");
-  # add also tlpkg/TeXLive for copied modules like JSON which
-  # requests JSON::BackportPP
-  unshift (@INC, "$Master/tlpkg/TeXLive");
   unshift (@INC, "$Master/texmf-dist/scripts/texlive");
 }
 
@@ -581,19 +578,6 @@ for the full story.\n";
     tldie("$prg: Try --help if you need it.\n");
   }
 
-  if ($opts{'json'}) {
-    eval { require JSON; };
-    if ($@) {
-      # that didn't work out, give some usefull error message and stop
-      if ($^O =~ /^MSWin/i) {
-        require Win32;
-        my $msg = "Cannot load JSON, that should not happen as we ship it!\n(Error message: $@)\nStopping here.\n";
-        Win32::MsgBox($msg, 1|Win32::MB_ICONSTOP(), "Warning");
-      }
-      tldie("Cannot load JSON module, this should not happen, please report!\n");
-    }
-  }
-
   #
   # the main tree we will be working on
   $::maintree = $Master;
@@ -1859,7 +1843,7 @@ sub action_restore {
     if (keys %backups) {
       if ($opts{'json'}) {
         my @bla = map { report_backup_revdate($_, "json", %{$backups{$_}}) } keys %backups;
-        my $str = JSON::encode_json(\@bla);
+        my $str = TeXLive::TLUtils::encode_json(\@bla);
         print "$str\n";
       } else {
         print "Available backups:\n";
@@ -1877,7 +1861,7 @@ sub action_restore {
   if (!defined($rev)) {
     if ($opts{'json'}) {
       my @bla = report_backup_revdate($pkg, "json", %{$backups{$pkg}});
-      my $str = JSON::encode_json(\@bla);
+      my $str = TeXLive::TLUtils::encode_json(\@bla);
       print "$str\n";
     } else {
       print "Available backups for $pkg: ";
@@ -3673,7 +3657,6 @@ sub show_one_package {
 }
 
 sub show_one_package_json {
-  require JSON;
   my ($p) = @_;
   my @out;
   my $loctlp = $localtlpdb->get_package($p);
@@ -3691,8 +3674,8 @@ sub show_one_package_json {
   my $tlp = ($is_installed ? $loctlp : $remtlp);
   #my $tlp = ($is_available ? $remtlp : $loctlp);
   # add available, installed, lrev, rrev fields and remove revision field
-  my $str = $tlp->as_json(available => ($is_available ? $JSON::true : $JSON::false), 
-                          installed => ($is_installed ? $JSON::true : $JSON::false),
+  my $str = $tlp->as_json(available => ($is_available ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()), 
+                          installed => ($is_installed ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()),
                           lrev      => ($is_installed ? $loctlp->revision : 0),
                           rrev      => ($is_available ? $remtlp->revision : 0),
                           revision  => undef);
diff --git a/Master/tlpkg/TeXLive/TLPDB.pm b/Master/tlpkg/TeXLive/TLPDB.pm
index 9176a04e715..32015fa692d 100644
--- a/Master/tlpkg/TeXLive/TLPDB.pm
+++ b/Master/tlpkg/TeXLive/TLPDB.pm
@@ -479,7 +479,6 @@ the tag of the sub-database, and C<tlpdb> giving the JSON of the database.
 
 sub as_json {
   my $self = shift;
-  require JSON;
   my $ret = "{";
   if ($self->is_virtual) {
     my $firsttlpdb = 1;
@@ -508,7 +507,7 @@ sub _as_json {
     if ($TeXLive::TLConfig::TLPDBOptions{$k}[0] =~ m/^n/) {
       $opts->{$k} += 0 if (exists($opts->{$k}));
     } elsif ($TeXLive::TLConfig::TLPDBOptions{$k}[0] eq "b") {
-      $opts->{$k} = ($opts->{$k} ? $JSON::true : $JSON::false) if (exists($opts->{$k}));
+      $opts->{$k} = ($opts->{$k} ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()) if (exists($opts->{$k}));
     } elsif ($k eq "location") {
       if (exists($opts->{$k})) {
         my %foo = TeXLive::TLUtils::repository_to_array($opts->{$k});
@@ -520,27 +519,27 @@ sub _as_json {
     }
     # the last else is plain strings, nothing to do
   }
-  $ret .= JSON::encode_json($opts);
+  $ret .= TeXLive::TLUtils::encode_json($opts);
   $ret .= ',"settings":';
   my $sets = $self->settings;
   for my $k (keys %TeXLive::TLConfig::TLPDBSettings) {
     if ($TeXLive::TLConfig::TLPDBSettings{$k} eq "b") {
-      $sets->{$k} = ($sets->{$k} ? $JSON::true : $JSON::false) if (exists($sets->{$k}));
+      $sets->{$k} = ($sets->{$k} ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False()) if (exists($sets->{$k}));
     } elsif ($TeXLive::TLConfig::TLPDBSettings{$k} eq "available_architectures") {
       delete($sets->{$k});
       @{$sets->{$k}} = $self->available_architectures;
     }
     # else are strings
   }
-  $ret .= JSON::encode_json($sets);
+  $ret .= TeXLive::TLUtils::encode_json($sets);
   $ret .= ',"configs":';
   my %cfgs;
-  $cfgs{'container_split_src_files'} = ($self->config_src_container ? $JSON::true : $JSON::false);
-  $cfgs{'container_split_doc_files'} = ($self->config_doc_container ? $JSON::true : $JSON::false);
+  $cfgs{'container_split_src_files'} = ($self->config_src_container ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False());
+  $cfgs{'container_split_doc_files'} = ($self->config_doc_container ? TeXLive::TLUtils::True() : TeXLive::TLUtils::False());
   $cfgs{'container_format'} = $self->config_container_format;
   $cfgs{'release'} = $self->config_release;
   $cfgs{'minrelease'} = $self->config_minrelease;
-  $ret .= JSON::encode_json(\%cfgs);
+  $ret .= TeXLive::TLUtils::encode_json(\%cfgs);
   $ret .= ',"tlpkgs": [';
   my $first = 1;
   foreach (keys %{$self->{'tlps'}}) {
diff --git a/Master/tlpkg/TeXLive/TLPOBJ.pm b/Master/tlpkg/TeXLive/TLPOBJ.pm
index 8dadf1723fd..82eaf531ce4 100644
--- a/Master/tlpkg/TeXLive/TLPOBJ.pm
+++ b/Master/tlpkg/TeXLive/TLPOBJ.pm
@@ -423,8 +423,6 @@ sub writeout_simple {
 sub as_json {
   my $self = shift;
   my %addargs = @_;
-  require JSON;
-  #my $json = JSON::PP->new->utf8;
   my %foo = %{$self};
   # set the additional args
   for my $k (keys %addargs) {
@@ -445,9 +443,9 @@ sub as_json {
   # encode boolean as boolean flags
   if (exists($foo{'relocated'})) {
     if ($foo{'relocated'}) {
-      $foo{'relocated'} = $JSON::true;
+      $foo{'relocated'} = TeXLive::TLUtils::True();
     } else {
-      $foo{'relocated'} = $JSON::false;
+      $foo{'relocated'} = TeXLive::TLUtils::False();
     }
   }
   # adjust the docfiles entry to the specification in JSON-formats
@@ -469,11 +467,7 @@ sub as_json {
   $foo{'docfiles'} = [ @newdocf ];
   delete($foo{'docfiledata'});
   #
-  # my home-made solution is a bit faster then JSON::PP
-  # but we still prefer that one for security ;-)
-  # If JSON::XS is installed, that is the fastest.
-  #my $utf8_encoded_json_text = TeXLive::TLUtils::hash_to_json(\%foo);
-  my $utf8_encoded_json_text = JSON::encode_json(\%foo);
+  my $utf8_encoded_json_text = TeXLive::TLUtils::encode_json(\%foo);
   return $utf8_encoded_json_text;
 }
 
diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm
index 3be5b0eb697..54ed8dbac53 100644
--- a/Master/tlpkg/TeXLive/TLUtils.pm
+++ b/Master/tlpkg/TeXLive/TLUtils.pm
@@ -103,10 +103,9 @@ C<TeXLive::TLUtils> -- utilities used in TeX Live infrastructure
 
 =head2 JSON
 
-  TeXLive::TLUtils::simple_hash_to_json($hashref);
-  TeXLive::TLUtils::scalar_to_json($hashref);
-  TeXLive::TLUtils::hash_to_json($hashref);
-  TeXLive::TLUtils::array_to_json($hashref);
+  TeXLive::TLUtils::encode_json($ref);
+  TeXLive::TLUtils::True();
+  TeXLive::TLUtils::False();
 
 =head1 DESCRIPTION
 
@@ -195,7 +194,9 @@ BEGIN {
     &get_full_line
     &sort_archs
     &repository_to_array
-    &simple_hash_to_json
+    &encode_json
+    &True
+    &False
   );
   @EXPORT = qw(setup_programs download_file process_logging_options
                tldie tlwarn info log debug ddebug dddebug debug_hash
@@ -4164,20 +4165,145 @@ sub repository_to_array {
   return %r;
 }
 
-=item C<simple_hash_tpo_json($hashref)>
+=item C<encode_json($ref)>
 
-Returns the JSON representation of C<$hashref>. Only simple key/value
-hashes are supported, and all entries are treated as strings.
+Returns the JSON representation of the object C<$ref> is pointing at.
+This tries to load the C<JSON> Perl module, and uses it if available,
+otherwise falls back to module internal conversion.
+
+The used backend can be selected by setting the environment variable
+C<TL_JSONMODE> to either C<json> or C<texlive> (all other values are
+ignored). If C<json> is requested and the C<JSON> module cannot be loaded
+the program terminates.
 
 =cut
 
-sub simple_hash_to_json {
-  my $hr = shift;
-  return 
-    "{" . join (",", map { "\"$_\":\"" . $hr->{$_} . "\"" } keys(%$hr)) . "}"
+my $TLTrueValue = 1;
+my $TLFalseValue = 0;
+my $TLTrue = \$TLTrueValue;
+my $TLFalse = \$TLFalseValue;
+bless $TLTrue, 'TLBOOLEAN';
+bless $TLFalse, 'TLBOOLEAN';
+
+my $jsonmode = "";
+
+=item C<True()>
+=item C<False()>
+
+these two function must be used to get proper JSON C<true> and C<false> 
+in the output independent of the backend used.
+
+=cut
+
+sub True {
+  ensure_json_available();
+  if ($jsonmode eq "json") {
+    return($JSON::true);
+  } else {
+    return($TLTrue);
+  }
+}
+sub False {
+  ensure_json_available();
+  if ($jsonmode eq "json") {
+    return($JSON::false);
+  } else {
+    return($TLFalse);
+  }
+}
+
+sub ensure_json_available {
+  return if ($jsonmode);
+  # check the environment for mode to use:
+  # $ENV{'TL_JSONMODE'} = texlive | json
+  my $envdefined = 0;
+  if ($ENV{'TL_JSONMODE'}) {
+    $envdefined = 1;
+    if ($ENV{'TL_JSONMODE'} eq "texlive") {
+      $jsonmode = "texlive";
+      print STDERR "texlive json module used!\n";
+      return;
+    } elsif ($ENV{'TL_JSONMODE'} eq "json") {
+      # nothing to do
+    } else {
+      tlwarn("Unsupported mode \'$ENV{TL_JSONMODE}\' set in TL_JSONMODE, ignoring it!");
+      $envdefined = 0;
+    }
+  }
+  return if ($jsonmode); # was set to texlive
+  eval { require JSON; };
+  if ($@) {
+    # that didn't work out, use home-grown json
+    if ($envdefined) {
+      # environment asks for JSON but cannot be loaded, die!
+      tldie("env variable TL_JSONMODE request JSON module but cannot be load!\n");
+    }
+    $jsonmode = "texlive";
+    print STDERR "texlive json module used!\n";
+  } else {
+    $jsonmode = "json";
+    my $json = JSON->new;
+    print STDERR "JSON " . $json->backend . " used!\n";
+  }
+}
+
+sub encode_json {
+  my $val = shift;
+  ensure_json_available();
+  if ($jsonmode eq "json") {
+    my $utf8_encoded_json_text = JSON::encode_json($val);
+    return $utf8_encoded_json_text;
+  } else {
+    my $type = ref($val);
+    if ($type eq "") {
+      tldie("encode_json: accept only refs: $val");
+    } elsif ($type eq 'SCALAR') {
+      return(scalar_to_json($$val));
+    } elsif ($type eq 'ARRAY') {
+      return(array_to_json($val));
+    } elsif ($type eq 'HASH') {
+      return(hash_to_json($val));
+    } elsif ($type eq 'REF') {
+      return(encode_json($$val));
+    } elsif (Scalar::Util::blessed($val)) {
+      if ($type eq "TLBOOLEAN") {
+        return($$val ? "true" : "false");
+      } else {
+        tldie("encode_json: unsupported blessed object");
+      }
+    } else {
+      tldie("encode_json: unsupported format $type");
+    }
+  }
 }
 
 sub scalar_to_json {
+  sub looks_like_numeric {
+    # code from JSON/backportPP.pm
+    my $value = shift;
+    no warnings 'numeric';
+    # detect numbers
+    # string & "" -> ""
+    # number & "" -> 0 (with warning)
+    # nan and inf can detect as numbers, so check with * 0
+    return unless length((my $dummy = "") & $value);
+    return unless 0 + $value eq $value;
+    return 1 if $value * 0 == 0;
+    return -1; # inf/nan
+  }
+  my $val = shift;
+  if (defined($val)) {
+    if (looks_like_numeric($val)) {
+      return("$val");
+    } else {
+      return(string_to_json($val));
+    }
+  } else {
+    return("null");
+  }
+}
+
+sub string_to_json {
   my $val = shift;
   my %esc = (
     "\n" => '\n',
@@ -4190,59 +4316,23 @@ sub scalar_to_json {
     "\'" => '\\\'',
   );
   $val =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
-  return($val);
+  return("\"$val\"");
 }
 
 sub hash_to_json {
   my $hr = shift;
-  my $ret = "{";
-  my @keystr;
+  my @retvals;
   for my $k (keys(%$hr)) {
     my $val = $hr->{$k};
-    if (!$val) {
-      push @keystr, "\"$k\":null";
-    } elsif (ref($val) eq "") {
-      push @keystr, "\"$k\":\"" . scalar_to_json($val) . "\"";
-    } elsif (ref($val) eq 'SCALAR') {
-      push @keystr, "\"$k\":\"" . scalar_to_json($$val) . "\"";
-    } elsif (ref($val) eq 'ARRAY') {
-      push @keystr, "\"$k\":" . array_to_json($val);
-    } elsif (ref($val) eq 'HASH') {
-      push @keystr, "\"$k\":" . hash_to_json($val);
-    } elsif (Scalar::Util::blessed($val)) {
-      if (ref($val) eq "JSON::PP::Boolean") {
-        push @keystr, "\"$k\":" . ($val == $JSON::true ? "true" : "false");
-      } else {
-        die "Unsupported blessed object!";
-      }
-    } else {
-      die("Unsupported reference in hash_to_json: " . ref($val));
-    }
+    push @retvals, "\"$k\":" . encode_json(\$val);
   }
-  $ret .= join(",",@keystr) . "}";
+  my $ret = "{" . join(",", @retvals) . "}";
   return($ret);
 }
 
 sub array_to_json {
   my $hr = shift;
-  my $ret = "[";
-  my @keystr;
-  for my $val (@$hr) {
-    if (!$val) {
-      push @keystr, "null";
-    } elsif (ref($val) eq "") {
-      push @keystr, "\"" . scalar_to_json($val) . "\"";
-    } elsif (ref($val) eq 'SCALAR') {
-      push @keystr, "\"" . scalar_to_json($$val) . "\"";
-    } elsif (ref($val) eq 'ARRAY') {
-      push @keystr, array_to_json($val);
-    } elsif (ref($val) eq 'HASH') {
-      push @keystr, hash_to_json($val);
-    } else {
-      die("Unsupported reference in array_to_json");
-    }
-  }
-  $ret .= join(",",@keystr) . "]";
+  my $ret = "[" . join(",", map { encode_json(\$_) } @$hr) . "]";
   return($ret);
 }