"Fossies" - the Fresh Open Source Software Archive

Member "MagickStudio-1.9.6/fonts/type.sh" (14 Feb 2021, 11714 Bytes) of package /linux/www/MagickStudio-1.9.6.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Bash source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 #!/usr/bin/perl -w
    2 #
    3 use strict;
    4 (my $prog = $0) =~ s/^.*\///;
    5 sub Usage {
    6   die @_, &herefile( qq{
    7     | Usage: $prog > ~/.magick/type.xml
    8     |
    9     | Generate an ImageMagick font list "type.xml" file for ALL fonts (both
   10     | true type fonts (ttf) and Ghostscript fonts (afm))  currently on the
   11     | local linux system.  The fonts are found using the linux "locate"
   12     | command, and the output informs IM of their location, font type, name
   13     | and family.
   14     |
   15     | When the file has been generated you can then see a list of the
   16     | fonts found with...
   17     |    convert -list type
   18     | And use the fonts, by name, with commands like...
   19     |    convert -font Candice -pointsize 72 label:Anthony  x:
   20     | Instead of specifying the specific TTF font file
   21     |    convert -font ~/lib/font/truetype/favoriate/candice.ttf \
   22     |            -pointsize 72 label:Anthony  x:
   23     |
   24     | NOTE before IM v6.1.2-3  the font list file was called "type.mgk" and
   25     | not "type.xml".
   26     |
   27     | Note: IM version 5.5.7 installed as a system program (such as from a
   28     | linux RPM) will NOT read this file from the home directory location
   29     | above automatically.  To fix this you may need to add a line to the
   30     | systems "type.mgk" file such as...
   31     |    <include file="../../../../../../../home/anthony/.magick/type.mgk"/>
   32     | Note that the path must be a relative path, thus the numerious ".."
   33     | in the above line, you can specify more ".." than you really need.
   34     |
   35     |  Anthony Thyssen  May 2003
   36   });
   37 }
   38 # Internal working notes...
   39 #
   40 # This script requires the linux "locate" command to find the fonts.
   41 # originally it needed an extrenal tool to read TTF fonts, but now
   42 # that is built-in.
   43 #
   44 # WARNING: Input arguments are NOT tested for correctness.
   45 # This script represents a security risk if used ONLINE.
   46 # I accept no responsiblity for misuse. Use at own risk.
   47 #
   48 # The original version of this hack script was found on
   49 #   http://studio.imagemagick.org/pipermail/magick-users/2003-March/001703.html
   50 # by  raptor <raptor@unacs.bg>, presumaibly around  March 2002
   51 #
   52 # Re-Write by Anthony Thyssen <anthony@cit.gu.edu.au>, August 2002
   53 # May 2003   Update with TTF family names
   54 # Oct 2005   Update to use "getttinfo" is available
   55 #
   56 use strict;
   57 use Fcntl qw( O_RDONLY SEEK_SET );
   58 binmode(STDOUT, ":utf8");
   59 binmode(STDERR, ":utf8");
   60 
   61 my $VERBOSE = 1; # verbose output of fonts found
   62 my $DEBUG   = 0; # debug TTF file decoding
   63 
   64 # ======================================================================
   65 # Subroutines...
   66 # ======================================================================
   67 #
   68 # True Type fonts Handling
   69 #
   70 my $ttf_template = herefile( q{
   71   |   <type
   72   |      format="ttf"
   73   |      name="%s"
   74   |      glyphs="%s"
   75   |      />
   76   });
   77 my $ttf_template_full = herefile( q{
   78   |   <type
   79   |      format="ttf"
   80   |      name="%s"
   81   |      fullname="%s"
   82   |      family="%s"
   83   |      glyphs="%s"
   84   |      />
   85   });
   86 
   87 sub ttf_file_parse {
   88   #
   89   # Method for Parsing TTF files curtesy of
   90   #     Peter N Lewis <peter@stairways.com.au>
   91   #
   92   my $file = $_[0];
   93   my ( $font_family, $font_fullname, $font_psname ) = ( '','','','' );
   94 
   95   my ( $fh, $len );
   96   unless ( sysopen( $fh, $file, O_RDONLY ) ) {
   97     warn "Cannot open $file: $!\n";
   98     return;
   99   }
  100   my $header;
  101   unless ( sysread( $fh, $header, 12 ) ) {
  102     warn "Cant read header: $file";
  103     close($fh);
  104     return;
  105   }
  106   my ( $sfnt_version, $numTables, $searchRange, $entrySelector, $rangeShift
  107      ) = unpack( 'Nnnnn', $header );
  108 
  109   my $sfnt_version_code = unpack( 'A4', $header );
  110   unless (  $sfnt_version == 0x00010000
  111          || $sfnt_version_code eq 'true'
  112          || $sfnt_version_code eq 'typ1' ) {
  113     warn "TTF Version mismatch, not a basic TrueType font file: $file";
  114     close($fh);
  115     return;
  116   }
  117 
  118   #print STDERR "TTF Table count: $numTables\n" if $DEBUG;
  119   foreach ( 1..$numTables ) {
  120     my $table_entry;
  121     unless ( sysread( $fh, $table_entry, 16 ) ) {
  122       warn "Cant read master table $_ from $file";
  123       last;
  124     }
  125 
  126     my ( $table_tag, $table_checkSum, $table_offset, $table_length
  127        ) = unpack( 'A4NNN', $table_entry );
  128     #print STDERR "Table: $table_tag\n" if $DEBUG;
  129     $table_tag eq 'name' or next;
  130 
  131     my $table_header;
  132     sysseek( $fh, $table_offset, SEEK_SET ) or die "Can't seek: $file";
  133     sysread( $fh, $table_header, 6 );
  134     my ( $table_format, $table_count, $table_stringOffset
  135        ) = unpack( 'nnn', $table_header );
  136     print STDERR "Name Table Entries: $table_count\n" if $DEBUG;
  137     my $table_base = $table_offset + 6;
  138     my $storage_base = $table_base + $table_count * 12;
  139 
  140     foreach my $index ( 1..$table_count ) {
  141       my $entry;
  142       sysseek( $fh, $table_base + ($index-1)*12, SEEK_SET )
  143           or die "Cant seek: $file";
  144       sysread( $fh, $entry, 12 );
  145       my ( $name_platformID, $name_encodingID, $name_languageID,
  146            $name_id, $name_length, $name_offset
  147          ) = unpack( 'nnnnnn', $entry );
  148       print STDERR "Index[$index]: ", join ( ", ",
  149               $name_platformID, $name_encodingID, $name_languageID,
  150               $name_id, $name_length, $name_offset ), "\n" if $DEBUG;
  151       #
  152       # ID meanings : figured out from getttinfo
  153       #
  154       # Platform: 0=Apple  1=macintosh  3=microsoft
  155       # Encoding: 0=unicode(8) 1=unicode(16)
  156       # Language: 0=english  1033=English-US  1041=Japanese 2052=Chinese
  157       #
  158       next unless $name_languageID == 0
  159                || $name_languageID == 1033
  160                ;
  161 
  162       my $name;
  163       sysseek( $fh, $storage_base + $name_offset, SEEK_SET )
  164             or die "Cant seek: $file";
  165       sysread( $fh, $name, $name_length );
  166 
  167       # Decode UTF-16 to UTF-8 if nessary
  168       $name = pack("U*",unpack("n*", $name)) if $name_encodingID == 1;
  169       $name =~ s/\0//g;   # clean fonts use UTF-16 when it should be UTF-8
  170       print STDERR "$name\n" if $DEBUG;
  171 
  172       $font_family = $name       if $name_id == 1;
  173       #font_subfamily = $name    if $name_id == 2;  # (EG: Regular)
  174       #font_identifier = $name   if $name_id == 3;  # Unique Name
  175       $font_fullname = $name     if $name_id == 4;
  176       #font_version = $name      if $name_id == 5;
  177       $font_psname = $name       if $name_id == 6;  # Postscipt Name
  178       #font_trademark = $name    if $name_id == 7;
  179       #font_manufacturer = $name if $name_id == 8;
  180       #font_designer = $name     if $name_id == 9;
  181     }
  182     last;  # found "name" table -- skip any other tables as irrelevent
  183   }
  184   close( $fh );
  185   return ( $font_family, $font_fullname, $font_psname );
  186 }
  187 
  188 sub ttf_name {
  189   my $file = shift;
  190 
  191   my ( $family, $fullname, $psname ) = &ttf_file_parse( $file );
  192   print STDERR "$file\n\t==> $family -- $fullname -- $psname\n" if $DEBUG;
  193 
  194   $fullname =~ s/[^\s\w-]//g;        # Check: Pepsi.ttf
  195   $fullname =~ s/^\s+//;
  196   $fullname =~ s/\s+$//;
  197   $fullname =~ s/(^|\s)-/$1/g;
  198   $fullname =~ s/-(\s|$)/$1/g;
  199 
  200   $family   =~ s/[^\s\w-]//g;        # Check: Pepsi.ttf
  201   $family   =~ s/^\s*//;
  202   $family   =~ s/\s*$//;
  203   $family   =~ s/\s*(MS|ITC)$//;     # font factory ititials
  204   $family   =~ s/^(MS|ITC)\s*//;
  205   $family   =~ s/\s*(FB|MT)\s*/ /;   # Check: MaturaScriptCapitals
  206   $family   =~ s/^Monotype\s*//;     # Check: Corsiva
  207   $family   =~ s/^AR PL\s*//;        # Check: gkai00mp.ttf
  208 
  209   # Determine simple font name 
  210   #   Junk/abbr decriptive strings, foundaries, etc
  211   #   Test with the fonts given
  212   my $name = ($fullname);
  213   $name =~ s/-/ /g;
  214   $name   =~ s/\s*(MS|ITC)$//;  # font factory ititials
  215   $name   =~ s/^(MS|ITC)\s*//;
  216   $name   =~ s/\s*(FB|MT)\s*/ /;   # Check: MaturaScriptCapitals
  217   $name   =~ s/^Monotype\s*//;     # Check: Corsiva
  218   $name   =~ s/^AR PL\s*//;         # Check: gkai00mp.ttf
  219 
  220   $name =~ s/Regular//g;                # Check: Gecko
  221   $name =~ s/\bReg\b//g;                # Check: agencyr.ttf
  222   $name =~ s/\bNormal\b//g;
  223   #$name =~ s/\bSans\b//g;
  224   $name =~ s/\bDemi\s*[Bb]old\b/Db/g;
  225   $name =~ s/\bCondensed\b/C/g;
  226   $name =~ s/\bBold\b/B/g;
  227   $name =~ s/\bItalic\b/I/g;
  228   $name =~ s/\bExtra[Bb]old\b/Xb/g;
  229   $name =~ s/\bBlack\b/Bk/g;
  230   $name =~ s/\bHeavy\b/H/g;
  231   $name =~ s/\bMedium\b/M/g;            # Check: gkai00mp.ttf
  232   $name =~ s/\bLight\b/L/g;
  233   $name =~ s/\bOblique\b/Ob/g;
  234 
  235   $name =~ s/\s+//g;
  236 
  237   $fullname =~ s/\s+/ /g;
  238   $fullname =~ s/\s$//;
  239   $fullname =~ s/^\s//;
  240 
  241   # Failed to parse TTF file?
  242   return( ( $file =~ m/^.*\/(.*?).ttf$/ )[0] ) unless $name;
  243 
  244   return ($name, $fullname, $family);  # return the name if found!
  245 }
  246 
  247 sub do_ttf_fonts {
  248   for my $file ( locate('.ttf') ) {
  249     chop $file;
  250     my (@ttf) = ttf_name($file);
  251 
  252     print STDERR join( ' - ', @ttf), "\n"  if $VERBOSE;
  253     printf $ttf_template, @ttf, $file       if @ttf == 1;
  254     printf $ttf_template_full, @ttf, $file  if @ttf == 3;
  255   }
  256 }
  257 
  258 
  259 #---------------------------
  260 #
  261 # Adobe Type fonts
  262 #
  263 # Get font name from the AFM file
  264 my $afm_template_full = herefile( q{
  265   |   <type
  266   |      format="type1"
  267   |      name="%s"
  268   |      fullname="%s"
  269   |      family="%s"
  270   |      glyphs="%s"
  271   |      metrics="%s"
  272   |      />
  273   });
  274 
  275 sub afm_name {
  276   my $file = shift;
  277 
  278   my( $name, $fullname, $family ) = ('','','');
  279   if ( open AFM, $file ) {
  280     while( <AFM> ) {
  281       chop; last if /^StartCharMetrics/;
  282       #$name     = $1  if /^FontName (.*)/;
  283       $fullname = $1  if /^FullName (.*)/;
  284       $family   = $1  if /^FamilyName (.*)/;
  285     }
  286     close AFM;
  287 
  288     $family =~ s/\s*L$//;    # just the stupid 'L'
  289     $fullname =~ s/\bL\b//;
  290 
  291     $name = $fullname;
  292 
  293     $name =~ s/\bRegular\b//;            # Junk/abbr decriptive strings
  294     $name =~ s/\bDemi\s*[Bb]old\b/Db/g;
  295     $name =~ s/\bCondensed\b/C/g;
  296     $name =~ s/\bBold\b/B/g;
  297     $name =~ s/\bItalic\b/I/g;
  298     $name =~ s/\bExtra[Bb]old\b/Xb/g;
  299     $name =~ s/\bBlack\b/Bk/g;
  300     $name =~ s/\bHeavy\b/H/g;
  301     $name =~ s/\bLight\b/L/g;
  302 
  303     $name =~ s/[-\s]+//g;
  304     $fullname =~ s/\s+/ /g;
  305     $fullname =~ s/\s$//g;
  306     $fullname =~ s/^\s//g;
  307   } else {
  308     warn "Cannot open $file";
  309   }
  310 
  311   return ($name, $fullname, $family ) if $name && $fullname && $family;
  312 }
  313 
  314 sub do_afm_fonts {
  315   my %atf;
  316   # locate abode font files
  317   map { chop; my ($k) = m/^(.*?).pfb*$/; $atf{$k}{pfb} = $_ } locate('.pfb');
  318   map { chop; my ($k) = m/^(.*?).afm*$/; $atf{$k}{afm} = $_ } locate('.afm');
  319 
  320   # for each Abode font where BOTH files were found.
  321   for my $key (keys %atf) {
  322     next unless $atf{$key}{pfb} && $atf{$key}{afm};
  323     my (@afm) = afm_name($atf{$key}{afm});
  324 
  325     print STDERR join( ' - ', @afm), "\n"   if $VERBOSE;
  326     printf $afm_template_full, @afm, $atf{$key}{pfb}, $atf{$key}{afm}
  327                                                          if @afm == 3;
  328   }
  329 }
  330 
  331 # -----------------------------
  332 #
  333 #  Miscellanous functions
  334 #
  335 sub locate {
  336   #return `locate -r $_[0]\$`;
  337   return `locate $_[0] | grep $_[0]\$`;
  338 }
  339 
  340 sub herefile {  # Handle a multi-line quoted indented string
  341   my $string = shift;
  342   $string =~ s/^\s*//;        # remove start spaces
  343   $string =~ s/^\s*\| ?//gm;  # remove line starts
  344   $string =~ s/\s*$/\n/g;     # remove end spaces
  345   return $string;
  346 }
  347 
  348 # ======================================================================
  349 # Main Function
  350 # ======================================================================
  351 
  352 
  353 # HACK -- extract font names for the given TTF font file.
  354 if ( @ARGV ) {
  355   $DEBUG=1,shift if $ARGV[0] =~ /^-d$/i;
  356   Usage     unless $ARGV[0] =~ /\.ttf$/i;
  357   for my $file ( @ARGV ) {
  358     print join( ' - ', ttf_name($file) ), "\n";
  359   }
  360   exit 0;
  361 }
  362 
  363 # Generate the "type.xml" file.
  364 
  365 # Do the job...
  366 print herefile( q{
  367   | <?xml version="1.0"?>
  368   | <typemap>
  369 });
  370 
  371 print STDERR "Doing TTF fonts\n" if $VERBOSE;
  372 do_ttf_fonts();
  373 print STDERR "Doing ATM fonts\n" if $VERBOSE;
  374 do_afm_fonts();
  375 
  376 print "</typemap>\n";
  377 
  378