move new-infra to Master/tlpkg

rename stuff
create list files
tlsrc for all packages (also schemes)


git-svn-id: svn://tug.org/texlive/trunk@4439 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 309 insertions, 0 deletions

diff --git a/Master/tlpkg/TeXLive/TLTREE.pm b/Master/tlpkg/TeXLive/TLTREE.pm
new file mode 100644
index 00000000000..27294e6bbc9
--- /dev/null
+++ b/Master/tlpkg/TeXLive/TLTREE.pm
@@ -0,0 +1,309 @@
+#
+# TeXLive::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 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/;
+
+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 = 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);
+}
+
+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;
+	&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;
+}
+
+#
+# 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 = 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);
+}
+
+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);
+}
+
+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;
+}
+
+
+#
+# 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: #