summaryrefslogtreecommitdiff
path: root/language/chinese/CJK/cjk-4.8.5/utils/subfonts/sfd2uni.pl
diff options
context:
space:
mode:
Diffstat (limited to 'language/chinese/CJK/cjk-4.8.5/utils/subfonts/sfd2uni.pl')
-rw-r--r--language/chinese/CJK/cjk-4.8.5/utils/subfonts/sfd2uni.pl348
1 files changed, 348 insertions, 0 deletions
diff --git a/language/chinese/CJK/cjk-4.8.5/utils/subfonts/sfd2uni.pl b/language/chinese/CJK/cjk-4.8.5/utils/subfonts/sfd2uni.pl
new file mode 100644
index 0000000000..5aa1946d32
--- /dev/null
+++ b/language/chinese/CJK/cjk-4.8.5/utils/subfonts/sfd2uni.pl
@@ -0,0 +1,348 @@
+#! /usr/bin/perl -w
+#
+# This script creates virtual subfonts in Unicode encoding for a font
+# encoding given by a subfont definition file (which must use Unicode
+# code points).
+#
+# As prerequisites it needs the programs `tftopl' and `vptovf' which must be
+# in the path.
+#
+# Call the script as
+#
+# perl sfd2uni.pl sfd-file namestem uni-namestem codingscheme
+#
+# `sfd-file' is the subfont definition file, `namestem' is the name stem
+# of the subfonts defined in `sfd-file', and `uni-namestem' holds the prefix
+# for the Unicode subfonts. `codingscheme' (converted to uppercase) is used
+# for the CODINGSCHEME parameter in the resulting TFM files.
+#
+# `sfd2uni.pl' reads all TFM files from the font family with name stem
+# `namestem'.
+#
+# Example:
+#
+# perl sfd2uni.pl UKS-HLaTeX.sfd wmj uwmj HLATEX
+#
+# A collection of useful subfont definition files for CJK fonts can be found
+# in the ttf2pk package.
+
+# Copyright (C) 1994-2021 Werner Lemberg <wl@gnu.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program in doc/COPYING; if not, write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301 USA
+
+use strict;
+
+my $prog = $0;
+$prog =~ s@.*/@@;
+
+if ($#ARGV != 3) {
+ die("usage: $prog sfd-file namestem uni-namestem codingscheme\n");
+}
+
+my $sfdfile = $ARGV[0];
+my $namestem = $ARGV[1];
+my $uninamestem = $ARGV[2];
+my $codingscheme = $ARGV[3];
+
+
+# Read subfont definition file.
+
+my %sfd;
+my @subfonts;
+
+read_sfdfile($sfdfile, \%sfd, \@subfonts);
+
+
+# Read TFM files.
+
+my @unicmetrics;
+
+foreach my $sub (@subfonts) {
+ my $tfmname = "$namestem$sub.tfm";
+
+ read_tfmfile($tfmname, \@unicmetrics, \%sfd, $sub);
+}
+
+
+# Read FONTDIMEN block.
+
+my $fontdimen = read_fontdimen("$namestem$subfonts[0].tfm");
+
+
+# Write VPL files.
+
+my $index = 0;
+foreach my $i (0 .. 255) {
+ my @entries;
+
+ foreach my $j (0 .. 255) {
+ if (defined ($unicmetrics[$index])) {
+ push(@entries, "$j $unicmetrics[$index]");
+ }
+ $index++;
+ }
+
+ if ($#entries >= 0) {
+ write_vplfile($uninamestem . sprintf("%02x.vpl", $i), \@entries);
+ }
+}
+
+
+# Generate VF and TFM files, then remove the VPL files.
+
+my @vplfiles = glob("$uninamestem*.vpl");
+foreach my $vplfile (@vplfiles) {
+ print("Processing \`$vplfile'...\n");
+ my $arg = "vptovf $vplfile";
+ system($arg) == 0
+ || die("$prog: calling \`$arg' failed: $?");;
+ print("Removing \`$vplfile'...\n");
+ unlink($vplfile);
+}
+
+
+# Read an SFD file.
+#
+# $1: Name of the SFD file.
+# $2: Reference to the target hash file, mapping from the subfont index to
+# the character code. The format of the key value is the concatenation
+# of the subfont suffix, a space, and the index.
+# $3: Reference to a target array which holds the subfont suffixes.
+
+sub read_sfdfile {
+ my ($sfdfile, $sfdhash, $sfdarray) = @_;
+
+ print("Reading subfont definition file \`$sfdfile'...\n");
+
+ open(SFD, $sfdfile)
+ || die("$prog: can't open \`$sfdfile': $!\n");
+
+ my $line;
+ my $continuation = 0;
+ while (<SFD>) {
+ chop;
+
+ next if /^\s*$/;
+ next if /^#/;
+
+ if ($continuation) {
+ $line .= $_;
+ }
+ else {
+ $line = $_;
+ }
+ $continuation = 0;
+
+ if ($line =~ s/\\$//) {
+ $continuation = 1;
+ next;
+ }
+
+ $_ = $line;
+ my @field = split(" ");
+
+ my $suffix = $field[0];
+ push(@{$sfdarray}, $suffix);
+
+ shift(@field);
+ my $index = 0;
+
+ while (@field) {
+ if ($field[0] =~ /(.*):$/) {
+ $index = $1;
+ }
+ elsif ($field[0] =~ /(.*)_(.*)/) {
+ my $start = $1;
+ my $end = $2;
+ $start = oct($start) if ($start =~ /^0/);
+ $end = oct($end) if ($end =~ /^0/);
+ foreach my $i ($start .. $end) {
+ $sfdhash->{"$suffix $index"} = $i;
+ $index++;
+ }
+ }
+ else {
+ my $value = $field[0];
+ $value = oct($value) if ($value =~ /^0/);
+ $sfdhash->{"$suffix $index"} = $value;
+ $index++;
+ }
+ shift(@field);
+ }
+ }
+ close(SFD);
+}
+
+
+# Read TFM file.
+#
+# $1: Name of the TFM file.
+# $2: Reference to the target array holding metric information in the form
+# `<subfont> <subfont_index> <width> <heigth> <depth>'.
+# $3: Reference to a hash created by `read_sfdfile'.
+# $4: Subfont suffix.
+
+sub read_tfmfile {
+ my ($tfmfile, $unicarray, $sfdhash, $sub) = @_;
+
+ print("Processing metrics file \`$tfmfile'...\n");
+ my $arg = "tftopl $tfmfile > $tfmfile.pl";
+ system($arg) == 0
+ || die("$prog: calling \`$arg' failed: $?\n");
+
+ print("Reading property list file \`$tfmfile.pl'...\n");
+ open(PL, "$tfmfile.pl")
+ || die("$prog: can't open \`$tfmfile.pl': $!\n");
+
+ while (<PL>) {
+ my $index;
+ if (/^\(CHARACTER O (\d+)/) {
+ $index = oct($1);
+ }
+ elsif (/^\(CHARACTER C (.)/) {
+ $index = ord($1);
+ }
+ else {
+ next;
+ }
+
+ my $wd = "0";
+ my $ht = "0";
+ my $dp = "0";
+
+ $_ = <PL>;
+ if (/\(CHARWD R (.*)\)/) {
+ $wd = "$1";
+ $_ = <PL>;
+ }
+ if (/\(CHARHT R (.*)\)/) {
+ $ht = "$1";
+ $_ = <PL>;
+ }
+ if (/\(CHARDP R (.*)\)/) {
+ $dp = "$1";
+ }
+
+ if (defined ($sfdhash->{"$sub $index"})) {
+ $unicarray->[$sfdhash->{"$sub $index"}] = "$sub $index $wd $ht $dp";
+ }
+ }
+ close(PL);
+ print("Removing \`$tfmfile.pl'...\n");
+ unlink("$tfmfile.pl");
+}
+
+
+# Read FONTDIMEN block of a TFM file.
+#
+# $1: Name of the TFM file.
+#
+# Return the block as a string.
+
+sub read_fontdimen {
+ my ($tfmfile) = @_;
+
+ print("Processing metrics file \`$tfmfile'...\n");
+ my $arg = "tftopl $tfmfile > $tfmfile.pl";
+ system($arg) == 0
+ || die("$prog: calling \`$arg' failed: $?\n");
+
+ print("Reading property list file \`$tfmfile.pl'...\n");
+ open(PL, "$tfmfile.pl")
+ || die("$prog: can't open \`$tfmfile.pl': $!\n");
+
+ my $s = "";
+ my $have_fontdimen = 0;
+
+ while (<PL>) {
+ if (/^\(FONTDIMEN/) {
+ $have_fontdimen = 1;
+ }
+
+ if ($have_fontdimen) {
+ $s .= $_;
+
+ last if (/^ \)/);
+ }
+ }
+
+ close(PL);
+ print("Removing \`$tfmfile.pl'...\n");
+ unlink("$tfmfile.pl");
+
+ return $s;
+}
+
+
+# Write VPL file.
+#
+# $1: Name of the VPL file.
+# $2: Reference to list which holds the font entries. An entry has the
+# form `<idx> <subfont> <subfont_idx> <width> <height> <depth>'.
+
+sub write_vplfile {
+ my ($vplfile, $metricsarray) = @_;
+
+ my %subfonts;
+ my $subcount = 0;
+
+ foreach my $entry (@{$metricsarray}) {
+ my @field = split(" ", $entry);
+ my $subfont = $field[1];
+ if (!defined ($subfonts{$subfont})) {
+ $subfonts{$subfont} = $subcount;
+ $subcount++;
+ }
+ }
+
+ print("Writing virtual property list file \`$vplfile'...\n");
+
+ open(VPL, ">", $vplfile)
+ || die("$prog: can't open \`$vplfile': $!\n");
+ my $oldfh = select(VPL);
+
+ print("(VTITLE Created by \`$prog " . join(" ", @ARGV) . "')\n");
+ print("(FAMILY TEX-\U$uninamestem\E)\n");
+ print("(CODINGSCHEME \U$codingscheme\E)\n");
+ print $fontdimen;
+
+ foreach my $subfont
+ (sort { $subfonts{$a} <=> $subfonts{$b} } keys %subfonts) {
+ print("(MAPFONT D $subfonts{$subfont}\n");
+ print(" (FONTNAME $namestem$subfont)\n");
+ print(" )\n");
+ }
+
+ foreach my $entry (@{$metricsarray}) {
+ my ($index, $subnumber, $subindex, $wd, $ht, $dp) = split(" ", $entry);
+
+ print("(CHARACTER D $index\n");
+ print(" (CHARWD R $wd)\n");
+ print(" (CHARHT R $ht)\n");
+ print(" (CHARDP R $dp)\n");
+ print(" (MAP\n");
+ print(" (SELECTFONT D $subfonts{$subnumber})\n");
+ print(" (SETCHAR D $subindex)\n");
+ print(" )\n");
+ print(" )\n");
+ }
+
+ close(VPL);
+ select($oldfh);
+}
+
+
+# eof