1 #! /usr/perl5/bin/perl -w

     2 

     3 #

     4 # Copyright (c) 2010, Oracle and/or its affiliates. All rights reserved.

     5 #

     6 # Permission is hereby granted, free of charge, to any person obtaining a

     7 # copy of this software and associated documentation files (the "Software"),

     8 # to deal in the Software without restriction, including without limitation

     9 # the rights to use, copy, modify, merge, publish, distribute, sublicense,

    10 # and/or sell copies of the Software, and to permit persons to whom the

    11 # Software is furnished to do so, subject to the following conditions:

    12 #

    13 # The above copyright notice and this permission notice (including the next

    14 # paragraph) shall be included in all copies or substantial portions of the

    15 # Software.

    16 #

    17 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR

    18 # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,

    19 # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL

    20 # THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER

    21 # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING

    22 # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER

    23 # DEALINGS IN THE SOFTWARE.

    24 #

    25 #

    26 

    27 require 5.005;				# minimal Perl version required

    28 use strict;				#

    29 use diagnostics;			#

    30 use integer;				#

    31 use File::Spec;				# pathname manipulation routines

    32 use English qw( -nomatchvars );

    33 use Getopt::Long;

    34 

    35 # Required arguments:

    36 # -p <proto_area>

    37 # -m <manifest>

    38 

    39 my $proto_dir;

    40 my $manifest;

    41 

    42 my $result = GetOptions('p|protodir=s' => \$proto_dir,

    43                         'm|manifest=s' => \$manifest);

    44 

    45 if (!defined($proto_dir)) {

    46   print STDERR "Missing required protodir argument\n";

    47   exit(1);

    48 }

    49 

    50 if (!defined($manifest)) {

    51   print STDERR "Missing required manifest argument\n";

    52   exit(1);

    53 }

    54 

    55 # Directories containing font files

    56 my %fontdirs = ();

    57 

    58 open my $MANIFEST, '<', $manifest

    59   or die "Cannot open manifest $manifest: $!\n";

    60 

    61 while (my $man = <$MANIFEST>) {

    62   if ($man =~ m{path=(\S+)/fonts.dir}) {

    63     $fontdirs{$1} = $1;

    64   }

    65 }

    66 close $MANIFEST;

    67 

    68 foreach my $fd (keys %fontdirs) {

    69   my $protofontpath = join('/', $proto_dir, $fd);

    70   my $protometafile = join('/', $proto_dir, $fd, 'fonts.dir');

    71   my %xlfds = ();

    72 

    73   open my $XFILE, '<', $protometafile

    74     or die "Cannot open $protometafile: $!\n";

    75 

    76   while (my $x = <$XFILE>) {

    77     chomp($x);

    78     if ($x =~ m{\s+}) {

    79       my ($fontfile, $fontxlfd) = split(/\s+/, $x, 2);

    80       $xlfds{$fontxlfd} = $fontfile;

    81       printf

    82 	qq(<transform file path="$fd/%s" -> add info.file.font.xlfd "%s">\n),

    83 	$fontfile, $fontxlfd;

    84     }

    85   }

    86   close $XFILE;

    87 

    88   $protometafile = join('/', $proto_dir, $fd, 'fonts.alias');

    89 

    90   if (-f $protometafile) {

    91 

    92     open my $XFILE, '<', $protometafile

    93       or die "Cannot open $protometafile: $!\n";

    94 

    95     while (my $x = <$XFILE>) {

    96       chomp($x);

    97       if ($x =~ m{\s+}) {

    98 	my ($fontalias, $fontxlfd) = split(/\s+/, $x, 2);

    99 	$fontxlfd =~ s{^"(.*)"$}{$1};

   100 	if (exists $xlfds{$fontxlfd}) {

   101 	  my $fontfile = $xlfds{$fontxlfd};

   102 	  printf

   103 	    qq(<transform file path="$fd/%s" -> add info.file.font.xlfd "%s">\n),

   104 	      $fontfile, $fontalias;

   105 	} else {

   106 #	  print STDERR qq(No match found for "$fontxlfd" in $protometafile\n);

   107 	}

   108       }

   109     }

   110     close $XFILE;

   111   }

   112 

   113 }

   114 

   115 # Run fc-scan from the proto area, since it wasn't delivered until build 141

   116 my $fc_scan = "$proto_dir/usr/bin/fc-scan";

   117 

   118 # See FcPatternFormat(3) for the full definition of the format syntax

   119 #  %{file} => print the named value for this font

   120 #  %{fullname|cescape} => print the named value with C-style string escapes

   121 #			  (adds \ in front of \ or " characters)

   122 #  %{?fullname{..A..}{..B..}} => if fullname is defined, then print A, else B

   123 #  []fullname,fullnamelang{..A..} => for each pair of fullname & fullnamelang,

   124 #					print A with those values substituted

   125 my $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}}}});

   126 

   127 

   128 chdir($proto_dir);

   129 system($fc_scan, $fc_scan_format, keys %fontdirs);

   130 if ($? == -1) {

   131   print STDERR "failed to execute $fc_scan: $!\n";

   132 }

   133 elsif ($? & 127) {

   134   printf STDERR "$fc_scan died with signal %d, %s coredump\n",

   135     ($? & 127),  ($? & 128) ? 'with' : 'without';

   136 }

   137 elsif ($? != 0) {

   138   my $exit_code = $? >> 8;

   139   if ($exit_code != 1) {

   140     printf STDERR "$fc_scan exited with value %d\n", $exit_code;

   141     exit($exit_code);

   142   }

   143 }

   144 

   145 exit(0);

   146