diff options
author | Norbert Preining <preining@logic.at> | 2007-06-16 16:22:16 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2007-06-16 16:22:16 +0000 |
commit | d4eefe7213116b2b11dbfa09d39b54d6470203ca (patch) | |
tree | d0fa75c399323763c095e1ac6d77ae6766ab88e5 /Master/tlpkg/TeXLive | |
parent | ad7c8ab6419951c6e744c47c4be81bef897a18b3 (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.pm | 346 | ||||
-rw-r--r-- | Master/tlpkg/TeXLive/TLPOBJ.pm | 590 | ||||
-rw-r--r-- | Master/tlpkg/TeXLive/TLPSRC.pm | 419 | ||||
-rw-r--r-- | Master/tlpkg/TeXLive/TLTREE.pm | 309 | ||||
-rw-r--r-- | Master/tlpkg/TeXLive/TLUtils.pm | 136 |
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: # |