path: root/new-infra/TLP.pm

#
# TLP.pm
# module for using tlp files
# Copyright 2007 Norbert Preining
#
# This file is licensed under the GNU General Public Licence version 2
# or any later version

package TLP;

use TLUtils;
use File::Path;
use Cwd;
use TLTREE;
use FileHandle;

my $_tmp;
my $_zipdir;

sub new { 
	my $class = shift;
	my %params = @_;
	my $self = {
		name        => $params{'name'},
		category    => defined($params{'category'}) ? $params{'category'} : "Package",
		shortdesc   => $params{'shortdesc'},
		longdesc    => $params{'longdesc'},
		catalogue   => $params{'catalogue'},
		runfiles    => defined($params{'runfiles'}) ? $params{'runfiles'} : [],
		runsize		=> $params{'runsize'},
		srcfiles    => defined($params{'srcfiles'}) ? $params{'srcfiles'} : [],
		srcsize		=> $params{'srcsize'},
		docfiles    => defined($params{'docfiles'}) ? $params{'docfiles'} : [],
		docsize		=> $params{'docsize'},
		executes    => defined($params{'executes'}) ? $params{'executes'} : [],
		# note that binfiles is an ARRAY with keys of $arch!
		binfiles    => defined($params{'binfiles'}) ? $params{'binfiles'} : {},
		binsize     => defined($params{'binsize'}) ? $params{'binsize'} : {},
		depends     => defined($params{'depends'}) ? $params{'depends'} : [],
		revision    => $params{'revision'},
	};
	$_zipdir = $params{'zipdir'} if defined($params{'zipdir'});
	bless $self, $class;
	return $self;
}

sub from_file {
	my $self = shift;
	if (@_ != 1) {
		die("Need a filename for initialization!");
	}
	open(TMP,"<$_[0]") || die("Cannot open tlp file: $_[0]");
	$self->from_fh(\*TMP);
}
	
sub from_fh {
	my ($self,$fh,$multi) = @_;
	my $started = 0;
	my $lastcmd = "";
	my $arch;
	my $size;

	while (my $line = $fh->getline) {
		&TLUtils::debug("reading line: >>>$line<<<\n");
		&TLUtils::debug("multi=...$multi...\n");
		$line =~ /^\s*#/ && next;          # skip comment lines
		if ($line =~ /^\s*$/) {
			if (!$started) { next; }
			if (defined($multi)) {
				# we may read from a tldb file
				return 1;
			} else {
				# we are reading one tldb file, nothing else allowed
				die("No empty line allowed within tlp files!");
			}
		}
		if ($line =~ /^ /) {
			if ( ($lastcmd eq "longdesc") ||
			     ($lastcmd eq "runfiles")  ||
			     ($lastcmd eq "binfiles")  ||
			     ($lastcmd eq "docfiles")  ||
			     ($lastcmd eq "srcfiles")  ||
			     ($lastcmd eq "executes")  ||
				 ($lastcmd eq "depend") ) {
				$line =~ s/^ /${lastcmd}continued /;
			} else {
				die("Continuation of $lastcmd not allowed, please fix tlp!\n");
			}
		}
		if ($line =~ /^name\s*([-\w]+)$/) {
			$name = "$1";
			$lastcmd = "name";
			$self->name("$name");
			$started && die("Cannot have two name directives: $line!");
			$started = 1;
		} else {
			$started || die("First directive needs to be 'name'");
			if ($line =~ /^shortdesc\s+(.*)$/) {
				$self->{'shortdesc'} .= "$1";
				$lastcmd = "shortdesc";
				next;
			} elsif ($line =~ /^longdesc(continued)?\s+(.*)$/) {
				if ("$1" eq "continued") {
					$self->{'longdesc'} .= " ";
				}
				$self->{'longdesc'} .= "$2";
				$lastcmd = "longdesc";
				next;
			} elsif ($line =~ /^category\s+(Package|TLCore|Documentation)$/) {
				$self->{'category'} = "$1";
				$lastcmd = "category";
				next;
			} elsif ($line =~ /^revision\s+(.*)$/) {
				$self->{'revision'} = "$1";
				$lastcmd = "revision";
				next;
			} elsif ($line =~ /^catalogue\s+(.*)$/) {
				$self->catalogue("$1");
				$lastcmd = "catalogue";
				next;
			} elsif ($line =~ /^(doc|src|run)files\s+/) {
				my $type = $1;
				my @words = split ' ',$line;
				# first entry is "XXXfiles", shift it away
				$lastcmd = shift @words;
				while (@words) {
					$_ = shift @words;
					if (/^size=(.*)$/) {
						$size=$1;
					} else {
						die "Unknown tag: $line";
					}
				}
				if (defined($size)) {
					$self->{"${type}size"} = $size;
				}
				next;
			} elsif ($line =~ /^(doc|src|run)filescontinued\s+(.*)$/) {
				push @{$self->{$1."files"}}, "$2";
				next;
			} elsif ($line =~ /^binfiles\s+/) {
				my @words = split ' ',$line;
				# first entry is "binfiles", shift it away
				shift @words;
				while (@words) {
					$_ = shift @words;
					if (/^arch=(.*)$/) {
						$arch=$1;
					} elsif (/^size=(.*)$/) {
						$size=$1;
					} else {
						die "Unknown tag: $line";
					}
				}
				if (defined($size)) {
					$self->{'binsize'}{$arch} = $size;
				}
				$lastcmd = "binfiles";
				next;
			} elsif ($line =~ /^binfilescontinued\s+(.*)$/) {
				push @{$self->{'binfiles'}{$arch}}, "$1";
				next;
			} elsif ($line =~ /^execute(continued)?\s*(.*)$/) {
				push @{$self->{'executes'}}, "$2" unless "$2" eq "";
				$lastcmd = "execute";
				next;
			} elsif ($line =~ /^depend(continued)?\s*(.*)$/) {
				push @{$self->{'depends'}}, "$2" unless "$2" eq "";
				$lastcmd = "depend";
				next;
			} else {
				die("Unknown directive ...$line... , please fix it!");
			}
		}
	}
	return $started;
}

