summaryrefslogtreecommitdiff
path: root/support/TVS/TVS/tvs.pl
blob: 925b480a0d1395a2c8e7ea32c975b39e26857863 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
#! /usr/bin/perl -w
# -*- cperl -*-

# use diagnostics;

# This is TVS, system for storing complete source codes for TeX documents
# Written and maintained by David Antos, xantos (at) fi.muni.cz
# Distributed free od charge but without ANY WARRANTY in hope you find
# it useful. See enclosed General Public License for details.

# Copyright (c) 2000 David Antos
# $Author: antos $
# $Id: tvs.pl,v 1.28 2000/08/16 16:56:41 antos Exp $

use strict;
use locale;
use Getopt::Long;
use Cwd qw(cwd abs_path);
use File::Basename;
use File::Copy;
use File::Path;

sub build_patterns {
# Builds patterns from specified file
# Input:  Filename --- pattern file
#         Pattern list reference
# Output: Destroys second parameter and fills it up.

  my ($pattern_file, $patts) = @_;

  if (not defined($pattern_file) or $pattern_file eq "") {
    @$patts = ();
    return;
  }
  if (open(PATTERNS, $pattern_file)) {
    print "\nOpened file \"$pattern_file\"\n" if ($::verbose);
    print "Building pattern list\n" if ($::verbose);

    my ($pat);
    while ($pat = <PATTERNS>) {
      chomp($pat);
      ($pat) = split(/[%#]/, $pat); # Erase comments --- they start with # or %
      next unless (defined($pat)); # Nothing to do
      # Delete white characters before and after non-white characters
      $pat =~ s/\s*(.*\S)\s*/$1/;
      next if ($pat eq ""); # Nothing to do
      push(@$patts, $pat);
      print "Found pattern \"$pat\"\n" if ($::verbose >= 2);
    }
    close(PATTERNS);
  }
  else {
    @$patts = ();
    warn "\nWARNING: File \"$pattern_file\" can't be opened.\n";
  }
} # build_patterns

sub parse_tex_log {
# Finds possible filenames in TeX log file, tests if they are real files.
# Omits files matching RE in @$ign_patts.
# Input:  Name of TeX logfile (with .log)
#         List of patterns to ignore (reference)
#         Hash to add matching names (ref.)
# Output: Adds names to %$filenms, keys are filenames,
#            values are filenames too

  my ($logname, $ign_patts, $filenms) = @_;

  open(TEXLOG,$logname) or die "\nCan't open logfile \"$logname\"\n";
  print "\nOpened logfile \"$logname\"\n";

  my($line, $filename, $oldfn, $pat);
  while ($line = <TEXLOG>) {
    chomp($line);
    # In log, anything between "(" or "<" and end-of-line may be a filename.
    # Parsing of it is quite stupid because there may be spaces
    # in filenames. I decided to use real brutal force.
    # So we go to the first ( or < in line, test the rest, cut the rightmost
    # character, test, and so on.
    # Even names ended with ),_,', etc. are tested to be files, but
    # --- who knows --- what if someone uses them [:-O]?
    # It's slow but it doesn't need much memory, which can be useful
    # for DOS/emTeX users. (Sorry, users of _real_ operating systems...)
    BRACKET:
    while ($line =~ /[\(\<]/) { # left "(" or "<" in line
      $line =~ s#^.*?[\(\<]+(.*)$#$1#; # cut to the first left bracket (incl.)
      $filename = $line;
      do {
        print "Testing name: \"$filename\"\n" if ($::verbose >= 2);
	if (-f $filename) { # it's a real file
	  print "> Found file: \"$filename\"\n" if ($::verbose);
	  $$filenms{$filename} = $filename;
          # If $filename matches any pattern, then delete it
	  foreach $pat (@$ign_patts) {
	    if ($filename =~ m#$pat$#) {
	      print "    ... ignored\n" if ($::verbose);
	      print "    ... matches pattern \"$pat\"\n" if ($::verbose>=2);
	      delete($$filenms{$filename});
	    }
	  }
	  # If there is only -, \w, _, \, /, : or .,
	  # it won't be a filename anymore
	  if ($filename =~ /^[-\w_\\\/\.:]*$/) { next BRACKET; }
          # (This optimalization may be omitted if you think it is unsafe.)
	}
      	$oldfn = $filename; # remember last
	$filename =~ s#^(.+).$#$1#; # cut the rightmost character
      } while($oldfn ne $filename); # while it changes
    } # while "(" or "<"
  }
  close TEXLOG;
} # parse_tex_log

sub get_format_name {
# Gets format name from log, parses first format=this_is_result in file
# If opt_fmtname was given, returns opt_fmtname
# Input:  Filename (with .log)
# Output: Format name (returns string) or "" if failed

  my ($filenm) = @_;
  my ($line);

  if ($::opt_fmtname ne "") {
    print "\nForced format \"$::opt_fmtname\". Make sure this is correct!\n";
    return $::opt_fmtname;
  }
  else {
    if (not open(TEXLOG, $filenm)) {
      print "\nCan't open logfile \"$filenm\" to get format name\n";
    }
    else {
      while ($line = <TEXLOG>) {
        chomp($line);
        if ($line =~ s#.*format=(\w*).*#$1#) { return $line; };
        # Success
      };
    };
  };
  return ""; # Failure
} # get_format_name

sub determine_storing_names {
# Reads keys from hash --- filenames to store.
# Checks for name conflicts and solves them.
# Input:  Ref. to hash, it's keys are filenames, values equal to keys
#         Ref. to list containing patterns to cut from paths
# Output: Hash, keys are keeping new names, values original ones

  my($filenms, $cuts) = @_;

  my (%storing_names); # New names => orig. (real) names
  my ($fn);

  foreach $fn (keys %$filenms) {
    my ($newfn) = $fn;
    print "Preparing name for file \"$fn\"\n" if ($::verbose);
    # Determine new storing name
    my ($pat);
    foreach $pat (@$cuts) {
      $pat =~ s#^(.*[^\\\/])[\\\/]?#$1#; # cut the rightmost / or \
      print " Checking pattern \"$pat\"\n" if ($::verbose >= 2);
      # cut filename if starts with $pat, only first pattern is used
      if ( $newfn =~ m#^$pat[\\\/](.*)# ) {
        $newfn = $1;
	print " Pattern matches.\n" if ($::verbose >= 2);
	last; # exit cycle
      };
    }; # foreach $pat
    # if new name doesn't conflict, add it
    if (not exists($storing_names{$newfn})) {
      print "Name \"$newfn\" will be used.\n" if ($::verbose);
      $storing_names{$newfn} = $fn;
    }
    else { # error, name conflicts
      print "\nError, name \"$newfn\" conflicts.\n";
      print "Cannot save files \"$fn\"\n";
      print "and \"$storing_names{$newfn}\"\n";
      print "with the same name \"$newfn\".\n";
      print "Please check setting of paths to cut. Shortenning of belonging\n";
      print "prefix should help. Consult the documentation when in trouble.\n";
      die "*** Name conflict detected, gave up ***\n";
    };
  };
  return %storing_names;
} # determine_storing_names

sub copy_files {
# Takes keys from hash and copies all files from it to working_dir/prefix
# Input:  Prefix, hash --- keys are filenames
# Output: None

  my($prefix, %filenms) = @_;
  my ($name, $prefname);

  foreach $name (keys %filenms) {
    $prefname = $name;
    # cut leading / or \
    $prefname =~ s#[\\\/]?(.*)#$1#;
    $prefname = $prefix.'/'.$prefname;
    # Prepare directories, umask may be switch in the future
    mkpath(dirname($prefname), $::verbose, 0700) unless ($::opt_dummy);
    copy($filenms{$name}, $prefname) unless ($::opt_dummy);
    print "Copying \"$filenms{$name}\"\n to \"$prefname\"\n" if ($::verbose);
  };
} #copy_files

sub main_pack {
# Main procedure for packing files
# Creates tree of source files
# Input:  Filename of TeX source, extension .log is tried
# Output: None
# Uses:   Variables $main::opt_...

  my ($source) = @_;
  my (%filenames); # Keys are filenames to store --- source
  my (@ignore_patterns); # Patterns to be ignored
  my (@path_cuts); # Paths to cut

  if ($::opt_ignore ne "") {
    print "\nBuilding ignore pattern list\n" if ($::verbose);
    &build_patterns($::opt_ignore, \@ignore_patterns);
  }
  else {
    @ignore_patterns = ();
  };

  if ($::opt_pathcuts ne "") {
    print "\nBuilding list of paths to cut\n" if ($::verbose);
    &build_patterns($::opt_pathcuts, \@path_cuts);
  }
  else {
    @path_cuts = ();
  };

  # If file $source doesn't exist try dtto.log
  if (not -f $source) {
    print "\nFile \"$source\" does not exist, trying \"${source}.log\"\n";
    $source = "${source}.log";
    if (not -f $source) { die "File \"$source\" does not exist\n"; }
  }

  %filenames=();
  # Get list of needed files from TeX log
  &parse_tex_log($source, \@ignore_patterns, \%filenames);
  %filenames = &determine_storing_names(\%filenames, \@path_cuts);
  &copy_files("$::opt_output",%filenames);

  # If format needed, get name
  if ($::opt_format ne "") {
    %filenames = (); # Delete all, it is done and copied
    my ($format_name) = &get_format_name($source);
    print "\nGot format name \"$format_name\"\n";
    # Delete last / or \
    $::opt_format =~ s/^(.*[^\\\/])[\\\/]?/$1/;
    &parse_tex_log($::opt_format."/".$format_name.'.log',
	  \@ignore_patterns, \%filenames);
    %filenames = &determine_storing_names(\%filenames, \@path_cuts);
    &copy_files("$::opt_output"."/FORMAT", %filenames);
  }; # if format wanted

  # If font sources needed, get them
  if ($::opt_dvips ne "") {
    %filenames = (); # Delete all
    print "\nGetting font source files from dvips log \"$::opt_dvips\"\n";
    &parse_tex_log($::opt_dvips, \@ignore_patterns, \%filenames);
    %filenames = &determine_storing_names(\%filenames, \@path_cuts);
    &copy_files("$::opt_output"."/FONTS", %filenames);
  }; # if dvips

} # main_pack

# -------------- Help and version info ---------
sub print_version {
# Prints version
# Input, output: none
  print "\nThis is TVS, TeX Versioning System\n";
  print 'Version 1.0 ($Id: tvs.pl,v 1.28 2000/08/16 16:56:41 antos Exp $)'.
    "\n";
  print "This is free software distributed under General Public License\n";
  print "but WITHOUT ANY WARRANTY\n";
} # print_version

sub print_usage {
# Prints usage info
# Input, output: none
  print "\nUsage:\n";
  print "tvs.pl -h | --help            print this help and exit\n\n";
  print "tvs.pl [options] filename[.log]\n\n";
  print "where options are:\n";
  print "  -v | --verbose              set verbosity level\n";
  print "  --dummy                     no real work\n";
  print "  -c | --config file          set configuration file\n";
  print "  -i | --ignore [file]        set ignore pattern file\n";
  print "  -p | --pathcuts [file]      set pathcuts patt. file\n";
  print "  -o | --output dir           output directory name\n";
  print "  -f | --format [dir]         pack format sources\n";
  print "  --fmtname [name]            forces format name\n";
  print "  -d | --dvips file           pack font sources -- experimental!\n";
  print "\n";
  print "Please consult the documentation. Note that packing source codes\n";
  print "is a delicate and sensitive operation.\n\n";
} # print_usage

# ------------------ Parsing config ------------
sub parse_config_file {
# Parses config file and sets options with omitted value on command line
# Input, output: none
# Changes: Values of %config hash (global in main)

  # Default name of config file
  if (not defined($::opt_config)) { $::opt_config = "tvsrc"; };

  if (not open(CONFIG, $::opt_config)) {
    warn "\nConfig file \"$::opt_config\" can't be opened.\n";
    warn "Config file ignored.\n";
  }
  else {
    # Parse config file
    my ($line, $name, $value);
    while ($line = <CONFIG>) {
      chomp($line);
      # Ignore anything after # or $
      ($line) = split(/[%#]/, $line); # Erase comments, they start with # or %
      next unless defined($line);
      # Delete white chars
      $line =~ s#\s*(.*\S)\s*#$1#;
      # Split on first space
      ($name, $value) = split(/\s/, $line, 2);
      next unless defined($name);
      next unless defined($value);
      # Set values
      if ($name ne "" and $value ne "") { $::config_file{$name} = $value; };
    }
  }
} # parse_config_file

# --------------- MAIN PROGRAM -----------------
# Handles parsing of command line arguments and calls actions.
# Input: see Getopt command

# Print header
&print_version();

# Set option variables
Getopt::Long::Configure("bundling","no_auto_abbrev");
# Allow write e.g. -vv, allow only full names of options

# These are global options. They are taken from commandline,
# if not set (or value omitted), config file is usually tried.
use vars qw($verbose $opt_help $opt_config $opt_dummy $opt_format);
use vars qw($opt_fmtname $opt_dvips $opt_ignore $opt_output $opt_pathcuts);

if (not GetOptions('v|verbose+',\$verbose,         # verbosity level 
                   'h|help',\$opt_help,            # print help and exit
		   'c|config=s',\$opt_config,      # config file name
		   'dummy',\$opt_dummy,            # do not really copy files

		   'f|format:s',\$opt_format,      # dir with iniTeX logs
		   'fmtname=s',\$opt_fmtname,      # format name (forced)
		   'd|dvips=s',\$opt_dvips,        # dvips log

		   'i|ignore:s',\$opt_ignore,      # file with names to ignore
		   'p|pathcuts:s',\$opt_pathcuts,  # file with paths to cut

		   'o|output=s',\$opt_output       # output directory name
                   )) { &print_usage(); die "*** Wrong options ***" };

use vars qw($filename); # File --- log of TeX or archive (if -x)
use vars qw(%config_file); # Content of config file --- global,
                           # used for setting $opt_... only
&parse_config_file();

# If $verbose undefined, try config file, else set it to 0
unless (defined($verbose)) {
  if (exists($config_file{"verbose"})) {
    $verbose = $config_file{"verbose"}; }
  else { $verbose = 0; };
};

# Print version info if -h or --version (and exit then)
if (defined($opt_help)) { &print_usage(); exit 0; };

# If dummy, warn
if (defined($opt_dummy)) {
  warn "\n*** WARNING: dummy mode selected ***\n";
  warn "Nothing will be really done!\n\n";
}
else { $opt_dummy = 0; };

# Check format option
if (defined($opt_format)){
  if ($opt_format eq "") {
    if (exists($config_file{"format"})) {
      $opt_format = $config_file{"format"}
    }
    else {
      &print_usage();
      die "*** Format option parameter is not specified ***\n";
    };
  };
}
else { $opt_format = ""; };

# Forced format name
if (not defined($opt_fmtname)) { $opt_fmtname = ""; };

# Dvips
if (not defined($opt_dvips)) { $opt_dvips = ""; };

# Ignore file
if (defined($opt_ignore)) {
  if ($opt_ignore eq "") {
    if (exists($config_file{"ignore"})) {
      $opt_ignore = $config_file{"ignore"};
    }
    else {
      &print_usage();
      die "*** Ignore parameter is not specified ***\n";
    };
  };
}
else { $opt_ignore = ""; };

# Pathcuts
if ((not defined($opt_pathcuts)) or ($opt_pathcuts eq "")) {
  if (exists($config_file{"pathcuts"})) {
    $opt_pathcuts = $config_file{"pathcuts"};
  }
  else { $opt_pathcuts = ""; };
}

# Output dir
unless (defined($opt_output)) {
  unless (exists($config_file{"output"})) { $opt_output = 'TVS-OUT'; }
  else { $opt_output = $config_file{"output"} }
};

# Set filename
unless (defined($ARGV[0])) {
  &print_usage;
  die "*** Please specify filename ***";
};
$filename = $ARGV[0];
# Allow TVS only to be run in source directory
my($working_directory) = cwd;
if ($working_directory ne abs_path(dirname($filename))) {
  &print_usage;
  die "*** Please run TVS in the source directory ***";
};

&main_pack($filename);

print "\nThank you for using TVS and supporting free software\n";