path: root/new-infra/TLTREE.pm

#
# 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;

use 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 = TLUtils::basename($entry);
			my $dn = 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;
	&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";
	}
	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 = TLUtils::dirname($globline);
	my $basepart = 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) {
		&TLUtils::debug("matching $f in $dirpart via glob $globline\n");
		if ($f =~ /^$basepart$/) {
			&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$/) {
			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);
				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}}) {
		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);
			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: #