# $Id$
# Written 2004, Fabrice Popineau.
# Public domain.
#
package Tpm;
BEGIN {
# $Exporter::Verbose = 1;
use Exporter ();
use Carp;
use XML::DOM;
use File::Path;
use FileUtils;
use Cwd;
@ISA = qw( Exporter );
@EXPORT_OK = qw (
new
$MasterDir
%TexmfTreeOfType %TypeOfTexmfTree
$FtpDir $CurrentArch
@TpmCategories
@TexmfTrees
@ArchList
@StandAlonePackages
$IgnoredFiles
&toRDF &toString
&setAttribute &getAttribute
&setList &getList
&setHash &getHash
&patternsExpand
&patternsUpdate
&buildPatternsPackage
&buildPatternsDocumentation
&getPatterns
&fixDate
&fixRequires
&patternsAuto
&completeUsingCatalogue
&getAllFileList
&getRequiredFileList
&getRequiredTpm
&getFilesFromPatterns
&writeFile
&testSync
&Tpm2Zip
&Clean
&Remove
$Verbose
);
use vars (@ISA);
}
$MasterDir = "c:/Source/TeXLive/Master";
$ZipDir = "c:/InetPub/ftp/fptex/0.7";
$CurrentArch = "all";
$Editor = ($^O =~ m/win32/i ? "notepad": "vi");
#print "$MasterDir $CurrentArch\n";
%TexmfTreeOfType = ( "TLCore" => "texmf",
"Documentation" => "texmf-doc",
"Package" => "texmf-dist");
%TypeOfTexmfTree = &reverse_hash(%TexmfTreeOfType);
@TpmCategories = keys %TexmfTreeOfType;
@TexmfTrees = values %TexmfTreeOfType;
# must match subdir names in Master/bin/ directory.
@ArchList = (
"alpha-linux",
"alpha-osf",
"i386-darwin",
"i386-freebsd",
"i386-linux",
"mips-irix",
"powerpc-aix",
"powerpc-darwin",
"sparc-solaris",
"sparc-linux",
"win32",
"win32-static",
"x86_64-linux"
);
@StandAlonePackages = (
"TLCore/bin-afm2pl",
"TLCore/bin-aleph",
"TLCore/bin-dvipdfm",
"TLCore/bin-dvipdfmx",
"TLCore/bin-dvipsk",
"TLCore/bin-gsftopk",
"TLCore/bin-lcdftypetools",
"TLCore/bin-omega",
"TLCore/bin-pdftex",
"TLCore/bin-metapost",
"TLCore/bin-t1utils",
"TLCore/bin-tex4htk",
"TLCore/bin-windvi"
);
# this list is not up to date, therefore I think it is not needed.
# . "bin/i386-freebsd|bin/i386-openbsd|bin/i386-solaris|bin/mips-irix"
# . "|bin/powerpc-aix|bin/powerpc-darwin|bin/sparc-solaris"
# used both to ignore whole tpm's (?) and individual files?
# must match whole path
$IgnoredFiles = "("
. 'source/.*'
. '|texmf/tpm/(collection-binaries|texlive|xemtex|scheme-.*|.*-static)\.tpm'
. '|texmf(-doc|-dist)?/(ls-R|aliases|lists/.*|README|tpm/tpm.dtd)'
. '|.*/\.svn.*'
. ")";
# The so-called engines
my @engines = ("aleph", "enctex", "eomega", "metafont", "metapost", "omega", "pdftex", "pdfetex", "tex", "vtex",
"bibtex", "context", "dvipdfm", "dvips", "ispell",
"makeindex","mft", "psutils", "tex4ht", "texdoctk",
"ttf2pk");
# The so called formats
my @formats = (
"alatex", "amstex", "context", "cslatex", "csplain", "enctex",
"eplain", "fontinst", "generic", "jadetex", "lambda",
"latex", "latex3",
"mex", "physe", "phyzzx", "plain", "psizzl",
"startex", "texinfo", "texsis", "xetex", "xmltex", "ytex", );
# Kind of font files
my @fonttypes = (
"afm", "misc", "ofm", "opentype", "ovf", "ovp", "pfb",
"pk", "sfd", "source", "tfm", "truetype", "type1", "vf"
);
# Font vendors
my @vendors = (
"adobe", "amsfonts", "archaic", "arphic",
"bakoma", "bh", "bitstrea", "bluesky",
"cg", ,"cns", "cspsfonts-adobe",
"hoekwater", "ibm", "itc", "jknappen", "jmn", "korean", "lh",
"mathdesign", "misc", "monotype", "paragrap",
"public", "uhc", "urw", "urw35vf", "vntex", "wadalab",
"yandy");
my @fontmodes = (
"ljfour", "ljfive", "cx"
);
my @languages = ("bulgarian", "czechslovak", "dutch", "english",
"finnish", "french", "general",
"german", "greek", "italian", "japanese", "korean",
"mongolian",
"polish", "portuguese", "russian", "slovak", "spanish",
"thai", "ukrainian", "vietnamese");
my %dotfiles = (
"texmf-dist/tex/latex/tools/*" => ( "texmf-dist/tex/latex/tools/.tex" ),
"texmf/chktex/*" => ( "texmf/chktex/.chktexrc" )
);
my $CatalogueDir = "${MasterDir}/texmf-doc/doc/english/catalogue";
my $Catalogue;
my $Verbose = 0;
sub reverse_hash {
{
my (%direct) = @_;
my %reversed;
my ($key, $value);
foreach $key (keys %direct) {
$reversed{$direct{$key}} = $key;
}
return %reversed;
}
}
#----------------------------------------------------------------------
# Helper functions
sub getTextField {
my ($doc, $f) = @_;
my $nodelist = $doc->getElementsByTagName("TPM:$f");
my %s = ( );
return %s if ($nodelist->getLength <= 0);
my $node = $nodelist->item(0);
return %s if (! $node);
foreach my $k (@{$node->getAttributes->getValues}) {
$k = $k->getName;
$s{$k} = $node->getAttribute($k);
}
$node = $node->getFirstChild();
return %s if (! $node);
my $str = $node->toString;
$str = $node->expandEntityRefs($str);
$s{"text"} = $str;
return %s;
}
sub getListField {
my ($doc, $f) = @_;
my %s = getTextField($doc, $f);
my $str = $s{"text"};
$str =~ s/^\n*//;
$str =~ s/\n*$//;
$str =~ s/\n/ /gomsx;
@{$s{"text"}} = split(" ", $str);
return %s;
}
sub getMultipleTextField {
my ($doc, $f) = @_;
my $nodelist = $doc->getElementsByTagName("TPM:$f");
my @stringlist = ( );
for (my $i = 0; $i < $nodelist->getLength; $i++) {
my $node = $nodelist->item($i);
my %s = ( );
foreach my $k (@{$node->getAttributes->getValues}) {
$k = $k->getName;
$s{$k} = $node->getAttribute($k);
}
$node = $node->getFirstChild();
if ($node) {
my $text = $node->toString;
$text =~ s/\n/ /gomsx;
push @{$s{"text"}}, split(" ", $text);
}
push @stringlist, \%s;
}
return @stringlist;
}
sub getAttributes {
my ($doc, $f) = @_;
my $nodelist = $doc->getElementsByTagName("TPM:$f");
my %attr = ( );
return %attr if ($nodelist->getLength <= 0);
my $node = $nodelist->item(0);
foreach my $k (@{$node->getAttributes->getValues}) {
$k = $k->getName;
$attr{$k} = $node->getAttribute($k);
}
return %attr;
}
#----------------------------------------------------------------------
sub new {
my $type = shift;
my ($filename) = @_;
my $self = { };
bless $self, $type;
if ($filename) {
$filename =~ s@\\@/@g;
$filename .= ".tpm" if ($filename !~ m@\.tpm$@);
if (! &FileUtils::is_absolute($filename)) {
$filename = "${Tpm::MasterDir}/${filename}";
}
if (! -f $filename) {
$filename =~ m@^.*/(.*)/(.*)$@;
if (&FileUtils::member($1, @TpmCategories)) {
$filename = "${Tpm::MasterDir}/" . $TexmfTreeOfType{$1} . "/tpm/$2";
}
}
die (`pwd` . "$filename not found!\n") if (! -f $filename);
my $parser = new XML::DOM::Parser;
$doc = $parser->parsefile($filename);
my ($type, $name);
$filename =~ m@^(.*/|)([^/]+)[/\\]tpm[/\\]([^/\.]+)\.tpm$@;
$type = $TypeOfTexmfTree{$2}; $name = $3;
$self->initialize($type,$name,$doc);
}
return $self;
}
sub initialize {
my ($self, $type, $name, $doc) = @_;
my $parser = new XML::DOM::Parser;
my $text;
my @list;
my %field;
%field = &getTextField($doc, "Name");
$text = $field{"text"};
if ($text ne $name) {
print "Warning: $filename has wrong Name attribute ($text should be $name) ... fixing it.\n";
}
$self->setAttribute("Name", $name);
%field = &getTextField($doc, "Type");
$text = $field{"text"};
if ($text ne $type) {
print "Warning: $filename has wrong Type attribute ($text should be $type) ... fixing it.\n";
}
$self->setAttribute("Type", $type);
for my $tag ("Date", "Version", "Creator", "Size", "Author", "Title", "Description", "Provides") {
%field = &getTextField($doc, "$tag");
$text = $field{"text"};
$self->setAttribute("$tag", $text);
}
$text = $self->getAttribute("Provides");
if ("$type/$name" ne $text) {
print "Warning: $filename has wrong Provides attribute ($text should be $type/$name) ... fixing it.\n";
}
$self->setAttribute("Provides", "$type/$name");
%field = &getAttributes($doc, "Flags");
$self->setHash("Flags", %field);
# map { print "$_ = $field{$_}\n"; } (keys %field);
for my $tag ("BinPatterns", "RunPatterns", "DocPatterns", "SourcePatterns", "RemotePatterns") {
%field = &getListField($doc, "$tag");
@list = @{$field{"text"}};
$self->setList("$tag", @list);
}
# FIXME ! several architectures !
@list = &getMultipleTextField($doc, "BinFiles");
$self->setList("BinFiles", @list);
for my $tag ("RunFiles", "DocFiles", "SourceFiles", "RemoteFiles") {
%field = &getListField($doc, "$tag");
$self->setHash("$tag", %field);
}
my %requires = ();
for my $tag (@TpmCategories) {
my $nodelist = $doc->getElementsByTagName("TPM:$tag");
for (my $i = 0; $i < $nodelist->getLength; $i = $i+1) {
my $package = $nodelist->item($i)->getAttribute("name");
push @{$requires{$tag}}, $package;
}
}
$self->setHash("Requires",%requires);
# Installation instructions
my @instructions = ();
$nodelist = $doc->getElementsByTagName("TPM:Installation");
if ($nodelist->getLength > 0) {
my $executelist = $doc->getElementsByTagName("TPM:Execute");
for (my $i = 0; $i < $executelist->getLength; $i++) {
my $inst = $executelist->item($i);
my %execute = ();
foreach my $attr (@{$inst->getAttributes->getValues}) {
$attr = $attr->getName;
$execute{$attr} = $inst->getAttribute($attr);
}
push @instructions, \%execute;
}
}
$self->setList("Installation", @instructions);
}
#
# Create a fresh package of $name and $type
#
sub fresh {
my $type = shift;
my $self = { };
bless $self, $type;
my ($provides) = @_;
my $name;
$provides =~ m@^([^/]+)[/\\]([^/\.]+)$@;
$type = $1; $name = $2;
my $texmf = $TexmfTreeOfType{$type};
print "Creating new $type $name tpm file\n";
my $parser = new XML::DOM::Parser;
chomp (my $user = `whoami`); # for Creator field.
my $doc = $parser->parse("\
\
\
\
${name}\
${type}\
1970/01/01 01:00:00\
\
$user\
\
The ${name} package.\
314\
\
\
${texmf}/tpm/${name}.tpm\
\
${texmf}/tpm/${name}.tpm\
${type}/${name}\
\
\
");
$self->initialize($type, $name, $doc);
return $self;
}
sub toRDF {
my ($self) = @_;
my $parser = new XML::DOM::Parser;
$doc = $parser->parse("\n\
\n\n");
my ($node, $child, $father, $nodelist, %attr);
# Add an 'about' field
my $tpmdesc = $doc->createElement("rdf:Description");
my $name = $self->getAttribute("Name");
my $type = $self->getAttribute("Type");
if ($name) {
# Add an about node
$node = $doc->createAttribute("about", "http://texlive.dante.de/texlive/" . $type . "/" . $name . ".zip");
# my $tpmhref = $doc->createAttribute("href", $href);
$tpmdesc->setAttributeNode($node);
# $tpmdesc->setAttributeNode($tpmhref);
}
else {
warn " toRDF(), no Name found!\n" if (! $name);
}
for my $tag ("Name", "Type", "Date", "Version", "Creator", "Title",
"Description", "Author", "Size") {
my $attribute = $self->getAttribute("$tag");
# None of these are optional
$node = $doc->createElement("TPM:$tag");
$child = $doc->createTextNode($attribute);
$node->appendChild($child);
$tpmdesc->appendChild($node);
warn " toRDF($name), no $tag found\n" if ! $attribute && $::opt_warnings;
}
# Flags are optional
$node = $doc->createElement("TPM:Flags");
%attr = $self->getHash("Flags");
if (%attr) {
foreach $key (keys %attr) {
$child = $doc->createAttribute($key, ${attr}{$key});
$node->setAttributeNode($child);
}
# Only if there are attributes
$tpmdesc->appendChild($node);
}
# Globbed expressions
$father = $doc->createElement("TPM:Build");
for my $tag ("BinPatterns", "RunPatterns", "DocPatterns", "SourcePatterns", "RemotePatterns") {
$node = $doc->createElement("TPM:$tag");
$text = $self->getList("$tag");
if ($text ne "" && $text !~ m/^[\s\n]+$/sx) {
$child = $doc->createTextNode($text);
$node->appendChild($child);
$father->appendChild($node);
}
}
$tpmdesc->appendChild($father);
# End of globbed expressions
my @binfiles = $self->getList("BinFiles");
if (@binfiles) {
for (my $i = 0; $i <= $#binfiles; $i++) {
$node = $doc->createElement("TPM:BinFiles");
my %archbin = %{$binfiles[$i]};
my $tpmattr = $doc->createAttribute("arch", $archbin{"arch"});
$node->setAttributeNode($tpmattr);
$tpmattr = $doc->createAttribute("size", $archbin{"size"});
$node->setAttributeNode($tpmattr);
my @files = @{$archbin{"text"}};
if (@files) {
my $strfiles = (join "\n", @files) . "\n";
$child = $doc->createTextNode($strfiles);
$node->appendChild($child);
$tpmdesc->appendChild($node);
}
}
}
for my $tag ("RunFiles", "DocFiles", "SourceFiles", "RemoteFiles") {
$node = $doc->createElement("TPM:$tag");
%field = $self->getHash("$tag");
if (%field) {
my $tpmattr = $doc->createAttribute("size", $field{"size"});
$node->setAttributeNode($tpmattr);
my @files = @{$field{"text"}};
if (@files) {
my $strfiles = (join "\n", @files) . "\n";
$child = $doc->createTextNode($strfiles);
$node->appendChild($child);
$tpmdesc->appendChild($node);
}
}
}
$node = $doc->createElement("TPM:Requires");
my %requires = $self->getHash("Requires");
if (%requires) {
foreach my $k (sort @TpmCategories) {
my @taglist = @{$requires{$k}};
for my $tag (sort @taglist) {
my $tpmbin = $doc->createElement("TPM:$k");
my $a = $doc->createAttribute("name", $tag);
$tpmbin->setAttributeNode($a);
$node->appendChild($tpmbin);
}
}
$tpmdesc->appendChild($node);
}
$node = $doc->createElement("TPM:Installation");
my @installation = $self->getList("Installation");
if (@installation) {
for(my $i = 0 ; $i <= $#installation; $i++) {
my $tpmexec = $doc->createElement("TPM:Execute");
my %execute = %{$installation[$i]};
my $attr = $doc->createAttribute("function", $execute{"function"});
$tpmexec->setAttributeNode($attr);
print " kfunc = $execute{function}\n" if ($::opt_debug);
foreach my $kparam (sort keys %execute) {
print " kparam = $kparam\n" if $::opt_debug;
if ($kparam ne "function") {
$attr = $doc->createAttribute($kparam, $execute{$kparam});
$tpmexec->setAttributeNode($attr);
}
}
$node->appendChild($tpmexec);
}
$tpmdesc->appendChild($node);
}
$node = $doc->createElement("TPM:Provides");
$text = $self->getAttribute("Provides");
$text = $name if (! $text);
if ($text) {
$child = $doc->createTextNode($text);
$node->appendChild($child);
$tpmdesc->appendChild($node);
}
# Set the fragment
$doc->getElementsByTagName("rdf:RDF")->item(0)->appendChild($tpmdesc);
return $doc;
}
sub toString {
my ($self) = @_;
return $self->toRDF()->toString();
}
sub writeFile {
my ($self, $name) = @_;
if (! $name) {
$name = "${MasterDir}/" . $TexmfTreeOfType{$self->getAttribute("Type")} . "/tpm/" . $self->getAttribute("Name") . ".tpm";
}
open (OUT, ">$name") || die "open(>$name) failed: $!";
# rewrite them without ^M
binmode(OUT) if ($^O =~ /MSWin32/);
print OUT $self->toString();
close (OUT) || warn "close(>$name) failed: $!";
}
sub setAttribute {
my ($self, $n, $v) = @_;
$self->{$n} = $v;
}
sub getAttribute {
my ($self, $n) = @_;
return ($self->{$n});
}
sub setList {
my ($self, $n, @v) = @_;
@{$self->{$n}} = @v;
}
sub getFileList {
my ($self, $n) = @_;
my @l = ();
if ($n eq "BinFiles") {
foreach $v (@{$self->{$n}}) {
if (($CurrentArch eq "all" && FileUtils::member(${$v}{"arch"}, @Tpm::ArchList))
|| ${$v}{"arch"} eq ${CurrentArch}) {
my @val = @{${$v}{"text"}};
#print "getfilelist pushing for $v: @val\n";
push @l, @val;
}
}
}
elsif ($n =~ /^(Run|Doc|Source|Remote)Files$/) {
my %v = %{$self->{$n}};
@l = @{$v{"text"}};
}
else {
@l = @{$self->{$n}};
}
if (wantarray) {
#print "getfilelist($n) returning list: @l\n";
#&debug_hash ($n, $self->{$n});
#print "$n {text} = " . @{$n{text}} . "\n";
return @l;
}
else {
#print "getfilelist($n) returning scalar: @l\n";
if (@l) {
return (join "\n", @l);
}
else {
return "";
}
}
}
# Need to test forcycles !
sub getRequiredFileList {
my ($self, $n) = @_;
my @l = ();
# print "name = " . $self->getAttribute('Name') . "\n";
if ($n eq 'all') {
push @l, $self->getAllFileList();
}
else {
push @l, $self->getFileList($n);
}
my %requires = $self->getHash("Requires");
my @reqlist = ();
foreach my $k (keys %requires) {
foreach my $e (@{$requires{$k}}) {
push @reqlist, ${Tpm::TexmfTreeOfType}{$k} . "/tpm/$e.tpm";
}
}
map {
my $tpm = Tpm->new($_);
push @l, $tpm->getRequiredFileList($n);
} @reqlist;
return @l;
}
sub getRequiredTpm {
my ($self, $recursive) = @_;
my %requires = $self->getHash("Requires");
my @reqlist = ();
foreach my $k (keys %requires) {
foreach my $e (@{$requires{$k}}) {
push @reqlist, "$k/$e";
}
}
my @l = ();
if ($recursive) {
while (@reqlist) {
my $tpmname = pop @reqlist;
&FileUtils::push_uniq(\@l, $tpmname);
my $tpm = Tpm->new($tpmname);
print "tpmname = $tpmname\n";
%requires = $tpm->getHash("Requires");
foreach my $k (keys %requires) {
foreach my $e (@{$requires{$k}}) {
&FileUtils::push_uniq(\@reqlist, "$k/$e");
}
}
}
}
else {
@l = @reqlist;
}
print $self->getAttribute("Name") . " requires @l\n";
return @l;
}
sub getList {
my ($self, $n) = @_;
my @l = @{$self->{$n}};
if ($n eq "BinFiles") {
# the elements of BinFiles are hash references; we want to sort by
# the arch name, so the output will be stable.
@l = sort { $a->{"arch"} cmp $b->{"arch"} } @l;
} elsif ($n eq "Installation") {
# Need these alphabetically, too, e.g.,
@l = sort tpm_inst_sort @l;
} else {
@l = sort @l;
}
if (wantarray) {
return @l;
} elsif (@l) {
return (join "\n", @l);
} else {
return "";
}
}
# This function is used to sort the TPM:Installation elements for
# getList. Include both key names and values, e.g.,
#
#
# should be sorted in that order.
#
sub tpm_inst_sort
{
$astr = join (" ", map { $_ . "=" . $a->{$_} } keys %$a);
$bstr = join (" ", map { $_ . "=" . $b->{$_} } keys %$b);
return $astr cmp $bstr;
}
sub setHash {
my ($self, $n, %v) = @_;
%{$self->{$n}} = %v;
}
sub getHash {
my ($self, $n) = @_;
return %{$self->{$n}};
}
sub getPatterns {
my ($self, $recurse) = @_;
my @patterns = ();
warn "Doing " . $self->getAttribute("Name") . "\n";
my $type = $self->getAttribute("Type");
if ($type =~ m/tlcore/i) {
# already there
# push @patterns, $self->getList("RunPatterns");
# push @patterns, $self->getList("DocPatterns");
# push @patterns, $self->getList("SourcePatterns");
}
elsif ($type =~ m/package/i) {
$self->buildPatternsPackage();
# Add them
push @patterns, $self->getList("RunPatterns");
push @patterns, $self->getList("DocPatterns");
push @patterns, $self->getList("SourcePatterns");
$self->setList("RunPatterns", () );
$self->setList("DocPatterns", () );
$self->setList("SourcePatterns", () );
}
elsif ($type =~ m/documentation/i) {
$self->buildPatternsDocumentation();
push @patterns, $self->getList("RunPatterns");
push @patterns, $self->getList("DocPatterns");
push @patterns, $self->getList("SourcePatterns");
$self->setList("RunPatterns", () );
$self->setList("DocPatterns", () );
$self->setList("SourcePatterns", () );
}
if ($recurse) {
my %requires = $self->getHash("Requires");
my @reqlist = ();
foreach my $k (keys %requires) {
foreach my $e (@{$requires{$k}}) {
push @reqlist, ${Tpm::TexmfTreeOfType}{$k} . "/tpm/$e.tpm";
}
}
map {
print "testing $_\n";
if (&FileUtils::member("$_", @patterns)) {
print "Already done: $_\n";
}
else {
my $tpm = Tpm->new("${MasterDir}/$_");
push @patterns, $tpm->getPatterns($recurse);
}
} @reqlist;
}
return @patterns;
}
sub getFilesFromPatterns {
my ($self, $n, $recurse) = @_;
my @patterns = ();
if ($n eq "BinFiles") {
if ($CurrentArch eq "all") {
my @l = $self->getList("BinPatterns");
my @lgen = ();
my @lwin32 = ();
my @lothers = ();
while (@l) {
my $f = shift @l;
if ($f =~ m/\/\$\{ARCH\}\//) {
push @lgen, $f;
}
elsif ($f =~ m/\/win32(-static)?\//) {
push @lwin32, $f;
}
else {
push @lothers, $f;
}
}
foreach my $a (@ArchList) {
# Skip win32, since they are processed separately anyway
next if ($a =~ m/^win32(-static)?/);
my @l = @lgen;
map { $_ =~ s/\$\{ARCH\}/${a}/sxo } @l;
push @patterns, @l;
}
push @patterns, @lwin32;
push @patterns, @lothers;
}
elsif ($CurrentArch =~ m/win32/) {
my @l = grep { /\/${CurrentArch}\// } $self->getList("BinPatterns");
push @patterns, @l;
}
else {
push @patterns, (map {s/\$\{ARCH\}/$CurrentArch/ } $self->getList("BinPatterns"));
push @patterns, (grep { /\/${CurrentArch}\// } $self->getList("BinPatterns"));
}
}
else {
$n =~ s/Files/Patterns/;
my @files = $self->getList($n);
push @patterns, @files;
}
my @files = ();
if (@patterns) {
@files = ();
map {
push @files, $dotfiles{$_};
$_ = "$MasterDir/" . $_ ;
} @patterns;
for my $p (@patterns) {
push @files, &FileUtils::globexpand ($recurse, $p);
#print " files after $p: @files\n" if $::opt_debug;
}
map { $_ =~ s/^${MasterDir}\///; } @files;
@files = &FileUtils::sort_uniq(@files);
}
return @files;
}
sub patternsExpand {
my ($self, $recurse) = @_;
my (%v, $size);
my @allbinfiles = $self->getFilesFromPatterns("BinFiles", 0);
my @files = ();
my $file_number = $#allbinfiles + 1;
foreach my $a (@ArchList) {
my @archbinfiles = grep { /\/$a\// } @allbinfiles;
if (@archbinfiles) {
$size = &FileUtils::calc_file_size($MasterDir, @archbinfiles);
my %v = ( );
$v{"arch"} = $a;
$v{"size"} = $size;
push @{$v{"text"}}, @archbinfiles;
push @files, \%v;
}
}
$self->setList("BinFiles", @files);
#print "binfiles = @files\n";
for my $tag ("RunFiles", "DocFiles", "SourceFiles", "RemoteFiles") {
#print ($self->getAttribute("Name") . ", tag $tag\n") if $::opt_debug;
my %v = ( );
@files = $self->getFilesFromPatterns($tag, $recurse);
#print " files = @files\n" if $::opt_debug;
$file_number += $#files + 1;
$size = &FileUtils::calc_file_size($MasterDir, @files);
$v{"arch"} = $a;
$v{"size"} = $size;
@{$v{"text"}} = @files;
$self->setHash($tag, %v);
}
if ($file_number == 1) {
# No need to complain about the collection tpm's,
# they aren't intended to have files.
my $name = $self->getAttribute("Provides");
print "Package $name has no files !\n"
unless $name =~ m!/(collection-*|scheme-*|xemtex|texlive)!;
}
}
sub compress_bin {
my (@files) = @_;
my @result = ();
# Compute architectures list without win32
my @al = @ArchList;
@al = grep { $_ !~ m@win32(-static)?@ } @al;
# Process patterns one by one
while (@files) {
# First file in the list
my $f = $files[0];
# If it is a win32 file, nothing to do
if ($f =~ m@/win32(-static)?/@) {
push @result, $f;
shift @files;
next;
}
# Else, try to match an architecture in its path
my $re = $f;
my $a; # Keep the architecture that matched
for my $arch (@al) {
# Replace the architecture by a catch all pattern
if ($re =~ s@/(${arch})/@/[^\/]*/@x) {
$re = "^${re}\$";
$a = $1; last;
}
}
# Because of bg5+latex
$re =~ s/\+/\\\+/;
# Compute how many files in the list will match this pattern
my @match = grep {$_ =~ m@${re}@ } @files;
# If all the architectures are present, then do the replacement
if (@match == @al) {
@files = grep { $_ !~ m@${re}@ } @files;
$f =~ s@/${a}/@/\${ARCH}/@;
}
else {
shift @files;
}
push @result, $f;
}
return @result;
}
sub patternsUpdate {
my ($self) = @_;
my @patterns = &compress_bin(&FileUtils::regexpify(0, $MasterDir, $self->getFileList("BinFiles")));
$self->setList("BinPatterns", @patterns);
@patterns = &FileUtils::regexpify(0, $MasterDir, $self->getFileList("DocFiles"));
$self->setList("DocPatterns", @patterns);
@patterns = &FileUtils::regexpify(0, $MasterDir, $self->getFileList("RunFiles"));
$self->setList("RunPatterns", @patterns);
@patterns = &FileUtils::regexpify(0, $MasterDir, $self->getFileList("SourceFiles"));
$self->setList("SourcePatterns", @patterns);
@patterns = &FileUtils::regexpify(0, $MasterDir, $self->getFileList("RemoteFiles"));
$self->setList("RemotePatterns", @patterns);
}
sub testSync {
my ($self) = @_;
my @files_from_patterns = () ;
push @files_from_patterns, $self->getFilesFromPatterns("BinFiles");
push @files_from_patterns, $self->getFilesFromPatterns("RunFiles");
push @files_from_patterns, $self->getFilesFromPatterns("DocFiles");
push @files_from_patterns, $self->getFilesFromPatterns("SourceFiles");
push @files_from_patterns, $self->getFilesFromPatterns("RemoteFiles");
my @files = ();
push @files, $self->getFileList("BinFiles");
push @files, $self->getFileList("RunFiles");
push @files, $self->getFileList("DocFiles");
push @files, $self->getFileList("SourceFiles");
push @files, $self->getFileList("RemoteFiles");
my @l1 = ();
my @l2 = ();
&FileUtils::diff_list(@files_from_patterns, @files, \@l1, \@l2);
if ($#l1 < 0 && $#l2 < 0) {
return 1;
}
else {
print $self->getAttribute("Name") . ": patterns and file lists not in sync\n";
print "Files in patterns not in lists :\n";
map { print "$_\n"; } @l1;
print "Files in lists not in patterns :\n";
map { print "$_\n"; } @l2;
return 0;
}
}
sub formatdate {
return sprintf("%4d/%02d/%02d %02d:%02d:%02d",
$_[5]+1900, $_[4]+1, $_[3], $_[2], $_[1], $_[0]);
}
sub printdate {
my ($strDate) = @_;
my @mytime;
my ($s, $strTime);
($strDate, $strTime) = split " ", $strDate;
# print "strDate = $strDate; strTime = $strTime\n";
if ($strDate =~ m@(\d\d\d\d|\d\d)/(\d\d)/(\d\d)@) {
$mytime[5] = eval $1;
$mytime[4] = eval $2;
$mytime[3] = eval $3;
if ($strTime =~ m@(\d\d):(\d\d):(\d\d)@) {
$mytime[2] = eval $1;
$mytime[1] = eval $2;
$mytime[0] = eval $3;
}
$mytime[5] -= 1900 if ($mytime[5] > 1900);
$mytime[4] -= 1;
}
else {
@mytime = gmtime;
}
return &formatdate(@mytime);
}
sub debug_date
{
my ($str,$date) = @_;
#warn "$str " . &formatdate(gmtime($date)) . "\n";
}
# if any of FILES are newer than OLDDATE, return the newest mtime.
#
sub max_date
{
my ($olddate, @files) = @_;
my $tpmdate = 0;
&debug_date (" max_date files=@files, olddate=", $olddate);
for my $f (@files) {
# although the texmf/tpm/*.tpm files are mostly hand-maintained, it
# still seems best for the TPM:Date to reflect the newest date of
# the actual files in the package; the sizes and such might still
# get autoupdated.
if ($f =~ m,/tpm/.*\.tpm$,) {
$tpmdate = (stat("$MasterDir/$f"))[9];
&debug_date (" tpm itself, found ", $tpmdate);
}
elsif (-f "$MasterDir/$f") {
my @st = stat("$MasterDir/$f");
&debug_date (" file $f is ", $st[9]);
if ($st[9] > $olddate) {
&debug_date (" replacing olddate ", $olddate);
$olddate = $st[9];
}
}
}
if ($olddate == 0 && $tpmdate) {
&debug_date (" max_date using tpm date", $tpmdate);
$olddate = $tpmdate;
}
&debug_date (" max_date returning ", $olddate);
return $olddate;
}
sub fixDate {
my ($self) = @_;
my $newdate = 0;
my @binfiles = $self->getFileList("BinFiles");
#warn "binfiles=@binfiles";
if ($CurrentArch ne "all") {
@binfiles = grep { m@/${CurrentArch}/@ } @binfiles;
warn "arch-filtered for $CurrentArch binfiles=@binfiles";
}
$newdate = &max_date($newdate, @binfiles);
&debug_date (" newdate after bin: ", $newdate);
#
$newdate = &max_date($newdate, $self->getFileList("DocFiles"));
&debug_date (" newdate after doc: ", $newdate);
#
$newdate = &max_date($newdate, $self->getFileList("SourceFiles"));
&debug_date (" newdate after source: " , $newdate);
#
$newdate = &max_date($newdate, $self->getFileList("RemoteFiles"));
&debug_date (" newdate after remote: " , $newdate);
#
# Check the RunFiles last, because it includes the tpm itself, and we
# only want to use that as a last resort.
$rundate = &max_date($newdate, $self->getFileList("RunFiles"));
&debug_date (" newdate after run: ", $newdate);
$self->setAttribute("Date", &formatdate(gmtime($newdate)));
}
sub fixRequires {
my ($self, $test) = @_;
my %requires = $self->getHash("Requires");
if (%requires) {
foreach my $k (@TpmCategories) {
my @taglist = @{$requires{$k}};
my $texmf = $TexmfTreeOfType{$k};
my @newtaglist = ( );
for my $tag (@taglist) {
if (-f "${MasterDir}/${texmf}/tpm/${tag}.tpm") {
push @newtaglist, $tag;
}
elsif ($test == 0) {
print "Requirement ${MasterDir}/${texmf}/tpm/${tag}.tpm is not found.\n";
}
}
# @{$requires{$k}} = @newtaglist;
}
# if ($test >= 1) {
# $self->setHash("Requires",%requires);
# }
}
}
#
# This function will print every text node under given nodes
# and catenate the result.
#
sub myToText {
my (@nodes) = @_;
return
join '', ( map {
if ($_->isTextNode) {
my $s =$_->toString; chomp($s); $s;
}
else {
if ($_->hasChildNodes) {
myToText($_->getChildNodes) . " ";
}
else {
'';
}
}
} @nodes ) ;
}
sub trim {
my ($str) = @_;
$str =~ s/^[\n\s]+//;
$str =~ s/[\n\s]+$//;
return $str;
}
#
# Look into the Catalogue to find any supplementary information
# Get the license information, version and release numbers
#
sub completeUsingCatalogue {
my ($self) = @_;
my($author, $version, $license, $title, $description);
my $pkgname = $self->getAttribute("Name");
$pkgname =~ s/^(bin-|lib-|tex-)//;
# FIXME : we should handle several cases where the Catalogue name
# is not the package name...
print STDERR "Looking for $pkgname in the Catalogue.\n" if $Verbose;
my $fletter = substr($pkgname, 0, 1);
my $catname = "${CatalogueDir}/entries/$fletter/${pkgname}.xml";
return if (! -f $catname);
# print "catname = $catname\n";
my $parser = new XML::DOM::Parser;
my $catdoc = $parser->parsefile($catname);
my $nodelist = $catdoc->getElementsByTagName("author");
$author = '';
for (my $i = 0; $i < $nodelist->getLength; $i++) {
if ($nodelist->item($i)->getElementsByTagName("name")->item(0)->getFirstChild) {
$author .= ($i == 0 ? "" : " and ") . $nodelist->item($i)->getElementsByTagName("name")->item(0)->getFirstChild->toString;
}
}
# print "author = $author \n";
$nodelist = $catdoc->getElementsByTagName("version")->item(0);
if ($nodelist && $nodelist->getElementsByTagName("number")->item(0)) {
$version = $nodelist->getElementsByTagName("number")->item(0)->getFirstChild;
if ($version) {
$version = $version->toString;
# print "version = $version\n";
}
}
my $node = $catdoc->getElementsByTagName("license")->item(0);
if ($node) {
$license = $node->getAttribute("type");
}
$node = $catdoc->getElementsByTagName("caption")->item(0);
if ($node) {
$title = &trim($node->getFirstChild->toString);
}
$node = $catdoc->getElementsByTagName("description")->item(0);
if ($node) {
my $abstract = $node->getElementsByTagName("abstract")->item(0);
$node = $abstract if ($abstract);
$description = myToText( $node );
# $description = join '', (map { ($_->isTextNode ? $_->toString : '') } $node->getChildNodes);
$description = &trim($node->expandEntityRefs($description));
# print "description = |$description|\n";
}
my $old_author = &trim($self->getAttribute("Author"));
my $old_version = &trim($self->getAttribute("Version"));
my $old_title = &trim($self->getAttribute("Title"));
my $old_description = &trim($self->getAttribute("Description"));
if ($author && $author ne $old_author) {
$self->setAttribute("Author", $author);
print "Replacing $old_author by $author\n";
}
if ($version && $version ne $old_version) {
$self->setAttribute("Version", $version);
print "Replacing $old_version by $version\n";
}
if ($title && $title ne $old_title) {
$self->setAttribute("Title", $title);
print "Replacing $old_title by $title\n";
}
if ($description && ($description ne $old_description)) {
$self->setAttribute("Description", $description);
print "Replacing $old_description by $description\n";
}
}
sub buildPatternsPackage {
my ($self) = @_;
my $type = $self->getAttribute("Type");
return unless $type eq 'Package';
my $name = $self->getAttribute("Name");
my $texmf = $TexmfTreeOfType{$type};
# set run patterns
my @run_patterns = ( );
my @doc_patterns = ( );
my @source_patterns = ( );
# Usually the package name and the directory name match.
# Here are the special cases when they don't.
if (&FileUtils::member(${name}, @engines)) {
print "special engine patterns for $name\n" if $::opt_debug;
# If our $name is one of the engines
push @run_patterns, (
$texmf . "/${name}/base/*",
$texmf . "/${name}/data/*", # for context
$texmf . "/${name}/misc/*",
$texmf . "/${name}/config/*",
$texmf . "/metapost/${name}/*", # also for context
$texmf . "/tex/${name}/*"
);
push @doc_patterns, ( $texmf . "/doc/${name}/base/*" );
push @source_patterns, ( $texmf . "/source/${name}/base/*" );
# Shouldn't we chose between the previous patterns
# and these ones?
map {
push @run_patterns, $texmf . "/tex/$_/${name}/*";
push @doc_patterns, ( $texmf . "/doc/$_/${name}/*" );
push @source_patterns, ( $texmf . "/source/$_/${name}/*" );
} @formats;
# Exception for dvips and ttf2pk !
if (${name} eq 'dvips' || ${name} eq 'ttf2pk') {
push @run_patterns,
( $texmf . "/fonts/map/${name}/base/*", $texmf . "/fonts/map/${name}/config/*",
$texmf . "/fonts/enc/${name}/base/*", $texmf . "/fonts/enc/${name}/config/*" );
# Exception for metapost !
} elsif (${name} eq 'metapost') {
push @run_patterns, $texmf . "/metapost/support/*";
# Exception for tex4ht !
} elsif (${name} eq 'tex4ht') {
push @run_patterns, $texmf . "/tex4ht/ht-fonts/*";
# Exception for omega !
} elsif (${name} eq 'omega') {
push @run_patterns,
( $texmf . "/tex/generic/encodings/*",
$texmf . "/tex/generic/omegahyph/*",
$texmf . "/omega/otp/char2uni/*",
$texmf . "/omega/otp/uni2char/*",
$texmf . "/omega/ocp/char2uni/*",
$texmf . "/omega/ocp/uni2char/*" );
# Exception for vtex -- extra map files.
} if (${name} eq 'vtex') {
push @run_patterns, $texmf . "/fonts/map/${name}/*";
}
} elsif (&FileUtils::member(${name}, @formats)) {
print "special format patterns for $name\n" if $::opt_debug;
# if our $name is one of the formats
map {
my $e = $_;
push @run_patterns, ( $texmf . "/$e/${name}/base/*",
$texmf . "/$e/${name}/config/*",
);
push @run_patterns, $texmf . "/$e/${name}/*" if ($_ ne 'tex' && $_ ne 'omega');
} @engines;
map {
push @run_patterns, $texmf . "/tex/$_/${name}/*";
} @formats;
push @doc_patterns, ( $texmf . "/doc/${name}/base/*" );
push @source_patterns, ( $texmf . "/source/${name}/base/*" );
# Exception for Context !
if (${name} eq 'context') {
push @run_patterns, $texmf . "/tex/context/*";
# exception for texinfo since it has no subdirs.
} elsif (${name} eq 'texinfo') {
push @run_patterns, $texmf . "/tex/texinfo/*";
# Exception for fontinst, since it has lots of subdirs, including misc.
# cyrfinst is really a separate package, but let's not clean that up now.
} elsif (${name} eq 'fontinst') {
push @run_patterns, $texmf . "/tex/fontinst/*/*";
}
} elsif (&FileUtils::member(${name}, @vendors)) {
print "special vendor patterns for $name\n" if $::opt_debug;
push @run_patterns, $texmf . "/dvips/${name}/*";
map { push @run_patterns, $texmf . "/fonts/$_/${name}/*"; } @fonttypes;
map {
my $e = $_;
map {
push @run_patterns, $texmf . "/$e/$_/${name}/*"
unless $name eq "misc" && $_ eq "fontinst";
# keep fontinst/misc in fontinst.
} @formats;
} @engines;
# Exception for amsfonts -- te/staw decided in June 2005 to use ams
# for the directory name within fonts, but amsfonts elsehwere.
if (${name} eq 'amsfonts') {
push @run_patterns,
( $texmf . "/dvips/ams/config.*",
$texmf . "/fonts/map/*/ams/*",
$texmf . "/fonts/*/bluesky/ams/*",
$texmf . "/fonts/*/public/ams/*",
);
push @source_patterns,
( $texmf . "/source/latex/amsfonts/*" );
}
# Exception for lh: also have source/latex/lh.
push @source_patterns, ( $texmf . "/source/latex/$name/*" ); # lh
# Exception for mathdesign -- doc is in doc/latex instead of doc/fonts.
push @doc_patterns, ( $texmf . "/doc/latex/$name/*" ); # mathdesign
# Exception for vntex -- doc is in doc/generic instead of doc/fonts.
push @doc_patterns, ( $texmf . "/doc/generic/$name/*" ); # vntex
} else {
print "normal patterns for $name\n" if $::opt_debug;
map {
my $e = $_;
push @run_patterns, $texmf . "/$e/${name}/*";
push @doc_patterns, $texmf . "/doc/$e/${name}/*";
push @source_patterns, $texmf . "/source/$e/${name}/*";
map {
push @run_patterns, $texmf . "/$e/$_/${name}/*";
} @formats;
} @engines;
map {
push @run_patterns, $texmf . "/tex/$_/${name}/*";
push @doc_patterns, $texmf . "/doc/$_/${name}/*";
push @source_patterns, $texmf . "/source/$_/${name}/*";
} @formats;
push @doc_patterns, $texmf . "/doc/${name}/*";
push @source_patterns, $texmf . "/source/${name}/*";
# one more special case, fontname has its own odd map files.
if ($name eq 'fontname') {
push @run_patterns, $texmf . "/fonts/map/${name}/*";
}
}
map {
my $v = $_;
map {
push @run_patterns, $texmf . "/fonts/$_/$v/${name}/*";
} @fonttypes;
map {
push @run_patterns, $texmf . "/fonts/pk/$_/$v/${name}/*";
} @fontmodes;
} @vendors;
push @run_patterns, $texmf . "/scripts/${name}/*";
push @run_patterns, $texmf . "/dvips/${name}/*";
my $bibe = (${name} eq 'bibtex' ? 'base' : ${name});
push @run_patterns,
( $texmf . "/bibtex/bib/${bibe}/*",
$texmf . "/bibtex/bst/${bibe}/*",
$texmf . "/bibtex/csf/${bibe}/*" );
push @run_patterns,
( $texmf . "/fonts/map/dvips/${name}/*",
$texmf . "/fonts/map/dvipdfm/${name}/*",
$texmf . "/fonts/map/pdftex/${name}/*",
$texmf . "/fonts/map/ttf2pk/${name}/*",
$texmf . "/fonts/enc/dvips/${name}/*",
$texmf . "/fonts/enc/dvipdfm/${name}/*",
$texmf . "/fonts/enc/pdftex/${name}/*",
$texmf . "/fonts/enc/ttf2pk/${name}/*" );
push @run_patterns, "usergrps/$name/*";
push @doc_patterns, $texmf . "/doc/fonts/${name}/*";
push @run_patterns, $texmf . "/omega/ocp/${name}/*";
push @run_patterns, $texmf . "/omega/otp/${name}/*";
push @source_patterns, $texmf . "/source/fonts/${name}/*";
push @run_patterns, $texmf. "/tpm/$name.tpm";
$self->setList("RunPatterns", @run_patterns);
$self->setList("DocPatterns", @doc_patterns);
$self->setList("SourcePatterns", @source_patterns);
}
sub autoPatternsCore {
my ($self) = @_;
return if ($self->getAttribute("Type") ne 'TLCore');
my $type = $self->getAttribute("Type");
my $name = $self->getAttribute("Name");
my $texmf = $TexmfTreeOfType{$type};
}
sub buildPatternsDocumentation {
my ($self) = @_;
return if ($self->getAttribute("Type") ne 'Documentation');
my $type = $self->getAttribute("Type");
my $name = $self->getAttribute("Name");
my $texmf = $TexmfTreeOfType{$type};
# set run patterns
my @run_patterns = ( );
my @doc_patterns = ( );
my @source_patterns = ( );
map {
push @doc_patterns, $texmf . "/doc/$_/${name}/*";
push @source_patterns, $texmf . "/source/$_/${name}/*";
} @languages;
push @run_patterns, $texmf. "/tpm/$name.tpm";
$self->setList("RunPatterns", @run_patterns);
$self->setList("DocPatterns", @doc_patterns);
$self->setList("SourcePatterns", @source_patterns);
}
sub autoPatternsPackage {
my ($self) = @_;
# map { print "$_\n"; } @run_patterns;
# map { print "$_\n"; } @doc_patterns;
# map { print "$_\n"; } @source_patterns;
$self->buildPatternsPackage();
$self->patternsExpand(1);
$self->setList("RunPatterns", () );
$self->setList("DocPatterns", () );
$self->setList("SourcePatterns", () );
}
sub autoPatternsDocumentation {
my ($self) = @_;
$self->buildPatternsDocumentation();
$self->patternsExpand(1);
$self->setList("RunPatterns", () );
$self->setList("DocPatterns", () );
$self->setList("SourcePatterns", () );
}
sub patternsAuto {
my ($self) = @_;
my $type = $self->getAttribute("Type");
if ($type =~ m/tlcore/i) {
$self->autoPatternsCore();
}
elsif ($type =~ m/package/i) {
$self->autoPatternsPackage();
}
elsif ($type =~ m/documentation/i) {
$self->autoPatternsDocumentation();
}
}
#
# Get all files, optionnaly only for architecture $arch
#
sub getAllFileList {
my ($self, $arch) = @_;
my @files = ();
# print "Getting all file list for " . $self->getAttribute("Name") . "\n";
($arch = $CurrentArch) if (undef $arch);
push @files, $self->getFileList("BinFiles");
push @files, $self->getFileList("RunFiles");
push @files, $self->getFileList("DocFiles");
push @files, $self->getFileList("SourceFiles");
push @files, $self->getFileList("RemoteFiles");
return @files;
}
sub fixSize {
my ($self, $arch) = @_;
my $size = 0;
my @files = $self->getList("BinFiles");
foreach my $f (@files) {
$size += ${$f}{"size"};
}
foreach my $tag ("RunFiles", "DocFiles", "SourceFiles", "RemoteFiles") {
my %v = $self->getHash("$tag");
$size += $v{"size"};
}
if ($size != $self->getAttribute("Size")) {
my $name = $self->getAttribute("Name");
my $old_size = $self->getAttribute("Size");
print " $name\t size=$size\t old size=$old_size\t diff="
. ($size - $old_size) . "\n";
$self->setAttribute("Size", $size);
}
return $size;
}
sub Tpm2Zip {
my ($self, $destdir, $full, $standalone) = @_;
if (! $destdir) {
$destdir = $ZipDir;
}
my $name = $self->getAttribute("Name");
my $type = $self->getAttribute("Type");
my $version = $self->getAttribute("Version");
my @files = ();
if ($full eq "full") {
push @files, $self->getRequiredFileList("RunFiles");
push @files, $self->getRequiredFileList("DocFiles");
push @files, $self->getRequiredFileList("SourceFiles");
}
else {
push @files, $self->getFileList("RunFiles");
push @files, $self->getFileList("DocFiles");
push @files, $self->getFileList("SourceFiles");
}
my ($zipname, $tpmname, $zipcmd, $nul);
# Create zip files for all $arch if type = binary
# First, common files
if ($#files >=0) {
# if ($name =~ m/-static$/) {
if ($standalone && &FileUtils::member("$type/$name", @StandAlonePackages)) {
# static packages are expected to have more complete names
if ($full eq "full") {
push @files, $self->getRequiredFileList("BinFiles");
} else {
push @files, $self->getFileList("BinFiles");
}
$zipname = "$destdir/../standalone/$name";
$zipname .= "-${version}-${CurrentArch}.zip";
}
else {
$tpmname = "$destdir/$type/$name.tpm";
$zipname = "$destdir/$type/$name.zip";
}
if ($^O =~ /MSWin32/) {
$nul = "nul";
}
else {
$nul = "/dev/null";
}
@files = &FileUtils::sort_uniq(@files);
if ($zipname =~ /\/binary/ && $^O !~ /MSWin32/) {
$zipcmd = "| zip -9\@ory "
}
else {
$zipcmd = "| zip -9\@or "
}
&mkpath(&FileUtils::dirname($zipname)) if (! -d &FileUtils::dirname($zipname));
my $cwd = &getcwd;
chdir($MasterDir);
unlink $zipname;
print $zipcmd . $zipname . " > $nul\n" if ($::opt_debug);
open ZIP, $zipcmd . $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);
}
if (! $standalone) {
# Binaries
my $DoCurrentArch = ${CurrentArch};
foreach my $arch (@{ArchList}) {
if (${DoCurrentArch} eq "all" || ${DoCurrentArch} eq ${arch}) {
${CurrentArch} = $arch;
my @binfiles;
if ($full eq "full") {
@binfiles = $self->getRequiredFileList("BinFiles");
}
else {
@binfiles = $self->getFileList("BinFiles");
}
$zipname = "$destdir/$type/$name-$arch.zip";
if ($#binfiles >=0) {
&mkpath(&FileUtils::dirname($zipname)) if (! -d &FileUtils::dirname($zipname));
my $cwd = &getcwd;
chdir($MasterDir);
unlink $zipname;
print $zipcmd . $zipname . " > $nul\n" if ($::opt_debug);
open ZIP, $zipcmd . $zipname . " > $nul";
map {
if (! -f $_) {
print STDERR "!!!Error: non-existent $_\n";
} else {
print ZIP "$_\n";
}
} @binfiles;
close ZIP;
print "Done $zipname\n" if ($::opt_debug);
}
}
}
${CurrentArch} = ${DoCurrentArch};
}
# Write the tpm file together with the zip file in the current scheme
$self->writeFile($tpmname) if ($tpmname);
chdir($cwd);
}
sub Clean {
my ($self, $patterns, $fixreq) = @_;
# Update the Date to the date of the latest file in the package
$self->fixDate();
# Find missing information in the Catalogue if possible
$self->completeUsingCatalogue();
# Compute the overall size
$self->fixSize();
# Fix the tpm file
my @run_patterns = $self->getList("RunPatterns");
# First remove all tpm file present in the package
#print "run_patterns before remove_list = @run_patterns\n";
&FileUtils::remove_list(\@run_patterns, "\.tpm\$");
#print "run_patterns after remove_list = @run_patterns\n";
# Second, add the right one
my $name = $self->getAttribute("Name");
my $type = $self->getAttribute("Type");
push @run_patterns, ${Tpm::TexmfTreeOfType}{$type} . "/tpm/$name.tpm";
$self->setList("RunPatterns", @run_patterns);
# Fix the Title
if (! $self->getAttribute("Title")) {
$self->setAttribute("Title", "The " . $self->getAttribute("Name") . " package.");
}
# Big step, get fiels from patterns.
if ($patterns eq 'auto') {
$self->patternsAuto();
} elsif ($patterns eq 'to') {
# Update patterns
$self->patternsUpdate();
} elsif ($patterns eq 'from') {
$self->patternsExpand(0);
}
# Fix Requires field
$self->fixRequires(undef $fixreq || $fixreq == 0 || $fixreq eq '' ? 0 : 1);
$self->setList("RunPatterns", &FileUtils::sort_uniq($self->getList("RunPatterns")));
$self->setList("DocPatterns", &FileUtils::sort_uniq($self->getList("DocPatterns")));
$self->setList("SourcePatterns", &FileUtils::sort_uniq($self->getList("SourcePatterns")));
# Alternatively you could expand patterns if for example you have just edited them
# See the 'process2_tpm' function below
# Test that patterns and files list are n sync
if ($self->testSync()) {
print "Writing $type/$name\n";
$self->writeFile();
}
else {
print "ERROR: out of sync between patterns and files in $tpmname (not written).\n";
}
}
sub Remove {
my ($self, $patterns, $dry) = @_;
my @run_patterns = $self->getList("RunPatterns");
# First remove all tpm file present in the package
# print "run_patterns = @run_patterns\n";
&FileUtils::remove_list(\@run_patterns, "\.tpm\$");
# print "run_patterns = @run_patterns\n";
# Second, add the right one
my $name = $self->getAttribute("Name");
my $type = $self->getAttribute("Type");
push @run_patterns, ${Tpm::TexmfTreeOfType}{$type} . "/tpm/$name.tpm";
$self->setList("RunPatterns", @run_patterns);
if ($patterns eq 'auto') {
$self->patternsAuto();
}
elsif ($patterns eq 'to') {
# Update patterns
$self->patternsUpdate();
}
elsif ($patterns eq 'from') {
$self->patternsExpand(0);
}
$self->setList("RunPatterns", &FileUtils::sort_uniq($self->getList("RunPatterns")));
$self->setList("DocPatterns", &FileUtils::sort_uniq($self->getList("DocPatterns")));
$self->setList("SourcePatterns", &FileUtils::sort_uniq($self->getList("SourcePatterns")));
map {
my $file = "${MasterDir}/$_";
if ($dry) {
print "would unlink $file\n";
} else {
unlink($file) || warn "unlink($file) failed: $!";
print "unlinked $file\n";
}
} $self->getAllFileList();
}
# Log LABEL followed by hash elements, all on one line.
#
sub debug_hash
{
my ($label) = shift;
my (%hash) = (ref $_[0] && $_[0] =~ /.*HASH.*/) ? %{$_[0]} : @_;
my $str = "$label: {";
my @items = ();
for my $key (sort keys %hash) {
my $val = $hash{$key};
$key =~ s/\n/\\n/g;
$val =~ s/\n/\\n/g;
push (@items, "$key:$val");
}
$str .= join (",", @items);
$str .= "}";
print "$str\n";
}
1;