# # 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; 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 = "$9"; next if -d $entry; # TODO: what to do with links??? $self->{'_allfiles'}{$entry}{'lastchangedrev'} = $lastchanged; my $fn = basename($entry); my $dn = dirname($entry); add_path_to_tree($self->{'_dirtree'}, split("[/\\\\]", $dn)); push @{$self->{'_filesofdir'}{$dn}}, $fn; } else { die("Cannot read svn status output line: $l"); } } # 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 member { my ($e, @l) = @_; my ($f); foreach $f (@l) { if ($e eq $f) { return 1; } } return 0; } sub push_uniq { my ($l,@le) = @_; my ($e); foreach $e (@le) { if (! &member($e, @$l)) { push @$l, $e; } } } sub dirname { my ($f) = @_; if ($f =~ m@(^.*)[\\/][^\\/]*$@) { return $1; } else { return "."; } } sub basename { my ($f) = @_; $f =~ m@([^\\/]*)$@; return $1; } sub file_svn_lastrevision { my $self = shift; my $fn = shift; if (defined($self->{'_allfiles'}{$fn})) { return($self->{'_allfiles'}{$fn}{'lastchangedrev'}); } else { return(undef); } } sub get_files_matching_regexp_pattern { my $self = shift; my ($type,$p) = @_; my @returnfiles; FILELABEL: foreach my $f (keys(%{$self->{'_allfiles'}})) { if (_pattern_hit($f,$p)) { push_uniq(\@returnfiles,$f); next FILELABEL; } } return(@returnfiles); } sub _pattern_hit { my ($file, $pattern) = @_; my (@dirs) = split /\//, $file; $pattern =~ /^(d|f|t)\s+(.*)$/; my $pattype = $1; my $patdata = $2; if ($pattype eq "d") { pop @dirs ; my $foo = join "/",@dirs; if ($foo =~ /^$patdata$/) { return 1; } } elsif ($pattype eq "f") { if ($file =~ /^$patdata$/) { return 1; } } else { die("Unknown pattern specification: $pattern!"); } return 0; } sub get_files_matching_dir_pattern { my $self = shift; my ($type,@patwords) = @_; # the pattern type looks like: dir1 dir2 ... dirn dirtl # where a file matches if it looks like # dir1/dir2/.../dirn/.*/dirtl/file # all but the first define the first dirs, the last the leaf dir 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); push_uniq(\@returnfiles, @files); } } } return(@returnfiles); } sub files_under_path { my $self = shift; my $p = shift; my @files = (); foreach my $aa (@{$self->{'_filesofdir'}{$p}}) { push_uniq( \@files, $p . "/" . $aa); } if (defined($self->{'_subdirsofdir'}{$p})) { foreach my $sd (@{$self->{'_subdirsofdir'}{$p}}) { my @sdf = $self->files_under_path($p . "/" . $sd); push_uniq (\@files, @sdf); } } return @files; } # # member access functions # sub svnroot { my $self = shift; if (@_) { $self->{'svnroot'} = shift }; return $self->{'svnroot'}; } 1; ### Local Variables: ### perl-indent-level: 4 ### tab-width: 4 ### indent-tabs-mode: t ### End: # vim:set tabstop=4: #