sub recompute_sizes {
	my ($self,$tltree) = @_;
	$self->{'docsize'} = $self->_recompute_size("doc",$tltree);
	$self->{'srcsize'} = $self->_recompute_size("src",$tltree);
	$self->{'runsize'} = $self->_recompute_size("run",$tltree);
	foreach $a ($tltree->architectures) {
		$self->{'binsize'}{$a} = $self->_recompute_size("bin",$tltree,$a);
	}
}


sub _recompute_size {
	my ($self,$type,$tltree,$arch) = @_;
	my $size = 0;
	if ($type eq "bin") {
		my %binfiles = %{$self->{'binfiles'}};
		if (defined($binfiles{$arch})) {
			foreach $f (@{$binfiles{$arch}}) {
				$size += $tltree->size_of($f);
			}
		} 
	} else {
		if (defined($self->{"${type}files"}) && (@{$self->{"${type}files"}})) {
			foreach $f (@{$self->{"${type}files"}}) {
				my $s = $tltree->size_of($f);
				if (defined($s)) {
					$size += $s;
				} else {
					printf STDERR "size for $f not defined, strange ...\n";
				}
			}
		}
	}
	return $size;
}

sub writeout {
	my $self = shift;
	my $fd = (@_ ? $_[0] : STDOUT);
	format_name $fd "multilineformat";
	print $fd "name ", $self->name, "\n";
	print $fd "category ", $self->category, "\n";
	defined($self->{'revision'}) && print $fd "revision $self->{'revision'}\n";
	defined($self->{'catalogue'}) && print $fd "catalogue $self->{'catalogue'}\n";
	defined($self->{'shortdesc'}) && print $fd "shortdesc $self->{'shortdesc'}\n";
	if (defined($self->{'longdesc'})) {
		$_tmp = "longdesc $self->{'longdesc'}";
		write $fd;
	}
	if (defined($self->{'depends'})) {
		foreach (@{$self->{'depends'}}) {
			print $fd "depend $_\n";
		}
	}
	if (defined($self->{'executes'})) {
		foreach (@{$self->{'executes'}}) {
			print $fd "execute $_\n";
		}
	}
	if (defined($self->{'docfiles'}) && (@{$self->{'docfiles'}})) {
		print $fd "docfiles size=$self->{'docsize'}\n";
		foreach (sort @{$self->{'docfiles'}}) {
			print $fd " $_\n";
		}
	}
	if (defined($self->{'srcfiles'}) && (@{$self->{'srcfiles'}})) {
		print $fd "srcfiles size=$self->{'srcsize'}\n";
		foreach (sort @{$self->{'srcfiles'}}) {
			print $fd " $_\n";
		}
	}
	if (defined($self->{'runfiles'}) && (@{$self->{'runfiles'}})) {
		print $fd "runfiles size=$self->{'runsize'}\n";
		foreach (sort @{$self->{'runfiles'}}) {
			print $fd " $_\n";
		}
	}
	foreach my $arch (keys %{$self->{'binfiles'}}) {
		if (@{$self->{'binfiles'}{$arch}}) {
			print $fd "binfiles arch=$arch size=", $self->{'binsize'}{$arch}, "\n";
			foreach (sort @{$self->{'binfiles'}{$arch}}) {
				print $fd " $_\n";
			}
		}
	}
}

