diff options
Diffstat (limited to 'Master/tlpkg/TeXLive/TLTREE.pm')
-rw-r--r-- | Master/tlpkg/TeXLive/TLTREE.pm | 437 |
1 files changed, 219 insertions, 218 deletions
diff --git a/Master/tlpkg/TeXLive/TLTREE.pm b/Master/tlpkg/TeXLive/TLTREE.pm index 27294e6bbc9..f979618b303 100644 --- a/Master/tlpkg/TeXLive/TLTREE.pm +++ b/Master/tlpkg/TeXLive/TLTREE.pm @@ -11,201 +11,202 @@ 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/; + 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; + 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); + 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); + 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); + 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 { + warn("Ignoring svn status output line:\n $l\n"); + #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); + 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}); - } + 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"; - } + 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); + 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; - } + 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); + my ($node, @path) = @_; + my ($current); - while (@path) { - $current = shift @path; - if ($$node{$current}) { - $node = $$node{$current}; - } else { - $$node{$current} = { }; - $node = $$node{$current}; - } - } - return $node; + 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); - } + 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); - } + 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); - } + 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; + 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; } # @@ -213,73 +214,73 @@ sub _get_matching_files { # 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); + 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); + 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); + 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; + 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; } @@ -287,14 +288,14 @@ sub files_under_path { # member access functions # sub svnroot { - my $self = shift; - if (@_) { $self->{'svnroot'} = shift }; - return $self->{'svnroot'}; + my $self = shift; + if (@_) { $self->{'svnroot'} = shift }; + return $self->{'svnroot'}; } sub architectures { - my $self = shift; - if (@_) { @Architectures = @_ } - return @Architectures; + my $self = shift; + if (@_) { @Architectures = @_ } + return @Architectures; } @@ -302,8 +303,8 @@ sub architectures { 1; ### Local Variables: -### perl-indent-level: 4 -### tab-width: 4 -### indent-tabs-mode: t +### perl-indent-level: 2 +### tab-width: 2 +### indent-tabs-mode: nil ### End: -# vim:set tabstop=4: # +# vim:set tabstop=2: # |