summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/TeXLive/TLPOBJ.pm
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/TeXLive/TLPOBJ.pm
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/TeXLive/TLPOBJ.pm')
-rw-r--r--systems/texlive/tlnet/tlpkg/TeXLive/TLPOBJ.pm1837
1 files changed, 1837 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/TeXLive/TLPOBJ.pm b/systems/texlive/tlnet/tlpkg/TeXLive/TLPOBJ.pm
new file mode 100644
index 0000000000..54f868218c
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/TeXLive/TLPOBJ.pm
@@ -0,0 +1,1837 @@
+# $Id: TLPOBJ.pm 50211 2019-03-03 21:52:59Z preining $
+# TeXLive::TLPOBJ.pm - module for using tlpobj files
+# Copyright 2007-2019 Norbert Preining
+# This file is licensed under the GNU General Public License version 2
+# or any later version.
+
+package TeXLive::TLPOBJ;
+
+my $svnrev = '$Revision: 50211 $';
+my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown";
+sub module_revision { return $_modulerevision; }
+
+use TeXLive::TLConfig qw($DefaultCategory $CategoriesRegexp
+ $MetaCategoriesRegexp $InfraLocation
+ %Compressors $DefaultCompressorFormat
+ $RelocPrefix $RelocTree);
+use TeXLive::TLCrypto;
+use TeXLive::TLTREE;
+use TeXLive::TLUtils;
+
+our $_tmp;
+my $_containerdir;
+
+
+sub new {
+ my $class = shift;
+ my %params = @_;
+ my $self = {
+ name => $params{'name'},
+ category => defined($params{'category'}) ? $params{'category'} : $DefaultCategory,
+ shortdesc => $params{'shortdesc'},
+ longdesc => $params{'longdesc'},
+ catalogue => $params{'catalogue'},
+ relocated => $params{'relocated'},
+ runfiles => defined($params{'runfiles'}) ? $params{'runfiles'} : [],
+ runsize => $params{'runsize'},
+ srcfiles => defined($params{'srcfiles'}) ? $params{'srcfiles'} : [],
+ srcsize => $params{'srcsize'},
+ docfiles => defined($params{'docfiles'}) ? $params{'docfiles'} : [],
+ docsize => $params{'docsize'},
+ executes => defined($params{'executes'}) ? $params{'executes'} : [],
+ postactions => defined($params{'postactions'}) ? $params{'postactions'} : [],
+ # note that binfiles is a HASH with keys of $arch!
+ binfiles => defined($params{'binfiles'}) ? $params{'binfiles'} : {},
+ binsize => defined($params{'binsize'}) ? $params{'binsize'} : {},
+ depends => defined($params{'depends'}) ? $params{'depends'} : [],
+ revision => $params{'revision'},
+ cataloguedata => defined($params{'cataloguedata'}) ? $params{'cataloguedata'} : {},
+ };
+ $_containerdir = $params{'containerdir'} if defined($params{'containerdir'});
+ bless $self, $class;
+ return $self;
+}
+
+
+sub copy {
+ my $self = shift;
+ my $bla = {};
+ %$bla = %$self;
+ bless $bla, "TeXLive::TLPOBJ";
+ return $bla;
+}
+
+
+sub from_file {
+ my $self = shift;
+ if (@_ != 1) {
+ die("TLPOBJ:from_file: Need a filename for initialization");
+ }
+ open(TMP,"<$_[0]") || die("Cannot open tlpobj file: $_[0]");
+ $self->from_fh(\*TMP);
+}
+
+sub from_fh {
+ my ($self,$fh,$multi) = @_;
+ my $started = 0;
+ my $lastcmd = "";
+ my $arch;
+ my $size;
+
+ while (my $line = <$fh>) {
+ # we do not worry about whitespace at the end of a line;
+ # that would be a bug in the db creation, and it takes some
+ # noticeable time to get rid of it. So just chomp.
+ chomp($line);
+
+ # we call tllog only when something will be logged, to speed things up.
+ # this is the inner loop bounding the time to read tlpdb.
+ dddebug("reading line: >>>$line<<<\n") if ($::opt_verbosity >= 3);
+ $line =~ /^#/ && next; # skip comment lines
+ if ($line =~ /^\s*$/) {
+ if (!$started) { next; }
+ if (defined($multi)) {
+ # we may read from a tldb file
+ return 1;
+ } else {
+ # we are reading one tldb file, nothing else allowed
+ die("No empty line allowed within tlpobj files!");
+ }
+ }
+
+ my ($cmd, $arg) = split(/\s+/, $line, 2);
+ # first command must be name
+ $started || $cmd eq 'name'
+ or die("First directive needs to be 'name', not $line");
+
+ # now the big switch, ordered by decreasing number of occurences
+ if ($cmd eq '') {
+ if ($lastcmd eq "runfiles" || $lastcmd eq "srcfiles") {
+ push @{$self->{$lastcmd}}, $arg;
+ } elsif ($lastcmd eq "docfiles") {
+ my ($f, $rest) = split(' ', $arg, 2);
+ push @{$self->{'docfiles'}}, $f;
+ # docfiles can have tags, but the parse_line function is so
+ # time intense that we try to call it only when necessary
+ if (defined $rest) {
+ # parse_line has problems with double quotes in double quotes
+ # my @words = &TeXLive::TLUtils::parse_line('\s+', 0, $rest);
+ # do manual parsing
+ # this is not optimal, but since we support only two tags there
+ # are not so many cases
+ # Warning: need tp check the double cases first!!!
+ if ($rest =~ m/^language="(.*)"\s+details="(.*)"\s*$/) {
+ $self->{'docfiledata'}{$f}{'details'} = $2;
+ $self->{'docfiledata'}{$f}{'language'} = $1;
+ } elsif ($rest =~ m/^details="(.*)"\s+language="(.*)"\s*$/) {
+ $self->{'docfiledata'}{$f}{'details'} = $1;
+ $self->{'docfiledata'}{$f}{'language'} = $2;
+ } elsif ($rest =~ m/^details="(.*)"\s*$/) {
+ $self->{'docfiledata'}{$f}{'details'} = $1;
+ } elsif ($rest =~ m/^language="(.*)"\s*$/) {
+ $self->{'docfiledata'}{$f}{'language'} = $1;
+ } else {
+ tlwarn("$0: Unparsable tagging in TLPDB line: $line\n");
+ }
+ }
+ } elsif ($lastcmd eq "binfiles") {
+ push @{$self->{'binfiles'}{$arch}}, $arg;
+ } else {
+ die("Continuation of $lastcmd not allowed, please fix tlpobj: line = $line!\n");
+ }
+ } elsif ($cmd eq "longdesc") {
+ my $desc = defined $arg ? $arg : '';
+ if (defined($self->{'longdesc'})) {
+ $self->{'longdesc'} .= " $desc";
+ } else {
+ $self->{'longdesc'} = $desc;
+ }
+ } elsif ($cmd =~ /^catalogue-(.+)$/o) {
+ $self->{'cataloguedata'}{$1} = $arg if defined $arg;
+ } elsif ($cmd =~ /^(doc|src|run)files$/o) {
+ my $type = $1;
+ for (split ' ', $arg) {
+ my ($k, $v) = split('=', $_, 2);
+ if ($k eq 'size') {
+ $self->{"${type}size"} = $v;
+ } else {
+ die "Unknown tag: $line";
+ }
+ }
+ } elsif ($cmd eq 'containersize' || $cmd eq 'srccontainersize'
+ || $cmd eq 'doccontainersize') {
+ $arg =~ /^[0-9]+$/ or die "Invalid size value: $line!";
+ $self->{$cmd} = $arg;
+ } elsif ($cmd eq 'containermd5' || $cmd eq 'srccontainermd5'
+ || $cmd eq 'doccontainermd5') {
+ $arg =~ /^[a-f0-9]{32}$/ or die "Invalid md5 value: $line!";
+ $self->{$cmd} = $arg;
+ } elsif ($cmd eq 'containerchecksum' || $cmd eq 'srccontainerchecksum'
+ || $cmd eq 'doccontainerchecksum') {
+ $arg =~ /^[a-f0-9]{$TeXLive::TLConfig::ChecksumLength}$/
+ or die "Invalid checksum value: $line!";
+ $self->{$cmd} = $arg;
+ } elsif ($cmd eq 'name') {
+ $arg =~ /^([-.\w]+)$/ or die("Invalid name: $line!");
+ $self->{'name'} = $arg;
+ $started && die("Cannot have two name directives: $line!");
+ $started = 1;
+ } elsif ($cmd eq 'category') {
+ $self->{'category'} = $arg;
+ if ($self->{'category'} !~ /^$CategoriesRegexp/o) {
+ tlwarn("Unknown category " . $self->{'category'} . " for package "
+ . $self->name . " found.\nPlease update texlive.infra.\n");
+ }
+ } elsif ($cmd eq 'revision') {
+ $self->{'revision'} = $arg;
+ } elsif ($cmd eq 'shortdesc') {
+ $self->{'shortdesc'} .= defined $arg ? $arg : ' ';
+ } elsif ($cmd eq 'execute' || $cmd eq 'postaction'
+ || $cmd eq 'depend') {
+ push @{$self->{$cmd . 's'}}, $arg if defined $arg;
+ } elsif ($cmd eq 'binfiles') {
+ for (split ' ', $arg) {
+ my ($k, $v) = split('=', $_, 2);
+ if ($k eq 'arch') {
+ $arch = $v;
+ } elsif ($k eq 'size') {
+ $size = $v;
+ } else {
+ die "Unknown tag: $line";
+ }
+ }
+ if (defined($size)) {
+ $self->{'binsize'}{$arch} = $size;
+ }
+ } elsif ($cmd eq 'relocated') {
+ ($arg eq '0' || $arg eq '1') or die "Invalid value: $line!";
+ $self->{'relocated'} = $arg;
+ } elsif ($cmd eq 'catalogue') {
+ $self->{'catalogue'} = $arg;
+ } else {
+ die("Unknown directive ...$line... , please fix it!");
+ }
+ $lastcmd = $cmd unless $cmd eq '';
+ }
+ return $started;
+}
+
+sub recompute_revision {
+ my ($self,$tltree, $revtlpsrc) = @_;
+ my @files = $self->all_files;
+ my $filemax = 0;
+ $self->revision(0);
+ foreach my $f (@files) {
+ $filemax = $tltree->file_svn_lastrevision($f);
+ $self->revision(($filemax > $self->revision) ? $filemax : $self->revision);
+ }
+ if (defined($revtlpsrc)) {
+ if ($self->revision < $revtlpsrc) {
+ $self->revision($revtlpsrc);
+ }
+ }
+}
+
+sub recompute_sizes {
+ my ($self,$tltree) = @_;
+ $self->{'docsize'} = $self->_recompute_size("doc",$tltree);
+ $self->{'srcsize'} = $self->_recompute_size("src",$tltree);
+ $self->{'runsize'} = $self->_recompute_size("run",$tltree);
+ foreach $a ($tltree->architectures) {
+ $self->{'binsize'}{$a} = $self->_recompute_size("bin",$tltree,$a);
+ }
+}
+
+
+sub _recompute_size {
+ my ($self,$type,$tltree,$arch) = @_;
+ my $nrivblocks = 0;
+ if ($type eq "bin") {
+ my %binfiles = %{$self->{'binfiles'}};
+ if (defined($binfiles{$arch})) {
+ foreach $f (@{$binfiles{$arch}}) {
+ my $s = $tltree->size_of($f);
+ $nrivblocks += int($s/$TeXLive::TLConfig::BlockSize);
+ $nrivblocks++ if (($s%$TeXLive::TLConfig::BlockSize) > 0);
+ }
+ }
+ } else {
+ if (defined($self->{"${type}files"}) && (@{$self->{"${type}files"}})) {
+ foreach $f (@{$self->{"${type}files"}}) {
+ my $s = $tltree->size_of($f);
+ if (defined($s)) {
+ $nrivblocks += int($s/$TeXLive::TLConfig::BlockSize);
+ $nrivblocks++ if (($s%$TeXLive::TLConfig::BlockSize) > 0);
+ } else {
+ printf STDERR "size for $f not defined, strange ...\n";
+ }
+ }
+ }
+ }
+ return $nrivblocks;
+}
+
+sub writeout {
+ my $self = shift;
+ my $fd = (@_ ? $_[0] : STDOUT);
+ print $fd "name ", $self->name, "\n";
+ print $fd "category ", $self->category, "\n";
+ defined($self->{'revision'}) && print $fd "revision $self->{'revision'}\n";
+ defined($self->{'catalogue'}) && print $fd "catalogue $self->{'catalogue'}\n";
+ defined($self->{'shortdesc'}) && print $fd "shortdesc $self->{'shortdesc'}\n";
+ defined($self->{'license'}) && print $fd "license $self->{'license'}\n";
+ defined($self->{'relocated'}) && $self->{'relocated'} && print $fd "relocated 1\n";
+ # don't want to use FileHandle.pm; see man perlform
+ #format_name $fd "multilineformat";
+ select((select($fd),$~ = "multilineformat")[0]);
+ $fd->format_lines_per_page (99999); # no pages in this format
+ if (defined($self->{'longdesc'})) {
+ $_tmp = "$self->{'longdesc'}";
+ write $fd; # use that multilineformat
+ }
+ if (defined($self->{'depends'})) {
+ foreach (@{$self->{'depends'}}) {
+ print $fd "depend $_\n";
+ }
+ }
+ if (defined($self->{'executes'})) {
+ foreach (@{$self->{'executes'}}) {
+ print $fd "execute $_\n";
+ }
+ }
+ if (defined($self->{'postactions'})) {
+ foreach (@{$self->{'postactions'}}) {
+ print $fd "postaction $_\n";
+ }
+ }
+ if (defined($self->{'containersize'})) {
+ print $fd "containersize $self->{'containersize'}\n";
+ }
+ if (defined($self->{'containermd5'})) {
+ print $fd "containermd5 $self->{'containermd5'}\n";
+ }
+ if (defined($self->{'containerchecksum'})) {
+ print $fd "containerchecksum $self->{'containerchecksum'}\n";
+ }
+ if (defined($self->{'doccontainersize'})) {
+ print $fd "doccontainersize $self->{'doccontainersize'}\n";
+ }
+ if (defined($self->{'doccontainermd5'})) {
+ print $fd "doccontainermd5 $self->{'doccontainermd5'}\n";
+ }
+ if (defined($self->{'doccontainerchecksum'})) {
+ print $fd "doccontainerchecksum $self->{'doccontainerchecksum'}\n";
+ }
+ if (defined($self->{'docfiles'}) && (@{$self->{'docfiles'}})) {
+ print $fd "docfiles size=$self->{'docsize'}\n";
+ foreach my $f (sort @{$self->{'docfiles'}}) {
+ print $fd " $f";
+ if (defined($self->{'docfiledata'}{$f}{'details'})) {
+ my $tmp = $self->{'docfiledata'}{$f}{'details'};
+ #$tmp =~ s/\"/\\\"/g;
+ print $fd ' details="', $tmp, '"';
+ }
+ if (defined($self->{'docfiledata'}{$f}{'language'})) {
+ my $tmp = $self->{'docfiledata'}{$f}{'language'};
+ #$tmp =~ s/\"/\\\"/g;
+ print $fd ' language="', $tmp, '"';
+ }
+ print $fd "\n";
+ }
+ }
+ if (defined($self->{'srccontainersize'})) {
+ print $fd "srccontainersize $self->{'srccontainersize'}\n";
+ }
+ if (defined($self->{'srccontainermd5'})) {
+ print $fd "srccontainermd5 $self->{'srccontainermd5'}\n";
+ }
+ if (defined($self->{'srccontainerchecksum'})) {
+ print $fd "srccontainerchecksum $self->{'srccontainerchecksum'}\n";
+ }
+ if (defined($self->{'srcfiles'}) && (@{$self->{'srcfiles'}})) {
+ print $fd "srcfiles size=$self->{'srcsize'}\n";
+ foreach (sort @{$self->{'srcfiles'}}) {
+ print $fd " $_\n";
+ }
+ }
+ if (defined($self->{'runfiles'}) && (@{$self->{'runfiles'}})) {
+ print $fd "runfiles size=$self->{'runsize'}\n";
+ foreach (sort @{$self->{'runfiles'}}) {
+ print $fd " $_\n";
+ }
+ }
+ foreach my $arch (sort keys %{$self->{'binfiles'}}) {
+ if (@{$self->{'binfiles'}{$arch}}) {
+ print $fd "binfiles arch=$arch size=", $self->{'binsize'}{$arch}, "\n";
+ foreach (sort @{$self->{'binfiles'}{$arch}}) {
+ print $fd " $_\n";
+ }
+ }
+ }
+ # writeout all the catalogue keys
+ foreach my $k (sort keys %{$self->cataloguedata}) {
+ print $fd "catalogue-$k ", $self->cataloguedata->{$k}, "\n";
+ }
+}
+
+sub writeout_simple {
+ my $self = shift;
+ my $fd = (@_ ? $_[0] : STDOUT);
+ print $fd "name ", $self->name, "\n";
+ print $fd "category ", $self->category, "\n";
+ if (defined($self->{'depends'})) {
+ foreach (@{$self->{'depends'}}) {
+ print $fd "depend $_\n";
+ }
+ }
+ if (defined($self->{'executes'})) {
+ foreach (@{$self->{'executes'}}) {
+ print $fd "execute $_\n";
+ }
+ }
+ if (defined($self->{'postactions'})) {
+ foreach (@{$self->{'postactions'}}) {
+ print $fd "postaction $_\n";
+ }
+ }
+ if (defined($self->{'docfiles'}) && (@{$self->{'docfiles'}})) {
+ print $fd "docfiles\n";
+ foreach (sort @{$self->{'docfiles'}}) {
+ print $fd " $_\n";
+ }
+ }
+ if (defined($self->{'srcfiles'}) && (@{$self->{'srcfiles'}})) {
+ print $fd "srcfiles\n";
+ foreach (sort @{$self->{'srcfiles'}}) {
+ print $fd " $_\n";
+ }
+ }
+ if (defined($self->{'runfiles'}) && (@{$self->{'runfiles'}})) {
+ print $fd "runfiles\n";
+ foreach (sort @{$self->{'runfiles'}}) {
+ print $fd " $_\n";
+ }
+ }
+ foreach my $arch (sort keys %{$self->{'binfiles'}}) {
+ if (@{$self->{'binfiles'}{$arch}}) {
+ print $fd "binfiles arch=$arch\n";
+ foreach (sort @{$self->{'binfiles'}{$arch}}) {
+ print $fd " $_\n";
+ }
+ }
+ }
+}
+
+sub as_json {
+ my $self = shift;
+ my %addargs = @_;
+ my %foo = %{$self};
+ # set the additional args
+ for my $k (keys %addargs) {
+ if (defined($addargs{$k})) {
+ $foo{$k} = $addargs{$k};
+ } else {
+ delete($foo{$k});
+ }
+ }
+ # make sure numbers are encoded as numbers
+ for my $k (qw/revision runsize docsize srcsize containersize lrev rrev
+ srccontainersize doccontainersize runcontainersize/) {
+ $foo{$k} += 0 if exists($foo{$k});
+ }
+ for my $k (keys %{$foo{'binsize'}}) {
+ $foo{'binsize'}{$k} += 0;
+ }
+ # encode boolean as boolean flags
+ if (exists($foo{'relocated'})) {
+ if ($foo{'relocated'}) {
+ $foo{'relocated'} = TeXLive::TLUtils::True();
+ } else {
+ $foo{'relocated'} = TeXLive::TLUtils::False();
+ }
+ }
+ # adjust the docfiles entry to the specification in JSON-formats
+ my @docf = $self->docfiles;
+ my $dfd = $self->docfiledata;
+ my @newdocf;
+ for my $f ($self->docfiles) {
+ my %newd;
+ $newd{'file'} = $f;
+ if (defined($dfd->{$f})) {
+ # TODO should we check that there are actually only "details"
+ # and "language" as key?
+ for my $k (keys %{$dfd->{$f}}) {
+ $newd{$k} = $dfd->{$f}->{$k};
+ }
+ }
+ push @newdocf, \%newd;
+ }
+ $foo{'docfiles'} = [ @newdocf ];
+ delete($foo{'docfiledata'});
+ #
+ my $utf8_encoded_json_text = TeXLive::TLUtils::encode_json(\%foo);
+ return $utf8_encoded_json_text;
+}
+
+
+sub cancel_reloc_prefix {
+ my $self = shift;
+ my @docfiles = $self->docfiles;
+ for (@docfiles) { s:^$RelocPrefix/::; }
+ $self->docfiles(@docfiles);
+ my @runfiles = $self->runfiles;
+ for (@runfiles) { s:^$RelocPrefix/::; }
+ $self->runfiles(@runfiles);
+ my @srcfiles = $self->srcfiles;
+ for (@srcfiles) { s:^$RelocPrefix/::; }
+ $self->srcfiles(@srcfiles);
+ # if there are bin files they have definitely NOT the
+ # texmf-dist prefix, so we cannot cancel it anyway
+}
+
+sub replace_reloc_prefix {
+ my $self = shift;
+ my @docfiles = $self->docfiles;
+ for (@docfiles) { s:^$RelocPrefix/:$RelocTree/:; }
+ $self->docfiles(@docfiles);
+ my @runfiles = $self->runfiles;
+ for (@runfiles) { s:^$RelocPrefix/:$RelocTree/:; }
+ $self->runfiles(@runfiles);
+ my @srcfiles = $self->srcfiles;
+ for (@srcfiles) { s:^$RelocPrefix/:$RelocTree/:; }
+ $self->srcfiles(@srcfiles);
+ # docfiledata needs to be adapted too
+ my $data = $self->docfiledata;
+ my %newdata;
+ while (my ($k, $v) = each %$data) {
+ $k =~ s:^$RelocPrefix/:$RelocTree/:;
+ $newdata{$k} = $v;
+ }
+ $self->docfiledata(%newdata);
+ # if there are bin files they have definitely NOT the
+ # texmf-dist prefix, so we cannot cancel it anyway
+}
+
+sub cancel_common_texmf_tree {
+ my $self = shift;
+ my @docfiles = $self->docfiles;
+ for (@docfiles) { s:^$RelocTree/:$RelocPrefix/:; }
+ $self->docfiles(@docfiles);
+ my @runfiles = $self->runfiles;
+ for (@runfiles) { s:^$RelocTree/:$RelocPrefix/:; }
+ $self->runfiles(@runfiles);
+ my @srcfiles = $self->srcfiles;
+ for (@srcfiles) { s:^$RelocTree/:$RelocPrefix/:; }
+ $self->srcfiles(@srcfiles);
+ # docfiledata needs to be adapted too
+ my $data = $self->docfiledata;
+ my %newdata;
+ while (my ($k, $v) = each %$data) {
+ $k =~ s:^$RelocTree/:$RelocPrefix/:;
+ $newdata{$k} = $v;
+ }
+ $self->docfiledata(%newdata);
+ # if there are bin files they have definitely NOT the
+ # texmf-dist prefix, so we cannot cancel it anyway
+}
+
+sub common_texmf_tree {
+ my $self = shift;
+ my $tltree;
+ my $dd = 0;
+ my @files = $self->all_files;
+ foreach ($self->all_files) {
+ my $tmp;
+ ($tmp) = split m@/@;
+ if (defined($tltree) && ($tltree ne $tmp)) {
+ return;
+ } else {
+ $tltree = $tmp;
+ }
+ }
+ # if there are no files then it is by default relocatable, so
+ # return the right tree
+ if (!@files) {
+ $tltree = $RelocTree;
+ }
+ return $tltree;
+}
+
+
+sub make_container {
+ my ($self,$type,$instroot,$destdir,$containername,$relative) = @_;
+ if (!($type eq 'tar' ||
+ TeXLive::TLUtils::member($type, @{$::progs{'working_compressors'}}))) {
+ tlwarn "$0: TLPOBJ supports @{$::progs{'working_compressors'}} and tar containers, not $type\n";
+ tlwarn "$0: falling back to $DefaultCompressorFormat as container type!\n";
+ $type = $DefaultCompressorFormat;
+ }
+
+ if (!defined($containername)) {
+ $containername = $self->name;
+ }
+ my @files = $self->all_files;
+ my $compresscmd;
+ my $tlpobjdir = "$InfraLocation/tlpobj";
+ @files = TeXLive::TLUtils::sort_uniq(@files);
+ # we do relative packages ONLY if the files do NOT span multiple
+ # texmf trees. check this here
+ my $tltree;
+ if ($relative) {
+ $tltree = $self->common_texmf_tree;
+ if (!defined($tltree)) {
+ die ("$0: package $containername spans multiple trees, "
+ . "relative generation not allowed");
+ }
+ if ($tltree ne $RelocTree) {
+ die ("$0: building $containername container relocatable but the common"
+ . " prefix is not $RelocTree");
+ }
+ s,^$RelocTree/,, foreach @files;
+ }
+ # load Cwd only if necessary ...
+ require Cwd;
+ my $cwd = &Cwd::getcwd;
+ if ("$destdir" !~ m@^(.:)?[/\\]@) {
+ # we have an relative containerdir, so we have to make it absolute
+ $destdir = "$cwd/$destdir";
+ }
+ &TeXLive::TLUtils::mkdirhier("$destdir");
+ chdir($instroot);
+ # in the relative case we have to chdir to the respective tltree
+ # and put the tlpobj into the root!
+ my $removetlpkgdir = 0;
+ if ($relative) {
+ chdir("./$tltree");
+ # in the relocatable case we will probably create the tlpkg dir
+ # in texmf-dist/tlpkg and want to remove it afterwards.
+ $removetlpkgdir = 1;
+ # we don't need to change the $tlpobjdir because we put it in
+ # all cases into tlpkg/tlpobj
+ #$tlpobjdir = "./tlpkg/tlpobj";
+ }
+ # we add the .tlpobj into the .tlpobj directory
+ my $removetlpobjdir = 0;
+ if (! -d "$tlpobjdir") {
+ &TeXLive::TLUtils::mkdirhier("$tlpobjdir");
+ $removetlpobjdir = 1;
+ }
+ open(TMP,">$tlpobjdir/$self->{'name'}.tlpobj")
+ || die "$0: create($tlpobjdir/$self->{'name'}.tlpobj) failed: $!";
+ # when we do relative we have to cancel the prefix before writing out
+ my $selfcopy = $self->copy;
+ if ($relative) {
+ $selfcopy->cancel_common_texmf_tree;
+ $selfcopy->relocated($relative);
+ }
+ $selfcopy->writeout(\*TMP);
+ close(TMP);
+ push(@files, "$tlpobjdir/$self->{'name'}.tlpobj");
+ $tarname = "$containername.tar";
+
+ # start the fun
+ my $tar = $::progs{'tar'};
+ if (!defined($tar)) {
+ tlwarn("$0: programs not set up, trying \"tar\".\n");
+ $tar = "tar";
+ }
+
+ $containername = $tarname;
+
+ # Here we need to distinguish between making the master containers for
+ # tlnet (where we can assume GNU tar) and making backups on a user's
+ # machine (where we can assume nothing). We determine this by whether
+ # there's a revision suffix in the container name.
+ #
+ # For the master containers, we want to set the owner/group, exclude
+ # .svn directories, and force ustar format. This last is for the sake
+ # of packages such as pgf which have filenames long enough that they
+ # overflow standard tar format and result in special things being
+ # done. We don't want the GNU-specific special things.
+ #
+ my $is_user_container = ( $containername =~ /\.r[0-9]/ );
+ my @attrs
+ = $is_user_container
+ ? ()
+ : ( "--owner", "0", "--group", "0", "--exclude", ".svn",
+ "--format", "ustar" );
+ my @cmdline = ($tar, "-cf", "$destdir/$tarname", @attrs);
+
+ # Get list of files and symlinks to back up. Nothing else should be
+ # in the list.
+ my @files_to_backup = ();
+ for my $f (@files) {
+ if (-f $f || -l $f) {
+ push(@files_to_backup, $f);
+ } elsif (! -e $f) {
+ tlwarn("$0: (make_container $containername) $f does not exist\n");
+ } else {
+ tlwarn("$0: (make_container $containername) $f not file or symlink\n");
+ }
+ }
+
+ my $tartempfile = "";
+ if (win32()) {
+ # Since we provide our own (GNU) tar on Windows, we know it has -T.
+ my $tmpdir = TeXLive::TLUtils::tl_tmpdir();
+ $tartempfile = "$tmpdir/mc$$";
+ open(TMP, ">$tartempfile") || die "open(>$tartempfile) failed: $!";
+ print TMP map { "$_\n" } @files_to_backup;
+ close(TMP) || warn "close(>$tartempfile) failed: $!";
+ push(@cmdline, "-T", $tartempfile);
+ } else {
+ # For Unix, we pass all the files on the command line, because there
+ # is no portable (across different platforms and different tars) way
+ # to pass them on stdin. Unfortunately, this can be too lengthy of
+ # a command line -- our biggest package is tex4ht, which needs about
+ # 200k. CentOS 5.2, at least, starts complaining around 140k.
+ #
+ # Therefore, if the command is likely to be too long, we call
+ # our collapse_dirs routine; in practice, this eliminates
+ # essentially all the individual files, leaving just a few
+ # directories, which is no problem. (For example, tex4ht collapses
+ # down to five directories and one file.)
+ #
+ # Although in principle we could do this in all cases, collapse_dirs
+ # isn't the most thoroughly tested function in the world. It seems
+ # safer to only do it in the (few) potentially problematic cases.
+ #
+ if (length ("@files_to_backup") > 50000) {
+ @files_to_backup = TeXLive::TLUtils::collapse_dirs(@files_to_backup);
+ # A complication, as always. collapse_dirs returns absolute paths.
+ # We want to change them back to relative so that the backup tar
+ # has the same structure.
+ # in relative mode we have to remove the texmf-dist prefix, too
+ s,^$instroot/,, foreach @files_to_backup;
+ if ($relative) {
+ s,^$RelocTree/,, foreach @files_to_backup;
+ }
+ }
+ push(@cmdline, @files_to_backup);
+ }
+
+ # Run tar. Unlink both here in case the container is also plain tar.
+ unlink("$destdir/$tarname");
+ unlink("$destdir/$containername");
+ xsystem(@cmdline);
+
+ if ($type ne 'tar') {
+ # compress it
+ my $compressor = $::progs{$type};
+ if (!defined($compressor)) {
+ # fall back to $type as compressor, but that shouldn't happen
+ tlwarn("$0: programs not set up, trying \"$type\".\n");
+ $compressor = $type;
+ }
+ my @compressorargs = @{$Compressors{$type}{'compress_args'}};
+ my $compressorextension = $Compressors{$type}{'extension'};
+ $containername = "$tarname.$compressorextension";
+ debug("selected compressor: $compressor with @compressorargs, "
+ . "on $destdir/$tarname\n");
+
+ # compress it.
+ if (-r "$destdir/$tarname") {
+ # system return 0 on success
+ if (system($compressor, @compressorargs, "$destdir/$tarname")) {
+ tlwarn("$0: Couldn't compress $destdir/$tarname\n");
+ return (0,0, "");
+ }
+ # make sure we remove the original tar since old lz4 versions
+ # cannot automatically delete it.
+ # We remove the tar file only when the compressed file was
+ # correctly created, something that should only happen in the
+ # most strange cases.
+ unlink("$destdir/$tarname")
+ if ((-r "$destdir/$tarname") && (-r "$destdir/$containername"));
+ } else {
+ tlwarn("$0: Couldn't find $destdir/$tarname to run $compressor\n");
+ return (0, 0, "");
+ }
+ }
+
+ # compute the size.
+ if (! -r "$destdir/$containername") {
+ tlwarn ("$0: Couldn't find $destdir/$containername\n");
+ return (0, 0, "");
+ }
+ my $size = (stat "$destdir/$containername") [7];
+ #
+ # if we are creating a system container, or there is a way to
+ # compute the checksums, do it
+ my $checksum = "";
+ if (!$is_user_container || $::checksum_method) {
+ $checksum = TeXLive::TLCrypto::tlchecksum("$destdir/$containername");
+ }
+
+ # cleaning up
+ unlink("$tlpobjdir/$self->{'name'}.tlpobj");
+ unlink($tartempfile) if $tartempfile;
+ rmdir($tlpobjdir) if $removetlpobjdir;
+ rmdir($InfraLocation) if $removetlpkgdir;
+ xchdir($cwd);
+
+ debug(" done $containername, size $size, $checksum\n");
+ return ($size, $checksum, "$destdir/$containername");
+}
+
+
+
+sub is_arch_dependent {
+ my $self = shift;
+ if (keys %{$self->{'binfiles'}}) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# computes the total size of a package
+# if no arguments are given this is
+# docsize + runsize + srcsize + max of binsize
+sub total_size {
+ my ($self,@archs) = @_;
+ my $ret = $self->docsize + $self->runsize + $self->srcsize;
+ if ($self->is_arch_dependent) {
+ my $max = 0;
+ my %foo = %{$self->binsize};
+ foreach my $k (keys %foo) {
+ $max = $foo{$k} if ($foo{$k} > $max);
+ }
+ $ret += $max;
+ }
+ return($ret);
+}
+
+
+# update_from_catalogue($tlc)
+# Update the current TLPOBJ object with the information from the
+# corresponding entry in C<$tlc->entries>.
+#
+sub update_from_catalogue {
+ my ($self, $tlc) = @_;
+ my $tlcname = $self->name;
+ if (defined($self->catalogue)) {
+ $tlcname = $self->catalogue;
+ } elsif ($tlcname =~ m/^bin-(.*)$/) {
+ if (!defined($tlc->entries->{$tlcname})) {
+ $tlcname = $1;
+ }
+ }
+ $tlcname = lc($tlcname);
+ if (defined($tlc->entries->{$tlcname})) {
+ my $entry = $tlc->entries->{$tlcname};
+ # Record the id of the catalogue entry if it's found due to
+ # quest4texlive.
+ if ($entry->entry->{'id'} ne $tlcname) {
+ $self->catalogue($entry->entry->{'id'});
+ }
+ if (defined($entry->entry->{'date'})) {
+ my $foo = $entry->entry->{'date'};
+ $foo =~ s/^.Date: //;
+ # trying to extract the interesting part of a subversion date
+ # keyword expansion here, e.g.,
+ # $Date: 2019-03-03 22:52:59 +0100 (Sun, 03 Mar 2019) $
+ # ->2007-08-15 19:43:35 +0100
+ $foo =~ s/ \(.*\)( *\$ *)$//; # maybe nothing after parens
+ $self->cataloguedata->{'date'} = $foo;
+ }
+ if (defined($entry->license)) {
+ $self->cataloguedata->{'license'} = $entry->license;
+ }
+ if (defined($entry->version) && $entry->version ne "") {
+ $self->cataloguedata->{'version'} = $entry->version;
+ }
+ if (defined($entry->ctan) && $entry->ctan ne "") {
+ $self->cataloguedata->{'ctan'} = $entry->ctan;
+ }
+ # TODO TODO TODO
+ # we should rewrite the also fields to TeX Live package names ...
+ # for now these are CTAN package names!
+ # warning, we expect that cataloguedata entries are strings,
+ # so stringify these lists
+ if (@{$entry->also}) {
+ $self->cataloguedata->{'also'} = "@{$entry->also}";
+ }
+ if (@{$entry->alias}) {
+ $self->cataloguedata->{'alias'} = "@{$entry->alias}";
+ }
+ if (@{$entry->topics}) {
+ $self->cataloguedata->{'topics'} = "@{$entry->topics}";
+ }
+ if (%{$entry->contact}) {
+ for my $k (keys %{$entry->contact}) {
+ $self->cataloguedata->{"contact-$k"} = $entry->contact->{$k};
+ }
+ }
+ #if (defined($entry->texlive)) {
+ # $self->cataloguedata->{'texlive'} = $entry->texlive;
+ #}
+ #if (defined($entry->miktex)) {
+ # $self->cataloguedata->{'miktex'} = $entry->miktex;
+ #}
+ if (defined($entry->caption) && $entry->caption ne "") {
+ $self->{'shortdesc'} = $entry->caption unless $self->{'shortdesc'};
+ }
+ if (defined($entry->description) && $entry->description ne "") {
+ $self->{'longdesc'} = $entry->description unless $self->{'longdesc'};
+ }
+ #
+ # we need to do the following:
+ # - take the href entry for a documentation file entry in the TC
+ # - remove the 'ctan:' prefix
+ # - remove the <ctan path='...'> part
+ # - match the rest against all docfiles in an intelligent way
+ #
+ # Example:
+ # juramisc.xml contains:
+ # <documentation details='Package documentation' language='de'
+ # href='ctan:/macros/latex/contrib/juramisc/doc/jmgerdoc.pdf'/>
+ # <ctan path='/macros/latex/contrib/juramisc'/>
+ my @tcdocfiles = keys %{$entry->docs}; # Catalogue doc files.
+ my %tcdocfilebasenames; # basenames of those, as we go.
+ my @tlpdocfiles = $self->docfiles; # TL doc files.
+ foreach my $tcdocfile (sort @tcdocfiles) { # sort so shortest first
+ #warn "looking at tcdocfile $tcdocfile\n";
+ my $tcdocfilebasename = $tcdocfile;
+ $tcdocfilebasename =~ s/^ctan://; # remove ctan: prefix
+ $tcdocfilebasename =~ s,.*/,,; # remove all but the base file name
+ #warn " got basename $tcdocfilebasename\n";
+ #
+ # If we've already seen this basename, skip. This is for the sake
+ # of README files, which can exist in different directories but
+ # get renamed into different files in TL for various annoying reasons;
+ # e.g., ibygrk, rsfs, songbook. In these cases, it turns out we
+ # always prefer the first entry (top-level README).
+ next if exists $tcdocfilebasenames{$tcdocfilebasename};
+ $tcdocfilebasenames{$tcdocfilebasename} = 1;
+ #
+ foreach my $tlpdocfile (@tlpdocfiles) {
+ #warn "considering merge into tlpdocfile $tlpdocfile\n";
+ if ($tlpdocfile =~ m,/$tcdocfilebasename$,) {
+ # update the language/detail tags from Catalogue if present.
+ if (defined($entry->docs->{$tcdocfile}{'details'})) {
+ my $tmp = $entry->docs->{$tcdocfile}{'details'};
+ #warn "merging details for $tcdocfile: $tmp\n";
+ # remove all embedded quotes, they are just a pain
+ $tmp =~ s/"//g;
+ $self->{'docfiledata'}{$tlpdocfile}{'details'} = $tmp;
+ }
+ if (defined($entry->docs->{$tcdocfile}{'language'})) {
+ my $tmp = $entry->docs->{$tcdocfile}{'language'};
+ #warn "merging lang for $tcdocfile: $tmp\n";
+ $self->{'docfiledata'}{$tlpdocfile}{'language'} = $tmp;
+ }
+ }
+ }
+ }
+ }
+}
+
+sub is_meta_package {
+ my $self = shift;
+ if ($self->category =~ /^$MetaCategoriesRegexp$/) {
+ return 1;
+ }
+ return 0;
+}
+
+sub docfiles_package {
+ my $self = shift;
+ if (not($self->docfiles)) { return ; }
+ my $tlp = new TeXLive::TLPOBJ;
+ $tlp->name($self->name . ".doc");
+ $tlp->shortdesc("doc files of " . $self->name);
+ $tlp->revision($self->revision);
+ $tlp->category($self->category);
+ $tlp->add_docfiles($self->docfiles);
+ $tlp->docsize($self->docsize);
+ # $self->clear_docfiles();
+ # $self->docsize(0);
+ return($tlp);
+}
+
+sub srcfiles_package {
+ my $self = shift;
+ if (not($self->srcfiles)) { return ; }
+ my $tlp = new TeXLive::TLPOBJ;
+ $tlp->name($self->name . ".source");
+ $tlp->shortdesc("source files of " . $self->name);
+ $tlp->revision($self->revision);
+ $tlp->category($self->category);
+ $tlp->add_srcfiles($self->srcfiles);
+ $tlp->srcsize($self->srcsize);
+ # $self->clear_srcfiles();
+ # $self->srcsize(0);
+ return($tlp);
+}
+
+sub split_bin_package {
+ my $self = shift;
+ my %binf = %{$self->binfiles};
+ my @retlist;
+ foreach $a (keys(%binf)) {
+ my $tlp = new TeXLive::TLPOBJ;
+ $tlp->name($self->name . ".$a");
+ $tlp->shortdesc("$a files of " . $self->name);
+ $tlp->revision($self->revision);
+ $tlp->category($self->category);
+ $tlp->add_binfiles($a,@{$binf{$a}});
+ $tlp->binsize( $a => $self->binsize->{$a} );
+ push @retlist, $tlp;
+ }
+ if (keys(%binf)) {
+ push @{$self->{'depends'}}, $self->name . ".ARCH";
+ }
+ $self->clear_binfiles();
+ return(@retlist);
+}
+
+
+# Helpers.
+#
+sub add_files {
+ my ($self,$type,@files) = @_;
+ die("Cannot use add_files for binfiles, we need that arch!")
+ if ($type eq "bin");
+ &TeXLive::TLUtils::push_uniq(\@{ $self->{"${type}files"} }, @files);
+}
+
+sub remove_files {
+ my ($self,$type,@files) = @_;
+ die("Cannot use remove_files for binfiles, we need that arch!")
+ if ($type eq "bin");
+ my @finalfiles;
+ foreach my $f (@{$self->{"${type}files"}}) {
+ if (not(&TeXLive::TLUtils::member($f,@files))) {
+ push @finalfiles,$f;
+ }
+ }
+ $self->{"${type}files"} = [ @finalfiles ];
+}
+
+sub contains_file {
+ my ($self,$fn) = @_;
+ # if the filename already contains a / do not add it at the beginning
+ my $ret = "";
+ if ($fn =~ m!/!) {
+ return(grep(m!$fn$!, $self->all_files));
+ } else {
+ return(grep(m!(^|/)$fn$!,$self->all_files));
+ }
+}
+
+sub all_files {
+ my ($self) = shift;
+ my @ret = ();
+
+ push (@ret, $self->docfiles);
+ push (@ret, $self->runfiles);
+ push (@ret, $self->srcfiles);
+ push (@ret, $self->allbinfiles);
+
+ return @ret;
+}
+
+sub allbinfiles {
+ my $self = shift;
+ my @ret = ();
+ my %binfiles = %{$self->binfiles};
+
+ foreach my $arch (keys %binfiles) {
+ push (@ret, @{$binfiles{$arch}});
+ }
+
+ return @ret;
+}
+
+sub format_definitions {
+ my $self = shift;
+ my $pkg = $self->name;
+ my @ret;
+ for my $e ($self->executes) {
+ if ($e =~ m/AddFormat\s+(.*)\s*/) {
+ my %r = TeXLive::TLUtils::parse_AddFormat_line("$1");
+ if (defined($r{"error"})) {
+ die "$r{'error'}, package $pkg, execute $e";
+ }
+ push @ret, \%r;
+ }
+ }
+ return @ret;
+}
+
+#
+# execute stuff
+#
+sub fmtutil_cnf_lines {
+ my $obj = shift;
+ my @disabled = @_;
+ my @fmtlines = ();
+ my $first = 1;
+ my $pkg = $obj->name;
+ foreach my $e ($obj->executes) {
+ if ($e =~ m/AddFormat\s+(.*)\s*/) {
+ my %r = TeXLive::TLUtils::parse_AddFormat_line("$1");
+ if (defined($r{"error"})) {
+ die "$r{'error'}, package $pkg, execute $e";
+ }
+ if ($first) {
+ push @fmtlines, "#\n# from $pkg:\n";
+ $first = 0;
+ }
+ my $mode = ($r{"mode"} ? "" : "#! ");
+ $mode = "#! " if TeXLive::TLUtils::member ($r{'name'}, @disabled);
+ push @fmtlines, "$mode$r{'name'} $r{'engine'} $r{'patterns'} $r{'options'}\n";
+ }
+ }
+ return @fmtlines;
+}
+
+
+sub updmap_cfg_lines {
+ my $obj = shift;
+ my @disabled = @_;
+ my %maps;
+ foreach my $e ($obj->executes) {
+ if ($e =~ m/addMap (.*)$/) {
+ $maps{$1} = 1;
+ } elsif ($e =~ m/addMixedMap (.*)$/) {
+ $maps{$1} = 2;
+ } elsif ($e =~ m/addKanjiMap (.*)$/) {
+ $maps{$1} = 3;
+ }
+ # others are ignored here
+ }
+ my @updmaplines;
+ foreach (sort keys %maps) {
+ next if TeXLive::TLUtils::member($_, @disabled);
+ if ($maps{$_} == 1) {
+ push @updmaplines, "Map $_\n";
+ } elsif ($maps{$_} == 2) {
+ push @updmaplines, "MixedMap $_\n";
+ } elsif ($maps{$_} == 3) {
+ push @updmaplines, "KanjiMap $_\n";
+ } else {
+ tlerror("Should not happen!\n");
+ }
+ }
+ return(@updmaplines);
+}
+
+
+sub language_dat_lines {
+ my $self = shift;
+ local @disabled = @_; # we use @disabled in the nested sub
+ my @lines = $self->_parse_hyphen_execute(\&make_dat_lines, 'dat');
+ return @lines;
+
+ sub make_dat_lines {
+ my ($name, $lhm, $rhm, $file, $syn) = @_;
+ my @ret;
+ return if TeXLive::TLUtils::member($name, @disabled);
+ push @ret, "$name $file\n";
+ foreach (@$syn) {
+ push @ret, "=$_\n";
+ }
+ return @ret;
+ }
+}
+
+
+sub language_def_lines {
+ my $self = shift;
+ local @disabled = @_; # we use @disabled in the nested sub
+ my @lines = $self->_parse_hyphen_execute(\&make_def_lines, 'def');
+ return @lines;
+
+ sub make_def_lines {
+ my ($name, $lhm, $rhm, $file, $syn) = @_;
+ return if TeXLive::TLUtils::member($name, @disabled);
+ my $exc = "";
+ my @ret;
+ push @ret, "\\addlanguage\{$name\}\{$file\}\{$exc\}\{$lhm\}\{$rhm\}\n";
+ foreach (@$syn) {
+ # synonyms in language.def ???
+ push @ret, "\\addlanguage\{$_\}\{$file\}\{$exc\}\{$lhm\}\{$rhm\}\n";
+ #debug("Ignoring synonym $_ for $name when creating language.def\n");
+ }
+ return @ret;
+ }
+}
+
+
+sub language_lua_lines {
+ my $self = shift;
+ local @disabled = @_; # we use @disabled in the nested sub
+ my @lines = $self->_parse_hyphen_execute(\&make_lua_lines, 'lua', '--');
+ return @lines;
+
+ sub make_lua_lines {
+ my ($name, $lhm, $rhm, $file, $syn, $patt, $hyph, $special) = @_;
+ return if TeXLive::TLUtils::member($name, @disabled);
+ my @syn = (@$syn); # avoid modifying the original
+ map { $_ = "'$_'" } @syn;
+ my @ret;
+ push @ret, "['$name'] = {", "\tloader = '$file',",
+ "\tlefthyphenmin = $lhm,", "\trighthyphenmin = $rhm,",
+ "\tsynonyms = { " . join(', ', @syn) . " },";
+ push @ret, "\tpatterns = '$patt'," if defined $patt;
+ push @ret, "\thyphenation = '$hyph'," if defined $hyph;
+ push @ret, "\tspecial = '$special'," if defined $special;
+ push @ret, '},';
+ map { $_ = "\t$_\n" } @ret;
+ return @ret;
+ }
+}
+
+
+sub _parse_hyphen_execute {
+ my ($obj, $coderef, $db, $cc) = @_;
+ $cc ||= '%'; # default comment char
+ my @langlines = ();
+ my $pkg = $obj->name;
+ my $first = 1;
+ foreach my $e ($obj->executes) {
+ if ($e =~ m/AddHyphen\s+(.*)\s*/) {
+ my %r = TeXLive::TLUtils::parse_AddHyphen_line("$1");
+ if (defined($r{"error"})) {
+ die "$r{'error'}, package $pkg, execute $e";
+ }
+ if (not TeXLive::TLUtils::member($db, @{$r{"databases"}})) {
+ next;
+ }
+ if ($first) {
+ push @langlines, "$cc from $pkg:\n";
+ $first = 0;
+ }
+ if ($r{"comment"}) {
+ push @langlines, "$cc $r{comment}\n";
+ }
+ my @foo = &$coderef ($r{"name"}, $r{"lefthyphenmin"},
+ $r{"righthyphenmin"}, $r{"file"}, $r{"synonyms"},
+ $r{"file_patterns"}, $r{"file_exceptions"},
+ $r{"luaspecial"});
+ push @langlines, @foo;
+ }
+ }
+ return @langlines;
+}
+
+
+
+# member access functions
+#
+sub _set_get_array_value {
+ my $self = shift;
+ my $key = shift;
+ if (@_) {
+ if (defined($_[0])) {
+ $self->{$key} = [ @_ ];
+ } else {
+ $self->{$key} = [ ];
+ }
+ }
+ return @{ $self->{$key} };
+}
+sub name {
+ my $self = shift;
+ if (@_) { $self->{'name'} = shift }
+ return $self->{'name'};
+}
+sub category {
+ my $self = shift;
+ if (@_) { $self->{'category'} = shift }
+ return $self->{'category'};
+}
+sub shortdesc {
+ my $self = shift;
+ if (@_) { $self->{'shortdesc'} = shift }
+ return $self->{'shortdesc'};
+}
+sub longdesc {
+ my $self = shift;
+ if (@_) { $self->{'longdesc'} = shift }
+ return $self->{'longdesc'};
+}
+sub revision {
+ my $self = shift;
+ if (@_) { $self->{'revision'} = shift }
+ return $self->{'revision'};
+}
+sub relocated {
+ my $self = shift;
+ if (@_) { $self->{'relocated'} = shift }
+ return ($self->{'relocated'} ? 1 : 0);
+}
+sub catalogue {
+ my $self = shift;
+ if (@_) { $self->{'catalogue'} = shift }
+ return $self->{'catalogue'};
+}
+sub srcfiles {
+ _set_get_array_value(shift, "srcfiles", @_);
+}
+sub containersize {
+ my $self = shift;
+ if (@_) { $self->{'containersize'} = shift }
+ return ( defined($self->{'containersize'}) ? $self->{'containersize'} : -1 );
+}
+sub srccontainersize {
+ my $self = shift;
+ if (@_) { $self->{'srccontainersize'} = shift }
+ return ( defined($self->{'srccontainersize'}) ? $self->{'srccontainersize'} : -1 );
+}
+sub doccontainersize {
+ my $self = shift;
+ if (@_) { $self->{'doccontainersize'} = shift }
+ return ( defined($self->{'doccontainersize'}) ? $self->{'doccontainersize'} : -1 );
+}
+sub containermd5 {
+ my $self = shift;
+ if (@_) { $self->{'containermd5'} = shift }
+ if (defined($self->{'containermd5'})) {
+ return ($self->{'containermd5'});
+ } else {
+ tlwarn("TLPOBJ: MD5 sums are no longer supported, please adapt your code!\n");
+ return ("");
+ }
+}
+sub srccontainermd5 {
+ my $self = shift;
+ if (@_) { $self->{'srccontainermd5'} = shift }
+ if (defined($self->{'srccontainermd5'})) {
+ return ($self->{'srccontainermd5'});
+ } else {
+ tlwarn("TLPOBJ: MD5 sums are no longer supported, please adapt your code!\n");
+ return ("");
+ }
+}
+sub doccontainermd5 {
+ my $self = shift;
+ if (@_) { $self->{'doccontainermd5'} = shift }
+ if (defined($self->{'doccontainermd5'})) {
+ return ($self->{'doccontainermd5'});
+ } else {
+ tlwarn("TLPOBJ: MD5 sums are no longer supported, please adapt your code!\n");
+ return ("");
+ }
+}
+sub containerchecksum {
+ my $self = shift;
+ if (@_) { $self->{'containerchecksum'} = shift }
+ return ( defined($self->{'containerchecksum'}) ? $self->{'containerchecksum'} : "" );
+}
+sub srccontainerchecksum {
+ my $self = shift;
+ if (@_) { $self->{'srccontainerchecksum'} = shift }
+ return ( defined($self->{'srccontainerchecksum'}) ? $self->{'srccontainerchecksum'} : "" );
+}
+sub doccontainerchecksum {
+ my $self = shift;
+ if (@_) { $self->{'doccontainerchecksum'} = shift }
+ return ( defined($self->{'doccontainerchecksum'}) ? $self->{'doccontainerchecksum'} : "" );
+}
+sub srcsize {
+ my $self = shift;
+ if (@_) { $self->{'srcsize'} = shift }
+ return ( defined($self->{'srcsize'}) ? $self->{'srcsize'} : 0 );
+}
+sub clear_srcfiles {
+ my $self = shift;
+ $self->{'srcfiles'} = [ ] ;
+}
+sub add_srcfiles {
+ my ($self,@files) = @_;
+ $self->add_files("src",@files);
+}
+sub remove_srcfiles {
+ my ($self,@files) = @_;
+ $self->remove_files("src",@files);
+}
+sub docfiles {
+ _set_get_array_value(shift, "docfiles", @_);
+}
+sub clear_docfiles {
+ my $self = shift;
+ $self->{'docfiles'} = [ ] ;
+}
+sub docsize {
+ my $self = shift;
+ if (@_) { $self->{'docsize'} = shift }
+ return ( defined($self->{'docsize'}) ? $self->{'docsize'} : 0 );
+}
+sub add_docfiles {
+ my ($self,@files) = @_;
+ $self->add_files("doc",@files);
+}
+sub remove_docfiles {
+ my ($self,@files) = @_;
+ $self->remove_files("doc",@files);
+}
+sub docfiledata {
+ my $self = shift;
+ my %newfiles = @_;
+ if (@_) { $self->{'docfiledata'} = \%newfiles }
+ return $self->{'docfiledata'};
+}
+sub binfiles {
+ my $self = shift;
+ my %newfiles = @_;
+ if (@_) { $self->{'binfiles'} = \%newfiles }
+ return $self->{'binfiles'};
+}
+sub clear_binfiles {
+ my $self = shift;
+ $self->{'binfiles'} = { };
+}
+sub binsize {
+ my $self = shift;
+ my %newsizes = @_;
+ if (@_) { $self->{'binsize'} = \%newsizes }
+ return $self->{'binsize'};
+}
+sub add_binfiles {
+ my ($self,$arch,@files) = @_;
+ &TeXLive::TLUtils::push_uniq(\@{ $self->{'binfiles'}{$arch} }, @files);
+}
+sub remove_binfiles {
+ my ($self,$arch,@files) = @_;
+ my @finalfiles;
+ foreach my $f (@{$self->{'binfiles'}{$arch}}) {
+ if (not(&TeXLive::TLUtils::member($f,@files))) {
+ push @finalfiles,$f;
+ }
+ }
+ $self->{'binfiles'}{$arch} = [ @finalfiles ];
+}
+sub runfiles {
+ _set_get_array_value(shift, "runfiles", @_);
+}
+sub clear_runfiles {
+ my $self = shift;
+ $self->{'runfiles'} = [ ] ;
+}
+sub runsize {
+ my $self = shift;
+ if (@_) { $self->{'runsize'} = shift }
+ return ( defined($self->{'runsize'}) ? $self->{'runsize'} : 0 );
+}
+sub add_runfiles {
+ my ($self,@files) = @_;
+ $self->add_files("run",@files);
+}
+sub remove_runfiles {
+ my ($self,@files) = @_;
+ $self->remove_files("run",@files);
+}
+sub depends {
+ _set_get_array_value(shift, "depends", @_);
+}
+sub executes {
+ _set_get_array_value(shift, "executes", @_);
+}
+sub postactions {
+ _set_get_array_value(shift, "postactions", @_);
+}
+sub containerdir {
+ my @self = shift;
+ if (@_) { $_containerdir = $_[0] }
+ return $_containerdir;
+}
+sub cataloguedata {
+ my $self = shift;
+ my %ct = @_;
+ if (@_) { $self->{'cataloguedata'} = \%ct }
+ return $self->{'cataloguedata'};
+}
+
+$: = " \n"; # don't break at -
+format multilineformat =
+longdesc ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
+$_tmp
+.
+
+1;
+__END__
+
+
+=head1 NAME
+
+C<TeXLive::TLPOBJ> -- TeX Live Package Object access module
+
+=head1 SYNOPSIS
+
+ use TeXLive::TLPOBJ;
+
+ my $tlpobj=TeXLive::TLPOBJ->new(name => "foobar");
+
+=head1 DESCRIPTION
+
+The L<TeXLive::TLPOBJ> module provide access to TeX Live Package Object
+files describing a self-contained package.
+
+=head1 FILE SPECIFICATION
+
+Please see L<TeXLive::TLPSRC> documentation for the specification. The
+only differences are that the various C<*pattern> keys are invalid, and
+instead there are the respective C<*files> keys described below. Furthermore
+some more I<keys> is allowed: C<revision> which specifies the maximum of
+all last changed revision of files contained in the package, anything
+starting with C<catalogue-> specifying information coming from the
+TeX Catalogue, and C<relocated> taking either 0 or 1 indicating that
+this packages has been relocated, i.e., in the containers the
+initial C<texmf-dist> directory has been stripped off.
+
+All these keys have in common that they are followed by a list of files
+I<indented> by one space. They differ only in the first line itself
+(described below).
+
+=over 4
+
+=item C<srcfiles>, C<runfiles>, C<binfiles>, C<docfiles>
+each of these items contains addition the sum of sizes of the
+single files (in number of C<TeXLive::TLConfig::BlockSize> blocks, which
+is currently 4k).
+
+ srcfiles size=NNNNNN
+ runfiles size=NNNNNN
+
+=item C<docfiles>
+
+The docfiles line itself is similar to the C<srcfiles> and C<runfiles> lines
+above:
+
+ docfiles size=NNNNNN
+
+But the lines listing the files are allowed to have additional tags:
+
+ /------- excerpt from achemso.tlpobj
+ |...
+ |docfiles size=1702468
+ | texmf-dist/doc/latex/aeguill/README details="Package Readme"
+ | texmf-dist/doc/latex/achemso/achemso.pdf details="Package documentation" language="en"
+ |...
+
+Currently only the tags C<details> and C<language> are allowed. These
+additional information can be accessed via the C<docfiledata> function
+returning a hash with the respective files (including path) as key.
+
+=item C<binfiles>
+
+Since C<binfiles> are different for the different architectures one
+C<tlpobj> file can contain C<binfiles> lines for different
+architectures. The architecture is specified on the C<binfiles> using
+the C<arch=>I<XXX> tag. Thus, C<binfiles> lines look like
+
+ binfiles arch=XXXX size=NNNNN
+
+=back
+
+Here is an excerpt from the representation of the C<dvipsk> package,
+with C<|> characters inserted to show the indentation:
+
+ |name dvipsk
+ |category TLCore
+ |revision 4427
+ |docfiles size=959434
+ | texmf-dist/doc/dvips/dvips.html
+ | ...
+ |runfiles size=1702468
+ | texmf-dist/dvips/base/color.pro
+ | ...
+ | texmf-dist/scripts/pkfix/pkfix.pl
+ |binfiles arch=i386-solaris size=329700
+ | bin/i386-solaris/afm2tfm
+ | bin/i386-solaris/dvips
+ | bin/i386-solaris/pkfix
+ |binfiles arch=win32 size=161280
+ | bin/win32/afm2tfm.exe
+ | bin/win32/dvips.exe
+ | bin/win32/pkfix.exe
+ |...
+
+=head1 PACKAGE VARIABLES
+
+TeXLive::TLPOBJ has one package wide variable which is C<containerdir> where
+generated container files are saved (if not otherwise specified.
+
+ TeXLive::TLPOBJ->containerdir("path/to/container/dir");
+
+=head1 MEMBER ACCESS FUNCTIONS
+
+For any of the I<keys> a function
+
+ $tlpobj->key
+
+is available, which returns the current value when called without an argument,
+and sets the respective value when called with an argument. For the
+TeX Catalogue Data the function
+
+ $tlpobj->cataloguedata
+
+returns and takes as argument a hash.
+
+Arguments and return values for C<name>, C<category>, C<shortdesc>,
+C<longdesc>, C<catalogue>, C<revision> are single scalars.
+
+Arguments and return values for C<depends>, C<executes> are lists.
+
+Arguments and return values for C<docfiles>, C<runfiles>, C<srcfiles>
+are lists.
+
+Arguments and return values for C<binfiles> is a hash with the
+architectures as keys.
+
+Arguments and return values for C<docfiledata> is a hash with the
+full file names of docfiles as key, and the value is again a hash.
+
+The size values are handled with these functions:
+
+ $tlpobj->docsize
+ $tlpobj->runsize
+ $tlpobj->srcsize
+ $tlpobj->binsize("arch1" => size1, "arch2" => size2, ...)
+
+which set or get the current value of the respective sizes. Note that also
+the C<binsize> function returns (and takes as argument) a hash with the
+architectures as keys, similar to the C<runfiles> functions (see above).
+
+Futhermore, if the tlpobj is contained ina tlpdb which describes a media
+where the files are distributed in packed format (usually as .tar.xz),
+there are 6 more possible keys:
+
+ $tlpobj->containersize
+ $tlpobj->doccontainersize
+ $tlpobj->srccontainersize
+ $tlpobj->containerchecksum
+ $tlpobj->doccontainerchecksum
+ $tlpobj->srccontainerchecksum
+
+describing the respective sizes and checksums in bytes and as hex string, resp.
+The latter two are only present if src/doc file container splitting is
+activated for that install medium.
+
+=head1 OTHER FUNCTIONS
+
+The following functions can be called for an C<TLPOBJ> object:
+
+=over 4
+
+=item C<new>
+
+The constructor C<new> returns a new C<TLPSRC> object. The arguments
+to the C<new> constructor can be in the usual hash representation for
+the different keys above:
+
+ $tlpobj=TLPOBJ->new(name => "foobar", shortdesc => "The foobar package");
+
+=item C<from_file("filename")>
+
+reads a C<tlpobj> file.
+
+ $tlpobj = new TLPOBJ;
+ $tlpobj->from_file("path/to/the/tlpobj/file");
+
+=item C<from_fh($filehandle[, $multi])>
+
+read the textual representation of a TLPOBJ from an already opened
+file handle. If C<$multi> is undef (i.e., not given) then multiple
+tlpobj in the same file are treated as errors. If C<$multi> is defined,
+then returns after reading one tlpobj.
+
+Returns C<1> if it found a C<tlpobj>, otherwise C<0>.
+
+=item C<writeout>
+
+writes the textual representation of a C<TLPOBJ> object to C<stdout>,
+or the filehandle if given:
+
+ $tlpsrc->writeout;
+ $tlpsrc->writeout(\*FILEHANDLE);
+
+=item C<writeout_simple>
+
+debugging function for comparison with C<tpm>/C<tlps>, will go away.
+
+=item C<as_json>
+
+returns the representation of the C<TLPOBJ> in JSON format.
+
+=item C<common_texmf_tree>
+
+if all files of the package are from the same texmf tree, this tree
+is returned, otherwise an undefined value. That is also a check
+whether a package is relocatable.
+
+=item C<make_container($type,$instroot[, $destdir[, $containername[, $relative]]])>
+
+creates a container file of the all files in the C<TLPOBJ>
+in C<$destdir> (if not defined then C<< TLPOBJ->containerdir >> is used).
+
+The C<$type> variable specifies the type of container to be used.
+Currently only C<zip> or C<xz> are allowed, and are generating
+zip files and tar.xz files, respectively.
+
+The file name of the created container file is C<$containername.extension>,
+where extension is either C<.zip> or C<.tar.xz>, depending on the
+setting of C<$type>. If no C<$containername> is specified the package name
+is used.
+
+All container files B<also> contain the respective
+C<TLPOBJ> file in C<tlpkg/tlpobj/$name.tlpobj>.
+
+The argument C<$instroot> specifies the root of the installation from
+which the files should be taken.
+
+If the argument C<$relative> is present and true (perlish true) AND the
+packages does not span multiple texmf trees (i.e., all the first path
+components of all files are the same) then a relative packages is created,
+i.e., the first path component is stripped. In this case the tlpobj file
+is placed into the root of the installation.
+
+This is used to distribute packages which can be installed in any arbitrary
+texmf tree (of other distributions, too).
+
+Return values are the size, the checksum, and the full name of the container.
+
+=item C<recompute_sizes($tltree)>
+
+recomputes the sizes based on the information present in C<$tltree>.
+
+=item C<recompute_revision($tltree [, $revtlpsrc ])>
+
+recomputes the revision based on the information present in C<$tltree>.
+The optional argument C<$rectlpsrc> can be an additional revision number
+which is taken into account. C<$tlpsrc->make_tlpobj> adds the revision
+number of the C<tlpsrc> file here so that collections (which do not
+contain files) also have revision number.
+
+=item C<update_from_catalogue($texcatalogue)>
+
+adds information from a C<TeXCatalogue> object
+(currently license, version, url, and updates docfiles with details and
+languages tags if present in the Catalogue).
+
+=item C<split_bin_package>
+
+splits off the binfiles of C<TLPOBJ> into new independent C<TLPOBJ> with
+the original name plus ".arch" for every arch for which binfiles are present.
+The original package is changed in two respects: the binfiles are removed
+(since they are now in the single name.arch packages), and an additional
+depend on "name.ARCH" is added. Note that the ARCH is a placeholder.
+
+=item C<srcfiles_package>
+
+=item C<docfiles_package>
+
+splits off the srcfiles or docfiles of C<TLPOBJ> into new independent
+C<TLPOBJ> with
+the original name plus ".sources". The source/doc files are
+B<not> removed from the original package, since these functions are only
+used for the creation of split containers.
+
+=item C<is_arch_dependent>
+
+returns C<1> if there are C<binfiles>, otherwise C<0>.
+
+=item C<total_size>
+
+If no argument is given returns the sum of C<srcsize>, C<docsize>,
+C<runsize>.
+
+If arguments are given, they are assumed to be architecture names, and
+it returns the above plus the sum of sizes of C<binsize> for those
+architectures.
+
+=item C<is_meta_package>
+
+Returns true if the package is a meta package as defined in TLConfig
+(Currently Collection and Scheme).
+
+=item C<clear_{src,run,doc,bin}files>
+
+Removes all the src/run/doc/binfiles from the C<TLPOBJ>.
+
+=item C<{add,remove}_{src,run,doc}files(@files)>
+
+adds or removes files to the respective list of files.
+
+=item C<{add,remove}_binfiles($arch, @files)>
+
+adds or removes files from the list of C<binfiles> for the given architecture.
+
+=item C<{add,remove}_files($type, $files)>
+
+adds or removes files for the given type (only for C<run>, C<src>, C<doc>).
+
+=item C<contains_file($filename)>
+
+returns the list of files matching $filename which are contained in
+the package. If $filename contains a / the matching is only anchored
+at the end with $. Otherwise it is prefix with a / and anchored at the end.
+
+=item C<all_files>
+
+returns a list of all files of all types. However, binary files won't
+be found until dependencies have been expanded via (most likely)
+L<TeXLive::TLPDB::expand_dependencies>. For a more or less standalone
+example, see the C<find_old_files> function in the
+script C<Master/tlpkg/libexec/place>.
+
+=item C<allbinfiles>
+
+returns a list of all binary files.
+
+=item C<< $tlpobj->format_definitions >>
+
+The function C<format_definitions> returns a list of references to hashes
+where each hash is a format definition.
+
+=item C<< $tlpobj->fmtutil_cnf_lines >>
+
+The function C<fmtutil_cnf_lines> returns the lines for fmtutil.cnf
+for this package.
+
+=item C<< $tlpobj->updmap_cfg_lines >>
+
+The function C<updmap_cfg_lines> returns the list lines for updmap.cfg
+for the given package.
+
+=item C<< $tlpobj->language_dat_lines >>
+
+The function C<language_dat_lines> returns the list of all
+lines for language.dat that can be generated from the tlpobj
+
+=item C<< $tlpobj->language_def_lines >>
+
+The function C<language_def_lines> returns the list of all
+lines for language.def that can be generated from the tlpobj.
+
+=item C<< $tlpobj->language_lua_lines >>
+
+The function C<language_lua_lines> returns the list of all
+lines for language.dat.lua that can be generated from the tlpobj.
+
+=back
+
+=head1 SEE ALSO
+
+The modules L<TeXLive::TLConfig>, L<TeXLive::TLCrypto>,
+L<TeXLive::TLUtils>, L<TeXLive::TLPSRC>, L<TeXLive::TLPDB>,
+L<TeXLive::TLTREE>, L<TeXLive::TeXCatalogue>, etc., and the
+documentation in the repository: C<Master/tlpkg/doc/>.
+
+=head1 AUTHORS AND COPYRIGHT
+
+This script and its documentation were written for the TeX Live
+distribution (L<http://tug.org/texlive>) and both are licensed under the
+GNU General Public License Version 2 or later.
+
+=cut
+
+### Local Variables:
+### perl-indent-level: 2
+### tab-width: 2
+### indent-tabs-mode: nil
+### End:
+# vim:set tabstop=2 expandtab: #