1# $Id: TLPOBJ.pm 35751 2014-12-05 18:45:04Z karl $
2# TeXLive::TLPOBJ.pm - module for using tlpobj files
3# Copyright 2007-2014 Norbert Preining
4# This file is licensed under the GNU General Public License version 2
5# or any later version.
6
7package TeXLive::TLPOBJ;
8
9use TeXLive::TLConfig qw($DefaultCategory $CategoriesRegexp
10                         $MetaCategoriesRegexp $InfraLocation
11                         $RelocPrefix $RelocTree);
12use TeXLive::TLUtils;
13use TeXLive::TLTREE;
14
15our $_tmp;
16my $_containerdir;
17
18my $svnrev = '$Revision: 35751 $';
19my $_modulerevision;
20if ($svnrev =~ m/: ([0-9]+) /) {
21  $_modulerevision = $1;
22} else {
23  $_modulerevision = "unknown";
24}
25sub module_revision {
26  return $_modulerevision;
27}
28
29sub new {
30  my $class = shift;
31  my %params = @_;
32  my $self = {
33    name        => $params{'name'},
34    category    => defined($params{'category'}) ? $params{'category'} : $DefaultCategory,
35    shortdesc   => $params{'shortdesc'},
36    longdesc    => $params{'longdesc'},
37    catalogue   => $params{'catalogue'},
38    relocated   => $params{'relocated'},
39    runfiles    => defined($params{'runfiles'}) ? $params{'runfiles'} : [],
40    runsize     => $params{'runsize'},
41    srcfiles    => defined($params{'srcfiles'}) ? $params{'srcfiles'} : [],
42    srcsize     => $params{'srcsize'},
43    docfiles    => defined($params{'docfiles'}) ? $params{'docfiles'} : [],
44    docsize     => $params{'docsize'},
45    executes    => defined($params{'executes'}) ? $params{'executes'} : [],
46    postactions => defined($params{'postactions'}) ? $params{'postactions'} : [],
47    # note that binfiles is a HASH with keys of $arch!
48    binfiles    => defined($params{'binfiles'}) ? $params{'binfiles'} : {},
49    binsize     => defined($params{'binsize'}) ? $params{'binsize'} : {},
50    depends     => defined($params{'depends'}) ? $params{'depends'} : [],
51    revision    => $params{'revision'},
52    cataloguedata => defined($params{'cataloguedata'}) ? $params{'cataloguedata'} : {},
53  };
54  $_containerdir = $params{'containerdir'} if defined($params{'containerdir'});
55  bless $self, $class;
56  return $self;
57}
58
59
60sub copy {
61  my $self = shift;
62  my $bla = {};
63  %$bla = %$self;
64  bless $bla, "TeXLive::TLPOBJ";
65  return $bla;
66}
67
68
69sub from_file {
70  my $self = shift;
71  if (@_ != 1) {
72    die("TLPOBJ:from_file: Need a filename for initialization");
73  }
74  open(TMP,"<$_[0]") || die("Cannot open tlpobj file: $_[0]");
75  $self->from_fh(\*TMP);
76}
77
78sub from_fh {
79  my ($self,$fh,$multi) = @_;
80  my $started = 0;
81  my $lastcmd = "";
82  my $arch;
83  my $size;
84
85  while (my $line = <$fh>) {
86    # we do not worry about whitespace at the end of a line;
87    # that would be a bug in the db creation, and it takes some
88    # noticeable time to get rid of it.  So just chomp.
89    chomp($line);
90
91    # we call tllog only when something will be logged, to speed things up.
92    # this is the inner loop bounding the time to read tlpdb.
93    dddebug("reading line: >>>$line<<<\n") if ($::opt_verbosity >= 3);
94    $line =~ /^#/ && next;          # skip comment lines
95    if ($line =~ /^\s*$/) {
96      if (!$started) { next; }
97      if (defined($multi)) {
98        # we may read from a tldb file
99        return 1;
100      } else {
101        # we are reading one tldb file, nothing else allowed
102        die("No empty line allowed within tlpobj files!");
103      }
104    }
105
106    my ($cmd, $arg) = split(/\s+/, $line, 2);
107    # first command must be name
108    $started || $cmd eq 'name'
109      or die("First directive needs to be 'name', not $line");
110
111    # now the big switch, ordered by decreasing number of occurences
112    if ($cmd eq '') {
113      if ($lastcmd eq "runfiles" || $lastcmd eq "srcfiles") {
114        push @{$self->{$lastcmd}}, $arg;
115      } elsif ($lastcmd eq "docfiles") {
116        my ($f, $rest) = split(' ', $arg, 2);
117        push @{$self->{'docfiles'}}, $f;
118        # docfiles can have tags, but the parse_line function is so
119        # time intense that we try to call it only when necessary
120        if (defined $rest) {
121          # parse_line has problems with double quotes in double quotes
122          # my @words = &TeXLive::TLUtils::parse_line('\s+', 0, $rest);
123          # do manual parsing
124          # this is not optimal, but since we support only two tags there
125          # are not so many cases
126          if ($rest =~ m/^details="(.*)"\s*$/) {
127            $self->{'docfiledata'}{$f}{'details'} = $1;
128          } elsif ($rest =~ m/^language="(.*)"\s*$/) {
129            $self->{'docfiledata'}{$f}{'language'} = $1;
130          } elsif ($rest =~ m/^language="(.*)"\s+details="(.*)"\s*$/) {
131            $self->{'docfiledata'}{$f}{'details'} = $2;
132            $self->{'docfiledata'}{$f}{'language'} = $1;
133          } elsif ($rest =~ m/^details="(.*)"\s+language="(.*)"\s*$/) {
134            $self->{'docfiledata'}{$f}{'details'} = $1;
135            $self->{'docfiledata'}{$f}{'language'} = $2;
136          } else {
137            tlwarn("$0: Unparsable tagging in TLPDB line: $line\n");
138          }
139        }
140      } elsif ($lastcmd eq "binfiles") {
141        push @{$self->{'binfiles'}{$arch}}, $arg;
142      } else {
143        die("Continuation of $lastcmd not allowed, please fix tlpobj: line = $line!\n");
144      }
145    } elsif ($cmd eq "longdesc") {
146      my $desc = defined $arg ? $arg : '';
147      if (defined($self->{'longdesc'})) {
148        $self->{'longdesc'} .= " $desc";
149      } else {
150        $self->{'longdesc'} = $desc;
151      }
152    } elsif ($cmd =~ /^catalogue-(.+)$/o) {
153      $self->{'cataloguedata'}{$1} = $arg if defined $arg;
154    } elsif ($cmd =~ /^(doc|src|run)files$/o) {
155      my $type = $1;
156      for (split ' ', $arg) {
157        my ($k, $v) = split('=', $_, 2);
158        if ($k eq 'size') {
159        $self->{"${type}size"} = $v;
160        } else {
161          die "Unknown tag: $line";
162        }
163      }
164    } elsif ($cmd eq 'containersize' || $cmd eq 'srccontainersize'
165        || $cmd eq 'doccontainersize') {
166      $arg =~ /^[0-9]+$/ or die "Illegal size value: $line!";
167      $self->{$cmd} = $arg;
168    } elsif ($cmd eq 'containermd5' || $cmd eq 'srccontainermd5'
169        || $cmd eq 'doccontainermd5') {
170      $arg =~ /^[a-f0-9]+$/ or die "Illegal md5 value: $line!";
171      $self->{$cmd} = $arg;
172    } elsif ($cmd eq 'name') {
173      $arg =~ /^([-.\w]+)$/ or die("Invalid name: $line!");
174      $self->{'name'} = $arg;
175      $started && die("Cannot have two name directives: $line!");
176      $started = 1;
177    } elsif ($cmd eq 'category') {
178      $self->{'category'} = $arg;
179      if ($self->{'category'} !~ /^$CategoriesRegexp/o) {
180        tlwarn("Unknown category " . $self->{'category'} . " for package "
181          . $self->name . " found.\nPlease update texlive.infra.\n");
182      }
183    } elsif ($cmd eq 'revision') {
184      $self->{'revision'} = $arg;
185    } elsif ($cmd eq 'shortdesc') {
186      $self->{'shortdesc'} .= defined $arg ? $arg : ' ';
187    } elsif ($cmd eq 'execute' || $cmd eq 'postaction'
188        || $cmd eq 'depend') {
189      push @{$self->{$cmd . 's'}}, $arg if defined $arg;
190    } elsif ($cmd eq 'binfiles') {
191      for (split ' ', $arg) {
192        my ($k, $v) = split('=', $_, 2);
193        if ($k eq 'arch') {
194          $arch = $v;
195        } elsif ($k eq 'size') {
196          $size = $v;
197        } else {
198          die "Unknown tag: $line";
199        }
200      }
201      if (defined($size)) {
202        $self->{'binsize'}{$arch} = $size;
203      }
204    } elsif ($cmd eq 'relocated') {
205      ($arg eq '0' || $arg eq '1') or die "Illegal value: $line!";
206      $self->{'relocated'} = $arg;
207    } elsif ($cmd eq 'catalogue') {
208      $self->{'catalogue'} = $arg;
209    } else {
210      die("Unknown directive ...$line... , please fix it!");
211    }
212    $lastcmd = $cmd unless $cmd eq '';
213  }
214  return $started;
215}
216
217sub recompute_revision {
218  my ($self,$tltree, $revtlpsrc) = @_;
219  my @files = $self->all_files;
220  my $filemax = 0;
221  $self->revision(0);
222  foreach my $f (@files) {
223    $filemax = $tltree->file_svn_lastrevision($f);
224    $self->revision(($filemax > $self->revision) ? $filemax : $self->revision);
225  }
226  if (defined($revtlpsrc)) {
227    if ($self->revision < $revtlpsrc) {
228      $self->revision($revtlpsrc);
229    }
230  }
231}
232
233sub recompute_sizes {
234  my ($self,$tltree) = @_;
235  $self->{'docsize'} = $self->_recompute_size("doc",$tltree);
236  $self->{'srcsize'} = $self->_recompute_size("src",$tltree);
237  $self->{'runsize'} = $self->_recompute_size("run",$tltree);
238  foreach $a ($tltree->architectures) {
239    $self->{'binsize'}{$a} = $self->_recompute_size("bin",$tltree,$a);
240  }
241}
242
243
244sub _recompute_size {
245  my ($self,$type,$tltree,$arch) = @_;
246  my $nrivblocks = 0;
247  if ($type eq "bin") {
248    my %binfiles = %{$self->{'binfiles'}};
249    if (defined($binfiles{$arch})) {
250      foreach $f (@{$binfiles{$arch}}) {
251        my $s = $tltree->size_of($f);
252        $nrivblocks += int($s/$TeXLive::TLConfig::BlockSize);
253        $nrivblocks++ if (($s%$TeXLive::TLConfig::BlockSize) > 0);
254      }
255    }
256  } else {
257    if (defined($self->{"${type}files"}) && (@{$self->{"${type}files"}})) {
258      foreach $f (@{$self->{"${type}files"}}) {
259        my $s = $tltree->size_of($f);
260        if (defined($s)) {
261          $nrivblocks += int($s/$TeXLive::TLConfig::BlockSize);
262          $nrivblocks++ if (($s%$TeXLive::TLConfig::BlockSize) > 0);
263        } else {
264          printf STDERR "size for $f not defined, strange ...\n";
265        }
266      }
267    }
268  }
269  return $nrivblocks;
270}
271
272sub writeout {
273  my $self = shift;
274  my $fd = (@_ ? $_[0] : STDOUT);
275  print $fd "name ", $self->name, "\n";
276  print $fd "category ", $self->category, "\n";
277  defined($self->{'revision'}) && print $fd "revision $self->{'revision'}\n";
278  defined($self->{'catalogue'}) && print $fd "catalogue $self->{'catalogue'}\n";
279  defined($self->{'shortdesc'}) && print $fd "shortdesc $self->{'shortdesc'}\n";
280  defined($self->{'license'}) && print $fd "license $self->{'license'}\n";
281  defined($self->{'relocated'}) && $self->{'relocated'} && print $fd "relocated 1\n";
282  # ugly hack to get rid of use FileHandle; see man perlform
283  #format_name $fd "multilineformat";
284  select((select($fd),$~ = "multilineformat")[0]);
285  $fd->format_lines_per_page (99999); # no pages in this format
286  if (defined($self->{'longdesc'})) {
287    $_tmp = "$self->{'longdesc'}";
288    write $fd;  # use that multilineformat
289  }
290  if (defined($self->{'depends'})) {
291    foreach (@{$self->{'depends'}}) {
292      print $fd "depend $_\n";
293    }
294  }
295  if (defined($self->{'executes'})) {
296    foreach (@{$self->{'executes'}}) {
297      print $fd "execute $_\n";
298    }
299  }
300  if (defined($self->{'postactions'})) {
301    foreach (@{$self->{'postactions'}}) {
302      print $fd "postaction $_\n";
303    }
304  }
305  if (defined($self->{'containersize'})) {
306    print $fd "containersize $self->{'containersize'}\n";
307  }
308  if (defined($self->{'containermd5'})) {
309    print $fd "containermd5 $self->{'containermd5'}\n";
310  }
311  if (defined($self->{'doccontainersize'})) {
312    print $fd "doccontainersize $self->{'doccontainersize'}\n";
313  }
314  if (defined($self->{'doccontainermd5'})) {
315    print $fd "doccontainermd5 $self->{'doccontainermd5'}\n";
316  }
317  if (defined($self->{'docfiles'}) && (@{$self->{'docfiles'}})) {
318    print $fd "docfiles size=$self->{'docsize'}\n";
319    foreach my $f (sort @{$self->{'docfiles'}}) {
320      print $fd " $f";
321      if (defined($self->{'docfiledata'}{$f}{'details'})) {
322        my $tmp = $self->{'docfiledata'}{$f}{'details'};
323        #$tmp =~ s/\"/\\\"/g;
324        print $fd ' details="', $tmp, '"';
325      }
326      if (defined($self->{'docfiledata'}{$f}{'language'})) {
327        my $tmp = $self->{'docfiledata'}{$f}{'language'};
328        #$tmp =~ s/\"/\\\"/g;
329        print $fd ' language="', $tmp, '"';
330      }
331      print $fd "\n";
332    }
333  }
334  if (defined($self->{'srccontainersize'})) {
335    print $fd "srccontainersize $self->{'srccontainersize'}\n";
336  }
337  if (defined($self->{'srccontainermd5'})) {
338    print $fd "srccontainermd5 $self->{'srccontainermd5'}\n";
339  }
340  if (defined($self->{'srcfiles'}) && (@{$self->{'srcfiles'}})) {
341    print $fd "srcfiles size=$self->{'srcsize'}\n";
342    foreach (sort @{$self->{'srcfiles'}}) {
343      print $fd " $_\n";
344    }
345  }
346  if (defined($self->{'runfiles'}) && (@{$self->{'runfiles'}})) {
347    print $fd "runfiles size=$self->{'runsize'}\n";
348    foreach (sort @{$self->{'runfiles'}}) {
349      print $fd " $_\n";
350    }
351  }
352  foreach my $arch (sort keys %{$self->{'binfiles'}}) {
353    if (@{$self->{'binfiles'}{$arch}}) {
354      print $fd "binfiles arch=$arch size=", $self->{'binsize'}{$arch}, "\n";
355      foreach (sort @{$self->{'binfiles'}{$arch}}) {
356        print $fd " $_\n";
357      }
358    }
359  }
360  # writeout all the catalogue keys
361  foreach my $k (sort keys %{$self->cataloguedata}) {
362    print $fd "catalogue-$k ", $self->cataloguedata->{$k}, "\n";
363  }
364}
365
366sub writeout_simple {
367  my $self = shift;
368  my $fd = (@_ ? $_[0] : STDOUT);
369  print $fd "name ", $self->name, "\n";
370  print $fd "category ", $self->category, "\n";
371  if (defined($self->{'depends'})) {
372    foreach (@{$self->{'depends'}}) {
373      print $fd "depend $_\n";
374    }
375  }
376  if (defined($self->{'executes'})) {
377    foreach (@{$self->{'executes'}}) {
378      print $fd "execute $_\n";
379    }
380  }
381  if (defined($self->{'postactions'})) {
382    foreach (@{$self->{'postactions'}}) {
383      print $fd "postaction $_\n";
384    }
385  }
386  if (defined($self->{'docfiles'}) && (@{$self->{'docfiles'}})) {
387    print $fd "docfiles\n";
388    foreach (sort @{$self->{'docfiles'}}) {
389      print $fd " $_\n";
390    }
391  }
392  if (defined($self->{'srcfiles'}) && (@{$self->{'srcfiles'}})) {
393    print $fd "srcfiles\n";
394    foreach (sort @{$self->{'srcfiles'}}) {
395      print $fd " $_\n";
396    }
397  }
398  if (defined($self->{'runfiles'}) && (@{$self->{'runfiles'}})) {
399    print $fd "runfiles\n";
400    foreach (sort @{$self->{'runfiles'}}) {
401      print $fd " $_\n";
402    }
403  }
404  foreach my $arch (sort keys %{$self->{'binfiles'}}) {
405    if (@{$self->{'binfiles'}{$arch}}) {
406      print $fd "binfiles arch=$arch\n";
407      foreach (sort @{$self->{'binfiles'}{$arch}}) {
408        print $fd " $_\n";
409      }
410    }
411  }
412}
413
414sub cancel_reloc_prefix {
415  my $self = shift;
416  my @docfiles = $self->docfiles;
417  for (@docfiles) { s:^$RelocPrefix/::; }
418  $self->docfiles(@docfiles);
419  my @runfiles = $self->runfiles;
420  for (@runfiles) { s:^$RelocPrefix/::; }
421  $self->runfiles(@runfiles);
422  my @srcfiles = $self->srcfiles;
423  for (@srcfiles) { s:^$RelocPrefix/::; }
424  $self->srcfiles(@srcfiles);
425  # if there are bin files they have definitely NOT the
426  # texmf-dist prefix, so we cannot cancel it anyway
427}
428
429sub replace_reloc_prefix {
430  my $self = shift;
431  my @docfiles = $self->docfiles;
432  for (@docfiles) { s:^$RelocPrefix/:$RelocTree/:; }
433  $self->docfiles(@docfiles);
434  my @runfiles = $self->runfiles;
435  for (@runfiles) { s:^$RelocPrefix/:$RelocTree/:; }
436  $self->runfiles(@runfiles);
437  my @srcfiles = $self->srcfiles;
438  for (@srcfiles) { s:^$RelocPrefix/:$RelocTree/:; }
439  $self->srcfiles(@srcfiles);
440  # docfiledata needs to be adapted too
441  my $data = $self->docfiledata;
442  my %newdata;
443  while (my ($k, $v) = each %$data) {
444    $k =~ s:^$RelocPrefix/:$RelocTree/:;
445    $newdata{$k} = $v;
446  }
447  $self->docfiledata(%newdata);
448  # if there are bin files they have definitely NOT the
449  # texmf-dist prefix, so we cannot cancel it anyway
450}
451
452sub cancel_common_texmf_tree {
453  my $self = shift;
454  my @docfiles = $self->docfiles;
455  for (@docfiles) { s:^$RelocTree/:$RelocPrefix/:; }
456  $self->docfiles(@docfiles);
457  my @runfiles = $self->runfiles;
458  for (@runfiles) { s:^$RelocTree/:$RelocPrefix/:; }
459  $self->runfiles(@runfiles);
460  my @srcfiles = $self->srcfiles;
461  for (@srcfiles) { s:^$RelocTree/:$RelocPrefix/:; }
462  $self->srcfiles(@srcfiles);
463  # docfiledata needs to be adapted too
464  my $data = $self->docfiledata;
465  my %newdata;
466  while (my ($k, $v) = each %$data) {
467    $k =~ s:^$RelocTree/:$RelocPrefix/:;
468    $newdata{$k} = $v;
469  }
470  $self->docfiledata(%newdata);
471  # if there are bin files they have definitely NOT the
472  # texmf-dist prefix, so we cannot cancel it anyway
473}
474
475sub common_texmf_tree {
476  my $self = shift;
477  my $tltree;
478  my $dd = 0;
479  my @files = $self->all_files;
480  foreach ($self->all_files) {
481    my $tmp;
482    ($tmp) = split m@/@;
483    if (defined($tltree) && ($tltree ne $tmp)) {
484      return;
485    } else {
486      $tltree = $tmp;
487    }
488  }
489  # if there are no files then it is by default relocatable, so
490  # return the right tree
491  if (!@files) {
492    $tltree = $RelocTree;
493  }
494  return $tltree;
495}
496
497
498sub make_container {
499  my ($self,$type,$instroot,$destdir,$containername,$relative) = @_;
500  if (($type ne "xz") && ($type ne "tar")) {
501    die "$0: TLPOBJ supports tar and xz containers, not $type";
502  }
503  if (!defined($containername)) {
504    $containername = $self->name;
505  }
506  my @files = $self->all_files;
507  my $compresscmd;
508  my $tlpobjdir = "$InfraLocation/tlpobj";
509  @files = TeXLive::TLUtils::sort_uniq(@files);
510  # we do relative packages ONLY if the files do NOT span multiple
511  # texmf trees. check this here
512  my $tltree;
513  if ($relative) {
514    $tltree = $self->common_texmf_tree;
515    if (!defined($tltree)) {
516      die ("$0: package $containername spans multiple trees, "
517           . "relative generation not allowed");
518    }
519    if ($tltree ne $RelocTree) {
520      die ("$0: building $containername container relocatable but the common"
521           . " prefix is not $RelocTree");
522    }
523    s,^$RelocTree/,, foreach @files;
524  }
525  # load Cwd only if necessary ...
526  require Cwd;
527  my $cwd = &Cwd::getcwd;
528  if ("$destdir" !~ m@^(.:)?/@) {
529    # we have an relative containerdir, so we have to make it absolute
530    $destdir = "$cwd/$destdir";
531  }
532  &TeXLive::TLUtils::mkdirhier("$destdir");
533  chdir($instroot);
534  # in the relative case we have to chdir to the respective tltree
535  # and put the tlpobj into the root!
536  my $removetlpkgdir = 0;
537  if ($relative) {
538    chdir("./$tltree");
539    # in the relocatable case we will probably create the tlpkg dir
540    # in texmf-dist/tlpkg and want to remove it afterwards.
541    $removetlpkgdir = 1;
542    # we don't need to change the $tlpobjdir because we put it in
543    # all cases into tlpkg/tlpobj
544    #$tlpobjdir = "./tlpkg/tlpobj";
545  }
546  # we add the .tlpobj into the .tlpobj directory
547  my $removetlpobjdir = 0;
548  if (! -d "$tlpobjdir") {
549    &TeXLive::TLUtils::mkdirhier("$tlpobjdir");
550    $removetlpobjdir = 1;
551  }
552  open(TMP,">$tlpobjdir/$self->{'name'}.tlpobj")
553  || die "$0: create($tlpobjdir/$self->{'name'}.tlpobj) failed: $!";
554  # when we do relative we have to cancel the prefix before writing out
555  my $selfcopy = $self->copy;
556  if ($relative) {
557    $selfcopy->cancel_common_texmf_tree;
558    $selfcopy->relocated($relative);
559  }
560  $selfcopy->writeout(\*TMP);
561  close(TMP);
562  push(@files, "$tlpobjdir/$self->{'name'}.tlpobj");
563  $tarname = "$containername.tar";
564  if ($type eq "tar") {
565    $containername = $tarname;
566  } else {
567    $containername = "$tarname.xz";
568  }
569
570  # start the fun
571  my $tar = $::progs{'tar'};
572  my $xz;
573  if (!defined($tar)) {
574    tlwarn("$0: programs not set up, trying \"tar\".\n");
575    $tar = "tar";
576  }
577  if ($type eq "xz") {
578    $xz = $::progs{'xz'};
579    if (!defined($xz)) {
580      tlwarn("$0: programs not set up, trying \"xz\".\n");
581      $xz = "xz";
582    }
583  }
584
585  # Here we need to distinguish between making the master containers for
586  # tlnet (where we can assume GNU tar) and making backups on a user's
587  # machine (where we can assume nothing).  We determine this by whether
588  # there's a revision suffix in the container name.
589  #
590  # For the master containers, we want to set the owner/group, exclude
591  # .svn directories, and force ustar format.  This last is for the sake
592  # of packages such as pgf which have filenames long enough that they
593  # overflow standard tar format and result in special things being
594  # done.  We don't want the GNU-specific special things.
595  #
596  my @attrs
597    = $containername =~ /\.r[0-9]/
598      ? ()
599      : ( "--owner", "0",  "--group", "0",  "--exclude", ".svn",
600          "--format", "ustar" );
601  my @cmdline = ($tar, "-cf", "$destdir/$tarname", @attrs);
602
603  # Get list of files and symlinks to back up.  Nothing else should be
604  # in the list.
605  my @files_to_backup = ();
606  for my $f (@files) {
607    if (-f $f || -l $f) {
608      push(@files_to_backup, $f);
609    } elsif (! -e $f) {
610      tlwarn("$0: (make_container $containername) $f does not exist\n");
611    } else {
612      tlwarn("$0: (make_container $containername) $f not file or symlink\n");
613    }
614  }
615
616  my $tartempfile = "";
617  if (win32()) {
618    # Since we provide our own (GNU) tar on Windows, we know it has -T.
619    my $tmpdir = TeXLive::TLUtils::get_system_tmpdir();
620    $tartempfile = "$tmpdir/mc$$";
621    open(TMP, ">$tartempfile") || die "open(>$tartempfile) failed: $!";
622    print TMP map { "$_\n" } @files_to_backup;
623    close(TMP) || warn "close(>$tartempfile) failed: $!";
624    push(@cmdline, "-T", $tartempfile);
625  } else {
626    # For Unix, we pass all the files on the command line, because there
627    # is no portable (across different platforms and different tars)  way
628    # to pass them on stdin.  Unfortunately, this can be too lengthy of
629    # a command line -- our biggest package is tex4ht, which needs about
630    # 200k.  CentOS 5.2, at least, starts complaining around 140k.
631    #
632    # Therefore, if the command is likely to be too long, we call
633    # our collapse_dirs routine; in practice, this eliminates
634    # essentially all the individual files, leaving just a few
635    # directories, which is no problem.  (For example, tex4ht collapses
636    # down to five directories and one file.)
637    #
638    # Although in principle we could do this in all cases, collapse_dirs
639    # isn't the most thoroughly tested function in the world.  It seems
640    # safer to only do it in the (few) potentially problematic cases.
641    #
642    if (length ("@files_to_backup") > 50000) {
643      @files_to_backup = TeXLive::TLUtils::collapse_dirs(@files_to_backup);
644      # A complication, as always.  collapse_dirs returns absolute paths.
645      # We want to change them back to relative so that the backup tar
646      # has the same structure.
647      # in relative mode we have to remove the texmf-dist prefix, too
648      s,^$instroot/,, foreach @files_to_backup;
649      if ($relative) {
650        s,^$RelocTree/,, foreach @files_to_backup;
651      }
652    }
653    push(@cmdline, @files_to_backup);
654  }
655
656  # Run tar. Unlink both here in case the container is also plain tar.
657  unlink("$destdir/$tarname");
658  unlink("$destdir/$containername");
659  xsystem(@cmdline);
660
661  # compress it.
662  if ($type eq "xz") {
663    if (-r "$destdir/$tarname") {
664      system($xz, "--force", "-z", "$destdir/$tarname");
665    } else {
666      tlwarn("$0: Couldn't find $destdir/$tarname to run $xz\n");
667      return (0, 0, "");
668    }
669  }
670
671  # compute the size.
672  if (! -r "$destdir/$containername") {
673    tlwarn ("$0: Couldn't find $destdir/$containername\n");
674    return (0, 0, "");
675  }
676  my $size = (stat "$destdir/$containername") [7];
677  my $md5 = TeXLive::TLUtils::tlmd5("$destdir/$containername");
678
679  # cleaning up
680  unlink("$tlpobjdir/$self->{'name'}.tlpobj");
681  unlink($tartempfile) if $tartempfile;
682  rmdir($tlpobjdir) if $removetlpobjdir;
683  rmdir($InfraLocation) if $removetlpkgdir;
684  xchdir($cwd);
685
686  debug(" done $containername, size $size, $md5\n");
687  return ($size, $md5, "$destdir/$containername");
688}
689
690
691
692sub is_arch_dependent {
693  my $self = shift;
694  if (keys %{$self->{'binfiles'}}) {
695    return 1;
696  } else {
697    return 0;
698  }
699}
700
701# computes the total size of a package
702# if no arguments are given this is
703#   docsize + runsize + srcsize + max of binsize
704sub total_size {
705  my ($self,@archs) = @_;
706  my $ret = $self->docsize + $self->runsize + $self->srcsize;
707  if ($self->is_arch_dependent) {
708    my $max = 0;
709    my %foo = %{$self->binsize};
710    foreach my $k (keys %foo) {
711      $max = $foo{$k} if ($foo{$k} > $max);
712    }
713    $ret += $max;
714  }
715  return($ret);
716}
717
718
719# update_from_catalogue($tlc)
720# Update the current TLPOBJ object with the information from the
721# corresponding entry in C<$tlc->entries>.
722#
723sub update_from_catalogue {
724  my ($self, $tlc) = @_;
725  my $tlcname = $self->name;
726  if (defined($self->catalogue)) {
727    $tlcname = $self->catalogue;
728  } elsif ($tlcname =~ m/^bin-(.*)$/) {
729    if (!defined($tlc->entries->{$tlcname})) {
730      $tlcname = $1;
731    }
732  }
733  $tlcname = lc($tlcname);
734  if (defined($tlc->entries->{$tlcname})) {
735    my $entry = $tlc->entries->{$tlcname};
736    # Record the id of the catalogue entry if it's found due to
737    # quest4texlive.
738    if ($entry->entry->{'id'} ne $tlcname) {
739      $self->catalogue($entry->entry->{'id'});
740    }
741    if (defined($entry->entry->{'date'})) {
742      my $foo = $entry->entry->{'date'};
743      $foo =~ s/^.Date: //;
744      # trying to extract the interesting part of a subversion date
745      # keyword expansion here, e.g.,
746      # $Date: 2014-12-05 19:45:04 +0100 (Fri, 05 Dec 2014) $
747      # ->2007-08-15 19:43:35 +0100
748      $foo =~ s/ \(.*\)( *\$ *)$//;  # maybe nothing after parens
749      $self->cataloguedata->{'date'} = $foo;
750    }
751    if (defined($entry->license)) {
752      $self->cataloguedata->{'license'} = $entry->license;
753    }
754    if (defined($entry->version) && $entry->version ne "") {
755      $self->cataloguedata->{'version'} = $entry->version;
756    }
757    if (defined($entry->ctan) && $entry->ctan ne "") {
758      $self->cataloguedata->{'ctan'} = $entry->ctan;
759    }
760    #if (defined($entry->texlive)) {
761    # $self->cataloguedata->{'texlive'} = $entry->texlive;
762    #}
763    #if (defined($entry->miktex)) {
764    #  $self->cataloguedata->{'miktex'} = $entry->miktex;
765    #}
766    if (defined($entry->caption) && $entry->caption ne "") {
767      $self->{'shortdesc'} = $entry->caption unless $self->{'shortdesc'};
768    }
769    if (defined($entry->description) && $entry->description ne "") {
770      $self->{'longdesc'} = $entry->description unless $self->{'longdesc'};
771    }
772    #
773    # we need to do the following:
774    # - take the href entry for a documentation file entry in the TC
775    # - remove the 'ctan:' prefix
776    # - remove the <ctan path='...'> part
777    # - match the rest against all docfiles in an intelligent way
778    #
779    # Example:
780    # juramisc.xml contains:
781    # <documentation details='Package documentation' language='de'
782    #   href='ctan:/macros/latex/contrib/juramisc/doc/jmgerdoc.pdf'/>
783    # <ctan path='/macros/latex/contrib/juramisc'/>
784    my @tcdocfiles = keys %{$entry->docs};  # Catalogue doc files.
785    my %tcdocfilebasenames;                 # basenames of those, as we go.
786    my @tlpdocfiles = $self->docfiles;      # TL doc files.
787    foreach my $tcdocfile (sort @tcdocfiles) {  # sort so shortest first
788      #warn "looking at tcdocfile $tcdocfile\n";
789      my $tcdocfilebasename = $tcdocfile;
790      $tcdocfilebasename =~ s/^ctan://;  # remove ctan: prefix
791      $tcdocfilebasename =~ s,.*/,,;     # remove all but the base file name
792      #warn "  got basename $tcdocfilebasename\n";
793      #
794      # If we've already seen this basename, skip.  This is for the sake
795      # of README files, which can exist in different directories but
796      # get renamed into different files in TL for various annoying reasons;
797      # e.g., ibygrk, rsfs, songbook.  In these cases, it turns out we
798      # always prefer the first entry (top-level README).
799      next if exists $tcdocfilebasenames{$tcdocfilebasename};
800      $tcdocfilebasenames{$tcdocfilebasename} = 1;
801      #
802      foreach my $tlpdocfile (@tlpdocfiles) {
803        #warn "considering merge into tlpdocfile $tlpdocfile\n";
804        if ($tlpdocfile =~ m,/$tcdocfilebasename$,) {
805          # update the language/detail tags from Catalogue if present.
806          if (defined($entry->docs->{$tcdocfile}{'details'})) {
807            my $tmp = $entry->docs->{$tcdocfile}{'details'};
808            #warn "merging details for $tcdocfile: $tmp\n";
809            # remove all embedded quotes, they are just a pain
810            $tmp =~ s/"//g;
811            $self->{'docfiledata'}{$tlpdocfile}{'details'} = $tmp;
812          }
813          if (defined($entry->docs->{$tcdocfile}{'language'})) {
814            my $tmp = $entry->docs->{$tcdocfile}{'language'};
815            #warn "merging lang for $tcdocfile: $tmp\n";
816            $self->{'docfiledata'}{$tlpdocfile}{'language'} = $tmp;
817          }
818        }
819      }
820    }
821  }
822}
823
824sub is_meta_package {
825  my $self = shift;
826  if ($self->category =~ /^$MetaCategoriesRegexp$/) {
827    return 1;
828  }
829  return 0;
830}
831
832sub docfiles_package {
833  my $self = shift;
834  if (not($self->docfiles)) { return ; }
835  my $tlp = new TeXLive::TLPOBJ;
836  $tlp->name($self->name . ".doc");
837  $tlp->shortdesc("doc files of " . $self->name);
838  $tlp->revision($self->revision);
839  $tlp->category($self->category);
840  $tlp->add_docfiles($self->docfiles);
841  $tlp->docsize($self->docsize);
842  # $self->clear_docfiles();
843  # $self->docsize(0);
844  return($tlp);
845}
846
847sub srcfiles_package {
848  my $self = shift;
849  if (not($self->srcfiles)) { return ; }
850  my $tlp = new TeXLive::TLPOBJ;
851  $tlp->name($self->name . ".source");
852  $tlp->shortdesc("source files of " . $self->name);
853  $tlp->revision($self->revision);
854  $tlp->category($self->category);
855  $tlp->add_srcfiles($self->srcfiles);
856  $tlp->srcsize($self->srcsize);
857  # $self->clear_srcfiles();
858  # $self->srcsize(0);
859  return($tlp);
860}
861
862sub split_bin_package {
863  my $self = shift;
864  my %binf = %{$self->binfiles};
865  my @retlist;
866  foreach $a (keys(%binf)) {
867    my $tlp = new TeXLive::TLPOBJ;
868    $tlp->name($self->name . ".$a");
869    $tlp->shortdesc("$a files of " . $self->name);
870    $tlp->revision($self->revision);
871    $tlp->category($self->category);
872    $tlp->add_binfiles($a,@{$binf{$a}});
873    $tlp->binsize( $a => $self->binsize->{$a} );
874    push @retlist, $tlp;
875  }
876  if (keys(%binf)) {
877    push @{$self->{'depends'}}, $self->name . ".ARCH";
878  }
879  $self->clear_binfiles();
880  return(@retlist);
881}
882
883
884# Helpers.
885#
886sub add_files {
887  my ($self,$type,@files) = @_;
888  die("Cannot use add_files for binfiles, we need that arch!")
889    if ($type eq "bin");
890  &TeXLive::TLUtils::push_uniq(\@{ $self->{"${type}files"} }, @files);
891}
892
893sub remove_files {
894  my ($self,$type,@files) = @_;
895  die("Cannot use remove_files for binfiles, we need that arch!")
896    if ($type eq "bin");
897  my @finalfiles;
898  foreach my $f (@{$self->{"${type}files"}}) {
899    if (not(&TeXLive::TLUtils::member($f,@files))) {
900      push @finalfiles,$f;
901    }
902  }
903  $self->{"${type}files"} = [ @finalfiles ];
904}
905
906sub contains_file {
907  my ($self,$fn) = @_;
908  # if the filename already contains a / do not add it at the beginning
909  my $ret = "";
910  if ($fn =~ m!/!) {
911    return(grep(m!$fn$!, $self->all_files));
912  } else {
913    return(grep(m!(^|/)$fn$!,$self->all_files));
914  }
915}
916
917sub all_files {
918  my ($self) = shift;
919  my @ret = ();
920
921  push (@ret, $self->docfiles);
922  push (@ret, $self->runfiles);
923  push (@ret, $self->srcfiles);
924  push (@ret, $self->allbinfiles);
925
926  return @ret;
927}
928
929sub allbinfiles {
930  my $self = shift;
931  my @ret = ();
932  my %binfiles = %{$self->binfiles};
933
934  foreach my $arch (keys %binfiles) {
935    push (@ret, @{$binfiles{$arch}});
936  }
937
938  return @ret;
939}
940
941sub format_definitions {
942  my $self = shift;
943  my $pkg = $self->name;
944  my @ret;
945  for my $e ($self->executes) {
946    if ($e =~ m/AddFormat\s+(.*)\s*/) {
947      my %r = TeXLive::TLUtils::parse_AddFormat_line("$1");
948      if (defined($r{"error"})) {
949        die "$r{'error'}, package $pkg, execute $e";
950      }
951      push @ret, \%r;
952    }
953  }
954  return @ret;
955}
956
957#
958# execute stuff
959#
960sub fmtutil_cnf_lines {
961  my $obj = shift;
962  my @disabled = @_;
963  my @fmtlines = ();
964  my $first = 1;
965  my $pkg = $obj->name;
966  foreach my $e ($obj->executes) {
967    if ($e =~ m/AddFormat\s+(.*)\s*/) {
968      my %r = TeXLive::TLUtils::parse_AddFormat_line("$1");
969      if (defined($r{"error"})) {
970        die "$r{'error'}, package $pkg, execute $e";
971      }
972      if ($first) {
973        push @fmtlines, "#\n# from $pkg:\n";
974        $first = 0;
975      }
976      my $mode = ($r{"mode"} ? "" : "#! ");
977      $mode = "#! " if TeXLive::TLUtils::member ($r{'name'}, @disabled);
978      push @fmtlines, "$mode$r{'name'} $r{'engine'} $r{'patterns'} $r{'options'}\n";
979    }
980  }
981  return @fmtlines;
982}
983
984
985sub updmap_cfg_lines {
986  my $obj = shift;
987  my @disabled = @_;
988  my %maps;
989  foreach my $e ($obj->executes) {
990    if ($e =~ m/addMap (.*)$/) {
991      $maps{$1} = 1;
992    } elsif ($e =~ m/addMixedMap (.*)$/) {
993      $maps{$1} = 2;
994    } elsif ($e =~ m/addKanjiMap (.*)$/) {
995      $maps{$1} = 3;
996    }
997    # others are ignored here
998  }
999  my @updmaplines;
1000  foreach (sort keys %maps) {
1001    next if TeXLive::TLUtils::member($_, @disabled);
1002    if ($maps{$_} == 1) {
1003      push @updmaplines, "Map $_\n";
1004    } elsif ($maps{$_} == 2) {
1005      push @updmaplines, "MixedMap $_\n";
1006    } elsif ($maps{$_} == 3) {
1007      push @updmaplines, "KanjiMap $_\n";
1008    } else {
1009      tlerror("Should not happen!\n");
1010    }
1011  }
1012  return(@updmaplines);
1013}
1014
1015
1016sub language_dat_lines {
1017  my $self = shift;
1018  local @disabled = @_;  # we use @disabled in the nested sub
1019  my @lines = $self->_parse_hyphen_execute(\&make_dat_lines, 'dat');
1020  return @lines;
1021
1022  sub make_dat_lines {
1023    my ($name, $lhm, $rhm, $file, $syn) = @_;
1024    my @ret;
1025    return if TeXLive::TLUtils::member($name, @disabled);
1026    push @ret, "$name $file\n";
1027    foreach (@$syn) {
1028      push @ret, "=$_\n";
1029    }
1030    return @ret;
1031  }
1032}
1033
1034
1035sub language_def_lines {
1036  my $self = shift;
1037  local @disabled = @_;  # we use @disabled in the nested sub
1038  my @lines = $self->_parse_hyphen_execute(\&make_def_lines, 'def');
1039  return @lines;
1040
1041  sub make_def_lines {
1042    my ($name, $lhm, $rhm, $file, $syn) = @_;
1043    return if TeXLive::TLUtils::member($name, @disabled);
1044    my $exc = "";
1045    my @ret;
1046    push @ret, "\\addlanguage\{$name\}\{$file\}\{$exc\}\{$lhm\}\{$rhm\}\n";
1047    foreach (@$syn) {
1048      # synonyms in language.def ???
1049      push @ret, "\\addlanguage\{$_\}\{$file\}\{$exc\}\{$lhm\}\{$rhm\}\n";
1050      #debug("Ignoring synonym $_ for $name when creating language.def\n");
1051    }
1052    return @ret;
1053  }
1054}
1055
1056
1057sub language_lua_lines {
1058  my $self = shift;
1059  local @disabled = @_;  # we use @disabled in the nested sub
1060  my @lines = $self->_parse_hyphen_execute(\&make_lua_lines, 'lua', '--');
1061  return @lines;
1062
1063  sub make_lua_lines {
1064    my ($name, $lhm, $rhm, $file, $syn, $patt, $hyph, $special) = @_;
1065    return if TeXLive::TLUtils::member($name, @disabled);
1066    my @syn = (@$syn); # avoid modifying the original
1067    map { $_ = "'$_'" } @syn;
1068    my @ret;
1069    push @ret, "['$name'] = {", "\tloader = '$file',",
1070               "\tlefthyphenmin = $lhm,", "\trighthyphenmin = $rhm,",
1071               "\tsynonyms = { " . join(', ', @syn) . " },";
1072    push @ret, "\tpatterns = '$patt'," if defined $patt;
1073    push @ret, "\thyphenation = '$hyph'," if defined $hyph;
1074    push @ret, "\tspecial = '$special'," if defined $special;
1075    push @ret, '},';
1076    map { $_ = "\t$_\n" } @ret;
1077    return @ret;
1078  }
1079}
1080
1081
1082sub _parse_hyphen_execute {
1083  my ($obj, $coderef, $db, $cc) = @_;
1084  $cc ||= '%'; # default comment char
1085  my @langlines = ();
1086  my $pkg = $obj->name;
1087  my $first = 1;
1088  foreach my $e ($obj->executes) {
1089    if ($e =~ m/AddHyphen\s+(.*)\s*/) {
1090      my %r = TeXLive::TLUtils::parse_AddHyphen_line("$1");
1091      if (defined($r{"error"})) {
1092        die "$r{'error'}, package $pkg, execute $e";
1093      }
1094      if (not TeXLive::TLUtils::member($db, @{$r{"databases"}})) {
1095        next;
1096      }
1097      if ($first) {
1098        push @langlines, "$cc from $pkg:\n";
1099        $first = 0;
1100      }
1101      if ($r{"comment"}) {
1102          push @langlines, "$cc $r{comment}\n";
1103      }
1104      my @foo = &$coderef ($r{"name"}, $r{"lefthyphenmin"},
1105                           $r{"righthyphenmin"}, $r{"file"}, $r{"synonyms"},
1106                           $r{"file_patterns"}, $r{"file_exceptions"},
1107                           $r{"luaspecial"});
1108      push @langlines, @foo;
1109    }
1110  }
1111  return @langlines;
1112}
1113
1114
1115
1116# member access functions
1117#
1118sub name {
1119  my $self = shift;
1120  if (@_) { $self->{'name'} = shift }
1121  return $self->{'name'};
1122}
1123sub category {
1124  my $self = shift;
1125  if (@_) { $self->{'category'} = shift }
1126  return $self->{'category'};
1127}
1128sub shortdesc {
1129  my $self = shift;
1130  if (@_) { $self->{'shortdesc'} = shift }
1131  return $self->{'shortdesc'};
1132}
1133sub longdesc {
1134  my $self = shift;
1135  if (@_) { $self->{'longdesc'} = shift }
1136  return $self->{'longdesc'};
1137}
1138sub revision {
1139  my $self = shift;
1140  if (@_) { $self->{'revision'} = shift }
1141  return $self->{'revision'};
1142}
1143sub relocated {
1144  my $self = shift;
1145  if (@_) { $self->{'relocated'} = shift }
1146  return ($self->{'relocated'} ? 1 : 0);
1147}
1148sub catalogue {
1149  my $self = shift;
1150  if (@_) { $self->{'catalogue'} = shift }
1151  return $self->{'catalogue'};
1152}
1153sub srcfiles {
1154  my $self = shift;
1155  if (@_) { $self->{'srcfiles'} = [ @_ ] }
1156  return @{ $self->{'srcfiles'} };
1157}
1158sub containersize {
1159  my $self = shift;
1160  if (@_) { $self->{'containersize'} = shift }
1161  return ( defined($self->{'containersize'}) ? $self->{'containersize'} : -1 );
1162}
1163sub srccontainersize {
1164  my $self = shift;
1165  if (@_) { $self->{'srccontainersize'} = shift }
1166  return ( defined($self->{'srccontainersize'}) ? $self->{'srccontainersize'} : -1 );
1167}
1168sub doccontainersize {
1169  my $self = shift;
1170  if (@_) { $self->{'doccontainersize'} = shift }
1171  return ( defined($self->{'doccontainersize'}) ? $self->{'doccontainersize'} : -1 );
1172}
1173sub containermd5 {
1174  my $self = shift;
1175  if (@_) { $self->{'containermd5'} = shift }
1176  return ( defined($self->{'containermd5'}) ? $self->{'containermd5'} : "" );
1177}
1178sub srccontainermd5 {
1179  my $self = shift;
1180  if (@_) { $self->{'srccontainermd5'} = shift }
1181  return ( defined($self->{'srccontainermd5'}) ? $self->{'srccontainermd5'} : "" );
1182}
1183sub doccontainermd5 {
1184  my $self = shift;
1185  if (@_) { $self->{'doccontainermd5'} = shift }
1186  return ( defined($self->{'doccontainermd5'}) ? $self->{'doccontainermd5'} : "" );
1187}
1188sub srcsize {
1189  my $self = shift;
1190  if (@_) { $self->{'srcsize'} = shift }
1191  return ( defined($self->{'srcsize'}) ? $self->{'srcsize'} : 0 );
1192}
1193sub clear_srcfiles {
1194  my $self = shift;
1195  $self->{'srcfiles'} = [ ] ;
1196}
1197sub add_srcfiles {
1198  my ($self,@files) = @_;
1199  $self->add_files("src",@files);
1200}
1201sub remove_srcfiles {
1202  my ($self,@files) = @_;
1203  $self->remove_files("src",@files);
1204}
1205sub docfiles {
1206  my $self = shift;
1207  if (@_) { $self->{'docfiles'} = [ @_ ] }
1208  return @{ $self->{'docfiles'} };
1209}
1210sub clear_docfiles {
1211  my $self = shift;
1212  $self->{'docfiles'} = [ ] ;
1213}
1214sub docsize {
1215  my $self = shift;
1216  if (@_) { $self->{'docsize'} = shift }
1217  return ( defined($self->{'docsize'}) ? $self->{'docsize'} : 0 );
1218}
1219sub add_docfiles {
1220  my ($self,@files) = @_;
1221  $self->add_files("doc",@files);
1222}
1223sub remove_docfiles {
1224  my ($self,@files) = @_;
1225  $self->remove_files("doc",@files);
1226}
1227sub docfiledata {
1228  my $self = shift;
1229  my %newfiles = @_;
1230  if (@_) { $self->{'docfiledata'} = \%newfiles }
1231  return $self->{'docfiledata'};
1232}
1233sub binfiles {
1234  my $self = shift;
1235  my %newfiles = @_;
1236  if (@_) { $self->{'binfiles'} = \%newfiles }
1237  return $self->{'binfiles'};
1238}
1239sub clear_binfiles {
1240  my $self = shift;
1241  $self->{'binfiles'} = { };
1242}
1243sub binsize {
1244  my $self = shift;
1245  my %newsizes = @_;
1246  if (@_) { $self->{'binsize'} = \%newsizes }
1247  return $self->{'binsize'};
1248}
1249sub add_binfiles {
1250  my ($self,$arch,@files) = @_;
1251  &TeXLive::TLUtils::push_uniq(\@{ $self->{'binfiles'}{$arch} }, @files);
1252}
1253sub remove_binfiles {
1254  my ($self,$arch,@files) = @_;
1255  my @finalfiles;
1256  foreach my $f (@{$self->{'binfiles'}{$arch}}) {
1257    if (not(&TeXLive::TLUtils::member($f,@files))) {
1258      push @finalfiles,$f;
1259    }
1260  }
1261  $self->{'binfiles'}{$arch} = [ @finalfiles ];
1262}
1263sub runfiles {
1264  my $self = shift;
1265  if (@_) { $self->{'runfiles'} = [ @_ ] }
1266  return @{ $self->{'runfiles'} };
1267}
1268sub clear_runfiles {
1269  my $self = shift;
1270  $self->{'runfiles'} = [ ] ;
1271}
1272sub runsize {
1273  my $self = shift;
1274  if (@_) { $self->{'runsize'} = shift }
1275  return ( defined($self->{'runsize'}) ? $self->{'runsize'} : 0 );
1276}
1277sub add_runfiles {
1278  my ($self,@files) = @_;
1279  $self->add_files("run",@files);
1280}
1281sub remove_runfiles {
1282  my ($self,@files) = @_;
1283  $self->remove_files("run",@files);
1284}
1285sub depends {
1286  my $self = shift;
1287  if (@_) { $self->{'depends'} = [ @_ ] }
1288  return @{ $self->{'depends'} };
1289}
1290sub executes {
1291  my $self = shift;
1292  if (@_) { $self->{'executes'} = [ @_ ] }
1293  return @{ $self->{'executes'} };
1294}
1295sub postactions {
1296  my $self = shift;
1297  if (@_) { $self->{'postactions'} = [ @_ ] }
1298  return @{ $self->{'postactions'} };
1299}
1300sub containerdir {
1301  my @self = shift;
1302  if (@_) { $_containerdir = $_[0] }
1303  return $_containerdir;
1304}
1305sub cataloguedata {
1306  my $self = shift;
1307  my %ct = @_;
1308  if (@_) { $self->{'cataloguedata'} = \%ct }
1309  return $self->{'cataloguedata'};
1310}
1311
1312format multilineformat =
1313longdesc ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
1314$_tmp
1315.
1316
13171;
1318__END__
1319
1320
1321=head1 NAME
1322
1323C<TeXLive::TLPOBJ> -- TeX Live Package Object access module
1324
1325=head1 SYNOPSIS
1326
1327  use TeXLive::TLPOBJ;
1328
1329  my $tlpobj=TeXLive::TLPOBJ->new(name => "foobar");
1330
1331=head1 DESCRIPTION
1332
1333The L<TeXLive::TLPOBJ> module provide access to TeX Live Package Object
1334files describing a self-contained package.
1335
1336=head1 FILE SPECIFICATION
1337
1338Please see L<TeXLive::TLPSRC> documentation for the specification. The
1339only differences are that the various C<*pattern> keys are invalid, and
1340instead there are the respective C<*files> keys described below. Furthermore
1341some more I<keys> is allowed: C<revision> which specifies the maximum of
1342all last changed revision of files contained in the package, anything
1343starting with C<catalogue-> specifying information coming from the
1344TeX Catalogue, and C<relocated> taking either 0 or 1 indicating that
1345this packages has been relocated, i.e., in the containers the
1346initial C<texmf-dist> directory has been stripped off.
1347
1348All these keys have in common that they are followed by a list of files
1349I<indented> by one space. They differ only in the first line itself
1350(described below).
1351
1352=over 4
1353
1354=item C<srcfiles>, C<runfiles>, C<binfiles>, C<docfiles>
1355each of these items contains addition the sum of sizes of the
1356single files (in number of C<TeXLive::TLConfig::BlockSize> blocks, which
1357is currently 4k).
1358
1359  srcfiles size=NNNNNN
1360  runfiles size=NNNNNN
1361
1362=item C<docfiles>
1363
1364The docfiles line itself is similar to the C<srcfiles> and C<runfiles> lines
1365above:
1366
1367  docfiles size=NNNNNN
1368
1369But the lines listing the files are allowed to have additional tags:
1370
1371  /------- excerpt from achemso.tlpobj
1372  |...
1373  |docfiles size=1702468
1374  | texmf-dist/doc/latex/aeguill/README details="Package Readme"
1375  | texmf-dist/doc/latex/achemso/achemso.pdf details="Package documentation" language="en"
1376  |...
1377
1378Currently only the tags C<details> and C<language> are allowed. These
1379additional information can be accessed via the C<docfiledata> function
1380returning a hash with the respective files (including path) as key.
1381
1382=item C<binfiles>
1383
1384Since C<binfiles> are different for the different architectures one
1385C<tlpobj> file can contain C<binfiles> lines for different
1386architectures. The architecture is specified on the C<binfiles> using
1387the C<arch=>I<XXX> tag. Thus, C<binfiles> lines look like
1388
1389  binfiles arch=XXXX size=NNNNN
1390
1391=back
1392
1393Here is an excerpt from the representation of the C<dvipsk> package,
1394with C<|> characters inserted to show the indentation:
1395
1396  |name dvipsk
1397  |category TLCore
1398  |revision 4427
1399  |docfiles size=959434
1400  | texmf-dist/doc/dvips/dvips.html
1401  | ...
1402  |runfiles size=1702468
1403  | texmf-dist/dvips/base/color.pro
1404  | ...
1405  | texmf-dist/scripts/pkfix/pkfix.pl
1406  |binfiles arch=i386-solaris size=329700
1407  | bin/i386-solaris/afm2tfm
1408  | bin/i386-solaris/dvips
1409  | bin/i386-solaris/pkfix
1410  |binfiles arch=win32 size=161280
1411  | bin/win32/afm2tfm.exe
1412  | bin/win32/dvips.exe
1413  | bin/win32/pkfix.exe
1414  |...
1415
1416=head1 PACKAGE VARIABLES
1417
1418TeXLive::TLPOBJ has one package wide variable which is C<containerdir> where
1419generated container files are saved (if not otherwise specified.
1420
1421  TeXLive::TLPOBJ->containerdir("path/to/container/dir");
1422
1423=head1 MEMBER ACCESS FUNCTIONS
1424
1425For any of the I<keys> a function
1426
1427  $tlpobj->key
1428
1429is available, which returns the current value when called without an argument,
1430and sets the respective value when called with an argument. For the
1431TeX Catalogue Data the function
1432
1433  $tlpobj->cataloguedata
1434
1435returns and takes as argument a hash.
1436
1437Arguments and return values for C<name>, C<category>, C<shortdesc>,
1438C<longdesc>, C<catalogue>, C<revision> are single scalars.
1439
1440Arguments and return values for C<depends>, C<executes> are lists.
1441
1442Arguments and return values for C<docfiles>, C<runfiles>, C<srcfiles>
1443are lists.
1444
1445Arguments and return values for C<binfiles> is a hash with the
1446architectures as keys.
1447
1448Arguments and return values for C<docfiledata> is a hash with the
1449full file names of docfiles as key, and the value is again a hash.
1450
1451The size values are handled with these functions:
1452
1453  $tlpobj->docsize
1454  $tlpobj->runsize
1455  $tlpobj->srcsize
1456  $tlpobj->binsize("arch1" => size1, "arch2" => size2, ...)
1457
1458which set or get the current value of the respective sizes. Note that also
1459the C<binsize> function returns (and takes as argument) a hash with the
1460architectures as keys, similar to the C<runfiles> functions (see above).
1461
1462Futhermore, if the tlpobj is contained ina tlpdb which describes a media
1463where the files are distributed in packed format (usually as .tar.xz),
1464there are 6 more possible keys:
1465
1466  $tlpobj->containersize
1467  $tlpobj->doccontainersize
1468  $tlpobj->srccontainersize
1469  $tlpobj->containermd5
1470  $tlpobj->doccontainermd5
1471  $tlpobj->srccontainermd5
1472
1473describing the respective sizes and md5sums in bytes and as hex string, resp.
1474The latter two are only present
1475if src/doc file container splitting is activated for that install medium.
1476
1477=head1 OTHER FUNCTIONS
1478
1479The following functions can be called for an C<TLPOBJ> object:
1480
1481=over 4
1482
1483=item C<new>
1484
1485The constructor C<new> returns a new C<TLPSRC> object. The arguments
1486to the C<new> constructor can be in the usual hash representation for
1487the different keys above:
1488
1489  $tlpobj=TLPOBJ->new(name => "foobar", shortdesc => "The foobar package");
1490
1491=item C<from_file("filename")>
1492
1493reads a C<tlpobj> file.
1494
1495  $tlpobj = new TLPOBJ;
1496  $tlpobj->from_file("path/to/the/tlpobj/file");
1497
1498=item C<from_fh($filehandle[, $multi])>
1499
1500read the textual representation of a TLPOBJ from an already opened
1501file handle.  If C<$multi> is undef (i.e., not given) then multiple
1502tlpobj in the same file are treated as errors. If C<$multi> is defined,
1503then returns after reading one tlpobj.
1504
1505Returns C<1> if it found a C<tlpobj>, otherwise C<0>.
1506
1507=item C<writeout>
1508
1509writes the textual representation of a C<TLPOBJ> object to C<stdout>,
1510or the filehandle if given:
1511
1512  $tlpsrc->writeout;
1513  $tlpsrc->writeout(\*FILEHANDLE);
1514
1515=item C<writeout_simple>
1516
1517debugging function for comparison with C<tpm>/C<tlps>, will go away.
1518
1519=item C<common_texmf_tree>
1520
1521if all files of the package are from the same texmf tree, this tree
1522is returned, otherwise an undefined value. That is also a check
1523whether a package is relocatable.
1524
1525=item C<make_container($type,$instroot[, $destdir[, $containername[, $relative]]])>
1526
1527creates a container file of the all files in the C<TLPOBJ>
1528in C<$destdir> (if not defined then C<< TLPOBJ->containerdir >> is used).
1529
1530The C<$type> variable specifies the type of container to be used.
1531Currently only C<zip> or C<xz> are allowed, and are generating
1532zip files and tar.xz files, respectively.
1533
1534The file name of the created container file is C<$containername.extension>,
1535where extension is either C<.zip> or C<.tar.xz>, depending on the
1536setting of C<$type>. If no C<$containername> is specified the package name
1537is used.
1538
1539All container files B<also> contain the respective
1540C<TLPOBJ> file in C<tlpkg/tlpobj/$name.tlpobj>.
1541
1542The argument C<$instroot> specifies the root of the installation from
1543which the files should be taken.
1544
1545If the argument C<$relative> is present and true (perlish true) AND the
1546packages does not span multiple texmf trees (i.e., all the first path
1547components of all files are the same) then a relative packages is created,
1548i.e., the first path component is stripped. In this case the tlpobj file
1549is placed into the root of the installation.
1550
1551This is used to distribute packages which can be installed in any arbitrary
1552texmf tree (of other distributions, too).
1553
1554Return values are the size, the md5sum, and the full name of the container.
1555
1556=item C<recompute_sizes($tltree)>
1557
1558recomputes the sizes based on the information present in C<$tltree>.
1559
1560=item C<recompute_revision($tltree [, $revtlpsrc ])>
1561
1562recomputes the revision based on the information present in C<$tltree>.
1563The optional argument C<$rectlpsrc> can be an additional revision number
1564which is taken into account. C<$tlpsrc->make_tlpobj> adds the revision
1565number of the C<tlpsrc> file here so that collections (which do not
1566contain files) also have revision number.
1567
1568=item C<update_from_catalogue($texcatalogue)>
1569
1570adds information from a C<TeXCatalogue> object
1571(currently license, version, url, and updates docfiles with details and
1572languages tags if present in the Catalogue).
1573
1574=item C<split_bin_package>
1575
1576splits off the binfiles of C<TLPOBJ> into new independent C<TLPOBJ> with
1577the original name plus ".arch" for every arch for which binfiles are present.
1578The original package is changed in two respects: the binfiles are removed
1579(since they are now in the single name.arch packages), and an additional
1580depend on "name.ARCH" is added. Note that the ARCH is a placeholder.
1581
1582=item C<srcfiles_package>
1583
1584=item C<docfiles_package>
1585
1586splits off the srcfiles or docfiles of C<TLPOBJ> into new independent
1587C<TLPOBJ> with
1588the original name plus ".sources". The source/doc files are
1589B<not> removed from the original package, since these functions are only
1590used for the creation of split containers.
1591
1592=item C<is_arch_dependent>
1593
1594returns C<1> if there are C<binfiles>, otherwise C<0>.
1595
1596=item C<total_size>
1597
1598If no argument is given returns the sum of C<srcsize>, C<docsize>,
1599C<runsize>.
1600
1601If arguments are given, they are assumed to be architecture names, and
1602it returns the above plus the sum of sizes of C<binsize> for those
1603architectures.
1604
1605=item C<is_meta_package>
1606
1607Returns true if the package is a meta package as defined in TLConfig
1608(Currently Collection and Scheme).
1609
1610=item C<clear_{src,run,doc,bin}files>
1611
1612Removes all the src/run/doc/binfiles from the C<TLPOBJ>.
1613
1614=item C<{add,remove}_{src,run,doc}files(@files)>
1615
1616adds or removes files to the respective list of files.
1617
1618=item C<{add,remove}_binfiles($arch, @files)>
1619
1620adds or removes files from the list of C<binfiles> for the given architecture.
1621
1622=item C<{add,remove}_files($type, $files)>
1623
1624adds or removes files for the given type (only for C<run>, C<src>, C<doc>).
1625
1626=item C<contains_file($filename)>
1627
1628returns the list of files matching $filename which are contained in
1629the package. If $filename contains a / the matching is only anchored
1630at the end with $. Otherwise it is prefix with a / and anchored at the end.
1631
1632=item C<all_files>
1633
1634returns a list of all files of all types.  However, binary files won't
1635be found until dependencies have been expanded via (most likely)
1636L<TeXLive::TLPDB::expand_dependencies>.  For a more or less standalone
1637example, see the C<find_old_files> function in the
1638script C<Master/tlpkg/libexec/place>.
1639
1640=item C<allbinfiles>
1641
1642returns a list of all binary files.
1643
1644=item C<< $tlpobj->format_definitions  >>
1645
1646The function C<format_definitions> returns a list of references to hashes
1647where each hash is a format definition.
1648
1649=item C<< $tlpobj->fmtutil_cnf_lines >>
1650
1651The function C<fmtutil_cnf_lines> returns the lines for fmtutil.cnf
1652for this package.
1653
1654=item C<< $tlpobj->updmap_cfg_lines >>
1655
1656The function C<updmap_cfg_lines> returns the list lines for updmap.cfg
1657for the given package.
1658
1659=item C<< $tlpobj->language_dat_lines >>
1660
1661The function C<language_dat_lines> returns the list of all
1662lines for language.dat that can be generated from the tlpobj
1663
1664=item C<< $tlpobj->language_def_lines >>
1665
1666The function C<language_def_lines> returns the list of all
1667lines for language.def that can be generated from the tlpobj.
1668
1669=item C<< $tlpobj->language_lua_lines >>
1670
1671The function C<language_lua_lines> returns the list of all
1672lines for language.dat.lua that can be generated from the tlpobj.
1673
1674=back
1675
1676=head1 SEE ALSO
1677
1678The modules L<TeXLive::TLConfig>, L<TeXLive::TLUtils>, L<TeXLive::TLPSRC>,
1679L<TeXLive::TLPDB>, L<TeXLive::TLTREE>, L<TeXLive::TeXCatalogue>.
1680
1681=head1 AUTHORS AND COPYRIGHT
1682
1683This script and its documentation were written for the TeX Live
1684distribution (L<http://tug.org/texlive>) and both are licensed under the
1685GNU General Public License Version 2 or later.
1686
1687=cut
1688
1689### Local Variables:
1690### perl-indent-level: 2
1691### tab-width: 2
1692### indent-tabs-mode: nil
1693### End:
1694# vim:set tabstop=2 expandtab: #
1695