font/devpdf/util/BuildFoundries.pl

   1 #!/usr/bin/perl -w
   2 #
   3 #   BuildFoundries   : Given a Foundry file generate groff and download files
   4 #   Deri James       : Monday 07 Feb 2011
   5
   6 # Copyright (C) 2011-2018 Free Software Foundation, Inc.
   7 #      Written by Deri James <deri@chuzzlewit.demon.co.uk>
   8 #
   9 # This file is part of groff.
  10 #
  11 # groff is free software; you can redistribute it and/or modify it under
  12 # the terms of the GNU General Public License as published by the Free
  13 # Software Foundation, either version 3 of the License, or
  14 # (at your option) any later version.
  15 #
  16 # groff is distributed in the hope that it will be useful, but WITHOUT ANY
  17 # WARRANTY; without even the implied warranty of MERCHANTABILITY or
  18 # FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  19 # for more details.
  20 #
  21 # You should have received a copy of the GNU General Public License
  22 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 use strict;
  25
  26 (my $progname = $0) =~s @.*/@@;
  27 my $where=shift||'';
  28 my $devps=shift||'../devps';
  29 chdir $where if $where ne '';
  30 my (%foundry,%flg,@downloadpreamble,%download);
  31 my $GSpath=FindGSpath();
  32 my $warn=0;
  33 my $lct=0;
  34 my $foundry=''; # the default foundry
  35
  36 LoadDownload("download");
  37 LoadFoundry("Foundry");
  38 WriteDownload("download");
  39
  40 exit 0;
  41
  42
  43
  44 sub LoadFoundry
  45 {
  46     my $fn=shift;
  47     my $foundrypath='';
  48     my $notFoundFont=0;
  49
  50     open(F,"<$fn") or Die("No $fn file found");
  51
  52     while (<F>)
  53     {
  54         chomp;
  55         $lct++;
  56         s/\r$//;        # in case edited in windows
  57
  58         s/\s*#.*?$//;   # remove comments
  59
  60         next if $_ eq '';
  61
  62         if (m/^[A-Za-z]=/)
  63         {
  64             my (@f)=split('=');
  65             $flg{$f[0]}=$f[1];
  66             next;
  67         }
  68
  69         my (@r)=split('\|');
  70
  71         if (lc($r[0]) eq 'foundry')
  72         {
  73             Warn("\nThe path(s) used for searching:\n$foundrypath\n") if $notFoundFont;
  74             $foundry=uc($r[1]);
  75             $foundrypath=$r[2].' : '.$devps;
  76             $foundrypath=~s/\(gs\)/$GSpath /;
  77             $notFoundFont=0;
  78         }
  79         else
  80         {
  81             # 0=groff font name
  82             # 1=IsBase Y/N (one of PDFs 14 base fonts)
  83             # 2=afmtodit flag
  84             # 3=map file
  85             # 4=encoding file
  86             # 5=font file
  87             # 6=afm file
  88
  89             if (!defined($r[6]) or $r[6] eq '')
  90             {
  91                 # if no afm file, have a guess!
  92                 $r[6]=substr($r[5],0,-3)."afm";
  93             }
  94
  95             my $gfont=($foundry eq '')?$r[0]:"$foundry-$r[0]";
  96
  97             if ($r[2] eq '')
  98             {
  99                 # Don't run afmtodit, just copy the grops font file
 100
 101                 my $gotf=1;
 102                 my $gropsfnt=LocateFile($devps,$r[0],0);
 103
 104                 if ($gropsfnt ne '' and -r "$gropsfnt")
 105                 {
 106                     my $psfont=UseGropsVersion($gropsfnt);
 107                     if (!PutDownload($psfont,LocatePF($foundrypath,$r[5]),uc($r[1])))
 108                     {
 109                         if (uc($r[1]) ne 'Y')
 110                         {
 111                             $gotf=0;
 112                             my $fns=join(',',split('!',$r[5]));
 113                             Warn("Unable to locate font(s) $fns");
 114                             $notFoundFont=1;
 115                             unlink $gfont;      # Unable to find the postscript file for the font just created by afmtodit
 116                         }
 117                     }
 118                     Notice("Copied grops font $gfont...") if $gotf;
 119
 120                 }
 121                 else
 122                 {
 123                     Warn("Can't read grops font '$r[0]' for Foundry '$foundry'");
 124                 }
 125             }
 126             else
 127             {
 128                 # We need to run afmtodit to create this groff font
 129                 my $psfont=RunAfmtodit($gfont,LocateAF($foundrypath,$r[6]),$r[2],$r[3],$r[4]);
 130
 131                 if ($psfont)
 132                 {
 133                     if (!PutDownload($psfont,LocatePF($foundrypath,$r[5]),uc($r[1])))
 134                     {
 135                         unlink $gfont;  # Unable to find the postscript file for the font just created by afmtodit
 136                     }
 137                     else
 138                     {
 139                         Notice("Generated $gfont...");
 140                     }
 141                 }
 142                 else
 143                 {
 144                     Warn("Failed to create groff font '$gfont' by running afmtodit");
 145                     $notFoundFont=1;
 146                 }
 147             }
 148         }
 149     }
 150
 151     close();
 152     Warn("\nThe path(s) used for searching:\n$foundrypath\n") if $notFoundFont;
 153 }
 154
 155 sub RunAfmtodit
 156 {
 157     my $gfont=shift;
 158     my $afmfile=shift;
 159     my $flags=shift;
 160     my $map=shift||'';
 161     my $enc=shift||'';
 162     my $psfont='';
 163
 164     $enc="-e 'enc/$enc'" if $enc;
 165     $map="'map/$map'" if $map;
 166
 167     my $cmd='afmtodit -c -dDESC';
 168
 169     foreach my $f (split('',$flags))
 170     {
 171         if (!exists($flg{$f}))
 172         {
 173             Warn("Can't use undefined flag '$f' in calling afmtodit for groff font '$gfont'");
 174             return('');
 175         }
 176
 177         $cmd.=" $flg{$f}";
 178     }
 179
 180     system("$cmd $enc '$afmfile' $map $gfont 2>/dev/null");
 181
 182     if ($?)
 183     {
 184         unlink $gfont;
 185         return('');
 186     }
 187
 188     if (open(GF,"<$gfont"))
 189     {
 190         my (@gf)=(<GF>);
 191         my @ps=grep(/^internalname /,@gf);
 192         if ($#ps == 0)  # Just 1 match
 193         {
 194             (undef,$psfont)=split(' ',$ps[0],2);
 195             chomp($psfont);
 196         }
 197         else
 198         {
 199             Warn("Unexpected format for grops font '$gfont' for Foundry '$foundry' - ignoring");
 200         }
 201
 202         close(GF);
 203     }
 204
 205     return($psfont);
 206 }
 207
 208 sub LocateAF
 209 {
 210     my $path=shift;
 211     my $file=shift;
 212
 213     return(LocateFile($path,$file,1));
 214 }
 215
 216 sub LocatePF
 217 {
 218     my $path=shift;
 219     my $file=shift;
 220
 221     return(LocateFile($path,$file,0));
 222 }
 223
 224 sub LocateFile
 225 {
 226     my $path=shift;
 227     my $files=shift;
 228     my $tryafm=shift;
 229     return(substr($files,1)) if substr($files,0,1) eq '*';
 230
 231     foreach my $file (split('!',$files))
 232     {
 233     if ($file=~m'/')
 234     {
 235         # path given with file name so no need to search the paths
 236
 237         if (-r $file)
 238         {
 239             return($file);
 240         }
 241
 242         if ($tryafm and $file=~s'type1/'afm/'i)
 243         {
 244             if (-r "$file")
 245             {
 246                 return($file);
 247             }
 248         }
 249
 250         return('');
 251     }
 252
 253         if ($path eq '(tex)')
 254     {
 255         my $res=`kpsewhich $file`;
 256         return '' if $?;
 257         chomp($res);
 258         return($res);
 259     }
 260
 261         my (@paths)=split(/ (:|;)/,$path);
 262
 263     foreach my $p (@paths)
 264     {
 265             next if !defined($p) or $p eq ';' or $p eq ':';
 266         $p=~s/^\s+//;
 267         $p=~s/\s+$//;
 268
 269         next if $p=~m/^\%rom\%/;        # exclude %rom% paths (from (gs))
 270
 271         if (-r "$p/$file")
 272         {
 273             return("$p/$file");
 274         }
 275
 276         if ($tryafm and $p=~s'type1/'afm/'i)
 277         {
 278             if (-r "$p/$file")
 279             {
 280                 return("$p/$file");
 281             }
 282         }
 283     }
 284     }
 285
 286     return('');
 287 }
 288
 289 sub FindGSpath
 290 {
 291     my (@res)=`@GROFF_GHOSTSCRIPT_INTERPRETERS@ -h 2>/dev/null`;
 292     return '' if $?;
 293     my $buildpath='';
 294     my $stg=1;
 295
 296     foreach my $l (@res)
 297     {
 298         chomp($l);
 299
 300         if ($stg==1 and $l=~m/^Search path:/)
 301         {
 302             $stg=2;
 303         }
 304         elsif ($stg == 2)
 305         {
 306             if (substr($l,0,1) ne ' ')
 307             {
 308                 $stg=3;
 309             }
 310             else
 311             {
 312                 $l=~s/^\s+//;
 313                 $buildpath.=$l;
 314             }
 315         }
 316     }
 317
 318     return($buildpath);
 319 }
 320
 321 sub UseGropsVersion
 322 {
 323     my $gfont=shift;
 324     my $psfont='';
 325     my (@gfa)=split('/',$gfont);
 326     my $gfontbase=pop(@gfa);
 327
 328     if (open(GF,"<$gfont"))
 329     {
 330         my (@gf)=(<GF>);
 331         my @ps=grep(/^internalname /,@gf);
 332         if ($#ps == 0)  # Just 1 match
 333         {
 334             (undef,$psfont)=split(' ',$ps[0],2);
 335             chomp($psfont);
 336         }
 337         else
 338         {
 339             Warn("Unexpected format for grops font '$gfont' for Foundry '$foundry' - ignoring");
 340         }
 341
 342         close(GF);
 343
 344         if ($psfont)
 345         {
 346             if (open(GF,">$gfontbase"))
 347             {
 348                 local $"='';
 349                 print GF "@gf";
 350                 close(GF);
 351             }
 352             else
 353             {
 354                 $psfont='';
 355                 Warn("Failed to create new font '$gfont' for Foundry '$foundry'");
 356             }
 357         }
 358         else
 359         {
 360             Warn("Failed to locate postscript internalname in grops font '$gfont' for Foundry '$foundry'");
 361         }
 362
 363         close(GF);
 364     }
 365     else
 366     {
 367         Warn("Failed to open grops font '$gfont' for Foundry '$foundry'");
 368     }
 369
 370     return($psfont);
 371 }
 372
 373 sub PutDownload
 374 {
 375     my $psfont=shift;
 376     my $pffile=shift;
 377     my $IsBase14=shift;
 378     my $key="$foundry $psfont";
 379
 380     delete($download{$key}), return 0 if ($pffile eq '');
 381
 382     $pffile='*'.$pffile if $IsBase14 eq 'Y'; # This signals to gropdf to only edmbed if -e given
 383     $download{$key}=$pffile;
 384
 385     return 1;
 386 }
 387
 388 sub LoadDownload
 389 {
 390     my $fn=shift;
 391     my $top=1;
 392
 393     return if !open(F,"<$fn");
 394
 395     while (<F>)
 396     {
 397         chomp;
 398         s/\r$//;        # in case edited in windows
 399
 400         if ($top and substr($_,0,1) eq '#' or $_ eq '')
 401         {
 402             # Preserve comments at top of download file
 403
 404             push(@downloadpreamble,$_);
 405             next;
 406         }
 407
 408         $top=0;
 409         s/\s*#.*?$//;   # remove comments
 410
 411         next if $_ eq '';
 412
 413         my (@r)=split(/\t+/);
 414         my $key=$r[1];
 415         $key="$r[0] $r[1]";
 416         $download{$key}=$r[2];
 417     }
 418
 419     close(F);
 420 }
 421
 422 sub WriteDownload
 423 {
 424     my $fn=shift;
 425     my $top=1;
 426
 427     open(F,">$fn") or Die("Can't Create new file '$fn'");
 428
 429     print F join("\n",@downloadpreamble),"\n";
 430
 431     foreach my $k (sort keys %download)
 432     {
 433         my ($f,$ps)=split(/ /,$k);
 434         print F "$f\t$ps\t$download{$k}\n";
 435     }
 436
 437     close(F);
 438 }
 439
 440 sub Notice {
 441     my $msg=shift;
 442     Msg("notice: $msg");
 443 }
 444
 445 sub Warn {
 446     my $msg=shift;
 447     Msg("warning: line $lct: $msg");
 448     $warn=1;
 449 }
 450
 451 sub Die {
 452     my $msg=shift;
 453     Msg("error: line $lct: $msg");
 454     exit 2;
 455 }
 456
 457 sub Msg {
 458     my $msg=shift;
 459     print STDERR "$progname: $msg\n";
 460 }