development/autotests/useSystemFonts.pl

   1 #! /usr/bin/env perl
   2 # -*- mode: perl; -*-
   3 #
   4 # file useSystemFonts.pl
   5 # 1.) Copies lyx-files to another location
   6 # 2.) While copying,
   7 #   2a.) searches for relative references to files and
   8 #        replaces them with absolute ones
   9 #   2b.) Changes default fonts to use non-tex-fonts
  10 #   2c.) Changes the non-tex fonts setting if it is "default".
  11 #
  12 # Syntax: perl useSystemFonts.pl sourceFile destFile format
  13 # Each param represents a path to a file
  14 # sourceFile: full path to a lyx file
  15 # destFile: destination path
  16 #   Each subdocument will be copied into a subdirectory of dirname(destFile)
  17 # format: any string of the form '[a-zA-Z0-9]+', e.g. pdf5
  18 #
  19 # This file is free software; you can redistribute it and/or
  20 # modify it under the terms of the GNU General Public
  21 # License as published by the Free Software Foundation; either
  22 # version 2 of the License, or (at your option) any later version.
  23 #
  24 # This software is distributed in the hope that it will be useful,
  25 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  26 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  27 # General Public License for more details.
  28 #
  29 # You should have received a copy of the GNU General Public
  30 # License along with this software; if not, write to the Free Software
  31 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  32 #
  33 # Copyright (c) 2013 Kornel Benko <kornel@lyx.org>
  34 #           (c) 2013 Scott Kostyshak <skotysh@lyx.org>
  35
  36 use strict;
  37
  38 BEGIN {
  39   use File::Spec;
  40   my $p = File::Spec->rel2abs( __FILE__ );
  41   $p =~ s/[\/\\]?[^\/\\]+$//;
  42   unshift(@INC, "$p");
  43 }
  44 use File::Basename;
  45 use File::Path;
  46 use File::Copy "cp";
  47 use File::Temp qw/ :POSIX /;
  48 use lyxStatus;
  49
  50 # Prototypes
  51 sub printCopiedDocuments($);
  52 sub interpretedCopy($$$$);
  53 sub copyFoundSubdocuments($);
  54 sub copyJob($$);
  55 sub isrelativeFix($$$);
  56 sub isrelative($$$);
  57 sub createTemporaryFileName($$);
  58 sub copyJobPending($$);
  59 sub addNewJob($$$$$);
  60 sub addFileCopyJob($$$$);
  61 sub getNewNameOf($$);
  62 sub getlangs($$);
  63 sub simplifylangs($);
  64 sub getLangEntry();
  65
  66 # convert lyx file to be compilable with xetex
  67
  68 my ($source, $dest, $format, $fontT, $encodingT, $languageFile, $rest) = @ARGV;
  69 my %encodings = ();      # Encoding with TeX fonts, depending on language tag
  70
  71 diestack("Too many arguments") if (defined($rest));
  72 diestack("Sourcefilename not defined") if (! defined($source));
  73 diestack("Destfilename not defined") if (! defined($dest));
  74 diestack("Format (e.g. pdf4) not defined") if (! defined($format));
  75 diestack("Font type (e.g. texF) not defined") if (! defined($fontT));
  76 diestack("Encoding (e.g. ascii) not defined") if (! defined($encodingT));
  77
  78 $source = File::Spec->rel2abs($source);
  79 $dest = File::Spec->rel2abs($dest);
  80
  81 my %font = ();
  82 my $lang = "main";
  83 if ($source =~ /\/([a-z][a-z](_[A-Z][A-Z])?)[\/_]/) {
  84   $lang = $1;
  85 }
  86
  87 my $inputEncoding = undef;
  88 if ($fontT eq "systemF") {
  89   if ($font{roman} eq "default") {
  90     # Change non-tex fonts setting if it is "default".
  91     # TODO: set in document (if required).
  92     $font{roman} = "FreeSerif";
  93     $font{sans} = "FreeSans";
  94     $font{typewriter} = "FreeMono";
  95   }
  96 }
  97 elsif ($encodingT ne "default") {
  98   # set input encoding to the requested value
  99   $inputEncoding = {
 100         "search" => '.*', # this will be substituted from '\inputencoding'-line
 101         "out" => $encodingT,
 102     };
 103 }
 104 elsif (0) { # set to '1' to enable setting of inputencoding
 105   # use tex font here
 106   my %encoding = ();
 107   if (defined($languageFile)) {
 108     # The 2 lines below does not seem to have any effect
 109     #&getlangs($languageFile, \%encoding);
 110     #&simplifylangs(\%encoding);
 111   }
 112   if ($format =~ /^(pdf4)$/) { # xelatex
 113     # set input encoding to 'ascii' always
 114     $inputEncoding = {
 115       "search" => '.*', # this will be substituted from '\inputencoding'-line
 116       "out" => "ascii",
 117     };
 118   }
 119   elsif ($format =~ /^(dvi3|pdf5)$/) { # (dvi)?lualatex
 120     # when to set input encoding to 'ascii'?
 121     if (defined($encoding{$lang})) {
 122       $inputEncoding = {
 123         "search" => '.*', # this will be substituted from '\inputencoding'-line
 124         "out" => $encoding{$lang},
 125       };
 126     }
 127   }
 128 }
 129
 130 my $sourcedir = dirname($source);
 131 my $destdir = dirname($dest);
 132 if (! -d $destdir) {
 133   diestack("could not make dir \"$destdir\"") if (! mkpath $destdir);
 134 }
 135
 136 my $destdirOfSubdocuments;
 137 {
 138   my ($name, $pat, $suffix) = fileparse($source, qr/\.[^.]*/);
 139   my $ext = $format . "_$lang";
 140   $destdirOfSubdocuments = "$destdir/tmp_$ext" . "_$name"; # Global var, something TODO here
 141 }
 142
 143 if(-d $destdirOfSubdocuments) {
 144   rmtree($destdirOfSubdocuments);
 145 }
 146 mkpath($destdirOfSubdocuments); #  for possibly included files
 147
 148 my %IncludedFiles = ();
 149 my %type2hash = (
 150   "copy_only" => "copyonly",
 151   "interpret" => "interpret");
 152
 153 addNewJob($source, $dest, "interpret", {}, \%IncludedFiles);
 154
 155 copyFoundSubdocuments(\%IncludedFiles);
 156
 157 #printCopiedDocuments(\%IncludedFiles);
 158
 159 exit(0);
 160 ###########################################################
 161
 162 sub printCopiedDocuments($)
 163 {
 164   my ($rFiles) = @_;
 165   for my $k (keys %{$rFiles}) {
 166     my $rJob = $rFiles->{$k};
 167     for my $j ( values %type2hash) {
 168       if (defined($rJob->{$j})) {
 169         print "$j: $k->$rJob->{$j}, " . $rJob->{$j . "copied"} . "\n";
 170       }
 171     }
 172   }
 173 }
 174
 175 sub interpretedCopy($$$$)
 176 {
 177   my ($source, $dest, $destdirOfSubdocuments, $rFiles) = @_;
 178   my $sourcedir = dirname($source);
 179   my $res = 0;
 180
 181   diestack("could not read \"$source\"") if (!open(FI, $source));
 182   diestack("could not write \"$dest\"") if (! open(FO, '>', $dest));
 183
 184   initLyxStack(\%font, $fontT, $inputEncoding);
 185
 186   my $fi_line_no = 0;
 187   my @path_errors = ();
 188   while (my $l = <FI>) {
 189     $fi_line_no += 1;
 190     $l =~ s/[\n\r]+$//;
 191     #chomp($l);
 192     my $rStatus = checkLyxLine($l);
 193     if ($rStatus->{found}) {
 194       my $rF = $rStatus->{result};
 195       if ($rStatus->{"filetype"} eq "replace_only") {
 196         # e.g. if no files involved (font chage etc)
 197         $l = join('', @{$rF});
 198       }
 199       else {
 200         my $filelist = $rStatus->{filelist};
 201         my $fidx = $rStatus->{fileidx};
 202         my $separator = $rStatus->{"separator"};
 203         my $foundrelative = 0;
 204         for my $f (@{$filelist}) {
 205           my @isrel = isrelative($f,
 206                                   $sourcedir,
 207                                   $rStatus->{ext});
 208           if ($isrel[0]) {
 209             $foundrelative = 1;
 210             my $ext = $isrel[1];
 211             if ($rStatus->{"filetype"} eq "prefix_only") {
 212               $f = getNewNameOf("$sourcedir/$f", $rFiles);
 213             }
 214             else {
 215               my ($newname, $res1);
 216               ($newname, $res1) = addFileCopyJob("$sourcedir/$f$ext",
 217                                                   "$destdirOfSubdocuments",
 218                                                   $rStatus->{"filetype"},
 219                                                   $rFiles);
 220               print "Added ($res1) file \"$sourcedir/$f$ext\" to be copied to \"$newname\"\n";
 221               if ($ext ne "") {
 222                 $newname =~ s/$ext$//;
 223               }
 224               $f = $newname;
 225               $res += $res1;
 226             }
 227           }
 228           else {
 229             if (! -e "$f") {
 230               # Non relative (e.g. with absolute path) file should exist
 231               if ($rStatus->{"filetype"} eq "interpret") {
 232                 # filetype::interpret should be interpreted by lyx or latex and therefore emit error
 233                 # We prinnt a warning instead
 234                 print "WARNING: Interpreted file \"$f\" not found, at \"$source:$fi_line_no\"\n";
 235               }
 236               elsif ($rStatus->{"filetype"} eq "prefix_only") {
 237                 # filetype::prefix_only should be interpreted by latex
 238                 print "WARNING: Prefixed file \"$f\" not found, at \"$source:$fi_line_no\"\n";
 239               }
 240               else {
 241                 # Collect the path-error-messages
 242                 push(@path_errors, "File \"$f(" . $rStatus->{"filetype"} . ")\" not found, at \"$source:$fi_line_no\"");
 243               }
 244             }
 245           }
 246         }
 247         if ($foundrelative) {
 248           $rF->[$fidx] = join($separator, @{$filelist});
 249           $l = join('', @{$rF});
 250         }
 251       }
 252     }
 253     print FO "$l\n";
 254   }
 255   close(FI);
 256   close(FO);
 257   if (@path_errors > 0) {
 258     for my $entry (@path_errors) {
 259       print "ERROR: $entry\n";
 260     }
 261     diestack("Aborted because of path errors in \"$source\"");
 262   }
 263
 264   closeLyxStack();
 265   return($res);
 266 }
 267
 268 sub copyFoundSubdocuments($)
 269 {
 270   my ($rFiles) = @_;
 271   my $res = 0;
 272   do {
 273     $res = 0;
 274     my %copylist = ();
 275
 276     for my $filename (keys  %{$rFiles}) {
 277       next if (! copyJobPending($filename, $rFiles));
 278       $copylist{$filename} = 1;
 279     }
 280     for my $f (keys %copylist) {
 281       # Second loop needed, because here $rFiles may change
 282       my ($res1, @destfiles) = copyJob($f, $rFiles);
 283       $res += $res1;
 284       for my $destfile (@destfiles) {
 285         print "res1 = $res1 for \"$f\" to be copied to $destfile\n";
 286       }
 287     }
 288   } while($res > 0);            #  loop, while $rFiles changed
 289 }
 290
 291 sub copyJob($$)
 292 {
 293   my ($source, $rFiles) = @_;
 294   my $sourcedir = dirname($source);
 295   my $res = 0;
 296   my @dest = ();
 297
 298   for my $k (values %type2hash) {
 299     if ($rFiles->{$source}->{$k}) {
 300       if (! $rFiles->{$source}->{$k . "copied"}) {
 301         $rFiles->{$source}->{$k . "copied"} = 1;
 302         my $dest = $rFiles->{$source}->{$k};
 303         push(@dest, $dest);
 304         if ($k eq "copyonly") {
 305           diestack("Could not copy \"$source\" to \"$dest\"") if (! cp($source, $dest));
 306         }
 307         else {
 308           interpretedCopy($source, $dest, $destdirOfSubdocuments, $rFiles);
 309         }
 310         $res += 1;
 311       }
 312     }
 313   }
 314   return($res, @dest);
 315 }
 316
 317 # Trivial check
 318 sub isrelativeFix($$$)
 319 {
 320   my ($f, $sourcedir, $ext) = @_;
 321
 322   return(1, $ext) if  (-e "$sourcedir/$f$ext");
 323   return(0,0);
 324 }
 325
 326 sub isrelative($$$)
 327 {
 328   my ($f, $sourcedir, $ext) = @_;
 329
 330   if (ref($ext) eq "ARRAY") {
 331     for my $ext2 (@{$ext}) {
 332       my @res = isrelativeFix($f, $sourcedir, $ext2);
 333       if ($res[0]) {
 334         return(@res);
 335       }
 336     }
 337     return(0,0);
 338   }
 339   else {
 340     return(isrelativeFix($f, $sourcedir, $ext));
 341   }
 342 }
 343
 344 sub createTemporaryFileName($$)
 345 {
 346   my ($source, $destdir) = @_;
 347
 348   # get the basename to be used for the template
 349   my ($name, $path, $suffix) = fileparse($source, qr/\.[^.]*/);
 350   #print "source = $source, name = $name, path = $path, suffix = $suffix\n";
 351   my $template = "xx_$name" . "_";
 352   my $fname = File::Temp::tempnam($destdir, $template);
 353
 354   # Append extension from source
 355   if ($suffix ne "") {
 356     $fname .= "$suffix";
 357   }
 358   return($fname);
 359 }
 360
 361 # Check, if file not copied yet
 362 sub copyJobPending($$)
 363 {
 364   my ($f, $rFiles) = @_;
 365   for my $t (values %type2hash) {
 366     if (defined($rFiles->{$f}->{$t})) {
 367       return 1 if (! $rFiles->{$f}->{$t . "copied"});
 368     }
 369   }
 370   return 0;
 371 }
 372
 373 sub addNewJob($$$$$)
 374 {
 375   my ($source, $newname, $hashname, $rJob, $rFiles) = @_;
 376
 377   $rJob->{$hashname} = $newname;
 378   $rJob->{$hashname . "copied"} = 0;
 379   $rFiles->{$source} = $rJob;
 380 }
 381
 382 sub addFileCopyJob($$$$)
 383 {
 384   my ($source, $destdirOfSubdocuments, $filetype, $rFiles) = @_;
 385   my ($res, $newname) = (0, undef);
 386   my $rJob = $rFiles->{$source};
 387
 388   my $hashname = $type2hash{$filetype};
 389   if (! defined($hashname)) {
 390     diestack("unknown filetype \"$filetype\"");
 391   }
 392   if (!defined($rJob->{$hashname})) {
 393     addNewJob($source,
 394                createTemporaryFileName($source, $destdirOfSubdocuments),
 395                "$hashname", $rJob, $rFiles);
 396     $res = 1;
 397   }
 398   $newname = $rJob->{$hashname};
 399   return($newname, $res);
 400 }
 401
 402 sub getNewNameOf($$)
 403 {
 404   my ($f, $rFiles) = @_;
 405   my $resultf = $f;
 406
 407   if (defined($rFiles->{$f})) {
 408     for my $t (values %type2hash) {
 409       if (defined($rFiles->{$f}->{$t})) {
 410         $resultf = $rFiles->{$f}->{$t};
 411         last;
 412       }
 413     }
 414   }
 415   return($resultf);
 416 }
 417
 418 sub getlangs($$)
 419 {
 420   my ($languagefile, $rencoding) = @_;
 421
 422   if (open(FI, $languagefile)) {
 423     while (my $l = <FI>) {
 424       if ($l =~ /^Language/) {
 425         my ($lng, $enc) = &getLangEntry();
 426         if (defined($lng)) {
 427           $rencoding->{$lng} = $enc;
 428         }
 429       }
 430     }
 431     close(FI);
 432   }
 433 }
 434
 435 sub simplifylangs($)
 436 {
 437   my ($rencoding) = @_;
 438   my $base = "";
 439   my $enc = "";
 440   my $differ = 0;
 441   my @klist = ();
 442   my @klist2 = ();
 443   for my $k (reverse sort keys %{$rencoding}) {
 444     my @tag = split('_', $k);
 445     if ($tag[0] eq $base) {
 446       push(@klist, $k);
 447       if ($rencoding->{$k} ne $enc) {
 448         $differ = 1;
 449       }
 450     }
 451     else {
 452       # new base, check that old base was OK
 453       if ($base ne "") {
 454         if ($differ == 0) {
 455           $rencoding->{$base} = $enc;
 456           push(@klist2, @klist);
 457         }
 458       }
 459       @klist = ($k);
 460       $base = $tag[0];
 461       $enc = $rencoding->{$k};
 462       $differ = 0;
 463     }
 464   }
 465   if ($base ne "") {
 466     # close handling for last entry too
 467     if ($differ == 0) {
 468       $rencoding->{$base} = $enc;
 469       push(@klist2, @klist);
 470     }
 471   }
 472   for my $k (@klist2) {
 473     delete($rencoding->{$k});
 474   }
 475 }
 476
 477 sub getLangEntry()
 478 {
 479   my ($lng, $enc) = (undef, undef);
 480   while (my $l = <FI>) {
 481     chomp($l);
 482     if ($l =~ /^\s*Encoding\s+([^ ]+)\s*$/) {
 483       $enc = $1;
 484     }
 485     elsif ($l =~ /^\s*LangCode\s+([^ ]+)\s*$/) {
 486       $lng = $1;
 487     }
 488     elsif ($l =~ /^\s*End\s*$/) {
 489       last;
 490     }
 491   }
 492   if (defined($lng) && defined($enc)) {
 493     return($lng, $enc);
 494   }
 495   else {
 496     return(undef, undef);
 497   }
 498 }