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