From 4f8cc28897359bc2d56445dd0736754f8853edae Mon Sep 17 00:00:00 2001 From: Karl Berry Date: Sat, 9 Feb 2019 22:18:30 +0000 Subject: jfmutil (9feb19) git-svn-id: svn://tug.org/texlive/trunk@49986 c570f23f-e606-0410-a88d-b1316a301751 --- .../texk/texlive/linked_scripts/jfmutil/jfmutil.pl | 281 ++++++++++++++++++--- 1 file changed, 240 insertions(+), 41 deletions(-) (limited to 'Build') diff --git a/Build/source/texk/texlive/linked_scripts/jfmutil/jfmutil.pl b/Build/source/texk/texlive/linked_scripts/jfmutil/jfmutil.pl index 63835b85b69..3b4b5b76bc0 100755 --- a/Build/source/texk/texlive/linked_scripts/jfmutil/jfmutil.pl +++ b/Build/source/texk/texlive/linked_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 [] [] @@ -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 [] ... +Usage: $prog_name vfcopy [] ... $prog_name vfinfo [] + $prog_name jodel [] Arguments: 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 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 -- cgit v1.2.3