jfmutil (9feb19)

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

1 files changed, 240 insertions, 41 deletions

diff --git a/Master/texmf-dist/scripts/jfmutil/jfmutil.pl b/Master/texmf-dist/scripts/jfmutil/jfmutil.pl
index 63835b85b69..3b4b5b76bc0 100755
--- a/Master/texmf-dist/scripts/jfmutil/jfmutil.pl
+++ b/Master/texmf-dist/scripts/jfmutil/jfmutil.pl
@@ -2,7 +2,7 @@
 #
 # This is file 'jfmutil.pl'.
 #
-# Copyright (c) 2018 Takayuki YATO (aka. "ZR")
+# Copyright (c) 2019 Takayuki YATO (aka. "ZR")
 #   GitHub:   https://github.com/zr-tex8r
 #   Twitter:  @zr_tex8r
 #
@@ -12,8 +12,8 @@ use strict;
 
 #------------------------------------------------- ZRTeXtor module
 package ZRTeXtor;
-our $VERSION = 1.004_01;
-our $mod_date = "2018/01/20";
+our $VERSION = 1.005_00;
+our $mod_date = "2018/01/21";
 use Encode qw(encode decode);
 
 # Here follows excerpt from ZRTeXtor.pm
@@ -2139,8 +2139,6 @@ sub vf_assign_type
                  $_, $sty, $stype->{$_}));
         $stype->{$_} = $sty;
       } elsif ($ty != 0) { # set type >0
-        ($_ <= 0xFFFF) or return error(
-         sprintf("code value out of range: char %04X", $_));
         (defined $type->{$_}) or return error(
          sprintf("type assignment (%s) to char out of codespace:" .
                  "char %04X",
@@ -2501,7 +2499,10 @@ sub jfm_form_postprocess
    ($fs[0] == 9 || $fs[0] == 11)) or return;
   $pct = $fs[3] * 4 + 28; $lct = $fs[1] * 4;
   $ct = substr($jfm, $pct, $lct); @fs = unpack('n*', $ct);
-  for ($k = 2; $k <= $#fs; $k += 2) { $fs[$k] = $map->{$fs[$k]}; }
+  for ($k = 2; $k <= $#fs; $k += 2) {
+    my $cc = $map->{$fs[$k]};
+    $fs[$k] = ($cc & 0xFFFF); $fs[$k+1] |= ($cc >> 16 << 8);
+  }
   $ct = pack('n*', @fs);
   return substr($jfm, 0, $pct) . $ct . substr($jfm, $pct + $lct);
 }
@@ -2517,7 +2518,8 @@ sub jfm_parse_preprocess
   $pct = $fs[3] * 4 + 28; $lct = $fs[1] * 4;
   $ct = substr($jfm, $pct, $lct); @fs = unpack('n*', $ct);
   for ($jc = 0x2121, $k = 2; $k <= $#fs; $k += 2) {
-    $map{$jc} = $fs[$k]; $fs[$k] = $jc;
+    $map{$jc} = ($fs[$k] | $fs[$k+1] >> 8 << 16);
+    $fs[$k] = $jc; $fs[$k+1] &= 0xFF;
     $jc = jfm_nextcode($jc) or return;
   }
   $ct = pack('n*', @fs);
@@ -2758,23 +2760,23 @@ package main;
     pl_parse pl_form pl_prefer_hex
     jcode_set
     kpse
-    vf_parse vf_form vf_parse_ex vf_form_ex
+    vf_parse vf_form vf_parse_ex vf_form_ex vf_strict
     jfm_use_uptex_tool jfm_parse jfm_form
   )) {
     *{$_} = *{"ZRTeXtor::".$_};
   }
 }
 
-#------------------------------------------------- jfmutil stuffs
-# Here follows excerpt from jfmutil.pl
+#------------------------------------------------- pxutil stuffs
+# Here follows excerpt from pxutil.pl
 #================================================= BEGIN
 use Encode qw(encode decode);
 my $prog_name = 'jfmutil';
-my $version = '1.1.0';
-my $mod_date = '2017/09/16';
+my $version = '1.2.1';
+my $mod_date = '2019/02/08';
 #use Data::Dump 'dump';
 #
