diff options
Diffstat (limited to 'Build/tools/Tpm.pm')
-rw-r--r-- | Build/tools/Tpm.pm | 1874 |
1 files changed, 0 insertions, 1874 deletions
diff --git a/Build/tools/Tpm.pm b/Build/tools/Tpm.pm deleted file mode 100644 index 248b2d2fbca..00000000000 --- a/Build/tools/Tpm.pm +++ /dev/null @@ -1,1874 +0,0 @@ -# $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", - "hppa-hpux", - "i386-darwin", - "i386-freebsd", - "i386-linux", - "i386-openbsd", - "i386-solaris", - "mips-irix", - "powerpc-aix", - "powerpc-darwin", - "powerpc-linux", - "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", "xelatex", - "xmltex", "ytex", ); -# Kind of font files -my @fonttypes = ( - "afm", "misc", "ofm", "opentype", "ovf", "ovp", "pfb", - "pfm", "pk", "sfd", "source", "tfm", "truetype", "type1", "vf" - ); -# Font vendors -my @vendors = ( - "adobe", "amsfonts", "arabi", "archaic", "arphic", - "bakoma", "bh", "bitstrea", "bluesky", - "cg", "cns", "cspsfonts-adobe", "groff", - "hoekwater", "ibm", "itc", "jknappen", "jmn", "korean", "lh", - "mathdesign", "misc", "monotype", "paragrap", - "public", "uhc", "urw", "urw35vf", "vntex", "wadalab", - "xetex", "yandy"); -my @fontmodes = ( - "ljfour", "ljfive", "cx" - ); -my @languages = ("bulgarian", "chinese", "czechslovak", "dutch", "english", - "finnish", "french", "general", - "german", "greek", "italian", "japanese", "korean", - "mongolian", - "polish", "portuguese", "russian", "slovak", "spanish", - "thai", "turkish", "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; - -# -# %Tpm2Catalogue gives a mapping from tpm names to Catalogue entries -# -# missing entries -# ? bengali:pandey -# ? grotesq:urwvf -# ? helvetic:urwvf -# ? knuthotherfonts:halftone -# makedtx:makedtx not working! -# ? oberdiek:twoopt, tabularht, tabularkv, settobox, refcount, alphalph, chemar -# r, classlist, dvipscol, engord, hypbmsec, hypcap, ifdraft, ifpdf, ifvtexm pagese -# l, pdfcolmk pdfcrypt, pdflscape (somehing missing???) -my %Tpm2Catalogue = ( - "ctib" => "ctib4tex", - "CJK" => "cjk", - "bayer" => "universa", - "bigfoot" => "suffix", - "cb" => "cbgreek", - "cd-cover" => "cdcover", - "cmex" => "cmextra", - "cs" => "csfonts", - "cyrplain" => "t2", - "devanagr" => "devanagari", - "eCards" => "ecards", - "ESIEEcv" => "esieecv", - "euclide" => "pst-eucl", - "GuIT" => "guit", - "HA-prosper" => "prosper", - "ibycus" => "ibycus4", - "ibygrk" => "ibycus4", - "IEEEconf" => "ieeeconf", - "IEEEtran" => "ieeetran", - "iso" => "isostds", - "iso10303" => "isostds", - "jknapltx" => "jknappen", - "kastrup" => "binhex", - "le" => "frenchle", - "mathtime" => "mathtime-ltx", - "omega-devanagari" => "devanagari-omega", - "pdftexdef" => "pdftex-def", - "procIAGssymp" => "prociagssymp", - "resume" => "res", - "SIstyle" => "sistyle", - "SIunits" => "siunits", - "syntax" => "syntax2", - "Tabbing" => "tabbing" ); - -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("\ -<!DOCTYPE rdf:RDF SYSTEM \"../../support/tpm.dtd\">\ -<rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\" xmlns:TPM=\"http://texlive.dante.de/\">\ - <rdf:Description about=\"http://texlive.dante.de/texlive/tlcore/${name}.zip\">\ - <TPM:Name>${name}</TPM:Name>\ - <TPM:Type>${type}</TPM:Type>\ - <TPM:Date>1970/01/01 01:00:00</TPM:Date>\ - <TPM:Version></TPM:Version>\ - <TPM:Creator>$user</TPM:Creator>\ - <TPM:Author></TPM:Author>\ - <TPM:Title>The ${name} package.</TPM:Title>\ - <TPM:Size>314</TPM:Size>\ - <TPM:Description></TPM:Description>\ - <TPM:Build>\ - <TPM:RunPatterns>${texmf}/tpm/${name}.tpm</TPM:RunPatterns>\ - </TPM:Build>\ - <TPM:RunFiles size=\"270\">${texmf}/tpm/${name}.tpm</TPM:RunFiles>\ - <TPM:Provides>${type}/${name}</TPM:Provides>\ - </rdf:Description>\ -</rdf:RDF>\ -"); - $self->initialize($type, $name, $doc); - return $self; -} - -sub toRDF { - my ($self) = @_; - my $parser = new XML::DOM::Parser; - - $doc = $parser->parse("<!DOCTYPE rdf:RDF\n\ - SYSTEM \"../../support/tpm.dtd\">\n\ -<rdf:RDF xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns\#\"\n\ - xmlns:TPM=\"http://texlive.dante.de/\">\n</rdf:RDF>\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", "License") { - 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., -# <TPM:Execute function="addMap" mode="mixed" parameter="cm-super-t1.map"/> -# <TPM:Execute function="addMap" mode="mixed" parameter="cm-super-x2.map"/> -# 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-)//; - - # handle several cases where the Catalogue name - # is not the package name... - if (defined($Tpm2Catalogue{$pkgname})) { - $pkgcat = $Tpm2Catalogue{$pkgname}; - } else { - $pkgcat = $pkgname; - }print STDERR "Looking for $pkgname (as $pkgcat) in the Catalogue.\n" if $Verbose; - my $fletter = substr($pkgcat, 0, 1); - my $catname = "${CatalogueDir}/entries/$fletter/${pkgcat}.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")); - my $old_license = &trim($self->getAttribute("License")); - - 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"; - } - if ($license && ($license ne $old_license)) { - $self->setAttribute("License", $license); - print "Replacing $old_license by $license\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 context doc, since everything belongs to context.tpm. - } elsif (${name} eq 'context') { - push (@doc_patterns, "$texmf/doc/context/*"); - - # Exception for metapost ! - } elsif (${name} eq 'metapost') { - push @run_patterns, $texmf . "/metapost/support/*"; - - # Exception for tex4ht, since we just want everything. - } elsif (${name} eq 'tex4ht') { - push @run_patterns, - ("$texmf/tex4ht/bin/*", - "$texmf/tex4ht/ht-fonts/*", - "$texmf/tex4ht/xttl/*", - ); - - # 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}/*" - unless ($_ eq 'tex' || $_ eq 'omega') - } @engines; - - map { - push @run_patterns, $texmf . "/tex/$_/${name}/*"; - } @formats; - - # for xetex - push @run_patterns, "$texmf/fonts/misc/$name/*"; - push @doc_patterns, ( $texmf . "/doc/$name/*" ) if $name eq "xetex"; - - push @doc_patterns, ( $texmf . "/doc/${name}/base/*" ); - - push @source_patterns, ( $texmf . "/source/${name}/base/*" ); - - # exception for texinfo since it has no subdirs. - if (${name} eq 'texinfo') { - push @run_patterns, $texmf . "/tex/texinfo/*"; - - # exception for eplain since it has no subdirs either. - } elsif (${name} eq 'eplain') { - push @run_patterns, "$texmf/tex/eplain/*"; - push @doc_patterns, "$texmf/doc/eplain/*"; - push @source_patterns, "$texmf/source/eplain/*"; - - # 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}/*"; - - if ($name eq "groff") { - # Exception for groff: we do not want subdirectories (e.g., - # times), we only want actual files (psyrgo.tfm). Let groff/times - # end up in times.tpm. - map { push @run_patterns, "$texmf/fonts/$_/${name}/*.*"; } - @fonttypes; - } else { - # Everything but groff: - map { push @run_patterns, "$texmf/fonts/$_/${name}/*"; } - @fonttypes; - } - - map { - my $e = $_; - map { - push @run_patterns, $texmf . "/$e/$_/${name}/*" - # keep fontinst/misc in fontinst: - unless ($name eq "misc" && $_ eq "fontinst"); - } @formats; - } @engines; - - # 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}/*" - # keep tex/context/pgf in context. - unless $name eq "pgf" && $_ eq "context" && $e eq "tex"; - } @formats; - #warn "run_patterns after engine $e = @run_patterns\n"; - } @engines; - - map { - push @run_patterns, $texmf . "/tex/$_/${name}/*" - # keep tex/context/pgf in context. - unless $name eq "pgf" && $_ eq "context"; - #warn "run_patterns after format $_ = @run_patterns\n"; - - 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}/*"; - - # Exceptions for fontname and glyphlist: their own odd map files. - if ($name eq 'fontname') { - push @run_patterns, "$texmf/fonts/map/${name}/*"; - } elsif ($name eq 'glyphlist') { - push @run_patterns, "$texmf/fonts/map/${name}/*"; - } - } - - # common to all. - 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"; - - #warn "final run_patterns for $name: @run_patterns\n"; - $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; |