sub writeout_simple {
	my $self = shift;
	my $fd = (@_ ? $_[0] : STDOUT);
	format_name $fd "multilineformat";
	print $fd "name ", $self->name, "\n";
	print $fd "category ", $self->category, "\n";
	if (defined($self->{'depends'})) {
		foreach (@{$self->{'depends'}}) {
			print $fd "depend $_\n";
		}
	}
	if (defined($self->{'executes'})) {
		foreach (@{$self->{'executes'}}) {
			print $fd "execute $_\n";
		}
	}
	if (defined($self->{'docfiles'}) && (@{$self->{'docfiles'}})) {
		print $fd "docfiles\n";
		foreach (sort @{$self->{'docfiles'}}) {
			print $fd " $_\n";
		}
	}
	if (defined($self->{'srcfiles'}) && (@{$self->{'srcfiles'}})) {
		print $fd "srcfiles\n";
		foreach (sort @{$self->{'srcfiles'}}) {
			print $fd " $_\n";
		}
	}
	if (defined($self->{'runfiles'}) && (@{$self->{'runfiles'}})) {
		print $fd "runfiles\n";
		foreach (sort @{$self->{'runfiles'}}) {
			print $fd " $_\n";
		}
	}
	foreach my $arch (sort keys %{$self->{'binfiles'}}) {
		if (@{$self->{'binfiles'}{$arch}}) {
			print $fd "binfiles arch=$arch\n";
			foreach (sort @{$self->{'binfiles'}{$arch}}) {
				print $fd " $_\n";
			}
		}
	}
}


sub make_zip {
	my ($self,$tltree,$destdir,$zipname) = @_;
	my $zipn;
	if (not(defined($zipname))) {
		$zipname = $self->name . ".zip";
	}
	if (not(defined($destdir))) {
		$destdir = TLP->zipdir;
	}
	die("Undefined tltree argument!") if (not(defined($tltree)));
	if ($self->is_arch_dependent) {
		foreach my $t ($tltree->architectures) {
			if (defined($self->{'binfiles'}{$t})) {
				&TLUtils::debug("arch=$t\n");
				if ($zipname =~ /^(.*)\.zip$/) {
					$zipn = "$1-$t.zip";
				} else {
					$zipn = "$zipname-$t.zip";
				}
				$self->_make_zip($tltree,$destdir,$zipn,$t);
			}
		}
	} else {
		$self->_make_zip($tltree,$destdir,$zipname,"all");
	}
}

sub _make_zip {
	my ($self,$tltree,$destdir,$zipname,$arch) = @_;
	my $root = $tltree->svnroot;
	my @files = ();
	my $zipcmd;
	push @files, $self->runfiles;
	push @files, $self->docfiles;
	push @files, $self->srcfiles;
	if ($arch ne "all") {
		push @files, @{$self->{'binfiles'}{$arch}};
	}
	# note that the Tpm.pm module had something like
	# 	if ($zipname =~ /\/binary/ && $^O !~ /MSWin32/) {
	# 		$zipcmd = "| zip -9\@ory "
	# 	} else {
	# 		$zipcmd = "| zip -9\@or "
	# 	}
	if ($^O =~ /MSWin32/) {
		$nul = "nul";
		$zipcmd = "| zip -9\@or "
	} else {
		$nul = "/dev/null";
		$zipcmd = "| zip -9\@ory "
	}
	@files = TLUtils::sort_uniq(@files);
	if (!@files) {
		&TLUtils::debug("Not creating empty zip file $zipname\n");
		return;
	}
	&mkpath("$destdir") if (! -d "$destdir");
	my $cwd = &getcwd;
	chdir($tltree->svnroot);
	unlink($zipname);
	print $zipcmd . "$destdir/$zipname" . " > $nul\n" if ($::opt_debug);
	open ZIP, $zipcmd . "$destdir/$zipname" . " > $nul";
	map {
		if (! -f $_) {
			print STDERR "!!!Error: non-existent $_\n";
		} else {
			print ZIP "$_\n";
		}
	} @files;
	close ZIP;
	print "Done $zipname\n" if ($::opt_debug);
}

