summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2007-05-24 05:57:38 +0000
committerNorbert Preining <preining@logic.at>2007-05-24 05:57:38 +0000
commit66228037d637daf22538fb6cea973010d32ece93 (patch)
tree8cc7812c944da0daacb6d310287248ce799eb922
parent598d91543920cea47df4d65b6983fc379577e36b (diff)
more perl module hacks
git-svn-id: svn://tug.org/texlive/trunk@4349 c570f23f-e606-0410-a88d-b1316a301751
-rw-r--r--new-infra/TLSRC.pm2
-rw-r--r--new-infra/TLTREE.pm190
-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