-my ($sw_hex, $sw_uptool, $sw_noencout, $inenc, $exenc);
+my ($sw_hex, $sw_uptool, $sw_noencout, $inenc, $exenc, $sw_lenient);
 my ($proc_name, $infile, $in2file ,$outfile, $out2file);
 
 #### main procedure
@@ -2789,14 +2791,21 @@ my %procs = (
 );
 
 sub main {
-  my ($proc);
   if (defined textool_error()) { error(); }
-  if ((($proc_name) = $ARGV[0] =~ m/^:?(\w+)$/)
-      && defined($proc = $procs{$proc_name})) {
-    shift(@ARGV); $proc->();
-  } else {
+  local $_ = shift(@ARGV);
+  if (!defined $_) {
     show_usage();
-  }
+  } elsif (($proc_name) = m/^:?(\w+)$/) {
+    my $proc = $procs{$proc_name};
+    (defined $proc) or error("unknown subcommand name", $proc_name);
+    $proc->();
+  } elsif (m/^-/) {
+    if (m/^--?h(?:elp)?$/) {
+      show_usage();
+    } elsif (m/^-(?:V|-version)$/) {
+      show_version();
+    } else { error("unknown (or invalid usage of) option", $_); }
+  } else { error("invalid argument", $_); }
 }
 
 sub main_vf2zvp0 {
@@ -2863,10 +2872,14 @@ sub show_usage {
   print(usage_message());
   exit;
 }
+sub show_version {
+  print("$prog_name version $version\n");
+  exit;
+}
 sub usage_message {
   my ($v, $m);
   ($v, $m) = textool_version() or error();
-  return <<"END";
+  return <<"EOT1", <<"EOT2";
 This is $prog_name v$version <$mod_date> by 'ZR'.
 [ZRTeXtor library v$v <$m> by 'ZR']
 Usage: $prog_name vf2zvp0 [<options>] <in.vf> [<out.zvp0>]
@@ -2883,13 +2896,17 @@ Options:
        --hex      output charcode in 'H' form [default]
   -o / --octal    output charcode in 'O' form
   --uptool        use upTeX tools (uppltotf etc.)
+  --lenient       ignore non-fatal error on VFs
   The following options affect interpretation of 'K' form.
   --kanji=ENC     set source encoding: ENC=jis/sjis/euc/utf8/none
   --kanji-internal=ENC set internal encoding: ENC=jis/unicode/none
   -j / --jis      == --kanji=jis --kanji-internal=jis
   -u / --unicode  == --kanji=utf8 --kanji-internal=unicode
   -E / --no-encoding == --kanji=none --kanji-internal=none
-END
+EOT1
+  -h / --help     show this help message and exit
+  -V / --version  show version
+EOT2
 }
 
 #### command-line options
@@ -2901,12 +2918,16 @@ sub read_option {
     $opt = shift(@ARGV);
     if ($opt =~ m/--?h(elp)?/) {
       show_usage();
+    } elsif ($opt =~ m/-(?:V|-version)?/) {
+      show_version();
     } elsif ($opt eq '--hex') {
       $sw_hex = 1;
     } elsif ($opt eq '--octal' || $opt eq '-o') {
       $sw_hex = 0;
     } elsif ($opt eq '--uptool') {
       $sw_uptool = 1;
+    } elsif ($opt eq '--lenient') {
+      $sw_lenient = 1;
     } elsif ($opt eq '--no-encoding' || $opt eq '-E') {
       ($exenc, $inenc) = ('none', 'none');
     } elsif ($opt eq '--jis' || $opt eq '-j') {
@@ -2927,6 +2948,7 @@ sub read_option {
     or error("unknown internal kanji code: $inenc");
   #if ($inenc eq 'unicode') { $sw_uptool = 1; }
   if ($sw_hex) { pl_prefer_hex(1); }
+  if ($sw_lenient) { vf_strict(0); }
   (0 <= $#ARGV && $#ARGV <= 1)
     or error("wrong number of arguments");
   if ($proc_name eq 'vf2zvp0') {
@@ -2994,15 +3016,16 @@ sub error {
 *usage_message_org = \&usage_message;
 
 *usage_message = sub {
-  local $_ = usage_message_org();
+  local ($_) = usage_message_org();
   my ($part1, $part2) = (<<"EOT1", <<"EOT2");
 
 * ZVP Conversion
 EOT1
 
 * VF Replication
-Usage: $prog_name vfcopy [<options>] <in.vf> <out.zvf> <out_base.tfm>...
+Usage: $prog_name vfcopy [<options>] <in.vf> <out.vf> <out_base.tfm>...
        $prog_name vfinfo [<options>] <in.vf>
+       $prog_name jodel [<options>] <in.vf> <prefix>
 Arguments:
   <in.vf>       input virtual font name
     N.B. Input TFM/VF files are searched by Kpathsea.
@@ -3011,38 +3034,58 @@ Arguments:
                 each entry replaces a font mapping in the input font in
                 the given order, so the exactly same number of entries
                 must be given as font mappings
+  <prefix>      prefix of output font names (only for jodel)
 Options:
-  -z / --zero     change first fontmap id in vf to zero
+  -z / --zero   change first fontmap id in vf to zero
+  --uptex       assume input font to be for upTeX (only for jodel)
+  --unicode     generate VF for 'direct-unicode' mode imposed by pxufont
+                package; this option is supported only for upTeX fonts and
+                thus implies '--uptex' (only for jodel)
+
+* Common Options
+  -h / --help     show this help message and exit
+  -V / --version  show version
 EOT2
-  s/(Usage:)/$part1$1/; s/$/$part2/;
+  s/(Usage:)/$part1$1/; s/\z/$part2/;
   return $_;
 };
 
 %procs = (%procs,
   vfinfo  => \&main_vfinfo,
   vfcopy  => \&main_vfcopy,
+  jodel   => \&main_jodel,
 );
 
 sub main_vfinfo {
-  PXCopyFont::read_option(1);
+  PXCopyFont::read_option('vfinfo');
   PXCopyFont::info_vf();
 }
 
 sub main_vfcopy {
-  PXCopyFont::read_option(0);
+  PXCopyFont::read_option('vfcopy');
   PXCopyFont::copy_vf();
 }
 
+sub main_jodel {
+  PXCopyFont::read_option('jodel');
+  PXCopyFont::jodel();
+}
+
 #------------------------------------------------- pxcopyfont stuffs
 package PXCopyFont;
 
-*info = *main::show_info;
 *error = *main::error;
+*read_whole_file = *main::read_whole_file;
+*write_whole_file = *main::write_whole_file;
 
-our ($src_main, $dst_main, @dst_base, $op_zero);
+our ($src_main, $dst_main, @dst_base, $op_zero, $op_uptex, $op_quiet);
+
+sub info {
+  ($op_quiet) or main::show_info(@_);
+}
 
 sub copy_vf {
-  local $_ = main::read_whole_file(main::kpse("$src_main.vf"), 1) or error();
+  local $_ = read_whole_file(main::kpse("$src_main.vf"), 1) or error();
   my $vfc = parse_vf($_);
   my ($nb, $nb1) = (scalar(@{$vfc->[0]}), scalar(@dst_base));
   info("number of base TFMs in '$src_main'", $nb);
@@ -3051,14 +3094,14 @@ sub copy_vf {
   } elsif ($nb != $nb1) {
     error("wrong number of base TFMs given", $nb1);
   }
-  main::write_whole_file("$dst_main.vf", form_vf($vfc), 1) or error();
-  main::write_whole_file("$dst_main.tfm",
-      main::read_whole_file(main::kpse("$src_main.tfm"), 1), 1) or error();
+  write_whole_file("$dst_main.vf", form_vf($vfc), 1) or error();
+  write_whole_file("$dst_main.tfm",
+      read_whole_file(main::kpse("$src_main.tfm"), 1), 1) or error();
   foreach my $k (0 .. $#dst_base) {
     my $sfn = $vfc->[0][$k][1]; my $dfn = $dst_base[$k];
     ($sfn ne $dfn) or next;
-    main::write_whole_file("$dfn.tfm",
-      main::read_whole_file(main::kpse("$sfn.tfm"), 1), 1) or error();
+    write_whole_file("$dfn.tfm",
+      read_whole_file(main::kpse("$sfn.tfm"), 1), 1) or error();
   }
 }
 
@@ -3085,7 +3128,7 @@ sub parse_vf {
 }
 
 sub info_vf {
-  local $_ = main::read_whole_file(main::kpse("$src_main.vf"), 1) or error();
+  local $_ = read_whole_file(main::kpse("$src_main.vf"), 1) or error();
   my $vfc = parse_vf($_);
   foreach (@{$vfc->[0]}) {
     printf("%d=%s\n", $_->[2], $_->[1]);
@@ -3112,14 +3155,22 @@ sub form_vf {
 }
 
 sub read_option {
-  my ($op_info) = @_;
-  $op_zero = 0;
+  my ($proc) = @_;
+  $op_zero = 0; $op_uptex = 0; $op_quiet = 0;
   while ($ARGV[0] =~ m/^-/) {
     my $opt = shift(@ARGV);
     if ($opt =~ m/--?h(elp)?/) {
-      show_usage();
+      main::show_usage();
+    } elsif ($opt =~ m/-(?:V|-version)?/) {
+      main::show_version();
     } elsif ($opt eq '-z' || $opt eq '--zero') {
       $op_zero = 1;
+    } elsif ($opt eq '--uptex') {
+      $op_uptex = 1;
+    } elsif ($opt eq '--unicode') {
+      $op_uptex = 2;
+    } elsif ($opt eq '--quiet') { # undocumented
+      $op_quiet = 2;
     } else {
       error("invalid option", $opt);
     }
@@ -3127,15 +3178,163 @@ sub read_option {
   ($src_main, $dst_main, @dst_base) = @ARGV;
   $src_main =~ s/\.vf$//;
   (defined $src_main) or error("no argument given");
-  (!!$op_info == (!defined $dst_main))
+  (($proc eq 'vfinfo') ? (!defined $dst_main) :
+   ($proc eq 'vfcopy') ? (defined $dst_main) :
+   ($proc eq 'jodel') ? (defined $dst_main && $#dst_base == -1) : 1)
     or error("wrong number of arguments");
-  if (defined $dst_main) {
+  if ($proc eq 'vfcopy') {
     $dst_main =~ s/\.vf$//;
     foreach (@dst_base) { s/\.tfm$//; }
     ($src_main ne $dst_main)
       or error("output vf name is same as input");
     (@dst_base) or error("no base tfm name given");
   }
+  if ($proc eq 'jodel') {
+    (!$op_zero) or error("invalid in jodel command", "-z/--zero");
+    ($dst_main =~ m/^\w+$/)
+      or error("bad characters in prefix", $dst_main);
+    (length($dst_main) <= 100) or error("prefix too long", $dst_main);
+  } else {
+    (!$op_uptex) or error("invalid except in jodel command", "--uptex");
+  }
+}
+
+#------------------------------- jodel
+
+our %standard_vf = (
+  'rml'             => [1, 'hXXXN-h'],
+  'rmlv'            => [1, 'hXXXN-v'],
+  'uprml-h'         => [2, 'uphXXXN-h'],
+  'uprml-hq'        => [2, 'jodhXXX-hq'],
+  'uprml-v'         => [2, 'uphXXXN-v'],
+  'gbm'             => [1, 'hXXXN-h'],
+  'gbmv'            => [1, 'hXXXN-v'],
+  'upgbm-h'         => [2, 'uphXXXN-h'],
+  'upgbm-hq'        => [2, 'jodhXXX-hq'],
+  'upgbm-v'         => [2, 'uphXXXN-v'],
+);
+our @shape = (
+  'minl', 'minr', 'minb', 'gothr', 'gothb', 'gotheb', 'mgothr'
+);
+
+our ($jengine, $jtate, @jvfname, %jvfidx, %jvfparsed);
+
+sub jodel {
+  jodel_analyze();
+  if ($op_uptex == 2) {
+    ($jengine == 2)
+      or error("direct-unicode mode is only supported for pure upTeX fonts");
+    foreach (values %standard_vf) {
+      ($_->[1] =~ m/^jod/) and $_->[1] =~ s/jod/zu-jod/;
+    }
+  }
+  foreach (@shape) {
+    jodel_generate($_, '');
+    jodel_generate($_, 'n');
+  }
+}
+
+sub jodel_vf_name {
+  my ($shp, $nn, $idx) = @_;
+  my $zu = ($op_uptex == 2) ? 'zu-' : '';
+  my $i = ($idx > 0) ? "$idx" : '';
+  my $up = (jodel_for_uptex()) ? 'up' : '';
+  my $hv = ($jtate) ? 'v' : 'h';
+  return "$zu$dst_main-$i-${up}nml$shp$nn-$hv";
+}
+sub jodel_tfm_name {
+  my ($shp, $nn, $nam) = @_;
+  $nam =~ s/XXX/\Q$shp\E/; $nam =~ s/N/\Q$nn\E/;
+  return $nam;
+}
+sub jodel_for_uptex {
+  return ($jengine == 2 || ($jengine == 3 && $op_uptex));
+}
+
+{
+  my (%jkpse);
+  sub jodel_kpse {
+    my ($in) = @_;
+    if (exists $jkpse{$in}) { return $jkpse{$in}; }
+    my $out = main::kpse($in); $jkpse{$in} = $out;
+    return $out;
+  }
+}
+
+sub jodel_clone {
+  my ($val) = @_;
+  if (ref($val) eq '') {
+    return $val;
+  } elsif (ref($val) eq 'ARRAY') {
+    return [ map { jodel_clone($_) } (@$val) ];
+  } else { error("OOPS", 98, ref($val)); }
+}
+
+sub jodel_analyze {
+  local ($_);
+  info("**** Analyze VF '$src_main'");
+  $_ = read_whole_file(jodel_kpse("$src_main.tfm"), 1) or error();
+  $jtate = (unpack('n', $_) == 9);
+  info("direction", ($jtate) ? 'tate' : 'yoko');
+  @jvfname = ($src_main); $jengine = 0;
+  info("base TFMs", "");
+  for (my $i = 0; $i <= $#jvfname; $i++) {
+    my $nvf = $jvfname[$i];
+    $_ = read_whole_file(jodel_kpse("$nvf.vf"), 1)
+      or error(($i > 0) ? ("non-standard raw TFM", $nvf) : ());
+    $_ = parse_vf($_) or error();
+    $jvfidx{$nvf} = $i; $jvfparsed{$nvf} = $_;
+    my @lst = map { $_->[1] } @{$_->[0]};
+    info("  $nvf -> @lst");
+    foreach (@lst) {
+      if (exists $standard_vf{$_}) {
+        $jengine |= $standard_vf{$_}[0];
+        next;
+      }
+      (exists $jvfidx{$_}) and next;
+      push(@jvfname, $_);
+    }
+  }
+  my $eng = (jodel_for_uptex()) ? 'upTeX' : 'pTeX';
+  ($jengine == 3) and $eng .= ' (mixed)';
+  info("engine", $eng);
+}
+
+sub jodel_generate {
+  my ($shp, $nn) = @_; local ($_);
+  my $dnvf0 = jodel_vf_name($shp, $nn, 0);
+  info("*** Generate VF '$dnvf0'");
+  foreach my $i (0 .. $#jvfname) {
+    my $snvf = $jvfname[$i];
+    my $dnvf = jodel_vf_name($shp, $nn, $i);
+    my $vfc = jodel_clone($jvfparsed{$snvf});
+    my (@slst, @dlst);
+    foreach my $e (@{$vfc->[0]}) {
+      my $sbas = $e->[1]; my $dbas;
+      if (exists $standard_vf{$sbas}) {
+        $dbas = jodel_tfm_name($shp, $nn, $standard_vf{$sbas}[1]);
+      } elsif (exists $jvfidx{$sbas}) {
+        $dbas = jodel_vf_name($shp, $nn, $jvfidx{$sbas});
+      } else { error("OOPS", 95, "$sbas"); }
+      push(@slst, $sbas); push(@dlst, $dbas);
+      $e->[1] = $dbas;
+    }
+    info("from", "$snvf -> @slst");
+    info("  to", "$dnvf -> @dlst");
+    write_whole_file("$dnvf.vf", jodel_form_vf($vfc), 1) or error();
+    write_whole_file("$dnvf.tfm",
+        read_whole_file(jodel_kpse("$snvf.tfm"), 1), 1) or error();
+  }
+}
+
+sub jodel_form_vf {
+  my ($vfc) = @_; my (@lst);
+  foreach my $k (0 .. $#{$vfc->[0]}) {
+    my $t = $vfc->[0][$k]; my $dfn = $t->[1];
+    push(@lst, $t->[0], "\0" . chr(length($dfn)), $dfn);
+  }
+  my $tfm = join('', $vfc->[1], @lst, $vfc->[2]);
+  return $tfm . ("\xf8" x (4 - length($tfm) % 4));
 }
 
 #------------------------------------------------- go to main