sub is_arch_dependent {
	my $self = shift;
	if (keys %{$self->{'binfiles'}}) {
		return 1;
	} else {
		return 0;
	}
}

#
# member access functions
#
sub name {
	my $self = shift;
	if (@_) { $self->{'name'} = shift }
	return $self->{'name'};
}
sub category {
	my $self = shift;
	if (@_) { $self->{'category'} = shift }
	return $self->{'category'};
}
sub shortdesc {
	my $self = shift;
	if (@_) { $self->{'shortdesc'} = shift }
	return $self->{'shortdesc'};
}
sub longdesc {
	my $self = shift;
	if (@_) { $self->{'longdesc'} = shift }
	return $self->{'longdesc'};
}
sub revision {
	my $self = shift;
	if (@_) { $self->{'revision'} = shift }
	return $self->{'revision'};
}
sub catalogue {
	my $self = shift;
	if (@_) { $self->{'catalogue'} = shift }
	return $self->{'catalogue'};
}
sub srcfiles {
	my $self = shift;
	if (@_) { @{ $self->{'srcfiles'} } = @_ }
	return @{ $self->{'srcfiles'} };
}
sub srcsize {
	my $self = shift;
	if (@_) { @{ $self->{'srcsize'} } = @_ }
	return @{ $self->{'srcsize'} };
}
sub add_srcfiles {
	my ($self,@files) = @_;
	push @{ $self->{'srcfiles'} }, @files;
}
sub docfiles {
	my $self = shift;
	if (@_) { @{ $self->{'docfiles'} } = @_ }
	return @{ $self->{'docfiles'} };
}
sub docsize {
	my $self = shift;
	if (@_) { @{ $self->{'docsize'} } = @_ }
	return @{ $self->{'docsize'} };
}
sub add_docfiles {
	my ($self,@files) = @_;
	push @{ $self->{'docfiles'} }, @files;
}
sub binfiles {
	my $self = shift;
	my %newfiles = @_;
	if (@_) { $self->{'binfiles'} = \%newfiles }
	return $self->{'binfiles'};
}
sub binsizes {
	my $self = shift;
	my %newsizes = @_;
	if (@_) { $self->{'binsizes'} = \%newsizes }
	return $self->{'binsizes'};
}
sub add_binfiles {
	my ($self,$arch,@files) = @_;
	push @{ $self->{'binfiles'}{$arch} }, @files;
}
sub runfiles {
	my $self = shift;
	if (@_) { @{ $self->{'runfiles'} } = @_ }
	return @{ $self->{'runfiles'} };
}
sub runsize {
	my $self = shift;
	if (@_) { @{ $self->{'runsize'} } = @_ }
	return @{ $self->{'runsize'} };
}
sub add_runfiles {
	my ($self,@files) = @_;
	&TLUtils::push_uniq(\@{ $self->{'runfiles'} }, @files);
}
sub add_files {
	my ($self,$type,@files) = @_;
	die("Cannot use add_files for binfiles, we need that arch!") if ($type eq "bin");
	&TLUtils::push_uniq(\@{ $self->{"${type}files"} }, @files);
}
sub depends {
	my $self = shift;
	if (@_) { @{ $self->{'depends'} } = @_ }
	return @{ $self->{'depends'} };
}
sub executes {
	my $self = shift;
	if (@_) { @{ $self->{'executes'} } = @_ }
	return @{ $self->{'executes'} };
}

sub zipdir {
	my @self = shift;
	if (@_) { $_zipdir = $_[0] }
	return $_zipdir;
}

1;



###### Formats
format multilineformat =
^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$_tmp
 ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
$_tmp
.

### Local Variables:
### perl-indent-level: 4
### tab-width: 4
### indent-tabs-mode: t
### End:
# vim:set tabstop=4: #