diff options
author | Norbert Preining <preining@logic.at> | 2007-06-16 16:32:21 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2007-06-16 16:32:21 +0000 |
commit | 8e0118f7fbebfae6bab089e5d7b16fb86d3a5deb (patch) | |
tree | aa0340fccebc2617e0df06a92810f2f863654968 /new-infra/TLTREE.pm | |
parent | 4e696440566b8dc5101c0a4d341b8445423e1f84 (diff) |
delete more stuff
git-svn-id: svn://tug.org/texlive/trunk@4441 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'new-infra/TLTREE.pm')
-rw-r--r-- | new-infra/TLTREE.pm | 309 |
1 files changed, 0 insertions, 309 deletions
diff --git a/new-infra/TLTREE.pm b/new-infra/TLTREE.pm deleted file mode 100644 index 8b0a9b2a8bb..00000000000 --- a/new-infra/TLTREE.pm +++ /dev/null @@ -1,309 +0,0 @@ -# -# 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 TLTREE; - -use 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 = TLUtils::basename($entry); - my $dn = 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; - &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"; - } - 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 = TLUtils::dirname($globline); - my $basepart = 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) { - &TLUtils::debug("matching $f in $dirpart via glob $globline\n"); - if ($f =~ /^$basepart$/) { - &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$/) { - 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); - 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}}) { - 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); - 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: # |