doc/findfont.ph

   1 #!/usr/bin/perl
   2 ## --------------------------------------------------------------------------
   3 ##
   4 ##   Copyright 1996-2017 The NASM Authors - All Rights Reserved
   5 ##   See the file AUTHORS included with the NASM distribution for
   6 ##   the specific copyright holders.
   7 ##
   8 ##   Redistribution and use in source and binary forms, with or without
   9 ##   modification, are permitted provided that the following
  10 ##   conditions are met:
  11 ##
  12 ##   * Redistributions of source code must retain the above copyright
  13 ##     notice, this list of conditions and the following disclaimer.
  14 ##   * Redistributions in binary form must reproduce the above
  15 ##     copyright notice, this list of conditions and the following
  16 ##     disclaimer in the documentation and/or other materials provided
  17 ##     with the distribution.
  18 ##
  19 ##     THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
  20 ##     CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
  21 ##     INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
  22 ##     MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  23 ##     DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
  24 ##     CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  25 ##     SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
  26 ##     NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
  27 ##     LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  28 ##     HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
  29 ##     CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  30 ##     OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
  31 ##     EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  32 ##
  33 ## --------------------------------------------------------------------------
  34
  35 #
  36 # Try our best to find a specific PostScipt font in the system.
  37 # We need to find the font files so we can extract the metrics.
  38 # Sadly there isn't any reasonable Perl module to do this for us,
  39 # as far as I can tell.
  40 #
  41
  42 use strict;
  43 use File::Spec;
  44 use File::Find;
  45
  46 require 'afmmetrics.ph';
  47 require 'ttfmetrics.ph';
  48
  49 my %font_info_hash = ();
  50 my $fonts_scanned = 0;
  51 my %prefs = { 'otf' => 1, 'ttf' => 2, 'pfa' => 3, 'pfb' => 4 };
  52
  53 sub add_file_to_font_hash($) {
  54     my($filename) = @_;
  55
  56     return unless ( -f $filename );
  57     return unless ( $filename =~ /^(.*)\.([[:alnum:]]+)$/ );
  58
  59     my $filestem = $1;
  60     my $fonttype = $2;
  61     my $fontdata;
  62
  63     if ( $filename =~ /\.(otf|ttf)$/i ) {
  64         $fontdata = parse_ttf_file($filename);
  65     } elsif ( $filename =~ /\.(pfa|pfb)$/i ) {
  66         if ( -f "${filestem}.afm" ) {
  67             $fontdata = parse_afm_file($filestem, $fonttype);
  68         }
  69     }
  70
  71     return unless (defined($fontdata));
  72
  73     $fontdata->{filename} = $filename;
  74
  75     my $oldinfo = $font_info_hash{$fontdata->{name}};
  76
  77     if (!defined($oldinfo) ||
  78         $prefs{$fontdata->{type}} < $prefs{$oldinfo->{type}}) {
  79         $font_info_hash{$fontdata->{name}} = $fontdata;
  80     }
  81 }
  82
  83 my $win32_ok = eval {
  84     require Win32::TieRegistry;
  85     Win32::TieRegistry->import();
  86     1;
  87 };
  88
  89 # Based on Font::TTF::Win32 by
  90 # Martin Hosken <http://scripts.sil.org/FontUtils>.
  91 # LICENSING
  92 #
  93 #   Copyright (c) 1998-2014, SIL International (http://www.sil.org)
  94 #
  95 #   This module is released under the terms of the Artistic License 2.0.
  96 #   For details, see the full text of the license in the file LICENSE.
  97 sub scanfonts_win32() {
  98     return unless ($win32_ok);
  99
 100     my $Reg = $::Registry->Open('', {Access=>'KEY_READ', Delimiter=>'/'});
 101     my $fd;
 102     foreach my $win ('Windows NT', 'Windows') {
 103         $fd = $Reg->{"HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/$win/CurrentVersion/Fonts"};
 104         last if (defined($fd));
 105     }
 106     return unless (defined($fd));
 107
 108     foreach my $font (keys(%$fd)) {
 109         my($fname, $ftype) = ($font =~ m:^/(.+?)(| \([^\(\)]+\))$:);
 110         next unless ($ftype =~ / \((TrueType|OpenType)\)$/);
 111         my $file = File::Spec->rel2abs($fd->{$font}, $ENV{'windir'}.'\\fonts');
 112         add_file_to_font_hash($file);
 113     }
 114 }
 115
 116 sub font_search_file {
 117     add_file_to_font_hash($_);
 118 }
 119
 120 sub findfont($) {
 121     my($fontname) = @_;
 122     my $win32 = eval {
 123         require Font::TTF::Win32;
 124         Font::TTF::Win32->import();
 125         1;
 126     };
 127     my($file, $psname, $fontdata);
 128
 129     if (exists($font_info_hash{$fontname})) {
 130         return $font_info_hash{$fontname};
 131     }
 132
 133     # Are we on a system that uses fontconfig?
 134     # NOTE: use a single string for the command here, or this
 135     # script dies horribly on Windows, even though this isn't really
 136     # applicable there...
 137     if (open(my $fh, '-|',
 138              "fc-match -f \"%{file}\\n%{postscriptname}\\n\" ".
 139              "\" : postscriptname=$fontname\"")) {
 140         chomp($file = <$fh>);
 141         chomp($psname = <$fh>);
 142         close($fh);
 143         if ( -f $file ) {
 144             if ($psname eq $fontname) {
 145                 add_file_to_font_hash($file);
 146             }
 147             if (!exists($font_info_hash{$fontname})) {
 148                 $font_info_hash{$fontname} = undef;
 149             }
 150             return $font_info_hash{$fontname};
 151         }
 152     }
 153
 154     if (exists($font_info_hash{$fontname})) {
 155         return $font_info_hash{$fontname};
 156     } elsif ($fonts_scanned >= 1) {
 157         return $font_info_hash{$fontname} = undef;
 158     }
 159
 160     scanfonts_win32();
 161     $fonts_scanned = 1;
 162
 163     if (exists($font_info_hash{$fontname})) {
 164         return $font_info_hash{$fontname};
 165     } elsif ($fonts_scanned >= 2) {
 166         return $font_info_hash{$fontname} = undef;
 167     }
 168
 169     # Search a set of possible locations for a file, from a few different
 170     # systems...
 171     my @dirs = ('fonts', '/usr/share/fonts', '/usr/lib/fonts', '/Library/Fonts');
 172     push @dirs, $ENV{'windir'}.'\\fonts' if (defined $ENV{'windir'});
 173     push @dirs, $ENV{'HOME'}.'/.fonts', $ENV{'HOME'}.'/Library/Fonts'
 174         if (defined $ENV{'HOME'});
 175
 176     find({wanted => \&font_search_file, follow=>1, no_chdir=>1}, @dirs);
 177     $fonts_scanned = 2;
 178
 179     return $font_info_hash{$fontname};
 180 }
 181
 182 1;