summaryrefslogtreecommitdiff
path: root/fonts/utilities/cjk-gs-integrate/cjk-gs-integrate.pl
diff options
context:
space:
mode:
Diffstat (limited to 'fonts/utilities/cjk-gs-integrate/cjk-gs-integrate.pl')
-rwxr-xr-xfonts/utilities/cjk-gs-integrate/cjk-gs-integrate.pl619
1 files changed, 346 insertions, 273 deletions
diff --git a/fonts/utilities/cjk-gs-integrate/cjk-gs-integrate.pl b/fonts/utilities/cjk-gs-integrate/cjk-gs-integrate.pl
index 270600e38f..68ea6e6198 100755
--- a/fonts/utilities/cjk-gs-integrate/cjk-gs-integrate.pl
+++ b/fonts/utilities/cjk-gs-integrate/cjk-gs-integrate.pl
@@ -6,6 +6,7 @@
# Copyright 2016-2020 by Japanese TeX Development Community
#
# This work is based on research and work by (in alphabetical order)
+# Masamichi Hosoda
# Yusuke Kuroki
# Yusuke Terada
# Bruno Voisin
@@ -31,30 +32,37 @@
#
# Note that symlink names should be consistent with ptex-fontmaps!
-$^W = 1;
use Getopt::Long qw(:config no_autoabbrev ignore_case_always);
use File::Basename;
use File::Path qw(make_path);
use Cwd 'abs_path';
use strict;
+use warnings;
+use utf8;
+use feature 'state';
+use Encode;
+use Encode::Alias;
-(my $prg = basename($0)) =~ s/\.pl$//;
-my $version = '20200307.0';
+my $debug_msg_before_init;
+init_encode_locale ();
+
+binmode (STDIN, ':encoding(console_in)');
+binmode (STDOUT, ':encoding(console_out)');
+binmode (STDERR, ':encoding(console_out)');
+
+@ARGV = map{ decode('locale', $_) }@ARGV;
+
+(my $prg = basename(decode('locale', $0))) =~ s/\.pl$//;
+my $version = '20201206.0';
if (win32()) {
- # conversion between internal (utf-8) and console (cp932):
- # multibyte characters should be encoded in cp932 at least during
- # * kpathsea file search
- # * abs_path existence test
- # * input/output on console
- # * batch file output
- # routines. make sure all of these should be restricted to win32 mode!
- # TODO: what to do with $opt_fontdef, @opt_aliases and $opt_filelist,
- # with regard to encodings?
- use utf8;
- use Encode;
# some perl functions (symlink, -l test) does not work
print_warning("Sorry, we have only partial support for Windows!\n");
+
+ require Win32::API;
+ Win32::API->import ();
+ require File::Compare;
+ File::Compare->import ();
}
# The followings are installed by ptex-fontmaps (texjporg):
@@ -272,10 +280,6 @@ my $akotfps_pathpart = "dvips/ps2otfps";
my $akotfps_datafilename = "psnames-for-otf";
my $akotfps_datacontent = '';
-# if windows, we might create batch file for links
-my $winbatch = "makefontlinks.bat";
-my $winbatch_content = '';
-
# dump output for data file (for easy editing for users)
my $dump_datafile = "$prg-data.dat";
@@ -335,6 +339,10 @@ if (! GetOptions(
die "Try \"$0 --help\" for more information.\n";
}
+if ($debug_msg_before_init) {
+ print_debug ($debug_msg_before_init);
+}
+
sub win32 { return ($^O=~/^MSWin(32|64)$/i); }
sub macosx { return ($^O=~/^darwin$/i); }
my $nul = (win32() ? 'nul' : '/dev/null') ;
@@ -356,12 +364,15 @@ if (system("kpsewhich --version >$nul 2>&1 <$nul" ) != 0) {
if ($opt_debug >= 2) {
require Data::Dumper;
+ no warnings qw(once);
$Data::Dumper::Indent = 1;
}
my $zrlistttc = kpse_miscfont("zrlistttc.lua");
my $zrlistttc_available;
-chomp(my $zrlistttc_help = `texlua $zrlistttc 2>$nul`);
+my $cmdl = "texlua $zrlistttc 2>$nul";
+$cmdl = encode('locale', $cmdl);
+chomp(my $zrlistttc_help = `$cmdl`);
if ($?) {
if ($opt_strictpsname) {
print_error("The script 'zrlistttc.lua' not found, cannot proceed!\n");
@@ -385,7 +396,7 @@ if (macosx()) {
$macos_ver_major =~ s/^(\d+)\.(\d+).*/$1/;
my $macos_ver_minor = $macos_ver;
$macos_ver_minor =~ s/^(\d+)\.(\d+).*/$2/;
- if ($macos_ver_major==10 && $macos_ver_minor>=8) {
+ if ($macos_ver_major>=11 || ($macos_ver_major==10 && $macos_ver_minor>=8)) {
if (!$opt_cleanup && !$opt_fontdef && !@opt_fontdef_add) { # if built-in only
print_warning("Our built-in database does not support recent\n");
print_warning("versions of Mac OS (10.8 Mountain Lion or later)!\n");
@@ -402,7 +413,11 @@ if (defined($opt_texmflink)) {
if ($opt_texmflink eq '') {
# option was passed but didn't receive a value
# -> use TEXMFLOCAL
- chomp($foo = `kpsewhich -var-value=TEXMFLOCAL`);
+ $foo = `kpsewhich -var-value=TEXMFLOCAL`;
+ # We assume that the output of kpsewhich is
+ # the same as perl's locale (or active code page).
+ decode('locale', $foo);
+ chomp($foo);
} else {
# option was passed with an argument
# -> use it
@@ -417,7 +432,11 @@ if (defined($opt_akotfps)) {
if (defined($opt_texmflink)) {
$foo = $opt_texmflink;
} else {
- chomp($foo = `kpsewhich -var-value=TEXMFLOCAL`);
+ $foo = `kpsewhich -var-value=TEXMFLOCAL`;
+ # We assume that the output of kpsewhich is
+ # the same as perl's locale (or active code page).
+ decode('locale', $foo);
+ chomp($foo);
}
} else {
$foo = $opt_akotfps;
@@ -426,26 +445,10 @@ if (defined($opt_akotfps)) {
}
if (defined($opt_winbatch)) {
- if ($opt_winbatch ne '') {
- $winbatch = $opt_winbatch;
- }
- if (win32()) {
- $opt_winbatch = 1;
- unlink $winbatch if (-f $winbatch);
- } else {
- print_warning("ignoring --winbatch option due to non-Windows\n");
- $opt_winbatch = 0;
- }
-} else {
- $opt_winbatch = 0;
+ print_warning("ignoring --winbatch option due to being obsolete\n");
}
if ($opt_hardlink) {
- if (win32()) {
- $opt_hardlink = 1;
- } else {
- print_warning("ignoring --hardlink option due to non-Windows\n");
- $opt_hardlink = 0;
- }
+ print_warning("ignoring --hardlink option due to being obsolete\n");
}
if (defined($opt_dump_data)) {
@@ -453,7 +456,8 @@ if (defined($opt_dump_data)) {
$dump_datafile = $opt_dump_data;
}
$opt_dump_data = 1;
- unlink $dump_datafile if (-f $dump_datafile);
+ unlink encode('locale_fs', $dump_datafile)
+ if (-f encode('locale_fs', $dump_datafile));
} else {
$opt_dump_data = 0;
}
@@ -497,7 +501,7 @@ sub main {
if ($opt_dump_data) {
# with --dump-data, dump only effective database and exit
dump_font_database();
- if (-f $dump_datafile) {
+ if (-f encode('locale_fs', $dump_datafile)) {
print_info("*** Data dumped to $dump_datafile ***\n");
exit(0);
} else {
@@ -549,8 +553,8 @@ sub main {
$opt_output = $gsres;
}
}
- if (! -d $opt_output) {
- $dry_run || mkdir($opt_output) ||
+ if (! -d encode('locale_fs', $opt_output)) {
+ $dry_run || mkdir(encode('locale_fs', $opt_output)) ||
die("Cannot create directory $opt_output: $!");
}
if ($opt_cleanup) {
@@ -570,7 +574,6 @@ sub main {
print_info(($opt_remove ? "removing" : "generating") . " links, snippets and cidfmap.local for non-CID fonts ...\n");
do_nonotf_fonts();
}
- write_winbatch() if $opt_winbatch;
}
print_info(($opt_remove ? "removing" : "generating") . " snippets and cidfmap.aliases for font aliases ...\n");
do_aliases();
@@ -581,15 +584,6 @@ sub main {
system("mktexlsr");
}
print_info("finished\n");
- if ($opt_winbatch) {
- if (-f $winbatch) {
- print_info("*** Batch file $winbatch created ***\n");
- print_info("*** to complete, run it as administrator privilege.***\n");
- } else {
- print_error("Failed to create $winbatch!\n");
- exit(1);
- }
- }
}
sub do_all_fonts {
@@ -613,7 +607,8 @@ sub do_all_fonts {
# due to previous bugs
for my $class (%encode_list) {
for my $enc (@{$encode_list{$class}}) {
- unlink "$fontdest/$k-$enc" if (-f "$fontdest/$k-$enc");
+ unlink encode('locale_fs', "$fontdest/$k-$enc")
+ if (-f encode('locale_fs', "$fontdest/$k-$enc"));
}
}
#
@@ -646,8 +641,8 @@ sub do_all_fonts {
}
update_master_cidfmap('cidfmap.local');
# we are in cleanup mode, also remove cidfmap.local itself
- if (-f "$opt_output/$cidfmap_local_pathpart") {
- unlink "$opt_output/$cidfmap_local_pathpart";
+ if (-f encode('locale_fs', "$opt_output/$cidfmap_local_pathpart")) {
+ unlink encode('locale_fs', "$opt_output/$cidfmap_local_pathpart");
}
}
@@ -699,11 +694,13 @@ sub do_nonotf_fonts {
}
return if $dry_run;
if ($outp) {
- if (! -d "$opt_output/Init") {
- mkdir("$opt_output/Init") ||
+ if (! -d encode('locale_fs', "$opt_output/Init")) {
+ mkdir(encode('locale_fs', "$opt_output/Init")) ||
die("Cannot create directory $opt_output/Init: $!");
}
- open(FOO, ">$opt_output/$cidfmap_local_pathpart") ||
+ # It seems that tlgs can handle UTF-8 TTF filename in cidfmap.local.
+ open(FOO, ">:encoding(UTF-8)",
+ encode('locale_fs', "$opt_output/$cidfmap_local_pathpart")) ||
die("Cannot open $opt_output/$cidfmap_local_pathpart: $!");
print FOO $outp;
close(FOO);
@@ -775,8 +772,10 @@ sub do_aliases {
}
# special case for native CID fonts in ancient days
# if not readable, add aliases for substitution
- push @jal, "/HeiseiMin-W3 /Ryumin-Light ;" if (! -r "$ciddest/HeiseiMin-W3");
- push @jal, "/HeiseiKakuGo-W5 /GothicBBB-Medium ;" if (! -r "$ciddest/HeiseiKakuGo-W5");
+ push @jal, "/HeiseiMin-W3 /Ryumin-Light ;"
+ if (! -r encode('locale_fs', "$ciddest/HeiseiMin-W3"));
+ push @jal, "/HeiseiKakuGo-W5 /GothicBBB-Medium ;"
+ if (! -r encode('locale_fs', "$ciddest/HeiseiKakuGo-W5"));
#
$outp .= "\n% Japanese fonts\n" . join("\n", @jal) . "\n" if @jal;
$outp .= "\n% Korean fonts\n" . join("\n", @kal) . "\n" if @kal;
@@ -786,19 +785,21 @@ sub do_aliases {
#
return if $dry_run;
if ($outp && !$opt_remove) {
- if (! -d "$opt_output/Init") {
- mkdir("$opt_output/Init") ||
+ if (! -d encode('locale_fs', "$opt_output/Init")) {
+ mkdir(encode('locale_fs', "$opt_output/Init")) ||
die("Cannot create directory $opt_output/Init: $!");
}
- open(FOO, ">$opt_output/$cidfmap_aliases_pathpart") ||
+ open(FOO, ">:encoding(UTF-8)",
+ encode('locale_fs', "$opt_output/$cidfmap_aliases_pathpart")) ||
die("Cannot open $opt_output/$cidfmap_aliases_pathpart: $!");
print FOO $outp;
close(FOO);
}
update_master_cidfmap('cidfmap.aliases');
# if we are in cleanup mode, also remove cidfmap.aliases itself
- if (-f "$opt_output/$cidfmap_aliases_pathpart") {
- unlink "$opt_output/$cidfmap_aliases_pathpart" if $opt_cleanup;
+ if (-f encode('locale_fs', "$opt_output/$cidfmap_aliases_pathpart")) {
+ unlink encode('locale_fs', "$opt_output/$cidfmap_aliases_pathpart")
+ if $opt_cleanup;
}
}
@@ -815,11 +816,13 @@ sub do_cmaps {
# by others or distributed by gs itself
for my $class (%encode_list) {
for my $enc (@{$encode_list{$class}}) {
- if (-l "$cmapdest/$enc") {
- my $linkt = readlink("$cmapdest/$enc");
+ if (-l encode('locale_fs', "$cmapdest/$enc")) {
+ my $linkt = decode('locale_fs',
+ readlink(encode('locale_fs',
+ "$cmapdest/$enc")));
if ($linkt) {
if ($linkt eq search_cmap($enc)) {
- unlink("$cmapdest/$enc");
+ unlink(encode('locale_fs', "$cmapdest/$enc"));
}
}
}
@@ -828,7 +831,7 @@ sub do_cmaps {
return;
}
# add mode
- if (! -d "$cmapdest") {
+ if (! -d encode('locale_fs', "$cmapdest")) {
print_debug("Creating directory $cmapdest ...\n");
make_dir("$cmapdest", "cannot create CMap directory");
}
@@ -838,7 +841,7 @@ sub do_cmaps {
next if (!$fontdb{$1}{'available'});
}
for my $enc (@{$encode_list{$class}}) {
- if (! -f "$cmapdest/$enc") {
+ if (! -f encode('locale_fs', "$cmapdest/$enc")) {
print_debug("CMap $enc is not found in gs resource directory\n");
my $dest = search_cmap($enc);
if ($dest) {
@@ -858,7 +861,14 @@ sub search_cmap {
my ($cmap) = @_;
# search CMap with kpsewhich and cache
if (! exists $cmap_cache{$cmap}) {
- chomp($cmap_cache{$cmap} = `kpsewhich -format=cmap $cmap`);
+ my $cmdl = "kpsewhich -format=cmap $cmap";
+ $cmdl = encode('locale', $cmdl);
+ $cmap_cache{$cmap} = `$cmdl`;
+ # We assume that the output of kpsewhich is
+ # the same as perl's locale (or active code page).
+ $cmap_cache{$cmap} = decode('locale', $cmap_cache{$cmap});
+ chomp($cmap_cache{$cmap});
+ $cmap_cache{$cmap} =~ s/[\r\n]+\z//; # perl's chomp() on git-bash cannot strip CR of CRLF ??
}
return $cmap_cache{$cmap};
}
@@ -876,8 +886,8 @@ sub update_master_cidfmap {
my $cidfmap_master = "$opt_output/$cidfmap_pathpart";
print_info(sprintf("%s $add %s cidfmap file ...\n",
($opt_remove ? "removing" : "adding"), ($opt_remove ? "from" : "to")));
- if (-r $cidfmap_master) {
- open(FOO, "<", $cidfmap_master) ||
+ if (-r encode('locale_fs', $cidfmap_master)) {
+ open(FOO, "<:encoding(UTF-8)", encode('locale_fs', $cidfmap_master)) ||
die("Cannot open $cidfmap_master for reading: $!");
my $found = 0;
my $found_tl = 0;
@@ -916,7 +926,7 @@ sub update_master_cidfmap {
if ($opt_remove) {
if ($found || $found_tl) {
return if $dry_run;
- open(FOO, ">", $cidfmap_master) ||
+ open(FOO, ">:encoding(UTF-8)", encode('locale_fs', $cidfmap_master)) ||
die("Cannot clean up $cidfmap_master: $!");
print FOO $newmaster;
close FOO;
@@ -926,7 +936,7 @@ sub update_master_cidfmap {
print_info("$add already loaded in $cidfmap_master, no changes\n");
} else {
return if $dry_run;
- open(FOO, ">", $cidfmap_master) ||
+ open(FOO, ">:encoding(UTF-8)", encode('locale_fs', $cidfmap_master)) ||
die("Cannot open $cidfmap_master for appending: $!");
print FOO $newmaster;
print FOO "($add) .runlibfile\n";
@@ -936,7 +946,7 @@ sub update_master_cidfmap {
} else {
return if $dry_run;
return if $opt_remove;
- open(FOO, ">", $cidfmap_master) ||
+ open(FOO, ">:encoding(UTF-8)", encode('locale_fs', $cidfmap_master)) ||
die("Cannot open $cidfmap_master for writing: $!");
print FOO "($add) .runlibfile\n";
close(FOO);
@@ -987,10 +997,11 @@ sub generate_font_snippet {
}
for my $enc (@{$encode_list{$c}}) {
if ($opt_remove) {
- unlink "$fd/$n-$enc" if (-f "$fd/$n-$enc");
+ unlink encode('locale_fs', "$fd/$n-$enc")
+ if (-f encode('locale_fs', "$fd/$n-$enc"));
next;
}
- open(FOO, ">$fd/$n-$enc") ||
+ open(FOO, ">:encoding(UTF-8)", encode('locale_fs', "$fd/$n-$enc")) ||
die("cannot open $fd/$n-$enc for writing: $!");
print FOO "%!PS-Adobe-3.0 Resource-Font
%%DocumentNeededResources: $enc (CMap)
@@ -1053,16 +1064,16 @@ sub link_font {
}
my $target = "$cd/$n";
my $do_unlink = 0;
- if (-l $target) {
+ if (-l encode('locale_fs', $target)) {
if ($opt_cleanup) {
$do_unlink = 1;
} else {
- my $linkt = readlink($target);
+ my $linkt = decode('locale_fs', readlink(encode('locale_fs', $target)));
if ($linkt) {
if ($linkt eq $f) {
# case 1: exists, link, targets agree
$do_unlink = 1;
- } elsif (-r $linkt) {
+ } elsif (-r encode('locale_fs', $linkt)) {
# case 3: exists, link, targets different
if ($opt_force) {
print_info("Removing link $target due to --force!\n");
@@ -1081,12 +1092,24 @@ sub link_font {
exit(1);
}
}
- } elsif (-r $target) {
+ } elsif (-r encode('locale_fs', $target)) {
# case 4: exists, but not link (NTFS hardlink on win32 falls into this)
- if (-s $target) {
+ if (-s encode('locale_fs', $target)) {
if ($opt_force) {
print_info("Removing $target due to --force!\n");
$do_unlink = 1;
+ } elsif (win32()) {
+ my $result = compare (encode ('locale_fs', $f),
+ encode ('locale_fs', $target));
+ if ($result == -1) {
+ print_error("file compare failed: ${f}, ${target}\n");
+ exit(1);
+ } elsif ($result) {
+ print_error("$target already existing and different content, exiting!\n");
+ exit(1);
+ }
+ print_debug("$target already existing but same content, skipping!\n");
+ return;
} else {
print_error("$target already existing, exiting!\n");
exit(1);
@@ -1107,107 +1130,175 @@ sub link_font {
sub make_dir {
my ($d, $w) = @_;
- if (-r $d) {
- if (! -d $d) {
+ if (-r encode('locale_fs', $d)) {
+ if (! -d encode('locale_fs', $d)) {
print_error("$d is not a directory, $w\n");
exit(1);
}
} else {
- $dry_run || make_path($d);
+ $dry_run || make_path(encode('locale', $d));
}
}
-# perl symlink function does not work on windows, so leave it to
-# cmd.exe mklink function (or write to batch file).
-# if target already exists, do not try to override it. otherwise
-# "mklink error: Cannot create a file when that file already exists"
-# is thrown many times
+# perl symlink function does not work on windows, so we use Win32 API.
sub maybe_symlink {
my ($realname, $targetname) = @_;
if (win32()) {
- # hardlink vs. symlink -- HY 2017/04/26
- # * readablitiy: hardlink is easier, but it seems that current gs can read
- # symlink properly, so it doesn't matter
- # * permission: hardlink creation does not require administrator privilege,
- # but is likely to fail for c:/windows/fonts/* system files
- # due to "Access denied"
- # symlink creation requires administrator privilege, but
- # it can link to all files in c:/windows/fonts/
- # * versatility: symlink can point to a file on a different/remote volume
- # for these reasons, we try to create symlink by default.
- # if --hardlink option is given, we create hardlink instead.
- # also, if --winbatch option is given, we prepare batch file for link generation,
- # instead of creating links right away.
- $realname =~ s!/!\\!g;
- $targetname =~ s!/!\\!g;
- if ($opt_winbatch) {
- # re-encoding of $winbatch_content is done by write_winbatch()
- $winbatch_content .= "if not exist \"$targetname\" mklink ";
- $winbatch_content .= "/h " if $opt_hardlink;
- $winbatch_content .= "\"$targetname\" \"$realname\"\n";
- } else {
- # should be encoded in cp932 for win32 console
- $realname = encode_utftocp($realname);
- $targetname = encode_utftocp($targetname);
- my $cmdl = "cmd.exe /c if not exist \"$targetname\" mklink ";
- $cmdl .= "/h " if $opt_hardlink;
- $cmdl .= "\"$targetname\" \"$realname\"";
- my @ret = `$cmdl`;
- # sometimes hard link creation may fail due to "Access denied"
- # (especially when $realname is located in c:/windows/fonts).
- # TODO: what should we do to ensure resources, which might be
- # different from $realname? -- HY (2017/03/21)
- # -- one possibility:
- # if (@ret) {
- # @ret ="done";
- # } else {
- # print_info("Hard link creation for $realname failed. I will copy this file instead.\n");
- # $cmdl = "cmd.exe /c if not exist \"$targetname\" copy \"$realname\" \"$targetname\"";
- # @ret = `$cmdl`;
- # }
- # -- however, both tlgs (TeX Live) and standalone gswin32/64 (built
- # by Akira Kakuto) can search in c:/windows/fonts by default.
- # Thus, copying such files is waste of memory
+ # Try symbolic link, hard link, copy by Win32 API
+
+ # On Windows, the creation of a symbolic link requires a privilege.
+ # Therefore, if the creation of the symbolic link fails,
+ # create a hard link.
+ # However, the creation of the hard link requires the write permission
+ # to the original existing file.
+ # Thus, if the hard link also fails, copy the file.
+
+ if (win32_symlink ($realname, $targetname)) {
+ print_debug ("Symbolic link succeeded: ${targetname}\n");
+ return 1;
+ }
+
+ if (win32_hardlink ($realname, $targetname)) {
+ print_debug ("Hard link succeeded: ${targetname}\n");
+ return 1;
+ }
+
+ if (win32_copy ($realname, $targetname)) {
+ print_debug ("Copy succeeded: ${targetname}\n");
+ return 1;
}
+
+ print_warning ("Link/copy failed: ${targetname}\n");
} else {
symlink ($realname, $targetname);
}
}
-# unlink function actually works also on windows, however,
-# leave it to batch file for consistency. otherwise
-# option $opt_force may not work as expected
sub maybe_unlink {
my ($targetname) = @_;
- if (win32()) {
- $targetname =~ s!/!\\!g;
- if ($opt_winbatch) {
- # re-encoding of $winbatch_content is done by write_winbatch()
- $winbatch_content .= "if exist \"$targetname\" del \"$targetname\"\n";
- } else {
- # should be encoded in cp932 for win32 console
- $targetname = encode_utftocp($targetname);
- my $cmdl = "cmd.exe /c if exist \"$targetname\" del \"$targetname\"";
- my @ret = `$cmdl`;
+ unlink (encode('locale_fs', $targetname));
+}
+
+# For Windows: Create symbolic link
+sub win32_symlink {
+ my ($existingfilename, $newfilename) = @_;
+
+ # We use CreateSymbolicLinkW API directly for creating symbolic link
+ # because perl's symlink function may not work in Windows.
+ state $createsymboliclinkw = load_createsymboliclinkw ();
+
+ $existingfilename =~ s|/|\\|g;
+ $newfilename =~ s|/|\\|g;
+
+ my $r = $createsymboliclinkw->Call (
+ encode ('UTF-16LE', $newfilename),
+ encode ('UTF-16LE', $existingfilename),
+ 0
+ );
+ if (ord($r) != 0) {
+ return 1;
}
- } else {
- unlink ($targetname);
- }
+ my $msg = decode ('locale',
+ Win32::FormatMessage (Win32::GetLastError ()));
+ $msg =~ s/[\r\n]+\z//;
+ print_debug ("CreateSymbolicLinkW failed: ${msg}\n");
+
+ return 0;
}
-# write batch file (windows only)
-sub write_winbatch {
- return if $dry_run;
- open(FOO, ">$winbatch") ||
- die("cannot open $winbatch for writing: $!");
- # $winbatch_content may contain multibyte characters, and they
- # should be encoded in cp932 in batch file
- $winbatch_content = encode_utftocp($winbatch_content);
- print FOO "\@echo off\n",
- "$winbatch_content",
- "\@echo symlink ", ($opt_remove ? "removed\n" : "generated\n"),
- "\@pause 1\n";
- close(FOO);
+# For Windows: Create hard link
+sub win32_hardlink {
+ my ($existingfilename, $newfilename) = @_;
+
+ # We use CreateHardLinkW API directly for creating hard link
+ # because -W API is not affected by the perl's active code page.
+ state $createhardlinkw = load_createhardlinkw ();
+
+ $existingfilename =~ s|/|\\|g;
+ $newfilename =~ s|/|\\|g;
+
+ my $r = $createhardlinkw->Call (
+ encode ('UTF-16LE', $newfilename),
+ encode ('UTF-16LE', $existingfilename),
+ 0
+ );
+ if ($r) {
+ return 1;
+ }
+ my $msg = decode ('locale',
+ Win32::FormatMessage (Win32::GetLastError ()));
+ $msg =~ s/[\r\n]+\z//;
+ print_debug ("CreateHardLinkW failed: ${msg}\n");
+
+ return 0;
+}
+
+# For Windows: Copy file
+sub win32_copy {
+ my ($existingfilename, $newfilename) = @_;
+
+ # We use CopyFileW API directly for copying file
+ # because -W API is not affected by the perl's active code page.
+ state $copyfilew = load_copyfilew ();
+
+ $existingfilename =~ s|/|\\|g;
+ $newfilename =~ s|/|\\|g;
+
+ my $r = $copyfilew->Call (
+ encode ('UTF-16LE', $existingfilename),
+ encode ('UTF-16LE', $newfilename),
+ 1
+ );
+ if ($r) {
+ return 1;
+ }
+ my $msg = decode ('locale',
+ Win32::FormatMessage (Win32::GetLastError ()));
+ $msg =~ s/[\r\n]+\z//;
+ print_debug ("CopyFileW failed: ${msg}\n");
+
+ return 0;
+}
+
+# For Windows: Load CreateSymbolicLinkW API
+sub load_createsymboliclinkw {
+ my $createsymboliclinkw = Win32::API::More->new (
+ 'kernel32.dll',
+ 'BOOLEAN CreateSymbolicLinkW(
+ LPCWSTR lpSymlinkFileName,
+ LPCWSTR lpTargetFileName,
+ DWORD dwFlags
+ )'
+ ) or die ('Failed: Win32::API::More->new CreateSymbolicLinkW');
+
+ return $createsymboliclinkw;
+}
+# For Windows: Load CreateHardLinkW API
+sub load_createhardlinkw {
+ my $createhardlinkw = Win32::API::More->new (
+ 'kernel32.dll',
+ 'BOOL CreateHardLinkW(
+ LPCWSTR lpFileName,
+ LPCWSTR lpExistingFileName,
+ UINT_PTR lpSecurityAttributes
+ )'
+ ) or die ('Failed: Win32::API::More->new CreateHardLinkW');
+
+ return $createhardlinkw;
+}
+
+# For Windows: Load CopyFileW API
+sub load_copyfilew {
+ my $copyfilew = Win32::API::More->new (
+ 'kernel32.dll',
+ 'BOOL CopyFileW(
+ LPCWSTR lpExistingFileName,
+ LPCWSTR lpNewFileName,
+ BOOL bFailIfExists
+ )'
+ ) or die ('Failed: Win32::API::More->new CopyFileW');
+
+ return $copyfilew;
}
# write to psnames-for-otfps
@@ -1215,7 +1306,9 @@ sub write_akotfps_datafile {
return if $dry_run;
make_dir("$opt_akotfps/$akotfps_pathpart",
"cannot create $akotfps_datafilename in it!");
- open(FOO, ">$opt_akotfps/$akotfps_pathpart/$akotfps_datafilename") ||
+ open(FOO, ">:encoding(UTF-8)",
+ encode('locale_fs',
+ "$opt_akotfps/$akotfps_pathpart/$akotfps_datafilename")) ||
die("cannot open $opt_akotfps/$akotfps_pathpart/$akotfps_datafilename for writing: $!");
print FOO "% psnames-for-otf
%
@@ -1240,10 +1333,6 @@ sub info_found_fonts {
print "Type: $fontdb{$k}{'type'}\n";
print "Class: $fontdb{$k}{'class'}\n";
my $fn = $fontdb{$k}{'target'};
- # cp932 for win32 console
- if (win32()) {
- $fn = encode_utftocp($fn);
- }
if ($fontdb{$k}{'type'} eq 'TTC' || $fontdb{$k}{'type'} eq 'OTC') {
$fn .= "($fontdb{$k}{'subfont'})";
}
@@ -1285,10 +1374,6 @@ sub info_list_aliases {
for my $p (@ks) {
my $t = $aliases{$al}{$p};
my $fn = ($opt_listallaliases ? "-" : $fontdb{$t}{'target'} );
- # cp932 for win32 console
- if (win32()) {
- $fn = encode_utftocp($fn);
- }
# should always be the same ;-)
$cl = $fontdb{$t}{'class'};
if (!$opt_listallaliases && ($fontdb{$t}{'type'} eq 'TTC' || $fontdb{$t}{'type'} eq 'OTC')) {
@@ -1345,7 +1430,8 @@ sub make_all_available {
sub check_for_files {
my @foundfiles;
if ($opt_filelist) {
- open(FOO, "<", $opt_filelist) || die("Cannot open $opt_filelist: $!");
+ open(FOO, "<", encode('locale_fs', $opt_filelist)) ||
+ die("Cannot open $opt_filelist: $!");
@foundfiles = <FOO>;
close(FOO) || warn "Cannot close $opt_filelist: $!";
} else {
@@ -1371,13 +1457,15 @@ sub check_for_files {
for my $d (qw!/Library/Fonts /System/Library/Fonts
/System/Library/Assets /System/Library/AssetsV2
/Network/Library/Fonts /usr/share/fonts!) {
- push @extradirs, "$d//" if (-d $d); # recursive search
+ push @extradirs, "$d//"
+ if (-d encode('locale_fs', $d)); # recursive search
}
# the path contains white space, so hack required
for my $d (qw!/Library/Application__Support/Apple/Fonts!) {
my $sd = $d;
$sd =~ s/__/ /;
- push @extradirs, "$sd//" if (-d "$sd"); # recursive search
+ push @extradirs, "$sd//"
+ if (-d encode('locale_fs', "$sd")); # recursive search
}
# office for mac 2016
for my $d (qw!/Applications/Microsoft__Word.app
@@ -1385,11 +1473,14 @@ sub check_for_files {
/Applications/Microsoft__PowerPoint.app!) {
my $sd = $d;
$sd =~ s/__/ /;
- push @extradirs, "$sd/Contents/Resources/Fonts/" if (-d "$sd/Contents/Resources/Fonts");
- push @extradirs, "$sd/Contents/Resources/DFonts/" if (-d "$sd/Contents/Resources/DFonts");
+ push @extradirs, "$sd/Contents/Resources/Fonts/"
+ if (-d encode('locale_fs', "$sd/Contents/Resources/Fonts"));
+ push @extradirs, "$sd/Contents/Resources/DFonts/"
+ if (-d encode('locale_fs', "$sd/Contents/Resources/DFonts"));
}
my $home = $ENV{'HOME'};
- push @extradirs, "$home/Library/Fonts//" if (-d "$home/Library/Fonts");
+ push @extradirs, "$home/Library/Fonts//"
+ if (-d encode('locale_fs', "$home/Library/Fonts"));
}
#
if (@extradirs) {
@@ -1426,23 +1517,20 @@ sub check_for_files {
$cmdl .= " \"$f\" ";
}
# shoot up kpsewhich
- # this call (derived from the database) contains multibyte characters,
- # and they should be encoded in cp932 for win32 console
- if (win32()) {
- $cmdl = encode_utftocp($cmdl);
- }
print_ddebug("checking for $cmdl\n");
+ $cmdl = encode('locale', $cmdl);
@foundfiles = `$cmdl`;
+ # We assume that the output of kpsewhich is
+ # the same as perl's locale (or active code page).
+ @foundfiles = map { decode('locale', $_) } @foundfiles;
}
- # at this point, on windows, @foundfiles is encoded in cp932
- # which is suitable for the next few lines
chomp(@foundfiles);
print_ddebug("Found files @foundfiles\n");
# map basenames to filenames
my %bntofn;
for my $f (@foundfiles) {
$f =~ s/[\r\n]+\z//; # perl's chomp() on git-bash cannot strip CR of CRLF ??
- my $realf = abs_path($f);
+ my $realf = decode('locale_fs', abs_path(encode('locale_fs', $f)));
if (!$realf) {
print_warning("dead link or strange file found: $f - ignored!\n");
next;
@@ -1458,11 +1546,6 @@ sub check_for_files {
$temp_realfdir =~ s!^(.*)/(.*)$!$1!;
next if ($temp_realfdir =~ $otf_pathpart || $temp_realfdir =~ $ttf_pathpart);
}
- # decode now on windows! (cp932 -> internal utf-8)
- if (win32()) {
- $f = encode_cptoutf($f);
- $realf = encode_cptoutf($realf);
- }
my $bn = basename($f);
# kpsewhich -all might return multiple files with the same basename;
# collect all of them
@@ -1511,7 +1594,9 @@ sub check_for_files {
print_debug("We need to test whether\n");
print_debug(" $b:$index\n");
print_debug("is the correct one ($k). Invoking zrlistttc ...\n");
- chomp($actualpsname = `texlua $zrlistttc -i $index "$b"`);
+ my $cmdl = "texlua $zrlistttc -i $index \"$b\"";
+ $cmdl = encode('locale', $cmdl);
+ chomp($actualpsname = `$cmdl`);
if ($?) {
# something is wrong with the font file, or zrlistttc does not support it;
# still there is a chance that Ghostscript supports, so don't discard it
@@ -1521,6 +1606,9 @@ sub check_for_files {
$bname = $b;
last;
}
+ # We assume that the output of texlua is
+ # the same as perl's locale (or active code page).
+ $actualpsname = decode('locale', $actualpsname);
$actualpsname =~ s/[\r\n]+\z//; # perl's chomp() on git-bash cannot strip CR of CRLF ??
if ($actualpsname ne $k) {
print_debug("... PSName returned by zrlistttc ($actualpsname) is\n");
@@ -1688,7 +1776,7 @@ sub read_font_database {
# use "foo" as a substitute; otherwise, use built-in database
if ($opt_fontdef) {
my $foo = kpse_miscfont($opt_fontdef);
- open(FDB, "<$foo") ||
+ open(FDB, "<:encoding(UTF-8)", encode('locale_fs', $foo)) ||
die("Cannot find $opt_fontdef: $!");
@dbl = <FDB>;
close(FDB);
@@ -1702,7 +1790,7 @@ sub read_font_database {
# overwrite existing one (that is, the addition wins)
for (@opt_fontdef_add) {
my $foo = kpse_miscfont($_);
- open(FDB, "<$foo") ||
+ open(FDB, "<:encoding(UTF-8)", encode('locale_fs', $foo)) ||
die("Cannot find $_: $!");
@dbl = <FDB>;
close(FDB);
@@ -1773,7 +1861,7 @@ sub read_each_font_database {
next if (!$opt_cleanup);
my @dbl;
my $foo = kpse_miscfont($1);
- if (!open(FDB, "<$foo")) {
+ if (!open(FDB, "<:encoding(UTF-8)", encode('locale_fs', $foo))) {
print_warning("Cannot find $1, skipping!\n");
next;
}
@@ -1786,7 +1874,7 @@ sub read_each_font_database {
if ($l =~ m/^INCLUDE\s*(.*)$/) {
my @dbl;
my $foo = kpse_miscfont($1);
- if (!open(FDB, "<$foo")) {
+ if (!open(FDB, "<:encoding(UTF-8)", encode('locale_fs', $foo))) {
print_warning("Cannot find $1, skipping!\n");
next;
}
@@ -1807,12 +1895,7 @@ sub read_each_font_database {
if ($l =~ m/^OTFname(\((\d+)\))?:\s*(.*)$/) {
my $fn = $3;
$fontfiles{$fn}{'priority'} = ($2 ? $2 : 10);
- # cp932 for win32 console
- my $encoded_fn;
- if (win32()) {
- $encoded_fn = encode_utftocp($fn);
- }
- print_dddebug("filename: ", ($encoded_fn ? "$encoded_fn" : "$fn"), "\n");
+ print_dddebug("filename: ${fn}\n");
print_dddebug("type: otf\n");
$fontfiles{$fn}{'type'} = 'OTF';
next;
@@ -1820,12 +1903,7 @@ sub read_each_font_database {
if ($l =~ m/^OTCname(\((\d+)\))?:\s*(.*)$/) {
my $fn = $3;
$fontfiles{$fn}{'priority'} = ($2 ? $2 : 10);
- # cp932 for win32 console
- my $encoded_fn;
- if (win32()) {
- $encoded_fn = encode_utftocp($fn);
- }
- print_dddebug("filename: ", ($encoded_fn ? "$encoded_fn" : "$fn"), "\n");
+ print_dddebug("filename: ${fn}\n");
print_dddebug("type: otc\n");
$fontfiles{$fn}{'type'} = 'OTC';
next;
@@ -1833,12 +1911,7 @@ sub read_each_font_database {
if ($l =~ m/^TTFname(\((\d+)\))?:\s*(.*)$/) {
my $fn = $3;
$fontfiles{$fn}{'priority'} = ($2 ? $2 : 10);
- # cp932 for win32 console
- my $encoded_fn;
- if (win32()) {
- $encoded_fn = encode_utftocp($fn);
- }
- print_dddebug("filename: ", ($encoded_fn ? "$encoded_fn" : "$fn"), "\n");
+ print_dddebug("filename: ${fn}\n");
print_dddebug("type: ttf\n");
$fontfiles{$fn}{'type'} = 'TTF';
next;
@@ -1846,12 +1919,7 @@ sub read_each_font_database {
if ($l =~ m/^TTCname(\((\d+)\))?:\s*(.*)$/) {
my $fn = $3;
$fontfiles{$fn}{'priority'} = ($2 ? $2 : 10);
- # cp932 for win32 console
- my $encoded_fn;
- if (win32()) {
- $encoded_fn = encode_utftocp($fn);
- }
- print_dddebug("filename: ", ($encoded_fn ? "$encoded_fn" : "$fn"), "\n");
+ print_dddebug("filename: ${fn}\n");
print_dddebug("type: ttc\n");
$fontfiles{$fn}{'type'} = 'TTC';
next;
@@ -1860,12 +1928,7 @@ sub read_each_font_database {
if ($l =~ m/^Filename(\((\d+)\))?:\s*(.*)$/) {
my $fn = $3;
$fontfiles{$fn}{'priority'} = ($2 ? $2 : 10);
- # cp932 for win32 console
- my $encoded_fn;
- if (win32()) {
- $encoded_fn = encode_utftocp($fn);
- }
- print_dddebug("filename: ", ($encoded_fn ? "$encoded_fn" : "$fn"), "\n");
+ print_dddebug("filename: ${fn}\n");
if ($fn =~ m/\.otf$/i) {
print_dddebug("type: otf\n");
$fontfiles{$fn}{'type'} = 'OTF';
@@ -1888,12 +1951,7 @@ sub read_each_font_database {
if ($l =~ m/^RMVname(\((\d+)\))?:\s*(.*)$/) {
my $fn = $3;
$fontfiles{$fn}{'priority'} = ($2 ? $2 : 10);
- # cp932 for win32 console
- my $encoded_fn;
- if (win32()) {
- $encoded_fn = encode_utftocp($fn);
- }
- print_dddebug("filename: ", ($encoded_fn ? "$encoded_fn" : "$fn"), "\n");
+ print_dddebug("filename: ${fn}\n");
print_dddebug("type: remove\n");
$fontfiles{$fn}{'type'} = 'RMV';
next;
@@ -1906,7 +1964,7 @@ sub read_each_font_database {
}
sub dump_font_database {
- open(FOO, ">$dump_datafile") ||
+ open(FOO, ">:encoding(UTF-8)", encode('locale_fs', $dump_datafile)) ||
die("cannot open $dump_datafile for writing: $!");
for my $k (sort keys %fontdb) {
print FOO "Name: $fontdb{$k}{'origname'}\n";
@@ -1937,15 +1995,19 @@ sub find_gs_resource {
my $foundres = '';
if (win32()) {
# determine tlgs or native gs
- chomp(my $foo = `kpsewhich -var-value=SELFAUTOPARENT`);
- if ( -d "$foo/tlpkg/tlgs" ) {
+ my $foo = `kpsewhich -var-value=SELFAUTOPARENT`;
+ # We assume that the output of kpsewhich is
+ # the same as perl's locale (or active code page).
+ decode('locale', $foo);
+ chomp($foo);
+ if ( -d encode('locale_fs', "$foo/tlpkg/tlgs") ) {
# should be texlive with tlgs
print_debug("Assuming tlgs win32 ...\n");
$foundres = "$foo/tlpkg/tlgs/Resource";
# for TL2016, tlgs binary has built-in Resource,
# so we cannot set up CJK fonts correctly.
# the following test forces to exit in such case
- if ( ! -d $foundres ) {
+ if ( ! -d encode('locale_fs', $foundres) ) {
print_error("No Resource directory available for tlgs,\n");
print_error("we cannot support such gs, sorry.\n");
$foundres = '';
@@ -1957,18 +2019,20 @@ sub find_gs_resource {
} else {
# we assume gswin32c is in the path
# TODO: what should we do for gswin64c?
- chomp($foundres = `where gswin32c 2>$nul`); # assume 'where' is available
+ $foundres = `where gswin32c 2>$nul`; # assume 'where' is available
if ($?) {
print_error("Cannot run where gswin32c ...\n");
} else {
+ # We assume that the output of 'where' is
+ # the same as perl's locale (or active code page).
+ chomp($foundres = decode('locale', $foundres));
# trial 1: assume the relative path
# when C:\path\to\bin\gswin32c.exe is found, then there should be
# C:\path\to\Resource (note that 'where' returns backslash-ed path)
print_debug("Finding gs resource by assuming relative path ...\n");
- $foundres = encode_cptoutf($foundres); # 99.99% unnecessary
$foundres =~ s!\\!/!g;
$foundres =~ s!/bin/gswin32c\.exe$!/Resource!;
- if ( ! -d $foundres ) {
+ if ( ! -d encode('locale_fs', $foundres) ) {
$foundres = '';
}
if (!$foundres) {
@@ -1983,7 +2047,7 @@ sub find_gs_resource {
# trial 2: assume the fixed path, c:/gs/gs$gsver/Resource
print_debug("Finding gs resource by assuming fixed path ...\n");
$foundres = "c:/gs/gs$gsver/Resource";
- if ( ! -d $foundres ) {
+ if ( ! -d encode('locale_fs', $foundres) ) {
$foundres = '';
}
if (!$foundres) {
@@ -2002,9 +2066,13 @@ sub find_gs_resource {
# when /path/to/bin/gs is found, then there should be
# /path/to/share/ghostscript/$(gs --version)/Resource
print_debug("Finding gs resource by assuming relative path ...\n");
- chomp($foundres = `which gs`);
+ $foundres = `which gs`;
+ # We assume that the output of 'which' is
+ # the same as perl's locale (or active code page).
+ $foundres = decode('locale', $foundres);
+ chomp($foundres);
$foundres =~ s!/bin/gs$!/share/ghostscript/$gsver/Resource!;
- if ( ! -d $foundres ) {
+ if ( ! -d encode('locale_fs', $foundres) ) {
$foundres = '';
}
if (!$foundres) {
@@ -2012,10 +2080,14 @@ sub find_gs_resource {
}
}
if (!$foundres) {
- chomp(my @ret = `gs --help 2>$nul`);
+ my @ret = `gs --help 2>$nul`;
if ($?) {
print_error("Cannot run gs --help ...\n");
} else {
+ # We assume that the output of gs is
+ # the same as perl's locale (or active code page).
+ @ret = map { decode('locale', $_) } @ret;
+ chomp(@ret);
# trial 2: parse gs help message
print_debug("Finding gs resource by parsing help message ...\n");
$foundres = '';
@@ -2042,25 +2114,38 @@ sub kpse_miscfont {
my ($file) = @_;
my $foo = '';
# first, prioritize GitHub repository diretory structure
- $foo = "database/$file" if (-f "database/$file");
+ $foo = "database/$file" if (-f encode('locale_fs', "database/$file"));
if ($foo eq "") {
- chomp($foo = `kpsewhich -format=miscfont $file`);
+ my $cmdl = "kpsewhich -format=miscfont $file";
+ $cmdl = encode('locale', $cmdl);
+ $foo = `$cmdl`;
+ # We assume that the output of kpsewhich is
+ # the same as perl's locale (or active code page).
+ $foo = decode('locale', $foo);
+ chomp($foo);
}
return $foo;
}
-sub encode_utftocp {
- my ($foo) = @_;
- $foo = Encode::decode('utf-8', $foo);
- $foo = Encode::encode('cp932', $foo);
- return $foo;
-}
+sub init_encode_locale {
+ eval {
+ require Encode::Locale;
+ Encode::Locale->import();
-sub encode_cptoutf {
- my ($foo) = @_;
- $foo = Encode::decode('cp932', $foo);
- $foo = Encode::encode('utf-8', $foo);
- return $foo;
+ $debug_msg_before_init .= "Encode::Locale is loaded.\n";
+ };
+ if ($@) {
+ if (win32) {
+ die ("For Windows, Encode::Locale is required.\n");
+ }
+
+ $debug_msg_before_init .=
+ "Encode::Locale is not found. Assuming all encodings are UTF-8.\n";
+ Encode::Alias::define_alias('locale' => 'UTF-8');
+ Encode::Alias::define_alias('locale_fs' => 'UTF-8');
+ Encode::Alias::define_alias('console_in' => 'UTF-8');
+ Encode::Alias::define_alias('console_out' => 'UTF-8');
+ }
}
sub version {
@@ -2107,13 +2192,6 @@ sub Usage {
-h, --help this help
";
- my $winonlyoptions = "
---hardlink create hardlinks instead of symlinks
---winbatch [FILE] prepare a batch file for link generation, instead of
- generating links right away
- the batch file name defaults to $winbatch
-";
-
my $commandoptions = "
--dump-data [FILE] dump the set of font definitions which is currently
effective, where FILE (the dump output) defaults to
@@ -2269,8 +2347,9 @@ requirements of `LL` and `RR` must be fulfilled:
my $authors = "
The script and its documentation was written by Norbert Preining, based
-on research and work by Yusuke Kuroki, Yusuke Terada, Bruno Voisin,
-Hironobu Yamashita, Munehiro Yamamoto and the TeX Q&A wiki page.
+on research and work by Masamichi Hosoda, Yusuke Kuroki, Yusuke Terada,
+Bruno Voisin, Hironobu Yamashita, Munehiro Yamamoto and the TeX Q&A wiki
+page.
Maintained by Japanese TeX Development Community. For development, see
https://github.com/texjporg/cjk-gs-support
@@ -2286,8 +2365,6 @@ The contained font data is not copyrightable.
print "\n$shortdesc\nUsage\n-----\n\n`````\n$usage\n`````\n\n";
print "#### Options ####\n\n`````";
print_for_out($options, " ");
- print "`````\n\n#### Windows only options ####\n\n`````";
- print_for_out($winonlyoptions, " ");
print "`````\n\n#### Command like options ####\n\n`````";
print_for_out($commandoptions, " ");
print "`````\n\nOperation\n---------\n$operation\n";
@@ -2303,10 +2380,6 @@ The contained font data is not copyrightable.
print "\nUsage: $usage\n\n$headline\n$shortdesc";
print "\nOptions:\n";
print_for_out($options, " ");
- if (win32()) {
- print "\nWindows only options:\n";
- print_for_out($winonlyoptions, " ");
- }
print "\nCommand like options:\n";
print_for_out($commandoptions, " ");
print "\nOperation:\n";