lib/scripts/listFontWithLang.pl

   1 #! /usr/bin/env perl
   2 # -*- mode: perl; -*-
   3
   4 # file listFontWithLang.pl
   5 # This file is part of LyX, the document processor.
   6 # Licence details can be found in the file COPYING
   7 # or at http://www.lyx.org/about/licence.php
   8 #
   9 # author Kornel Benko
  10 # Full author contact details are available in the file CREDITS
  11 # or at https://www.lyx.org/Credits
  12 #
  13 # Usage: listFontWithLang.pl <options>
  14 #   Displays installed system font names selected by <options>
  15 #   Option-strings with more that 1 char need be prefixed by '--'
  16 #
  17 # Option to get list of options: -h
  18 #
  19 # Some equivalencies for instance with option -n
  20 #       -n arial
  21 #       -N=arial
  22 #       --nAme=Arial
  23 #       --name arial
  24 # Options and option-parameter are case insensitive
  25
  26 BEGIN {
  27     use File::Spec;
  28     my $p = File::Spec->rel2abs( __FILE__ );
  29     $p =~ s/[\/\\]?[^\/\\]+$//;
  30     unshift(@INC, $p);
  31 }
  32
  33 use strict;
  34 use warnings;
  35 use GetOptions;
  36
  37 sub convertlang($);
  38 sub extractlist($$$);   # my ($l, $islang, $txt, $rres) = @_;
  39 sub getIndex($$);
  40 sub getVal($$$);        # my ($l, $txtval, $txtlang) = @_;
  41 sub getproperties($$$$);
  42 sub correctstyle($);
  43
  44 # Following fields for a parameter can be defined:
  45 # fieldname:         Name of entry in %options
  46 # type:              [:=][sif], ':' = optional, '=' = required, 's' = string, 'i' = integer, 'f' = float
  47 # alias:             reference to a list of aliases e.g. ["alias1", "alias2", ... ]
  48 # listsep:           Separator for multiple data
  49 # comment:           Parameter description
  50 my %optionsDef = (
  51   # help + verbose already handled in 'GetOptions'
  52   "l"       => {fieldname => "Lang",
  53                 type => "=s", alias=>["lang"],
  54                 comment => "Comma separated list of desired languages"},
  55   "n"       => {fieldname => "FontName", listsep => ',',
  56                 type => "=s", alias => ["name"],
  57                 comment => "Select font-names matching these (comma separated) regexes"},
  58   "nn"      => {fieldname => "NFontName",
  59                 type => "=s", listsep => ',',
  60                 comment => "Select font-names NOT matching these (comma separated) regexes"},
  61   "ps"      => {fieldname => "Scripts", alias => ["printscripts"],
  62                 comment => "Print supported scripts"},
  63   "pl"      => {fieldname => "PrintLangs", alias => ["printlangs"],
  64                 comment => "Print supported languages"},
  65   "pp"      => {fieldname => "PrintProperties", alias => ["printproperties"],
  66                 comment => "Print properties from weight, slant and width"},
  67   "pf"      => {fieldname => "PrintFiles", alias => ["printfiles"],
  68                 comment => "Print font file names"},
  69   "p"       => {fieldname => "Property",
  70                 type => "=s", listsep => ',',
  71                 comment => "Select fonts with properties matching these (comma separated) regexes"},
  72   "np"      => {fieldname => "NProperty",
  73                 type => "=s", listsep => ',',
  74                 comment => "Select fonts with properties NOT matching these (comma separated) regexes"},
  75   "pw"      => {fieldname => "PrintWarnings",
  76                 comment => "Print warnings about discarded/overwritten fonts, conflicting styles"},
  77 );
  78 my %options = %{&handleOptions(\%optionsDef)};
  79
  80 $options{Lang} = "" if (! defined($options{Lang}));
  81
  82 #############################################################
  83
  84 my @langs = split(',', $options{Lang});
  85 for my $lg (@langs) {
  86   $lg = &convertlang($lg);
  87 }
  88
  89 my $cmd = "fc-list";
  90 if (defined($langs[0])) {
  91   $cmd .= " :lang=" . join(',', @langs);
  92 }
  93
  94 my $format = "foundry=\"%{foundry}\" postscriptname=\"%{postscriptname}\" fn=\"%{fullname}\" fnl=\"%{fullnamelang}\" family=\"%{family}\" flang=\"%{familylang}\" style=\"%{style}\" stylelang=\"%{stylelang}\"";
  95
  96 if (exists($options{Scripts})) {
  97   $format .= " script=\"%{capability}\"";
  98 }
  99 if (exists($options{PrintLangs}) || defined($langs[0])) {
 100   $format .= " lang=\"%{lang}\"";
 101 }
 102 if (exists($options{PrintProperties}) || defined($options{Property})) {
 103   $format .= " weight=%{weight} slant=%{slant} width=%{width} spacing=%{spacing}";
 104 }
 105 $format .= " file=\"%{file}\" abcd\\n";
 106 $cmd .= " -f '$format'";
 107 #print "$cmd\n";
 108
 109 my %ftypes = (
 110   # Dummy internal map
 111   0 => "Serif",
 112   100 => "Sans",
 113   "default" => "Serif",
 114 );
 115
 116 my %weights = (
 117   0 => "Thin",
 118   40 => "Extralight",
 119   50 => "Light",
 120   55 => "Semilight",
 121   75 => "Book",
 122   80 => "Regular",
 123   100 => "Medium",
 124   180 => "Semibold",
 125   200 => "Bold",
 126   205 => "Extrabold",
 127   210 => "Black",
 128 );
 129
 130 my %slants = (
 131   0 => "Roman",
 132   100 => "Italic",
 133   110 => "Oblique",
 134 );
 135
 136 my %widths = (
 137   50 => "Ultracondensed",
 138   63 => "Extracondensed",
 139   75 => "Condensed",
 140   87 => "Semicondensed",
 141   100 => "Normal",
 142   113 => "Semiexpanded",
 143   125 => "Expanded",
 144   150 => "Extraexpanded",
 145   200 => "Ultraexpanded",
 146 );
 147
 148 my %spacings = (
 149   0 => "Proportional",
 150   90 => "Dual",
 151   100 => "Mono",
 152   110 => "Charcell",
 153   "default" => "Proportional",
 154 );
 155
 156 # Build reverse mappings, (not needed yet)
 157 for my $txt (qw(ftypes weights slants widths spacings)) {
 158   my $map;
 159   eval "\$map = \\%$txt";
 160   for my $key (keys %{$map}) {
 161     next if ($key !~ /^\d+$/);
 162     my $value = lc($map->{$key});
 163     $map->{"r"}->{$value} = $key;
 164   }
 165 }
 166
 167 # key:= fontname
 168 #     subkey foundry
 169 #            subfoundry
 170 my %collectedfonts = ();
 171 my %fontpriority = (
 172   otf => 0,                # type 2, opentype CFF (Compact Font Format)
 173   ttc => 1.1,              # type 1 (True Type font Collection)
 174   ttf => 1.2,              # type 1 (True Type Font)
 175   woff=> 1.3,              # type 1 (Web Open Font Format)
 176   t1  => 1.4,              # type 1 (postscript)
 177   pfb => 1.5,              # type 1 (Printer Font Binary)
 178   pfa => 1.6,              # type 1 (Printer Font Ascii)
 179   pcf => 5,                # Bitmap (Packaged Collaboration Files)?
 180 );
 181 my $nexttype = 6;
 182
 183 if (open(FI,  "$cmd |")) {
 184  NXTLINE: while (my $l = <FI>) {
 185     chomp($l);
 186     while ($l !~ /abcd$/) {
 187       $l .= <FI>;
 188       chomp($l);
 189     }
 190     my $file = "";
 191     my $fonttype;
 192     if ($l =~ /file=\"([^\"]+)\"/) {
 193       $file = $1;
 194       #next if ($file !~ /\.(otf|ttf|pfa|pfb|pcf|ttc)$/i);
 195       if ($file !~ /\.([a-z0-9]{2,5})$/i) {
 196         print "Unhandled extension for file $file\n";
 197         next;
 198       }
 199       $fonttype = lc($1);
 200       if (! defined($fontpriority{$fonttype})) {
 201         print "Added extension $fonttype for file $file\n";
 202         $fontpriority{$fonttype} = $nexttype;
 203         $nexttype++;
 204       }
 205     }
 206     my $nfound = 0;
 207     my %usedlangs = ();
 208     if ($l =~ / lang=\"([^\"]+)\"/) {
 209       my @ll = split(/\|/, $1);
 210       for my $lx (@ll) {
 211         $usedlangs{&convertlang($lx)} = 1;
 212       }
 213     }
 214
 215     for my $lang (@langs) {
 216       next NXTLINE if (! defined($usedlangs{$lang}));
 217     }
 218     next if ($nfound);
 219     my $style = &getVal($l, "style", "stylelang");
 220     $style =~ s/^\\040//;
 221     my $fullname = &getVal($l, "fn", "fnl");
 222     my $postscriptname = "";
 223     if ($l =~ /postscriptname=\"([^\"]+)\"/) {
 224       $postscriptname = $1;
 225     }
 226     my $family = &getVal($l, "family", "flang");
 227     $family =~ s/\\040/\-/;
 228     my $fontname;
 229     if (length($family) < 3) {
 230       if (length($postscriptname) < 2) {
 231         $fontname = $fullname;
 232       }
 233       else {
 234         $fontname = $postscriptname;
 235       }
 236     }
 237     else {
 238       $fontname = "$family $style";
 239     }
 240     if (defined($options{NFontName})) {
 241       for my $fn (@{$options{NFontName}}) {
 242         next NXTLINE if ($fontname =~ /$fn/i);
 243       }
 244     }
 245     if (defined($options{FontName})) {
 246       for my $fn (@{$options{FontName}}) {
 247         next NXTLINE if ($fontname !~ /$fn/i);
 248       }
 249     }
 250     my $props = "";
 251     my @errors = ();
 252     if (exists($options{PrintProperties}) || defined($options{Property}) || defined($options{NProperty})) {
 253       my $properties = getproperties($l, $family, $style, \@errors);
 254       if (defined($options{Property})) {
 255         for my $pn (@{$options{Property}}) {
 256           next NXTLINE if ($properties !~ /$pn/i);
 257         }
 258       }
 259       if (defined($options{NProperty})) {
 260         for my $pn (@{$options{NProperty}}) {
 261           next NXTLINE if ($properties =~ /$pn/i);
 262         }
 263       }
 264       if (exists($options{PrintProperties})) {
 265         $props .= "($properties)";
 266       }
 267     }
 268
 269     if (exists($options{PrintLangs})) {
 270       $props .= '(' . join(',', sort keys %usedlangs) . ')';
 271     }
 272     if (exists($options{Scripts})) {
 273       if ($l =~ / script=\"([^\"]+)\"/) {
 274         my @scripts = split(/\s+/, $1);
 275         for my $ent (@scripts) {
 276           $ent =~ s/^\s*otlayout://;
 277           $ent = lc($ent);
 278         }
 279         $props .= '(' . join(',', @scripts) . ')';
 280       }
 281     }
 282     my $foundry = "";
 283     if ($l =~ /foundry=\"([^\"]+)\"/) {
 284       $foundry = $1;
 285       $foundry =~ s/^\s+//;
 286       $foundry =~ s/\s+$//;
 287     }
 288     if (defined($collectedfonts{$fontname}->{$foundry}->{errors})) {
 289       # Apparently not the first one, so add some info
 290       my $oldfonttype = $collectedfonts{$fontname}->{$foundry}->{fonttype};
 291       if (defined($errors[0])) {
 292         push(@{$collectedfonts{$fontname}->{$foundry}->{errors}}, @errors);
 293       }
 294       if ($fontpriority{$oldfonttype} > $fontpriority{$fonttype}) {
 295         push(@{$collectedfonts{$fontname}->{$foundry}->{errors}}, "Warning: overwriting old info for file: " . $collectedfonts{$fontname}->{$foundry}->{file});
 296       }
 297       else {
 298         push(@{$collectedfonts{$fontname}->{$foundry}->{errors}}, "Warning: discarding new info for file: $file");
 299         next;
 300       }
 301     }
 302     else {
 303       $collectedfonts{$fontname}->{$foundry}->{errors} = \@errors;
 304     }
 305     $collectedfonts{$fontname}->{$foundry}->{props} = $props;
 306     $collectedfonts{$fontname}->{$foundry}->{file} = $file;
 307     $collectedfonts{$fontname}->{$foundry}->{fonttype} = $fonttype;
 308   }
 309   close(FI);
 310 }
 311
 312 for my $fontname (sort keys %collectedfonts) {
 313   my @foundries = sort keys %{$collectedfonts{$fontname}};
 314   my $printfoundries = 0;
 315   if (defined($foundries[1])) {
 316     $printfoundries = 1;
 317   }
 318   for my $foundry (@foundries) {
 319     if (exists($options{PrintWarnings})) {
 320       for my $err (@{$collectedfonts{$fontname}->{$foundry}->{errors}}) {
 321         print "$err\n";
 322       }
 323     }
 324     print "Font : $fontname";
 325     if ($printfoundries && ($foundry ne "")) {
 326       print " \[$foundry\]";
 327     }
 328     print $collectedfonts{$fontname}->{$foundry}->{props};
 329     if (exists($options{PrintFiles})) {
 330       print ": " . $collectedfonts{$fontname}->{$foundry}->{file} . "\n";
 331     }
 332     else {
 333       print "\n";
 334     }
 335   }
 336 }
 337
 338 exit(0);
 339 #################################################################################
 340 sub convertlang($)
 341 {
 342   my ($ilang) = @_;
 343   if ($ilang =~ /^\s*([a-z]+)([\-_]([a-z]+))?\s*$/i) {
 344     my ($x, $y) = ($1, $3);
 345     if (defined($y)) {
 346       $ilang = lc($x) . '-' . lc($y);
 347     }
 348     else {
 349       $ilang = lc($x);
 350     }
 351   }
 352   return($ilang);
 353 }
 354
 355 sub extractlist($$$)
 356 {
 357   my ($l, $islang, $txt, $rres) = @_;
 358   my @res = ();
 359   if ($l =~ /$txt=\"([^\"]+)\"/) {
 360     @{res} = split(',', $1);
 361     if ($islang) {
 362       for my $lg (@res) {
 363         $lg = &convertlang($lg);
 364       }
 365     }
 366   }
 367   @{$rres} = @res;
 368 }
 369
 370 sub getIndex($$)
 371 {
 372   my ($lang, $rlangs) = @_;
 373   for (my $i = 0; defined($rlangs->[$i]); $i++) {
 374     return $i if ($rlangs->[$i] eq $lang);
 375   }
 376   return(-1);
 377 }
 378
 379 sub getVal($$$)
 380 {
 381   my ($l, $txtval, $txtlang) = @_;
 382   my @values = ();
 383   my @langs = ();
 384   &extractlist($l, 0, $txtval, \@values);
 385   return("") if (! defined($values[0]));
 386   &extractlist($l, 1, $txtlang, \@langs);
 387   my $i = &getIndex("en", \@langs);
 388   return ($values[$i]) if ($i >= 0);
 389   return($values[0]);
 390 }
 391
 392 sub getsinglevalue($$$)
 393 {
 394   my ($l, $txt, $rMap, $rget) = @_;
 395   my $val;
 396   if ($l =~ / $txt=(\d+)/) {
 397     $val = $1;
 398     # Search for nearest value to $val
 399     if (defined($rMap->{$val})) {
 400       return($rMap->{$val});
 401     }
 402     my $maxv = -1;
 403     my $minv = 1000;
 404     for my $key (keys %{$rMap}) {
 405       next if ($key !~ /^\d+$/);
 406       my $diff = abs($key - $val);
 407       if ($diff < $minv) {
 408         $maxv = $key;
 409         $minv = $diff;
 410       }
 411       elsif ($diff == $minv) {
 412         if ($key > $maxv) {
 413           $maxv = $key;
 414         }
 415       }
 416     }
 417     if (! defined($rMap->{$maxv})) {
 418       print "ERROR2: txt=$txt, val=$val\n";
 419       exit(-2);
 420     }
 421     if ($val > $maxv) {
 422       return($rMap->{$maxv} . "+$minv");
 423     }
 424     else {
 425       return($rMap->{$maxv} . "-$minv");
 426     }
 427   }
 428   else {
 429     return(undef);
 430   }
 431 }
 432
 433 sub addTxt($$)
 434 {
 435   my ($txt, $val) = @_;
 436   return("$txt($val)");
 437 }
 438
 439 sub getftype($$)
 440 {
 441   my ($family, $style) = @_;
 442   if ("$family" =~ /arial|helvet/i) {
 443     return($ftypes{100}); # Sans Serif
 444   }
 445   elsif ($family =~ /(sans)[-_ ]?(serif)?/i) {
 446     return($ftypes{100}); # Sans Serif
 447   }
 448   elsif ($family =~ /serif/i) {
 449     return($ftypes{0});    # Serif
 450   }
 451   else {
 452     return(undef);
 453   }
 454 }
 455
 456 sub getweight($$)
 457 {
 458   my ($family, $style) = @_;
 459   my $result = undef;
 460   for my $key (keys %weights) {
 461     next if ($key !~ /^\d+$/);
 462     my $val = $weights{$key};
 463     for my $info ($style, $family) {
 464       if ($info =~ /\b$val\b/i) {
 465         if ($val eq "Regular") {
 466           $result = $val;    # It may refer to width
 467         }
 468         else {
 469           return($val);
 470         }
 471       }
 472     }
 473   }
 474   return($result);
 475 }
 476
 477 sub getwidth($$)
 478 {
 479   my ($family, $style) = @_;
 480   my $result = undef;
 481   for my $key (keys %widths) {
 482     next if ($key !~ /^\d+$/);
 483     for my $info ($style, $family) {
 484       if ($info =~ /\b$widths{$key}\b/i) {
 485         return($widths{$key});
 486       }
 487       if ($info =~ /\bRegular\b/) {
 488         if (!defined($result)) {
 489           $result = $widths{100};
 490         }
 491       }
 492     }
 493   }
 494   return($result);
 495 }
 496
 497 sub getslant($$)
 498 {
 499   my ($family, $style) = @_;
 500   for my $key (keys %slants) {
 501     next if ($key !~ /^\d+$/);
 502     if ($style =~ /\b$slants{$key}\b/i) {
 503       return($slants{$key});
 504     }
 505   }
 506   return(undef);
 507 }
 508
 509 sub getspacing($$)
 510 {
 511   my ($family, $style) = @_;
 512   for my $key (keys %spacings) {
 513     next if ($key !~ /^\d+$/);
 514     if ($style =~ /\b$spacings{$key}\b/i) {
 515       return($spacings{$key});
 516     }
 517   }
 518   if ("$family $style" =~ /[-_ ](mono|typewriter|cursor)\b/i) {
 519     return($spacings{100}); # Mono
 520   }
 521   else {
 522     return(undef);
 523   }
 524 }
 525
 526 sub getproperties($$$$)
 527 {
 528   my ($l, $family, $style, $rerrors) = @_;
 529   my $newstyle = &correctstyle($style);
 530   my $newfam = &correctstyle($family);
 531   my @properties = ();
 532
 533   for my $txt (qw(ftype weight width slant spacing)) {
 534     my ($map, $rget);
 535     eval("\$map = " . '\%' . $txt . 's');
 536     eval('$rget = \&' . "get$txt");
 537     my $val2 = getsinglevalue($l, $txt, $map);
 538     my $val1 = $rget->($newfam, $newstyle);
 539     my $val;
 540     if (defined($val2) && defined($val1) && ($val2 ne $val1)) {
 541       push(@{$rerrors}, "Family($family),Style($style): Values for $txt ($val1 != $val2) differ, selecting internal $txt($val2)");
 542       $val = $val2;
 543     }
 544     elsif (! defined($val2)) {
 545       $val = $val1;
 546     }
 547     else {
 548       $val = $val2;
 549     }
 550     if (defined($val)) {
 551       push(@properties, &addTxt($txt,$val));
 552     }
 553     else {
 554       if (defined($map->{"default"})) {
 555         push(@properties, &addTxt($txt,$map->{"default"}));
 556       }
 557       else {
 558         push(@{$rerrors}, "Undefined value for $txt");
 559       }
 560     }
 561   }
 562   return(join(' ', @properties));
 563 }
 564
 565 sub correctstyle($)
 566 {
 567   my ($style) = @_;
 568   $style =~ s/^\\040//;
 569   $style =~ s/^\s*\d+\s*//;
 570   $style =~ s/\s*\d+$//;
 571   $style =~ s/italic/ Italic/i;
 572   $style =~ s/oblique/ Oblique/i;
 573   $style =~ s/[\-_]/ /g;
 574   $style =~ s/\breg\b/Regular/i;
 575   $style =~ s/\bregita(lic)?\b/Regular Italic/i;
 576   $style =~ s/\bregobl(ique)?\b/Regular Oblique/i;
 577   $style =~ s/medium/Medium /i;
 578   $style =~ s/\bmedita(lic)?\b/Medium Italic/i;
 579   $style =~ s/\bmedobl(ique)?\b/Medium Oblique/i;
 580   $style =~ s/\bmed\b/Medium /i;
 581   $style =~ s/\bdemi\b/SemiBold/i;
 582   $style =~ s/\bex(pd|t)\b/Expanded/i;
 583   $style =~ s/semi ?cond(ensed)?/SemiCondensed/i;
 584   $style =~ s/[sd]emi ?(bold|bd|bol)/SemiBold/i;
 585   $style =~ s/semi ?(expanded|extended|expd)/SemiExpanded/i;
 586   $style =~ s/[sd]emi ?light/SemiLight/i;
 587   $style =~ s/ultra ?(expanded|extended|expd)/UltraExpanded/i;
 588   $style =~ s/light/Light /i;
 589   $style =~ s/\blt\b/Light /i;
 590   $style =~ s/(ultra|extra)(light|lt)/ExtraLight /i;
 591   $style =~ s/\bheavy\b/Extrabold/i;
 592   $style =~ s/\bhairline\b/Extralight/i;
 593   $style =~ s/\bcond\b/Condensed/i;
 594   $style =~ s/(roman)?slanted/ Italic/i;
 595   $style =~ s/\bslant\b/Italic/i;
 596   $style =~ s/\b(SC|Small(caps(alt)?)?)\b/SmallCaps/i;
 597   $style =~ s/w3 mono/Dual/i;
 598   $style =~ s/Regul[ea]r/Regular/i;
 599   $style =~ s/  +/ /g;
 600   return($style);
 601 }