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