diff options
author | Norbert Preining <preining@logic.at> | 2007-05-24 05:57:38 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2007-05-24 05:57:38 +0000 |
commit | 66228037d637daf22538fb6cea973010d32ece93 (patch) | |
tree | 8cc7812c944da0daacb6d310287248ce799eb922 /new-infra | |
parent | 598d91543920cea47df4d65b6983fc379577e36b (diff) |
more perl module hacks
git-svn-id: svn://tug.org/texlive/trunk@4349 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'new-infra')
-rw-r--r-- | new-infra/TLSRC.pm | 2 | ||||
-rw-r--r-- | new-infra/TLTREE.pm | 190 | ||||
-rw-r--r-- | new-infra/test-tlsrc.pl (renamed from new-infra/test.pl) | 0 |
3 files changed, 191 insertions, 1 deletions
diff --git a/new-infra/TLSRC.pm b/new-infra/TLSRC.pm index 90dd4c5a155..8862e4cb3f4 100644 --- a/new-infra/TLSRC.pm +++ b/new-infra/TLSRC.pm @@ -32,7 +32,7 @@ sub from_file { if (@_ != 1) { die("Need a filename for initialization!"); } - open(TMP,"<$_[0]") || die("Cannot open $tlsrc: $_[0]"); + open(TMP,"<$_[0]") || die("Cannot open tlsrc file: $_[0]"); my @lines = <TMP>; close(TMP); my $name = ""; diff --git a/new-infra/TLTREE.pm b/new-infra/TLTREE.pm new file mode 100644 index 00000000000..4278188ad4d --- /dev/null +++ b/new-infra/TLTREE.pm @@ -0,0 +1,190 @@ +# +# 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 + _tree => {}, + _dirtree => {}, + _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 = "$9"; + next if -d $entry; # TODO: what to do with links??? + @{$self->{'_tree'}{$entry}{'used'}} = (); + $self->{'_tree'}{$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); + walk_tree($DirTree, \&find_alldirs); + chdir($oldpwd); +} + +sub print_tree { + my ($node) = @_; + &walk_tree($node, \&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 (@stack_dir); + walk_tree1(@_, @stack_dir); +} + +sub _walk_tree1 { + my ($self,$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; +} + +# +# 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: # diff --git a/new-infra/test.pl b/new-infra/test-tlsrc.pl index 8a2db80660b..8a2db80660b 100644 --- a/new-infra/test.pl +++ b/new-infra/test-tlsrc.pl |