970N/A#! /usr/perl5/bin/perl -w
970N/A
970N/A#
1479N/A# Copyright (c) 2010, 2014, Oracle and/or its affiliates. All rights reserved.
970N/A#
970N/A# Permission is hereby granted, free of charge, to any person obtaining a
970N/A# copy of this software and associated documentation files (the "Software"),
970N/A# to deal in the Software without restriction, including without limitation
970N/A# the rights to use, copy, modify, merge, publish, distribute, sublicense,
970N/A# and/or sell copies of the Software, and to permit persons to whom the
970N/A# Software is furnished to do so, subject to the following conditions:
970N/A#
970N/A# The above copyright notice and this permission notice (including the next
970N/A# paragraph) shall be included in all copies or substantial portions of the
970N/A# Software.
970N/A#
970N/A# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
970N/A# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
970N/A# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
970N/A# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
970N/A# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
970N/A# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
970N/A# DEALINGS IN THE SOFTWARE.
970N/A#
970N/A#
970N/A
970N/Arequire 5.005; # minimal Perl version required
970N/Ause strict; #
970N/Ause diagnostics; #
970N/Ause integer; #
970N/Ause File::Spec; # pathname manipulation routines
970N/Ause English qw( -nomatchvars );
970N/Ause Getopt::Long;
970N/A
970N/A# Required arguments:
970N/A# -p <proto_area>
970N/A# -m <manifest>
970N/A
970N/Amy $proto_dir;
970N/Amy $manifest;
970N/A
970N/Amy $result = GetOptions('p|protodir=s' => \$proto_dir,
970N/A 'm|manifest=s' => \$manifest);
970N/A
970N/Aif (!defined($proto_dir)) {
970N/A print STDERR "Missing required protodir argument\n";
970N/A exit(1);
970N/A}
970N/A
970N/Aif (!defined($manifest)) {
970N/A print STDERR "Missing required manifest argument\n";
970N/A exit(1);
970N/A}
970N/A
970N/A# Directories containing font files
970N/Amy %fontdirs = ();
970N/A
970N/Aopen my $MANIFEST, '<', $manifest
970N/A or die "Cannot open manifest $manifest: $!\n";
970N/A
970N/Awhile (my $man = <$MANIFEST>) {
970N/A if ($man =~ m{path=(\S+)/fonts.dir}) {
970N/A $fontdirs{$1} = $1;
970N/A }
970N/A}
970N/Aclose $MANIFEST;
970N/A
970N/Aforeach my $fd (keys %fontdirs) {
970N/A my $protofontpath = join('/', $proto_dir, $fd);
970N/A my $protometafile = join('/', $proto_dir, $fd, 'fonts.dir');
970N/A my %xlfds = ();
970N/A
1288N/A if (! -f $protometafile) {
1479N/A # mkfontscale -b -s -l is equivalent to mkfontdir
1479N/A run_cmd("$proto_dir/usr/bin/mkfontscale", "-b", "-s", "-l",
1479N/A $protofontpath);
1288N/A }
1288N/A
970N/A open my $XFILE, '<', $protometafile
970N/A or die "Cannot open $protometafile: $!\n";
970N/A
970N/A while (my $x = <$XFILE>) {
970N/A chomp($x);
970N/A if ($x =~ m{\s+}) {
970N/A my ($fontfile, $fontxlfd) = split(/\s+/, $x, 2);
970N/A $xlfds{$fontxlfd} = $fontfile;
970N/A printf
970N/A qq(<transform file path="$fd/%s" -> add info.file.font.xlfd "%s">\n),
970N/A $fontfile, $fontxlfd;
970N/A }
970N/A }
970N/A close $XFILE;
970N/A
970N/A $protometafile = join('/', $proto_dir, $fd, 'fonts.alias');
970N/A
970N/A if (-f $protometafile) {
970N/A
970N/A open my $XFILE, '<', $protometafile
970N/A or die "Cannot open $protometafile: $!\n";
970N/A
970N/A while (my $x = <$XFILE>) {
970N/A chomp($x);
970N/A if ($x =~ m{\s+}) {
970N/A my ($fontalias, $fontxlfd) = split(/\s+/, $x, 2);
970N/A $fontxlfd =~ s{^"(.*)"$}{$1};
970N/A if (exists $xlfds{$fontxlfd}) {
970N/A my $fontfile = $xlfds{$fontxlfd};
970N/A printf
970N/A qq(<transform file path="$fd/%s" -> add info.file.font.xlfd "%s">\n),
970N/A $fontfile, $fontalias;
970N/A } else {
970N/A# print STDERR qq(No match found for "$fontxlfd" in $protometafile\n);
970N/A }
970N/A }
970N/A }
970N/A close $XFILE;
970N/A }
970N/A
970N/A}
970N/A
970N/A# Run fc-scan from the proto area, since it wasn't delivered until build 141
970N/Amy $fc_scan = "$proto_dir/usr/bin/fc-scan";
970N/A
970N/A# See FcPatternFormat(3) for the full definition of the format syntax
970N/A# %{file} => print the named value for this font
970N/A# %{fullname|cescape} => print the named value with C-style string escapes
970N/A# (adds \ in front of \ or " characters)
970N/A# %{?fullname{..A..}{..B..}} => if fullname is defined, then print A, else B
970N/A# []fullname,fullnamelang{..A..} => for each pair of fullname & fullnamelang,
970N/A# print A with those values substituted
970N/Amy $fc_scan_format = q(--format=%{?fullname{%{[]fullname,fullnamelang{<transform file path="%{file}" -> add info.file.font.name:%{fullnamelang} "%{fullname|cescape}">\n}}}{%{[]family,style{<transform file path="%{file}" -> add info.file.font.name "%{family|cescape} %{style|cescape} %{pixelsize}">\n}}}});
970N/A
970N/A
970N/Achdir($proto_dir);
1288N/Arun_cmd($fc_scan, $fc_scan_format, keys %fontdirs);
970N/Aexit(0);
970N/A
1288N/Asub run_cmd {
1288N/A my $cmd = $_[0];
1288N/A system(@_);
1288N/A if ($? == -1) {
1288N/A print STDERR "failed to execute $cmd: $!\n";
1288N/A }
1288N/A elsif ($? & 127) {
1288N/A printf STDERR "$cmd died with signal %d, %s coredump\n",
1288N/A ($? & 127), ($? & 128) ? 'with' : 'without';
1288N/A }
1288N/A elsif ($? != 0) {
1288N/A my $exit_code = $? >> 8;
1288N/A if ($exit_code != 1) {
1288N/A printf STDERR "$cmd exited with value %d\n", $exit_code;
1288N/A exit($exit_code);
1288N/A }
1288N/A }
1288N/A}