# # TeXLive::TLPOBJ.pm # module for using tlpobj files # Copyright 2007 Norbert Preining # # This file is licensed under the GNU General Public Licence version 2 # or any later version package TeXLive::TLPOBJ; use TeXLive::TLUtils; use File::Path; use Cwd; use TeXLive::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 tlpobj 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) { &TeXLive::TLUtils::debug("reading line: >>>$line<<<\n"); &TeXLive::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 tlpobj 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 tlpobj!\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 (defined($1) && ("$1" eq "continued")) { $self->{'longdesc'} .= " $2"; } else { $self->{'longdesc'} = "$2"; } $lastcmd = "longdesc"; next; } elsif ($line =~ /^category\s+(Scheme|Collection|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_revision { my ($self,$tltree) = @_; my @files; foreach my $a (keys %{$self->{'binfiles'}}) { push @files, @{$self->{'binfiles'}{$a}}; } push @files, $self->runfiles; push @files, $self->docfiles; push @files, $self->srcfiles; $filemax = 0; foreach my $f (@files) { $filemax = $tltree->file_svn_lastrevision($f); $self->revision(($filemax > $self->revision) ? $filemax : $self->revision); } } 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 = "$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 = TeXLive::TLPOBJ->zipdir; } die("Undefined tltree argument!") if (not(defined($tltree))); # first build the arch independet part $self->_make_zip($tltree,$destdir,$zipname,"all"); # now the $pkg.$arch.zip if ($self->is_arch_dependent) { foreach my $t (keys %{$self->{'binfiles'}}) { &TeXLive::TLUtils::debug("arch=$t\n"); if ($zipname =~ /^(.*)\.zip$/) { $zipn = "$1.$t.zip"; } else { $zipn = "$zipname.$t.zip"; } $self->_make_zip($tltree,$destdir,$zipn,$t); } } } sub _make_zip { my ($self,$tltree,$destdir,$zipname,$arch) = @_; my $root = $tltree->svnroot; my @files = (); my $zipcmd; if ($arch ne "all") { push @files, @{$self->{'binfiles'}{$arch}}; } else { push @files, $self->runfiles; push @files, $self->docfiles; push @files, $self->srcfiles; } # 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 = TeXLive::TLUtils::sort_uniq(@files); if (!@files) { &TeXLive::TLUtils::debug("Not creating empty zip file $zipname\n"); return; } my $cwd = &getcwd; if ("$destdir" !~ m@^/@) { # we have an relative zipdir, so we have to make it absolute $destdir = "$cwd/$destdir"; } &mkpath("$destdir") if (! -d "$destdir"); chdir($tltree->svnroot); if ($arch eq "all") { # we add the .tlpobj into the .tlpobj directory my $removetlpobjdir = 0; if (! -d ".tlpobj") { &mkpath(".tlpobj"); $removetlpobjdir = 1; } open(TMP,">.tlpobj/$self->{'name'}.tlpobj") or die "Cannot create .tlpobj/$self->{'name'}.tlpobj"; $self->writeout(\*TMP); close(TMP); push @files, ".tlpobj/$self->{'name'}.tlpobj"; } 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; if ($arch eq "all") { # cleaning up unlink(".tlpobj/$self->{'name'}.tlpobj"); rmdir(".tlpobj") if $removetlpobjdir; } print "Done $zipname\n" if ($::opt_debug); } sub is_arch_dependent { my $self = shift; if (keys %{$self->{'binfiles'}}) { return 1; } else { return 0; } } # computes the total size of a package # if no arguments are given this is # docsize + runsize + srcsize + max of binsize sub total_size { my ($self,@archs) = @_; my $ret = $self->docsize + $self->runsize + $self->srcsize; if ($self->is_arch_dependent) { my $max = 0; my %foo = %{$self->binsize}; foreach my $k (keys %foo) { $max = $foo{$k} if ($foo{$k} > $max); } $ret += $max; } return($ret); } # # 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'} = shift } return ( defined($self->{'srcsize'}) ? $self->{'srcsize'} : 0 ); } sub add_srcfiles { my ($self,@files) = @_; $self->add_files("src",@files); } sub remove_srcfiles { my ($self,@files) = @_; $self->remove_files("src",@files); } sub docfiles { my $self = shift; if (@_) { @{ $self->{'docfiles'} } = @_ } return @{ $self->{'docfiles'} }; } sub docsize { my $self = shift; if (@_) { $self->{'docsize'} = shift } return ( defined($self->{'docsize'}) ? $self->{'docsize'} : 0 ); } sub add_docfiles { my ($self,@files) = @_; $self->add_files("doc",@files); } sub remove_docfiles { my ($self,@files) = @_; $self->remove_files("doc",@files); } sub binfiles { my $self = shift; my %newfiles = @_; if (@_) { $self->{'binfiles'} = \%newfiles } return $self->{'binfiles'}; } sub binsize { my $self = shift; my %newsizes = @_; if (@_) { $self->{'binsize'} = \%newsizes } return $self->{'binsize'}; } sub add_binfiles { my ($self,$arch,@files) = @_; &TeXLive::TLUtils::push_uniq(\@{ $self->{'binfiles'}{$arch} }, @files); } sub remove_binfiles { my ($self,$arch,@files) = @_; my @finalfiles; foreach my $f (@{$self->{'binfiles'}{$arch}}) { if (not(&TeXLive::TLUtils::member($f,@files))) { push @finalfiles,$f; } } $self->{'binfiles'}{$arch} = [ @finalfiles ]; } sub runfiles { my $self = shift; if (@_) { @{ $self->{'runfiles'} } = @_ } return @{ $self->{'runfiles'} }; } sub runsize { my $self = shift; if (@_) { $self->{'runsize'} = shift } return ( defined($self->{'runsize'}) ? $self->{'runsize'} : 0 ); } sub add_runfiles { my ($self,@files) = @_; $self->add_files("run",@files); } sub remove_runfiles { my ($self,@files) = @_; $self->remove_files("run",@files); } sub add_files { my ($self,$type,@files) = @_; die("Cannot use add_files for binfiles, we need that arch!") if ($type eq "bin"); &TeXLive::TLUtils::push_uniq(\@{ $self->{"${type}files"} }, @files); } sub remove_files { my ($self,$type,@files) = @_; die("Cannot use add_files for binfiles, we need that arch!") if ($type eq "bin"); my @finalfiles; foreach my $f (@{$self->{"${type}files"}}) { if (not(&TeXLive::TLUtils::member($f,@files))) { push @finalfiles,$f; } } $self->{"${type}files"} = [ @finalfiles ]; } 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 = longdesc ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~ $_tmp . ### Local Variables: ### perl-indent-level: 2 ### tab-width: 2 ### indent-tabs-mode: nil ### End: # vim:set tabstop=2: #