summaryrefslogtreecommitdiff
path: root/Master/tlpkg/TeXLive
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2007-06-16 16:22:16 +0000
committerNorbert Preining <preining@logic.at>2007-06-16 16:22:16 +0000
commitd4eefe7213116b2b11dbfa09d39b54d6470203ca (patch)
treed0fa75c399323763c095e1ac6d77ae6766ab88e5 /Master/tlpkg/TeXLive
parentad7c8ab6419951c6e744c47c4be81bef897a18b3 (diff)
move new-infra to Master/tlpkg
rename stuff create list files tlsrc for all packages (also schemes) git-svn-id: svn://tug.org/texlive/trunk@4439 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/TeXLive')
-rw-r--r--Master/tlpkg/TeXLive/TLPDB.pm346
-rw-r--r--Master/tlpkg/TeXLive/TLPOBJ.pm590
-rw-r--r--Master/tlpkg/TeXLive/TLPSRC.pm419
-rw-r--r--Master/tlpkg/TeXLive/TLTREE.pm309
-rw-r--r--Master/tlpkg/TeXLive/TLUtils.pm136
5 files changed, 1800 insertions, 0 deletions
diff --git a/Master/tlpkg/TeXLive/TLPDB.pm b/Master/tlpkg/TeXLive/TLPDB.pm
new file mode 100644
index 00000000000..1f5b79612cb
--- /dev/null
+++ b/Master/tlpkg/TeXLive/TLPDB.pm
@@ -0,0 +1,346 @@
+#
+# TeXLive::TLPDB.pm
+# module for using tldb files
+# Copyright 2007 Norbert Preining
+#
+# This file is licensed under the GNU General Public Licence version 2
+# or any later version
+
+package TeXLive::TLPDB;
+
+=pod
+=head1 NAME
+
+TeXLive::TLPDB - a database of TeX Live Packages
+
+=head1 SYNOPSIS
+
+ use TeXLive::TLPDB;
+
+ TeXLive::TLPDB->listdir([$dir]);
+ TeXLive::TLPDB->new ( [ location => "path/to/tldb/file" ] );
+
+ $tlpdb->location([$location]);
+ $tlpdb->from_file($filename);
+ $tlpdb->writeout([FILEHANDLE]);
+ $tlpdb->save;
+ $tlpdb->generate_listfiles([$destdir]);
+ $tlpdb->add_objpkg($tlpobj);
+ $tlpdb->get_package("packagename");
+ $tlpdb->package_revision("packagename");
+
+=head1 DESCRIPTION
+
+=cut
+
+use TeXLive::TLUtils;
+use TeXLive::TLPOBJ;
+
+my $_listdir;
+
+=pod
+
+C<TeXLive::TLPDB->new> creates a new C<TLPDB> object. If the argument
+location is given it will be initialized from this locations.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %params = @_;
+ my $self = {
+ location => $params{'location'},
+ tlps => $params{'tlps'}
+ };
+ $_listdir = $params{'listdir'} if defined($params{'listdir'});
+ bless $self, $class;
+ if (defined($self->{'location'})) {
+ $self->from_file($self->{'location'});
+ }
+ return $self;
+}
+
+=pod
+
+The C<add_tlpobj> adds an object of the type TLPOBJ to the TLPDB.
+
+=cut
+sub add_tlpobj {
+ my ($self,$tlp) = @_;
+ $self->{'tlps'}{$tlp->name} = $tlp;
+}
+
+=pod
+
+The C<from_file> function initializes the C<TLPDB> in case the location
+was not given at generation time.
+
+=cut
+sub from_file {
+ my $self = shift;
+ if (@_ != 1) {
+ die("Need a filename for initialization!");
+ }
+ if (defined($self->{'location'})) {
+ if ($self->location ne $_[0]) {
+ printf STDERR "Initialisation from different location as originally given.\nHope you are sure!\n";
+ }
+ }
+ $self->location($_[0]);
+ open(TMP,"<$_[0]") || die("Cannot open tldb file: $_[0]");
+ my $found = 0;
+ do {
+ my $tlp = TeXLive::TLPOBJ->new;
+ &TeXLive::TLUtils::debug("creating tlp ...\n");
+ $found = $tlp->from_fh(\*TMP,1);
+ if ($found) {
+ $self->add_tlpobj($tlp);
+ }
+ } until (!$found);
+}
+
+=pod
+
+The C<writeout> function writes the whole TLPDB to STDOUT, or to the file
+handle given as argument.
+
+=cut
+sub writeout {
+ my $self = shift;
+ my $fd = (@_ ? $_[0] : STDOUT);
+ foreach (sort keys %{$self->{'tlps'}}) {
+ &TeXLive::TLUtils::debug("tlpname = $_\n");
+ &TeXLive::TLUtils::debug("foo: " . $self->{'tlps'}{$_}->name . "\n");
+ $self->{'tlps'}{$_}->writeout($fd);
+ print $fd "\n";
+ }
+}
+
+=pod
+
+The C<save> functions saves the TLPDB to the file which has been set
+as location. If the location is undefined, die.
+
+=cut
+sub save {
+ my $self = shift;
+ open(FOO,">$self->{'location'}") || die("Cannot open $self->{'location'} for writing: $!");
+ $self->writeout(\*FOO);
+ close(FOO);
+}
+
+=pod
+
+The C<get_package> function returns a reference to an TLPOBJ object in case
+its name the the argument name coincide.
+
+=cut
+sub get_package {
+ my ($self,$pkg) = @_;
+ if (defined($self->{'tlps'}{$pkg})) {
+ return($self->{'tlps'}{$pkg});
+ } else {
+ return(undef);
+ }
+}
+
+=pod
+
+The C<package_revision> functions returns the the revision of the
+package named in the first argument.
+
+=cut
+sub package_revision {
+ my ($self,$pkg) = @_;
+ if (defined($self->{'tlps'}{$pkg})) {
+ return($self->{'tlps'}{$pkg}->revision);
+ } else {
+ return(undef);
+ }
+}
+
+=pod
+
+The C<generate_packagelist> lists all available TL Packages together
+with their revisions.
+
+=cut
+sub generate_packagelist {
+ my $self = shift;
+ my $fd = (@_ ? $_[0] : STDOUT);
+ foreach (sort keys %{$self->{'tlps'}}) {
+ print $fd $self->{'tlps'}{$_}->name, " ", $self->{'tlps'}{$_}->revision, "\n";
+ }
+}
+
+=pod
+
+The C<generate_listfiles> generates the list files for the old
+installers. This function will probably go away.
+
+=cut
+sub generate_listfiles {
+ my ($self,$destdir) = @_;
+ if (not(defined($destdir))) {
+ $destdir = TeXLive::TLPDB->listdir;
+ }
+ foreach (sort keys %{$self->{'tlps'}}) {
+ $tlp = $self->{'tlps'}{$_};
+ $self->_generate_listfile($tlp, $destdir, "all");
+ if ($tlp->is_arch_dependent) {
+ foreach my $a (keys %{$tlp->binfiles}) {
+ $self->_generate_listfile($tlp, $destdir, $a);
+ }
+ }
+ }
+}
+
+sub _generate_listfile {
+ my ($self,$tlp,$destdir,$arch) = @_;
+ my @files = ();
+ my $listname;
+ if ($arch ne "all") {
+ my %foo = %{$tlp->binfiles};
+ push @files, @{$foo{$arch}};
+ $listname = $tlp->name . ".$arch";
+ } else {
+ $listname = $tlp->name;
+ push @files, $tlp->runfiles;
+ push @files, $tlp->docfiles;
+ push @files, $tlp->srcfiles;
+ }
+ @files = TeXLive::TLUtils::sort_uniq(@files);
+ &mkpath("$destdir") if (! -d "$destdir");
+ my (@lop, @lot);
+ foreach my $d ($tlp->depends) {
+ if ($d =~ m/^(Package|Documentation)\/(.*)$/) {
+ push @lop, $2;
+ } elsif ($d =~ m/^TLCore\/(.*)$/) {
+ push @lot, $1;
+ } else {
+ warn "strange depends line: $d\n";
+ }
+ }
+ open(TMP, ">$destdir/$listname") or die "Cannot open $destdir/$listname!";
+ # title and size information for collections and schemes in the
+ # first two lines, marked with *
+ if ($listname =~ m/^collection-/) {
+ print TMP "*Title: ", $tlp->shortdesc, "\n";
+ # collections references Packages, we have to collect the sizes of
+ # all the Package-tlps included
+ # What is unclear for me is HOW the size is computed for bin-*
+ # packages. The collection-basicbin contains quite a lot of
+ # bin-files, but the sizes for the different archs differ.
+ # I guess we have to take the maximum?
+ my $s = 0;
+ foreach my $p (@lop) {
+ my $subtlp = $self->get_package($p);
+ if (!defined($subtlp)) {
+ warn "Strange: $listname references $p, but it is not in tldb";
+ }
+ $s += $subtlp->total_size;
+ }
+ # in case the collection itself ships files ...
+ $s += $tlp->runsize + $tlp->srcsize + $tlp->docsize;
+ print TMP "*Size: $s\n";
+ } elsif ($listname =~ m/^scheme-/) {
+ print TMP "*Title: ", $tlp->shortdesc, "\n";
+ my $s = 0;
+ # needs a bitof trickyness, because contained collections
+ # do not have intersections of packages, but there could be
+ # additional tlps included which would be doubly included
+ my (@inccol,@incpkg);
+ # first we add all the packages tlps that are directly included
+ @incpkg = @lop;
+ # now we select all collections, and for all collections we
+ # again select all packages of type Documentation and Package
+ foreach my $c (@lot) {
+ my $coll = $self->get_package($c);
+ foreach my $d ($coll->depends) {
+ if ($d =~ m/^(Package|Documentation)\/(.*)$/) {
+ TeXLive::TLUtils::push_uniq(\@incpkg,$2);
+ }
+ }
+ }
+ # finally go through all packages and add the ->total_size
+ foreach my $p (@incpkg) {
+ $s += $self->get_package($p)->total_size
+ }
+ print TMP "*Size: $s\n";
+ }
+ # dependencies and inclusion of packages
+ foreach my $t (@lot) {
+ # strange, schemes mark included collections via -, while collections
+ # themself mark deps on other collections with +. collection are
+ # never referenced in Packages
+ if ($listname =~ m/^scheme/) {
+ print TMP "-";
+ } else {
+ print TMP "+";
+ }
+ print TMP "$t\n";
+ }
+ foreach my $t (@lop) { print TMP "+$t\n"; }
+ # included files
+ foreach my $f (@files) { print TMP "$f\n"; }
+ # also print the listfile itself
+ print TMP "$destdir/$listname\n";
+ # execute statements
+ foreach my $e ($tlp->executes) {
+ print TMP "!$e\n";
+ }
+ # finish
+ close(TMP);
+}
+
+=pod
+
+The function C<location> allows to read and set the location of the
+text file of the TeX Live Database.
+
+=cut
+sub location {
+ my $self = shift;
+ if (@_) { $self->{'location'} = shift }
+ return $self->{'location'};
+}
+
+=pod
+
+The function C<listdir> allows to read and set the packages variable
+specifiying where generated list files are created.
+
+=cut
+sub listdir {
+ my @self = shift;
+ if (@_) { $_listdir = $_[0] }
+ return $_listdir;
+}
+
+
+=pod
+
+=head1 AUTHORS AND COPYRIGHT
+
+This module and its documentation was written by
+Norbert Preining <F<preining@logic.at>> for the TeX Live distribution and both
+are licensed under the GNU General Public License Version 2 or later.
+
+=head1 SEE ALSO
+
+The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>,
+L<TeXLive::TLTREE>, L<TeXLive::TLUtils> and the
+document L<Perl-API.txt> and the specification in the TeX Live
+repository trunk/Master/tlpkg/doc/.
+
+=cut
+
+
+1;
+
+### Local Variables:
+### perl-indent-level: 4
+### tab-width: 4
+### indent-tabs-mode: t
+### End:
+# vim:set tabstop=4: #
diff --git a/Master/tlpkg/TeXLive/TLPOBJ.pm b/Master/tlpkg/TeXLive/TLPOBJ.pm
new file mode 100644
index 00000000000..fa80650a973
--- /dev/null
+++ b/Master/tlpkg/TeXLive/TLPOBJ.pm
@@ -0,0 +1,590 @@
+#
+# TeXLive::TLPOBJ.pm
+# module for using tlp files
+# Copyright 2007 Norbert Preining
+#
+# This file is licensed under the GNU General Public Licence version 2
+# or any later version
+
+package TeXLive::TLPOBJ;
+
+use TeXLive::TLUtils;
+use File::Path;
+use Cwd;
+use TeXLive::TLTREE;
+use FileHandle;
+
+my $_tmp;
+my $_zipdir;
+
+sub new {
+ my $class = shift;
+ my %params = @_;
+ my $self = {
+ name => $params{'name'},
+ category => defined($params{'category'}) ? $params{'category'} : "Package",
+ shortdesc => $params{'shortdesc'},
+ longdesc => $params{'longdesc'},
+ catalogue => $params{'catalogue'},
+ 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'} : [],
+ # note that binfiles is an ARRAY 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'},
+ };
+ $_zipdir = $params{'zipdir'} if defined($params{'zipdir'});
+ bless $self, $class;
+ return $self;
+}
+
+sub from_file {
+ my $self = shift;
+ if (@_ != 1) {
+ die("Need a filename for initialization!");
+ }
+ open(TMP,"<$_[0]") || die("Cannot open tlp 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->getline) {
+ &TeXLive::TLUtils::debug("reading line: >>>$line<<<\n");
+ &TeXLive::TLUtils::debug("multi=...$multi...\n");
+ $line =~ /^\s*#/ && 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 tlp files!");
+ }
+ }
+ if ($line =~ /^ /) {
+ if ( ($lastcmd eq "longdesc") ||
+ ($lastcmd eq "runfiles") ||
+ ($lastcmd eq "binfiles") ||
+ ($lastcmd eq "docfiles") ||
+ ($lastcmd eq "srcfiles") ||
+ ($lastcmd eq "executes") ||
+ ($lastcmd eq "depend") ) {
+ $line =~ s/^ /${lastcmd}continued /;
+ } else {
+ die("Continuation of $lastcmd not allowed, please fix tlp!\n");
+ }
+ }
+ if ($line =~ /^name\s*([-\w]+)$/) {
+ $name = "$1";
+ $lastcmd = "name";
+ $self->name("$name");
+ $started && die("Cannot have two name directives: $line!");
+ $started = 1;
+ } else {
+ $started || die("First directive needs to be 'name'");
+ if ($line =~ /^shortdesc\s+(.*)$/) {
+ $self->{'shortdesc'} .= "$1";
+ $lastcmd = "shortdesc";
+ next;
+ } elsif ($line =~ /^longdesc(continued)?\s+(.*)$/) {
+ if (defined($1) && ("$1" eq "continued")) {
+ $self->{'longdesc'} .= " $2";
+ } else {
+ $self->{'longdesc'} = "$2";
+ }
+ $lastcmd = "longdesc";
+ next;
+ } elsif ($line =~ /^category\s+(Package|TLCore|Documentation)$/) {
+ $self->{'category'} = "$1";
+ $lastcmd = "category";
+ next;
+ } elsif ($line =~ /^revision\s+(.*)$/) {
+ $self->{'revision'} = "$1";
+ $lastcmd = "revision";
+ next;
+ } elsif ($line =~ /^catalogue\s+(.*)$/) {
+ $self->catalogue("$1");
+ $lastcmd = "catalogue";
+ next;
+ } elsif ($line =~ /^(doc|src|run)files\s+/) {
+ my $type = $1;
+ my @words = split ' ',$line;
+ # first entry is "XXXfiles", shift it away
+ $lastcmd = shift @words;
+ while (@words) {
+ $_ = shift @words;
+ if (/^size=(.*)$/) {
+ $size=$1;
+ } else {
+ die "Unknown tag: $line";
+ }
+ }
+ if (defined($size)) {
+ $self->{"${type}size"} = $size;
+ }
+ next;
+ } elsif ($line =~ /^(doc|src|run)filescontinued\s+(.*)$/) {
+ push @{$self->{$1."files"}}, "$2";
+ next;
+ } elsif ($line =~ /^binfiles\s+/) {
+ my @words = split ' ',$line;
+ # first entry is "binfiles", shift it away
+ shift @words;
+ while (@words) {
+ $_ = shift @words;
+ if (/^arch=(.*)$/) {
+ $arch=$1;
+ } elsif (/^size=(.*)$/) {
+ $size=$1;
+ } else {
+ die "Unknown tag: $line";
+ }
+ }
+ if (defined($size)) {
+ $self->{'binsize'}{$arch} = $size;
+ }
+ $lastcmd = "binfiles";
+ next;
+ } elsif ($line =~ /^binfilescontinued\s+(.*)$/) {
+ push @{$self->{'binfiles'}{$arch}}, "$1";
+ next;
+ } elsif ($line =~ /^execute(continued)?\s*(.*)$/) {
+ push @{$self->{'executes'}}, "$2" unless "$2" eq "";
+ $lastcmd = "execute";
+ next;
+ } elsif ($line =~ /^depend(continued)?\s*(.*)$/) {
+ push @{$self->{'depends'}}, "$2" unless "$2" eq "";
+ $lastcmd = "depend";
+ next;
+ } else {
+ die("Unknown directive ...$line... , please fix it!");
+ }
+ }
+ }
+ return $started;
+}
+
+sub recompute_revision {
+ my ($self,$tltree) = @_;
+ my @files;
+ foreach my $a (keys %{$self->{'binfiles'}}) {
+ push @files, @{$self->{'binfiles'}{$a}};
+ }
+ push @files, $self->runfiles;
+ push @files, $self->docfiles;
+ push @files, $self->srcfiles;
+ $filemax = 0;
+ foreach my $f (@files) {
+ $filemax = $tltree->file_svn_lastrevision($f);
+ $self->revision(($filemax > $self->revision) ? $filemax : $self->revision);
+ }
+}
+
+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 $size = 0;
+ if ($type eq "bin") {
+ my %binfiles = %{$self->{'binfiles'}};
+ if (defined($binfiles{$arch})) {
+ foreach $f (@{$binfiles{$arch}}) {
+ $size += $tltree->size_of($f);
+ }
+ }
+ } else {
+ if (defined($self->{"${type}files"}) && (@{$self->{"${type}files"}})) {
+ foreach $f (@{$self->{"${type}files"}}) {
+ my $s = $tltree->size_of($f);
+ if (defined($s)) {
+ $size += $s;
+ } else {
+ printf STDERR "size for $f not defined, strange ...\n";
+ }
+ }
+ }
+ }
+ return $size;
+}
+
+sub writeout {
+ my $self = shift;
+ my $fd = (@_ ? $_[0] : STDOUT);
+ format_name $fd "multilineformat";
+ 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";
+ if (defined($self->{'longdesc'})) {
+ $_tmp = "longdesc $self->{'longdesc'}";
+ write $fd;
+ }
+ 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->{'docfiles'}) && (@{$self->{'docfiles'}})) {
+ print $fd "docfiles size=$self->{'docsize'}\n";
+ foreach (sort @{$self->{'docfiles'}}) {
+ print $fd " $_\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 (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";
+ }
+ }
+ }
+}
+
+sub writeout_simple {
+ my $self = shift;
+ my $fd = (@_ ? $_[0] : STDOUT);
+ format_name $fd "multilineformat";
+ 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->{'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 make_zip {
+ my ($self,$tltree,$destdir,$zipname) = @_;
+ my $zipn;
+ if (not(defined($zipname))) {
+ $zipname = $self->name . ".zip";
+ }
+ if (not(defined($destdir))) {
+ $destdir = TeXLive::TLPOBJ->zipdir;
+ }
+ die("Undefined tltree argument!") if (not(defined($tltree)));
+ # first build the arch independet part
+ $self->_make_zip($tltree,$destdir,$zipname,"all");
+ # now the $pkg.$arch.zip
+ if ($self->is_arch_dependent) {
+ foreach my $t (keys %{$self->{'binfiles'}}) {
+ &TeXLive::TLUtils::debug("arch=$t\n");
+ if ($zipname =~ /^(.*)\.zip$/) {
+ $zipn = "$1.$t.zip";
+ } else {
+ $zipn = "$zipname.$t.zip";
+ }
+ $self->_make_zip($tltree,$destdir,$zipn,$t);
+ }
+ }
+}
+
+sub _make_zip {
+ my ($self,$tltree,$destdir,$zipname,$arch) = @_;
+ my $root = $tltree->svnroot;
+ my @files = ();
+ my $zipcmd;
+ if ($arch ne "all") {
+ push @files, @{$self->{'binfiles'}{$arch}};
+ } else {
+ push @files, $self->runfiles;
+ push @files, $self->docfiles;
+ push @files, $self->srcfiles;
+ }
+ # note that the Tpm.pm module had something like
+ # if ($zipname =~ /\/binary/ && $^O !~ /MSWin32/) {
+ # $zipcmd = "| zip -9\@ory "
+ # } else {
+ # $zipcmd = "| zip -9\@or "
+ # }
+ if ($^O =~ /MSWin32/) {
+ $nul = "nul";
+ $zipcmd = "| zip -9\@or "
+ } else {
+ $nul = "/dev/null";
+ $zipcmd = "| zip -9\@ory "
+ }
+ @files = TeXLive::TLUtils::sort_uniq(@files);
+ if (!@files) {
+ &TeXLive::TLUtils::debug("Not creating empty zip file $zipname\n");
+ return;
+ }
+ &mkpath("$destdir") if (! -d "$destdir");
+ my $cwd = &getcwd;
+ chdir($tltree->svnroot);
+ unlink($zipname);
+ print $zipcmd . "$destdir/$zipname" . " > $nul\n" if ($::opt_debug);
+ open ZIP, $zipcmd . "$destdir/$zipname" . " > $nul";
+ map {
+ if (! -f $_) {
+ print STDERR "!!!Error: non-existent $_\n";
+ } else {
+ print ZIP "$_\n";
+ }
+ } @files;
+ close ZIP;
+ print "Done $zipname\n" if ($::opt_debug);
+}
+
+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 binsizes
+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->binsizes};
+ foreach my $k (keys %foo) {
+ $max = $foo{$k} if ($foo{$k} > $max);
+ }
+ $ret += $max;
+ }
+ return($ret);
+}
+
+#
+# member access functions
+#
+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 catalogue {
+ my $self = shift;
+ if (@_) { $self->{'catalogue'} = shift }
+ return $self->{'catalogue'};
+}
+sub srcfiles {
+ my $self = shift;
+ if (@_) { @{ $self->{'srcfiles'} } = @_ }
+ return @{ $self->{'srcfiles'} };
+}
+sub srcsize {
+ my $self = shift;
+ if (@_) { $self->{'srcsize'} = shift }
+ return ( defined($self->{'srcsize'}) ? $self->{'srcsize'} : 0 );
+}
+sub add_srcfiles {
+ my ($self,@files) = @_;
+ $self->add_files("src",@files);
+}
+sub remove_srcfiles {
+ my ($self,@files) = @_;
+ $self->remove_files("src",@files);
+}
+sub docfiles {
+ my $self = shift;
+ if (@_) { @{ $self->{'docfiles'} } = @_ }
+ return @{ $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 binfiles {
+ my $self = shift;
+ my %newfiles = @_;
+ if (@_) { $self->{'binfiles'} = \%newfiles }
+ return $self->{'binfiles'};
+}
+sub binsizes {
+ my $self = shift;
+ my %newsizes = @_;
+ if (@_) { $self->{'binsizes'} = \%newsizes }
+ return $self->{'binsizes'};
+}
+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 {
+ my $self = shift;
+ if (@_) { @{ $self->{'runfiles'} } = @_ }
+ return @{ $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 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 add_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 depends {
+ my $self = shift;
+ if (@_) { @{ $self->{'depends'} } = @_ }
+ return @{ $self->{'depends'} };
+}
+sub executes {
+ my $self = shift;
+ if (@_) { @{ $self->{'executes'} } = @_ }
+ return @{ $self->{'executes'} };
+}
+
+sub zipdir {
+ my @self = shift;
+ if (@_) { $_zipdir = $_[0] }
+ return $_zipdir;
+}
+
+1;
+
+
+
+###### Formats
+format multilineformat =
+^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$_tmp
+ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
+$_tmp
+.
+
+### Local Variables:
+### perl-indent-level: 4
+### tab-width: 4
+### indent-tabs-mode: t
+### End:
+# vim:set tabstop=4: #
diff --git a/Master/tlpkg/TeXLive/TLPSRC.pm b/Master/tlpkg/TeXLive/TLPSRC.pm
new file mode 100644
index 00000000000..9497a6f962e
--- /dev/null
+++ b/Master/tlpkg/TeXLive/TLPSRC.pm
@@ -0,0 +1,419 @@
+#
+# TeXLive::TLPSRC.pm
+# module for using tlsrc files
+# Copyright 2007 Norbert Preining
+#
+# This file is licensed under the GNU General Public Licence version 2
+# or any later version
+
+package TeXLive::TLPSRC;
+
+use FileHandle;
+use TeXLive::TLPOBJ;
+use TeXLive::TLTREE;
+
+my $_tmp;
+
+sub new {
+ my $class = shift;
+ my %params = @_;
+ my $self = {
+ name => $params{'name'},
+ category => defined($params{'category'}) ? $params{'category'} : "Package",
+ shortdesc => $params{'shortdesc'},
+ longdesc => $params{'longdesc'},
+ catalogue => $params{'catalogue'},
+ runpatterns => $params{'runpatterns'},
+ srcpatterns => $params{'srcpatterns'},
+ docpatterns => $params{'docpatterns'},
+ binpatterns => $params{'binpatterns'},
+ executes => defined($params{'executes'}) ? $params{'executes'} : [],
+ depends => defined($params{'depends'}) ? $params{'depends'} : [],
+ };
+ bless $self, $class;
+ return $self;
+}
+
+sub from_file {
+ my $self = shift;
+ if (@_ != 1) {
+ die("Need a filename for initialization!");
+ }
+ open(TMP,"<$_[0]") || die("Cannot open tlsrc file: $_[0]");
+ my @lines = <TMP>;
+ close(TMP);
+ my $name = "";
+ # default category = Package
+ my $category = "Package";
+ my $shortdesc = "";
+ my $longdesc= "";
+ my $catalogue = "";
+ my (@executes, @depends);
+ my (@runpatterns, @docpatterns, @binpatterns, @srcpatterns);
+ my $started = 0;
+ my $finished = 0;
+ my $lastcmd = "";
+
+ foreach my $line (@lines) {
+ $line =~ /^\s*#/ && next; # skip comment lines
+ if ($line =~ /^\s*$/) {
+ if (!$started) { next; }
+ if ($finished) { next; }
+ die("No empty line allowed in tlsrc file $_[0]!");
+ }
+ if ($line =~ /^ /) {
+ if ( ($lastcmd eq "longdesc") ||
+ ($lastcmd eq "runpatterns") ||
+ ($lastcmd eq "binpatterns") ||
+ ($lastcmd eq "docpatterns") ||
+ ($lastcmd eq "srcpatterns") ||
+ ($lastcmd eq "execute") ||
+ ($lastcmd eq "depend") ) {
+ $line =~ s/^ /$lastcmd /;
+ } else {
+ die("Continuation of $lastcmd not allowed, please fix tlsrc!\n");
+ }
+ }
+ if ($line =~ /^name\s*([-\w]+)$/) {
+ $name = "$1";
+ $lastcmd = "name";
+ $started && die("Cannot have two name directives!");
+ $started = 1;
+ } else {
+ $started || die("First directive needs to be 'name'");
+ if ($line =~ /^shortdesc\s*(.*)$/) {
+ $shortdesc = "$1";
+ $lastcmd = "shortdesc";
+ next;
+ } elsif ($line =~ /^category\s+(Package|TLCore|Documentation)$/) {
+ $category = "$1";
+ $lastcmd = "category";
+ next;
+ } elsif ($line =~ /^longdesc\s+(.*)$/) {
+ $longdesc .= "$1 ";
+ $lastcmd = "longdesc";
+ next;
+ } elsif ($line =~ /^catalogue\s+(.*)$/) {
+ $catalogue = "$1";
+ $lastcmd = "catalogue";
+ next;
+ } elsif ($line =~ /^runpatterns\s+(.*)$/) {
+ push @runpatterns, "$1" if ("$1" ne "");
+ $lastcmd = "runpatterns";
+ next;
+ } elsif ($line =~ /^srcpatterns\s+(.*)$/) {
+ push @srcpatterns, "$1" if ("$1" ne "");
+ $lastcmd = "srcpatterns";
+ next;
+ } elsif ($line =~ /^docpatterns\s+(.*)$/) {
+ push @docpatterns, "$1" if ("$1" ne "");
+ $lastcmd = "docpatterns";
+ next;
+ } elsif ($line =~ /^binpatterns\s+(.*)$/) {
+ push @binpatterns, "$1" if ("$1" ne "");
+ $lastcmd = "binpatterns";
+ next;
+ } elsif ($line =~ /^execute\s+(.*)$/) {
+ push @executes, "$1" if ("$1" ne "");
+ $lastcmd = "execute";
+ next;
+ } elsif ($line =~ /^depend\s+(.*)$/) {
+ push @depends, "$1" if ("$1" ne "");
+ $lastcmd = "depend";
+ next;
+ } else {
+ #die("Unknown directive ...$line... in $_[0], please fix it!");
+ print STDERR "Unknown directive ...$line... in $_[0], please fix it!\n";
+ }
+ }
+ }
+ $self->name("$name");
+ $self->category("$category");
+ $self->catalogue($catalogue ne "" ? "$catalogue" : "$name");
+ $self->shortdesc("$shortdesc") if ($shortdesc ne "");
+ $self->longdesc("$longdesc") if ($longdesc ne "");
+ $self->srcpatterns(@srcpatterns) if ($#srcpatterns >= 0);
+ $self->runpatterns(@runpatterns) if ($#runpatterns >= 0);
+ $self->binpatterns(@binpatterns) if ($#binpatterns >= 0);
+ $self->docpatterns(@docpatterns) if ($#docpatterns >= 0);
+ $self->executes(@executes) if ($#executes >= 0);
+ $self->depends(@depends) if ($#depends >= 0);
+}
+
+sub writeout {
+ my $self = shift;
+ my $fd = (@_ ? $_[0] : STDOUT);
+ format_name $fd "multilineformat";
+ print $fd "name ", $self->name, "\n";
+ print $fd "category ", $self->category, "\n";
+ print $fd "catalogue $self->{'catalogue'}\n";
+ defined($self->{'shortdesc'}) && print $fd "shortdesc $self->{'shortdesc'}\n";
+ if (defined($self->{'longdesc'})) {
+ $_tmp = "longdesc $self->{'longdesc'}";
+ write $fd;
+ }
+ 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->{'srcpatterns'}) && (@{$self->{'srcpatterns'}})) {
+ print $fd "srcpatterns\n";
+ foreach (sort @{$self->{'srcpatterns'}}) {
+ print $fd " $_\n";
+ }
+ }
+ if (defined($self->{'runpatterns'}) && (@{$self->{'runpatterns'}})) {
+ print $fd "runpatterns\n";
+ foreach (sort @{$self->{'runpatterns'}}) {
+ print $fd " $_\n";
+ }
+ }
+ if (defined($self->{'docpatterns'}) && (@{$self->{'docpatterns'}})) {
+ print $fd "docpatterns\n";
+ foreach (sort @{$self->{'docpatterns'}}) {
+ print $fd " $_\n";
+ }
+ }
+ if (defined($self->{'binpatterns'}) && (@{$self->{'binpatterns'}})) {
+ print $fd "binpatterns\n";
+ foreach (sort @{$self->{'binpatterns'}}) {
+ print $fd " $_\n";
+ }
+ }
+}
+
+#
+# the hard work, generate a TLP file
+#
+
+sub make_tlpobj {
+ my ($self,$tltree) = @_;
+ my $tlp = TeXLive::TLPOBJ->new;
+ $tlp->name($self->name);
+ $tlp->category($self->category);
+ $tlp->shortdesc($self->{'shortdesc'}) if (defined($self->{'shortdesc'}));
+ $tlp->longdesc($self->{'longdesc'}) if (defined($self->{'longdesc'}));
+ $tlp->catalogue($self->{'catalogue'}) if (defined($self->{'catalogue'}));
+ $tlp->executes(@{$self->{'executes'}}) if (defined($self->{'executes'}));
+ $tlp->depends(@{$self->{'depends'}}) if (defined($self->{'depends'}));
+ $tlp->revision(0);
+ my $filemax;
+ my $usedefault = 1;
+ my @allpospats;
+ my @allnegpats;
+ foreach my $p (@{$self->{'runpatterns'}}) {
+ if ($p =~ m/^\+!(.*)$/) {
+ push @allnegpats, $1;
+ } elsif ($p =~ m/^\+(.*)$/) {
+ push @allpospats, $1;
+ } elsif ($p =~ m/^!(.*)$/) {
+ push @allnegpats, $1;
+ $usedefault = 0;
+ } else {
+ push @allpospats, $p;
+ $usedefault = 0;
+ }
+ }
+ if ($usedefault) {
+ if ($self->category eq "Package") {
+ foreach my $md (qw/bibtex context dvips fonts makeindex metafont
+ metapost mft omega scripts tex vtex/) {
+ push @allpospats, "t texmf-dist $md $self->{'name'}";
+ }
+ }
+ }
+ foreach my $p (@allpospats) {
+ $self->_do_normal_pattern($p,$tlp,$tltree,'run');
+ }
+ foreach my $p (@allnegpats) {
+ $self->_do_normal_pattern($p,$tlp,$tltree,'run',1);
+ }
+ @allpospats = ();
+ @allnegpats = ();
+ $usedefault = 1;
+ foreach my $p (@{$self->{'srcpatterns'}}) {
+ if ($p =~ m/^\+!(.*)$/) {
+ push @allnegpats, $1;
+ } elsif ($p =~ m/^\+(.*)$/) {
+ push @allpospats, $1;
+ } elsif ($p =~ m/^!(.*)$/) {
+ push @allnegpats, $1;
+ $usedefault = 0;
+ } else {
+ push @allpospats, $p;
+ $usedefault = 0;
+ }
+ }
+ if ($usedefault) {
+ # default patterns for srcfiles
+ if ($self->category eq "Package") {
+ push @allpospats, "t texmf-dist source $self->{'name'}";
+ } elsif ($self->category eq "Documentation") {
+ push @allpospats, "t texmf-doc source $self->{'name'}";
+ }
+ }
+ foreach my $p (@allpospats) {
+ $self->_do_normal_pattern($p,$tlp,$tltree,'src');
+ }
+ foreach my $p (@allnegpats) {
+ $self->_do_normal_pattern($p,$tlp,$tltree,'src',1);
+ }
+ @allpospats = ();
+ @allnegpats = ();
+ $usedefault = 1;
+ foreach my $p (@{$self->{'docpatterns'}}) {
+ if ($p =~ m/^\+!(.*)$/) {
+ push @allnegpats, $1;
+ } elsif ($p =~ m/^\+(.*)$/) {
+ push @allpospats, $1;
+ } elsif ($p =~ m/^!(.*)$/) {
+ push @allnegpats, $1;
+ $usedefault = 0;
+ } else {
+ push @allpospats, $p;
+ $usedefault = 0;
+ }
+ }
+ if ($usedefault) {
+ # default patterns for docfiles
+ if ($self->category eq "Package") {
+ push @allpospats, "t texmf-dist doc $self->{'name'}";
+ } elsif ($self->category eq "Documentation") {
+ push @allpospats, "t texmf-doc doc $self->{'name'}";
+ }
+ }
+ foreach my $p (@allpospats) {
+ $self->_do_normal_pattern($p,$tlp,$tltree,'doc');
+ }
+ foreach my $p (@allnegpats) {
+ $self->_do_normal_pattern($p,$tlp,$tltree,'doc',1);
+ }
+ # no default patterns for binfiles
+ @allpospats = ();
+ @allnegpats = ();
+ foreach my $p (@{$self->{'binpatterns'}}) {
+ if ($p =~ m/^\+!(.*)$/) {
+ push @allnegpats, $1;
+ } elsif ($p =~ m/^\+(.*)$/) {
+ push @allpospats, $1;
+ } elsif ($p =~ m/^!(.*)$/) {
+ push @allnegpats, $1;
+ } else {
+ push @allpospats, $p;
+ }
+ }
+ foreach my $p (@allpospats) {
+ my $matchref;
+ $matchref = $tltree->get_matching_files('bin',$p);
+ my %archmatches = %$matchref;
+ my @archs = $tltree->architectures;
+ foreach my $arch (@archs) {
+ $tlp->add_binfiles($arch,@{$archmatches{$arch}});
+ }
+ }
+ foreach my $p (@allnegpats) {
+ my $matchref;
+ $matchref = $tltree->get_matching_files('bin',$p);
+ my %archmatches = %$matchref;
+ my @archs = $tltree->architectures;
+ foreach my $arch (@archs) {
+ $tlp->remove_binfiles($arch,@{$archmatches{$arch}});
+ }
+ }
+ $tlp->recompute_sizes($tltree);
+ $tlp->recompute_revision($tltree);
+ return $tlp;
+}
+
+sub _do_normal_pattern {
+ my ($self,$p,$tlp,$tltree,$type,$negative) = @_;
+ my $matchref = $tltree->get_matching_files($type,$p);
+ my @matchfiles = @$matchref;
+ if (defined($negative) && $negative == 1) {
+ $tlp->remove_files($type,@matchfiles);
+ } else {
+ $tlp->add_files($type,@matchfiles);
+ }
+}
+
+#
+# member access functions
+#
+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 catalogue {
+ my $self = shift;
+ if (@_) { $self->{'catalogue'} = shift }
+ return $self->{'catalogue'};
+}
+sub srcpatterns {
+ my $self = shift;
+ if (@_) { @{ $self->{'srcpatterns'} } = @_ }
+ return @{ $self->{'srcpatterns'} };
+}
+sub docpatterns {
+ my $self = shift;
+ if (@_) { @{ $self->{'docpatterns'} } = @_ }
+ return @{ $self->{'docpatterns'} };
+}
+sub binpatterns {
+ my $self = shift;
+ if (@_) { @{ $self->{'binpatterns'} } = @_ }
+ return @{ $self->{'binpatterns'} };
+}
+sub depends {
+ my $self = shift;
+ if (@_) { @{ $self->{'depends'} } = @_ }
+ return @{ $self->{'depends'} };
+}
+sub runpatterns {
+ my $self = shift;
+ if (@_) { @{ $self->{'runpatterns'} } = @_ }
+ return @{ $self->{'runpatterns'} };
+}
+sub executes {
+ my $self = shift;
+ if (@_) { @{ $self->{'executes'} } = @_ }
+ return @{ $self->{'executes'} };
+}
+
+1;
+
+# FORMATS
+format multilineformat =
+^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$_tmp
+ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
+$_tmp
+.
+
+### Local Variables:
+### perl-indent-level: 4
+### tab-width: 4
+### indent-tabs-mode: t
+### End:
+# vim:set tabstop=4: #
diff --git a/Master/tlpkg/TeXLive/TLTREE.pm b/Master/tlpkg/TeXLive/TLTREE.pm
new file mode 100644
index 00000000000..27294e6bbc9
--- /dev/null
+++ b/Master/tlpkg/TeXLive/TLTREE.pm
@@ -0,0 +1,309 @@
+#
+# TeXLive::TLTREE.pm
+# helper module to work with the tree of all files
+# Copyright 2007 Norbert Preining
+#
+# This file is licensed under the GNU General Public Licence version 2
+# or any later version
+
+package TeXLive::TLTREE;
+
+use TeXLive::TLUtils;
+
+my @Architectures = qw/alpha-linux hppa-hpux i386-darwin i386-freebsd
+ i386-linux i386-openbsd i386-solaris mips-irix powerpc-aix powerpc-darwin
+ powerpc-linux sparc-linux sparc-solaris win32 x86_64-linux/;
+
+sub new {
+ my $class = shift;
+ my %params = @_;
+ my $self = {
+ svnroot => $params{'svnroot'},
+ # private stuff
+ _allfiles => {},
+ _dirtree => {},
+ _dirnames => {},
+ _filesofdir => {},
+ _subdirsofdir => {},
+ };
+ bless $self, $class;
+ return $self;
+}
+
+sub init_from_svn {
+ my $self = shift;
+ die("Undefined svn root!") if (!defined($self->{'svnroot'}));
+ my @lines = `cd $self->{'svnroot'} && svn status -v`;
+ $self->_initialize_lines(@lines);
+}
+
+sub init_from_statusfile {
+ my $self = shift;
+ die("Need a filename of svn status file!") if (@_ != 1);
+ open(TMP,"<$_[0]") || die("Cannot open svn status file: $_[0]");
+ my @lines = <TMP>;
+ close(TMP);
+ $self->_initialize_lines(@lines);
+}
+
+sub _initialize_lines {
+ my $self = shift;
+ my @lines = @_;
+ # we first chdir to the svn root, we need it for file tests
+ my $oldpwd = `pwd`;
+ chomp($oldpwd);
+ chdir($self->svnroot) || die("Cannot chdir to SVN root $self->{'svnroot'}!");
+ foreach my $l (@lines) {
+ chomp($l);
+ next if ($l =~ /^\?/); # ignore files not under version control
+ if ($l =~ /^(.)(.)(.)(.)(.)(.)..\s*(\d+)\s+([\d\?]+)\s+([\w\?]+)\s+(.+)$/) {
+ my $lastchanged = $8;
+ my $entry = "$10";
+ next if -d $entry; # TODO: what to do with links???
+ $self->{'_allfiles'}{$entry}{'lastchangedrev'} = $lastchanged;
+ $self->{'_allfiles'}{$entry}{'size'} = (lstat $entry)[7];
+ my $fn = TeXLive::TLUtils::basename($entry);
+ my $dn = TeXLive::TLUtils::dirname($entry);
+ add_path_to_tree($self->{'_dirtree'}, split("[/\\\\]", $dn));
+ push @{$self->{'_filesofdir'}{$dn}}, $fn;
+ } else {
+ die("Cannot read svn status output line:\n $l\n");
+ }
+ }
+ # now do some magic
+ # - create list of top level dirs with a list of full path names of
+ # the respective dir attached
+ $self->walk_tree(\&find_alldirs);
+ chdir($oldpwd);
+}
+
+sub print {
+ my $self = shift;
+ $self->walk_tree(\&print_node);
+}
+
+sub find_alldirs {
+ my ($self,$node, @stackdir) = @_;
+ my $tl = $stackdir[-1];
+ push @{$self->{'_dirnames'}{$tl}}, join("/", @stackdir);
+ if (keys(%{$node})) {
+ my $pa = join("/", @stackdir);
+ push @{$self->{'_subdirsofdir'}{$pa}}, keys(%{$node});
+ }
+}
+
+sub print_node {
+ my ($self,$node, @stackdir) = @_;
+ my $dp = join("/", @stackdir);
+ if ($self->{'_filesofdir'}{$dp}) {
+ foreach my $f (@{$self->{'_filesofdir'}{$dp}}) {
+ print "dp=$dp file=$f\n";
+ }
+ }
+ if (! keys(%{$node})) {
+ print join("/", @stackdir) . "\n";
+ }
+}
+
+sub walk_tree {
+ my $self = shift;
+ my (@stack_dir);
+ $self->_walk_tree1($self->{'_dirtree'},@_, @stack_dir);
+}
+
+sub _walk_tree1 {
+ my $self = shift;
+ my ($node,$pre_proc, $post_proc, @stack_dir) = @_;
+ my $v;
+ for my $k (keys(%{$node})) {
+ push @stack_dir, $k;
+ $v = $node->{$k};
+ if ($pre_proc) { &{$pre_proc}($self, $v, @stack_dir) }
+ $self->_walk_tree1 (\%{$v}, $pre_proc, $post_proc, @stack_dir);
+ $v = $node->{$k};
+ if ($post_proc) { &{$post_proc}($self, $v, @stack_dir) }
+ pop @stack_dir;
+ }
+}
+
+sub add_path_to_tree {
+ my ($node, @path) = @_;
+ my ($current);
+
+ while (@path) {
+ $current = shift @path;
+ if ($$node{$current}) {
+ $node = $$node{$current};
+ } else {
+ $$node{$current} = { };
+ $node = $$node{$current};
+ }
+ }
+ return $node;
+}
+
+sub file_svn_lastrevision {
+ my $self = shift;
+ my $fn = shift;
+ if (defined($self->{'_allfiles'}{$fn})) {
+ return($self->{'_allfiles'}{$fn}{'lastchangedrev'});
+ } else {
+ return(undef);
+ }
+}
+
+sub size_of {
+ my ($self,$f) = @_;
+ if (defined($self->{'_allfiles'}{$f})) {
+ return($self->{'_allfiles'}{$f}{'size'});
+ } else {
+ return(undef);
+ }
+}
+
+sub get_matching_files {
+ my ($self, $type, $p) = @_;
+ if ($type eq "bin") {
+ # we first substitute arch for ${ARCH}
+ my %returnfiles;
+ foreach $a (@Architectures) {
+ # return empty list of arch!=win32 and pattern matches bin/win32
+ # this is a special case to treat with tlsrc files auto generated
+ # from tpm files
+ if (($p =~ m@f bin/win32/@) && ($a ne "win32")) {
+ $returnfiles{$a} = [ ];
+ next;
+ }
+ my $ARCH = $a;
+ my $newp;
+ eval "\$newp = \"$p\"";
+ my @foo = $self->_get_matching_files($type,$newp);
+ $returnfiles{$a} = [ @foo ];
+ }
+ return(\%returnfiles);
+ } else {
+ my @returnfiles = $self->_get_matching_files($type,$p);
+ return(\@returnfiles);
+ }
+}
+
+
+sub _get_matching_files {
+ my ($self, $type, $p) = @_;
+ my ($pattype,$patdata,@rest) = split ' ',$p;
+ my @matchfiles;
+ &TeXLive::TLUtils::debug("check on $pattype,$patdata,@rest\n");
+ if ($pattype eq "t") {
+ @matchfiles = $self->_get_files_matching_dir_pattern($type,$patdata,@rest);
+ } elsif ($pattype eq "f") {
+ @matchfiles = $self->_get_files_matching_glob_pattern($type,$patdata);
+ } elsif ($pattype eq "r") {
+ @matchfiles = $self->_get_files_matching_regexp_pattern($type,$patdata);
+ } elsif ($pattype eq "d") {
+ @matchfiles = $self->files_under_path($patdata);
+ } else {
+ die "Unknown pattern $p";
+ }
+ TeXLive::TLUtils::debug("DEBUG: p=$p, matchfiles=@matchfiles\n");
+ return @matchfiles;
+}
+
+#
+# we transform a glob pattern to a regexp pattern:
+# currently supported globs: ? *
+#
+# sequences of subsitutions:
+# . -> \.
+# * -> .*
+# ? -> .
+sub _get_files_matching_glob_pattern {
+ my $self = shift;
+ my ($type,$globline) = @_;
+ my @returnfiles;
+ my $dirpart = TeXLive::TLUtils::dirname($globline);
+ my $basepart = TeXLive::TLUtils::basename($globline);
+ $basepart =~ s/\./\\./g;
+ $basepart =~ s/\*/.*/g;
+ $basepart =~ s/\?/./g;
+ $basepart =~ s/\+/\\+/g;
+ return unless (defined($self->{'_filesofdir'}{$dirpart}));
+ my @candfiles = @{$self->{'_filesofdir'}{$dirpart}};
+ foreach my $f (@candfiles) {
+ &TeXLive::TLUtils::debug("matching $f in $dirpart via glob $globline\n");
+ if ($f =~ /^$basepart$/) {
+ &TeXLive::TLUtils::debug("hit: globline=$globline, $dirpart/$f\n");
+ push @returnfiles, "$dirpart/$f";
+ }
+ }
+ return(@returnfiles);
+}
+
+sub _get_files_matching_regexp_pattern {
+ my $self = shift;
+ my ($type,$regexp) = @_;
+ my @returnfiles;
+ FILELABEL: foreach my $f (keys(%{$self->{'_allfiles'}})) {
+ if ($f =~ /^$regexp$/) {
+ TeXLive::TLUtils::push_uniq(\@returnfiles,$f);
+ next FILELABEL;
+ }
+ }
+ return(@returnfiles);
+}
+
+sub _get_files_matching_dir_pattern {
+ my ($self,$type,@patwords) = @_;
+ my $tl = pop @patwords;
+ my @returnfiles;
+ if (defined($self->{'_dirnames'}{$tl})) {
+ foreach my $tld (@{$self->{'_dirnames'}{$tl}}) {
+ if (index($tld,join("/",@patwords)."/") == 0) {
+ my @files = $self->files_under_path($tld);
+ TeXLive::TLUtils::push_uniq(\@returnfiles, @files);
+ }
+ }
+ }
+ return(@returnfiles);
+}
+
+sub files_under_path {
+ my $self = shift;
+ my $p = shift;
+ my @files = ();
+ foreach my $aa (@{$self->{'_filesofdir'}{$p}}) {
+ TeXLive::TLUtils::push_uniq(\@files, $p . "/" . $aa);
+ }
+ if (defined($self->{'_subdirsofdir'}{$p})) {
+ foreach my $sd (@{$self->{'_subdirsofdir'}{$p}}) {
+ my @sdf = $self->files_under_path($p . "/" . $sd);
+ TeXLive::TLUtils::push_uniq (\@files, @sdf);
+ }
+ }
+ return @files;
+}
+
+
+#
+# member access functions
+#
+sub svnroot {
+ my $self = shift;
+ if (@_) { $self->{'svnroot'} = shift };
+ return $self->{'svnroot'};
+}
+sub architectures {
+ my $self = shift;
+ if (@_) { @Architectures = @_ }
+ return @Architectures;
+}
+
+
+
+1;
+
+### Local Variables:
+### perl-indent-level: 4
+### tab-width: 4
+### indent-tabs-mode: t
+### End:
+# vim:set tabstop=4: #
diff --git a/Master/tlpkg/TeXLive/TLUtils.pm b/Master/tlpkg/TeXLive/TLUtils.pm
new file mode 100644
index 00000000000..f07c4588ed5
--- /dev/null
+++ b/Master/tlpkg/TeXLive/TLUtils.pm
@@ -0,0 +1,136 @@
+#
+# TeXLive::TLUtils.pm
+# common functions for TeX Live Infrastructure
+# Copyright 2007 Norbert Preining
+#
+# based on Fabrice Popineau's FileUtils.pm
+#
+# This file is licensed under the GNU General Public Licence version 2
+# or any later version
+
+package TeXLive::TLUtils;
+
+=pod
+=head1 NAME
+
+TeXLive::TLUtils - utilities used in the TeX Live Infrastructure Modules
+
+=head1 SYNOPSIS
+
+ use TeXLive::TLUtils;
+
+ TeXLive::TLUtils::sort_uniq(@list);
+ TeXLive::TLUtils::push_uniq(\@list, @items);
+ TeXLive::TLUtils::member($item, @list);
+ TeXLive::TLUtils::debug($string);
+
+=head1 DESCRIPTION
+
+=cut
+
+use File::Basename;
+
+BEGIN {
+ use Exporter ();
+ use Cwd;
+ use File::Path;
+ use vars qw( @ISA @EXPORT_OK );
+ @ISA = qw(Exporter);
+ @EXPORT_OK = qw(
+ &sort_uniq
+ &push_uniq
+ );
+}
+
+=pod
+
+The C<sort_uniq> function sorts the given array and throws away multiple
+occurrences of elements. It returns a sorted and unified array.
+
+=cut
+
+sub sort_uniq {
+ my (@l) = @_;
+ my ($e, $f, @r);
+ $f = "";
+ @l = sort(@l);
+ foreach $e (@l) {
+ if ($e ne $f) {
+ $f = $e;
+ push @r, $e;
+ }
+ }
+ return @r;
+}
+
+=pod
+
+The C<push_uniq> function pushes the last elements on the list referenced
+by the first argument.
+
+=cut
+
+sub push_uniq {
+ local (*l, @le) = @_;
+ my ($e);
+ foreach $e (@le) {
+ if (! &member($e, @l)) {
+ push @l, $e;
+ }
+ }
+}
+
+=pod
+
+The C<member> function returns true if the the first argument is contained
+in the list of the remaining arguments.
+
+=cut
+
+sub member {
+ my ($e, @l) = @_;
+ my ($f);
+ foreach $f (@l) {
+ if ($e eq $f) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+=pod
+
+The C<debug> function echos the argument string to STDERR in case that
+the global varialbe C<opt_debug> is set.
+
+=cut
+
+sub debug {
+ print STDERR @_ if ($::opt_debug);
+}
+
+1;
+
+=pod
+
+=head1 AUTHORS AND COPYRIGHT
+
+This module and its documentation was written by
+Norbert Preining <F<preining@logic.at>> for the TeX Live distribution and both
+are licensed under the GNU General Public License Version 2 or later.
+
+=head1 SEE ALSO
+
+The modules L<TeXLive::TLPSRC>, L<TeXLive::TLPOBJ>,
+L<TeXLive::TLPDB>, L<TeXLive::TLTREE>, and the
+document L<Perl-API.txt> and the specification in the TeX Live
+repository trunk/Master/tlpkg/doc/.
+
+=cut
+
+### Local Variables:
+### perl-indent-level: 4
+### tab-width: 4
+### indent-tabs-mode: t
+### End:
+# vim:set tabstop=4: #