From d4eefe7213116b2b11dbfa09d39b54d6470203ca Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Sat, 16 Jun 2007 16:22:16 +0000 Subject: 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 --- Master/tlpkg/TeXLive/TLTREE.pm | 309 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 309 insertions(+) create mode 100644 Master/tlpkg/TeXLive/TLTREE.pm (limited to 'Master/tlpkg/TeXLive/TLTREE.pm') 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 = ; + 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: # -- cgit v1.2.3