summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xBuild/tools/Check20
-rw-r--r--Build/tools/FileUtils.pm991
-rwxr-xr-xBuild/tools/MakeImages.sh220
-rw-r--r--Build/tools/README83
-rwxr-xr-xBuild/tools/RunTPM9
-rw-r--r--Build/tools/Strict.pm1
-rw-r--r--Build/tools/Tpm.pm1754
-rw-r--r--Build/tools/XML/DOM.pm5185
-rw-r--r--Build/tools/XML/DOM/DOMException.pm88
-rw-r--r--Build/tools/XML/DOM/NamedNodeMap.pm271
-rw-r--r--Build/tools/XML/DOM/NodeList.pm46
-rw-r--r--Build/tools/XML/DOM/PerlSAX.pm47
-rw-r--r--Build/tools/XML/Handler/BuildDOM.pm338
-rw-r--r--Build/tools/check111
-rw-r--r--Build/tools/collection2list.xsl92
-rwxr-xr-xBuild/tools/ctan2tl124
-rw-r--r--Build/tools/global-replace.pl149
-rwxr-xr-xBuild/tools/htmltext23
-rwxr-xr-xBuild/tools/mkdocindex165
-rwxr-xr-xBuild/tools/p4changelog89
-rw-r--r--Build/tools/scheme2list.xsl83
-rwxr-xr-xBuild/tools/tlrebuild126
-rwxr-xr-xBuild/tools/tpm-by-size16
-rwxr-xr-xBuild/tools/tpm-check36
-rwxr-xr-xBuild/tools/tpm-ctan-check289
-rwxr-xr-xBuild/tools/tpm-delete33
-rwxr-xr-xBuild/tools/tpm-factory.pl643
-rw-r--r--Build/tools/tpm.dtd74
-rw-r--r--Build/tools/tpm2binarytar.xsl55
-rw-r--r--Build/tools/tpm2list.xsl98
-rw-r--r--Build/tools/tpm2tar.xsl53
-rwxr-xr-xBuild/tools/tpmfromcat24
-rw-r--r--Build/tools/tpmfromcat.xsl81
-rwxr-xr-xBuild/tools/update-auto217
-rwxr-xr-xBuild/tools/update-lists44
-rwxr-xr-xBuild/tools/update-lsr22
-rwxr-xr-xBuild/tools/update-tpm40
-rw-r--r--Build/tools/update-tpm.bat24
-rw-r--r--Build/tools/updatetpm.xsl102
39 files changed, 11766 insertions, 0 deletions
diff --git a/Build/tools/Check b/Build/tools/Check
new file mode 100755
index 00000000000..a018592f5cb
--- /dev/null
+++ b/Build/tools/Check
@@ -0,0 +1,20 @@
+#!/bin/sh
+M=`cd \`dirname $0\`/.. && /bin/pwd`
+cd `dirname $0`
+perl tpm-factory.pl --master=$M --ftp_dir=/tmp --check=cov --arch=all --type=Package
+perl tpm-factory.pl --master=$M --ftp_dir=/tmp --check=cov --arch=all --type=Documentation
+perl tpm-factory.pl --master=$M --ftp_dir=/tmp --check=cov --arch=all --type=TLCore
+# will check coverage
+#
+# Checking dependencies:
+perl tpm-factory.pl --master=$M --ftp_dir=/tmp --check=dep --arch=all --type=Package
+perl tpm-factory.pl --master=$M --ftp_dir=/tmp --check=dep --arch=all --type=Documentation
+perl tpm-factory.pl --master=$M --ftp_dir=/tmp --check=dep --arch=all --type=TLCore
+# will check dependencies
+#
+# Checking duplicates:
+#perl tpm-factory.pl --master=$M --ftp_dir=/tmp --check=dup --arch=all --type=Package
+#perl tpm-factory.pl --master=$M --ftp_dir=/tmp --check=dup --arch=all --type=Documentation
+#perl tpm-factory.pl --master=$M --ftp_dir=/tmp --check=dup --arch=all --type=TLCore
+# will check duplicate file names
+
diff --git a/Build/tools/FileUtils.pm b/Build/tools/FileUtils.pm
new file mode 100644
index 00000000000..2b0bacd9c28
--- /dev/null
+++ b/Build/tools/FileUtils.pm
@@ -0,0 +1,991 @@
+# $Id$
+# Written 2004, Fabrice Popineau.
+# Public domain.
+#
+package FileUtils;
+
+BEGIN {
+ use Exporter ();
+ use Cwd;
+ use File::Path;
+ # use File::Copy qw(copy);
+ use vars qw( @ISA @EXPORT_OK);
+ if ($^O eq 'MSWin32')
+ { $Separator = "\\" ;}
+ else
+ { $Separator = "/" ;}
+
+ @ISA = qw(Exporter);
+
+ @EXPORT_OK = qw(
+ &basename
+ &build_path
+ &build_tree
+ &calc_file_size
+ &canon_dir
+ &check_path
+ &cleandir
+ &set_file_time
+ &copy
+ &diff_list
+ &dirname
+ &globexpand
+ &is_absolute
+ &is_dirsep
+ &look_for
+ &make_link
+ &member
+ &min max
+ &move
+ &newer
+ &newpath
+ &normalize
+ &print_tree
+ &push_uniq
+ &rec_copy
+ &rec_mkdir
+ &rec_rmdir
+ &regexpify
+ &remove_list
+ &sort_uniq
+ &start_redirection
+ &stop_redirection
+ &substitute_var_val
+ &sync_dir
+ &walk_dir
+ &walk_tree
+ );
+}
+
+# Is the character a directory separator ?
+sub is_dirsep {
+ my ($c) = @_;
+ if ($c =~ /[\/\\]/) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# Is the path absolute ?
+sub is_absolute {
+ my ($d) = @_;
+ if ($d =~ m@^([A-Za-z]:)?[/\\]@) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+# Rewrite '\\' into '/' and deletes multiple ones/
+sub canon_dir {
+ my ($p, $rep) = @_;
+ if ($p =~ m@^(.*)[/\\]$@) {
+ $p = $1;
+ }
+ if (($rep eq '') || ($rep eq '\\')) {
+ $p =~ s@/@\\@g;
+ $p =~ s@\\[\\]+@\\@g;
+ $p =~ s@\\\.\\@\\@g;
+ while ($p =~ m/\\\.\./) {
+ $p =~ s@\\([^\\]+)\\\.\.@\\@g;
+ $p =~ s@\\[\\]+@\\@g;
+ }
+ } elsif ($rep eq '/') {
+ $p =~ s@\\@/@g;
+ $p =~ s@/[/]+@/@g;
+ $p =~ s@/\./@/@g;
+ while ($p =~ m/\/\.\./) {
+ $p =~ s@/([^/]+)/\.\.@/@g;
+ $p =~ s@/[/]+@/@g;
+ }
+ } else {
+ die ("canon_dir($p) : invalid separator $rep.\n");
+ }
+ return $p;
+}
+
+# Merges all elements in the list into a single path, adding
+# directory separators as needed.
+sub build_path {
+ my($p, $s);
+ # Concatenates the arguments, adding path separators as needed
+ $p = $_[0];
+ for ($i = 1; $i <= $#_; $i++) {
+ $p = $p . $Separator . $_[$i];
+ }
+ return &canon_dir($p);
+}
+
+sub sort_uniq {
+ my (@l) = @_;
+ my ($e, $f, @r);
+ @l = sort(@l);
+ foreach $e (@l) {
+ if ($e ne $f) {
+ $f = $e;
+ push @r, $e;
+ }
+ }
+ return @r;
+}
+
+sub remove_list {
+ local (*l, $e) = @_;
+ my (@r, $f);
+ foreach $f (@l) {
+ if ($f !~ m/$e/) {
+ push @r, $f;
+ }
+ }
+ @l = @r;
+}
+
+sub member {
+ my ($e, @l) = @_;
+ my ($f);
+ foreach $f (@l) {
+ if ($e eq $f) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+sub push_uniq {
+ local (*l, @le) = @_;
+ my ($e);
+ foreach $e (@le) {
+ if (! &member($e, @l)) {
+ push @l, $e;
+ }
+ }
+}
+
+sub dirname {
+ my ($f) = @_;
+ $f =~ m@(^.*)[\\/][^\\/]*$@;
+ return $1;
+}
+
+sub basename {
+ my ($f) = @_;
+ $f =~ m@([^\\/]*)$@;
+ return $1;
+}
+
+sub normalize {
+ my ($p, $sep) = @_;
+ if ($sep eq '/') {
+ $p =~ s@\\@/@g;
+ $p =~ s@/(/|\./)*@/@g;
+ return $p;
+ } elsif ((! $sep) || ($sep eq '\\')) {
+ $p =~ s@/@\\@g;
+ $p =~ s@\\(\\|\.\\)*@\\@g;
+ return $p;
+ } else {
+ print STDERR "normalize : invalid separator, $sep\n";
+ return $p;
+ }
+}
+
+sub walk_dir {
+ # Walks the directory, executing $proc for each file,
+ # until done is returned.
+ my ($dir, $proc, $prune) = @_;
+ my (@l, $f, $done, $src, $DIR);
+
+ print " walking $dir with $proc, $prune\n" if $::opt_debug;
+
+ if ((! $prune) || ($prune && ! &{$prune}($dir))) {
+ $done = 0;
+ # Walk the directory tree
+ opendir (DIR, $dir) || die "opendir($dir) failed: $!";
+ while (my $d = readdir (DIR)) {
+ # do not forget to remove "." and ".."
+ next if $d =~ /^\.(\.?|svn)$/;
+ push (@l, $d);
+ }
+ closedir (DIR) || warn "closedir($dir) failed: $!";
+
+ # top-down
+ &{$proc}($dir, @l);
+
+ foreach $f (@l) {
+ my $try = $dir . $Separator . $f;
+ # Don't descend symlinks, since they are only used for generic
+ # architecture names in bin. The tpm files use the real arch
+ # directory names (with system version numbers).
+ if (-d $try && ! -l $try) {
+ &walk_dir($try, $proc, $prune);
+ }
+ }
+ }
+}
+
+# Builds up a tree from pathes
+# $node is a reference to a hash
+sub build_tree {
+ my (@elts) = @_;
+ my $node = { };
+ foreach my $p (@elts) {
+ &add_path_to_tree($node, split("[/\\\\]", $p));
+ }
+ return $node;
+}
+
+sub add_path_to_tree {
+ my ($node, @path) = @_;
+ my ($current);
+
+ while (@path) {
+ $current = shift @path;
+ if ($$node{$current}) {
+ $node = $$node{$current};
+ } else {
+ $$node{$current} = { };
+ $node = $$node{$current};
+ }
+ }
+ return $node;
+}
+
+# walks the tree, calling the function at each node
+sub walk_tree {
+ local (@stack_dir);
+ walk_tree1(@_);
+}
+
+sub walk_tree1 {
+ my ($node, $pre_proc, $post_proc) = @_;
+ for $k (keys(%{$node})) {
+ push @stack_dir, $k;
+ $v = $node->{$k};
+ if ($pre_proc) { &{$pre_proc}($v, @stack_dir) }
+ walk_tree1 (\%{$v}, $pre_proc, $post_proc);
+ $v = $node->{$k};
+ if ($post_proc) { &{$post_proc}($v, @stack_dir) }
+ pop @stack_dir;
+ }
+}
+
+sub print_node {
+ my ($node, @stackdir) = @_;
+ if (! keys(%{$node})) {
+ print join("/", @stackdir) . "\n";
+ }
+}
+
+sub print_tree {
+ my ($node) = @_;
+ &walk_tree($node, \&print_node);
+}
+
+sub node2list {
+ my ($node, @stackdir) = @_;
+ if (! keys(%{$node})) {
+ push @list, join("/", @stackdir);
+ }
+}
+
+sub tree2list {
+ my ($node) = @_;
+ local @list;
+ &walk_tree($node, \&node2list);
+ return @list;
+}
+
+# Check that a path exists in a tree
+# exactly or as a subpath
+sub check_path {
+ my ($node, @path, $exact) = @_;
+ my ($current);
+ # print "Checking for " . join('/', @path) . " exact = $exact\n";
+ while (@path) {
+ $current = shift @path;
+ if ($$node{$current} == undef) {
+ return 0;
+ } else {
+ $node = $$node{$current};
+ }
+ }
+ # print "left " . join('/', @path) . " leaf " . $#{keys %{$node}} . "\n";
+ if ($exact) {
+ # We are at a leaf !
+ return ($#{keys %{$node}} == -1);
+ } else {
+ return 1;
+ }
+}
+
+
+
+# Removes everything in the directory
+# Can't use walk_dir because it could not remove directories.
+sub cleandir {
+ my ($dir)= @_;
+ my ($DIR, $f, @l, $name);
+
+ if (-d $dir) {
+ opendir DIR, "$dir";
+ # do not forget to remove "." and ".."
+ @l = readdir (DIR); shift @l; shift @l;
+ closedir DIR;
+ foreach $f (@l) {
+ $name = $dir . $Separator . $f;
+ if (-d $name) {
+ &rmtree($name);
+ print "rmdir $name\n" if $opt_verbose;
+ rmdir "$name";
+ } elsif (-f "$name") {
+ print "Removing $name\n" if $opt_verbose;
+ unlink "$name";
+ } else {
+ print "Can't remove $name!\n";
+ }
+ }
+ }
+}
+
+sub rec_rmdir {
+ my (@files) = @_;
+ map { &cleandir($_); rmdir($_) } @files;
+}
+
+# Builds up a new directory together with any of its parents
+sub rec_mkdir {
+ my ($path) = @_;
+ my $tmp;
+ my $old_dir = &getcwd;
+ my @l = split ("[/\\\\]", $path);
+ if ($path =~ m@[/\\]@) {
+ chdir "/"; shift @l;
+ }
+ elsif ($l[0] =~ m/[A-Za-z]:/) {
+ chdir "$l[0]/";
+ shift @l;
+ }
+ while (@l) {
+ $tmp = shift(@l);
+ mkdir($tmp, 755) if (! -d $tmp);
+ print "mkdir $tmp\n";
+ chdir $tmp;
+ }
+ chdir $old_dir;
+}
+
+sub copy {
+ my (@src, $dest, $l, $t);
+ @l = @_;
+ $dest = pop @l;
+
+ @src = ();
+ if ($#l == 0 && -f $l[0]) {
+ @src = @l;
+ }
+ else {
+ map {
+ my @expand = ($_ =~ m/ / ? <"$_"> : <$_>);
+# print "expanding $_ => @expand\n";
+ push @src, @expand;
+ } @l;
+ }
+ my $target;
+ map {
+ if (! -d $_) {
+ open IN, "<$_";
+ $target = $dest;
+ if (-d $target) {
+ $target = &newpath($dest, &basename($_));
+ }
+ open OUT, ">$target";
+
+# print "Copying $_ to " . &newpath($dest, &basename($_)) . "\n";
+ binmode(IN);
+ binmode(OUT);
+ print OUT <IN>;
+ close(OUT);
+ close(IN);
+ &set_file_time($_, $target);
+ }
+ } @src;
+}
+
+sub set_file_time {
+ my ($from, $to) = @_;
+ @st = stat($from);
+ utime($st[8], $st[9], $to);
+}
+
+sub rec_copy {
+ my (@src, $dest, $l, $dir);
+ @l = @_;
+ $dest = pop @l;
+
+ @src = ();
+ map {
+ my @expand = ($_ =~ m/ / ? <"${_}"> : <${_}>);
+# print "expanding $_ => @expand\n";
+ push @src, @expand;
+ } @l;
+
+ if (! -d $dest) {
+ mkdir ($dest, 777);
+ }
+
+ $dir = &getcwd;
+ if (! is_absolute($dest) ) {
+ $dest = &canon_dir("$dir/$dest");
+ print "new dest = $dest\n";
+ }
+
+ map {
+ $l = $_;
+ if (-d $l) {
+ chdir($l);
+ &rec_copy("*", "$dest/" . &basename($l));
+ chdir($dir);
+ } else {
+ &copy($l, "$dest/" . &basename($l));
+ &set_file_time($l, "$dest/" . &basename($l));
+ }
+ } @src;
+}
+
+sub move {
+ my ($dest) = pop @_;
+ my ($src, $f, $l);
+
+ @l = @_;
+ foreach $f (@l) {
+ # Handle globbing
+ if ($f =~ m/[*?]/) {
+ my @expand = ($f =~ m/ / ? <"${f}"> : <${f}>);
+# print "expanding $f => @expand\n";
+ push @src, @expand;
+ } else {
+ push @src, $f;
+ }
+ }
+ if (($#src > 2) && (! -d $dest)) {
+ print STDERR "*** Move : can't move to $dest, not a directory.\n";
+ return;
+ }
+
+ foreach $f (@src) {
+ if (-d $dest) {
+ rename($f, &newpath($dest, &basename($f)));
+ } else {
+ &copy($f, $dest);
+ &set_file_time($f, $dest);
+ unlink($f);
+ }
+ }
+}
+
+# Simulate links by copying
+sub make_link {
+ my ($to, $from) = @_;
+ $to = canon_dir($to);
+ $from = &newpath(dirname($to), $from);
+ print "linking $from -> $to ...";
+ if (-e $to) {
+ unlink($to);
+ }
+ if (-d $from) {
+ system("xcopy $from $to /f/r/i/e/d/k");
+ } else {
+ &copy($from, $to);
+ &set_file_time($from, $to);
+ }
+ print " done\n";
+}
+
+# Merges all elements in the list into a single path, adding
+# directory separators as needed.
+sub newpath {
+ return &canon_dir(join ($Separator, @_));
+}
+
+#
+# Search for $key = $val in $file
+#
+sub look_for {
+ my($key, $file) = @_;
+ my($ret);
+ open FIN, "<$file";
+ while (<FIN>) {
+ if ($_ =~ m/^$key\s*=\s*(\S*)/) {
+ $ret = $1;
+ last;
+ } elsif (/^\#define\s+$key\s+(\S*)/) {
+ $ret = $1;
+ last;
+ }
+ }
+ close FIN;
+ return $ret;
+}
+
+
+sub max {
+ $m = shift;
+ while ($_ = shift) {
+ $m = $_ if ($_ > $m);
+ }
+ return $m;
+}
+
+sub min {
+ $m = shift;
+ while ($_ = shift) {
+ $m = $_ if ($_ < $m);
+ }
+ return $m;
+}
+
+# Changes lines of the form:
+# $var=... to
+# $var='$val' in $file
+#
+sub substitute_var_val {
+ my($file, $var, $val) = @_;
+ my($success);
+
+ @success = ( );
+
+ if (! -f $file) {
+ print STDERR "$0: $file is not a file\n";
+ return $success;
+ }
+ open IN, "<$file";
+ open OUT, ">$file.bak";
+
+ while (<IN>) {
+ s/^$var\s*=\s*(.*)$/do {
+ push @success, $1;
+ # "\$" . $var . "=" . eval('$val') . ";" .
+ "$var = $val"
+ }/e;
+ print OUT;
+ }
+ close IN;
+ close OUT;
+
+ &copy("$file.bak", "$file");
+ unlink("$file.bak");
+
+ return @success;
+}
+
+#
+# Used by globexpand($recurse, $dir)
+#
+sub globexpand_push {
+ my ($dir, @l) = @_;
+ #print "globexpand_push($dir, @l)\n" if $::opt_debug;
+ my ($file);
+ $dir =~ s@\\@/@g;
+ foreach $file (@l) {
+ next if $file =~ /^\.(\.?|svn)$/;
+ my $path = "$dir/$file";
+ next if $path =~ m/^${Tpm::IgnoredFiles}$/;
+ if (-f $path) {
+ #print " push $dir/$file\n" if $::opt_debug;
+ push @listglob, $path;
+ }
+ }
+}
+
+#
+# Returns the list of files that match $pattern
+# Recursively walking directories if $recurse
+#
+sub globexpand {
+ my ($recurse, $pattern) = @_;
+ local @listglob = ( );
+# $opt_verbose = ($pattern =~ m/GsTools/i ? 1 : 0);
+ if (-f $pattern) {
+ push @listglob, $pattern;
+ }
+ else {
+ my @expand = ($pattern =~ m/ / ? <"${pattern}"> : <${pattern}>);
+ #print " globexpanding $pattern => @expand\n" if $::opt_debug;
+ while ( @expand ) {
+ $_ = shift @expand;
+ #print "elt $_\n" if $::opt_debug;
+ if (-f $_) {
+ #print " pushing $_\n" if $::opt_debug;
+ push @listglob, $_;
+ } elsif (($_ ne "") && (-d $_) && ($recurse)) {
+ &walk_dir($_, \&globexpand_push);
+ }
+ }
+ }
+ #print " globexpanded $pattern => @listglob\n" if $::opt_debug;
+ return @listglob;
+}
+
+sub diff_list {
+ local ($l1, $l2, *l1_l2, *l2_l1) = @_;
+
+ # print "Before sorting:\n";
+ # map { print "$_\n"; } @$l1;
+ # print "\n";
+ # map { print "$_\n"; } @$l2;
+ # $opt_verbose = 1;
+ # $opt_debug = 1;
+
+ @l1 = sort(@$l1);
+ @l2 = sort(@$l2);
+
+ # print "After sorting:\n";
+ # map { print "$_\n"; } @l1;
+ # print "\n";
+ # map { print "$_\n"; } @l2;
+
+ while ($#l1 >= 0 || $#l2 >= 0) {
+ if ($#l1 == -1) {
+ print "No more elements in l1, over.\n" if $opt_debug;
+ push (@l2_l1, @l2);
+ @l2 = ();
+ } elsif ($#l2 == -1) {
+ print "No more elements in l2, over.\n" if $opt_debug;
+ push (@l1_l2, @l1);
+ @l1 = ();
+ } else {
+ my $comp = $l1[0] cmp $l2[0];
+
+ if ($comp == 0) {
+ print "Same element $l1[0], shifting both.\n" if $opt_debug;
+ shift @l1;
+ shift @l2;
+ } elsif ($comp > 0) {
+ print "Greater element $l1[0] than $l2[0], shifting l2.\n" if $opt_debug;
+ push (@l2_l1, shift @l2);
+ } else {
+ print "Smaller element $l1[0] than $l2[0], shifting l1.\n" if $opt_debug;
+ push (@l1_l2, shift @l1);
+ }
+ }
+ }
+
+ if ($opt_verbose) {
+ print "$#l1_l2, $#l2_l1\n";
+
+ print "Elts in l1 and not in l2 : \n";
+ map { print "$_\n"; } @l1_l2; print "\n";
+
+ print "Elts in l2 and not in l1 : \n";
+ map { print "$_\n"; } @l2_l1; print "\n";
+ }
+ return ($#l1_l2 == -1 && $#l2_l1 == -1);
+}
+
+sub sync_dir {
+ my ($src, $dst, $opt_proc, $opt_prune, $opt_dry, $opt_mirror, $opt_nomkdir) = @_;
+ local ($cwd, $dry, $mirror, $proc, $prune, $nomkdir);
+
+ $cwd = &getcwd;
+ $dry = $opt_dry;
+ $mirror = $opt_mirror;
+ $proc = $opt_proc;
+ $prune = $opt_prune;
+ $nomkdir = $opt_nomkdir;
+
+ print "src = $src\ndst = $dst\n";
+ if (! chdir($src)) {
+ print "Error: can't chdir to $src\n";
+ return;
+ }
+ sync_dir_1(".", $dst);
+ chdir($cwd);
+}
+
+sub newer {
+ my ($f1, $f2) = @_;
+ my (@t1, @t2, $t11, $t12);
+ @t1 = stat($f1);
+ @t2 = stat($f2);
+ $t11 = $t1[9];
+ $t12 = $t2[9];
+ return -1 if ($t11 < $t12);
+ return 1 if ($t11 > $t12);
+ return 0;
+}
+
+sub sync_dir_1 {
+ # Walks the directory, executing $proc for each file,
+ # until done is returned.
+ my ($dir, $dst) = @_;
+ my (@l, $f, $done, $src, $DIR);
+
+ print "Walking $dir\n" if $opt_verbose;
+
+ if (! -d $dst) {
+ if (-f $dst) {
+ # Clash
+ print "!!!Clash: $dir is a directory and $dst is a file.\n";
+ return;
+ } elsif (! $nomkdir) {
+ print "Creating missing directory $dst\n";
+ mkdir $dst if (! $dry);
+ }
+ }
+
+ if ((! $prune) || ($prune && ! &{$prune}($dir))) {
+ $done = 0;
+ # Walk the directory tree
+ opendir DIR, "$dir";
+ # do not forget to remove "." and ".."
+ @l = readdir (DIR); shift @l; shift @l;
+ closedir DIR;
+ # Apply the filter
+ @l = &{$proc}($dir, $dst, @l) if ($proc);
+
+ foreach $f (@l) {
+ if (-d $dir . $Separator . $f) {
+ # source is directory
+ &sync_dir_1($dir . $Separator . $f, $dst . $Separator . $f);
+ } elsif (-d $dst . $Separator . $f) {
+ # source is file and destination is directory
+ print "!!!Clash: $dir is a file and $dst is a directory.\n";
+ next;
+ } elsif (! -f $dst . $Separator . $f) {
+ # source is file and destination is missing
+ print "Copying missing file " . $dst . $Separator . $f . "\n";
+ if (! $dry) {
+ &copy ($dir . $Separator . $f, $dst . $Separator . $f);
+ &set_file_time($dir . $Separator . $f, $dst . $Separator . $f);
+ }
+ } else {
+ my $compare = &newer($dir . $Separator . $f, $dst . $Separator . $f);
+ if ($compare > 0 || ($mirror && $compare < 0)) {
+ # source is file and destination is older than source
+ print "Copying newer file " . $dir . $Separator . $f . " than " . $dst . $Separator . $f . "\n";
+ if (! $dry) {
+ &copy ($dir . $Separator . $f, $dst . $Separator . $f);
+ &set_file_time($dir . $Separator . $f, $dst . $Separator . $f);
+ }
+ }
+ }
+ }
+ # Look at the other side
+ opendir DIR, "$dst";
+ # do not forget to remove "." and ".."
+ @l = readdir (DIR); shift @l; shift @l;
+ closedir DIR;
+ # Apply the same filter procedure
+ @l = &{$proc}($dir, $dst, @l) if ($proc);
+ foreach $f (@l) {
+ # We should look only for things to remove on the destination side
+ next if (-e "$dir$Separator$f");
+ # If it does not exist on the source side, then remove it.
+ if (-d "$dst$Separator$f") {
+ print "Removing directory $dst$Separator$f\n";
+ &rmtree("$dst$Separator$f") if (! $dry);
+ } elsif (-f "$dst$Separator$f") {
+ print "Removing file $dst$Separator$f\n";
+ unlink("$dst$Separator$f") if (! $dry);
+ } else {
+ print "Unknown file type $f\n";
+ }
+ }
+ }
+}
+
+sub start_redirection {
+ local ($log) = @_;
+
+ # start redirection if asked
+ if ($log) {
+ print "Logging onto $log\n";
+ open(SO, ">&STDOUT");
+ open(SE, ">&STDERR");
+
+ close(STDOUT);
+ close(STDERR);
+
+ open(STDOUT, ">$log");
+ open(STDERR,">&STDOUT");
+
+ select(STDERR); $| = 1;
+ select(STDOUT); $| = 1;
+ }
+}
+
+sub stop_redirection {
+
+ local($log) = @_;
+
+ if ($log) {
+ close(STDOUT);
+ close(STDERR);
+ open(STDOUT, ">&SO");
+ open(STDERR, ">&SE");
+ }
+}
+
+sub calc_file_size {
+ my ($dir, @files) = @_;
+ my ($size, @st);
+
+ # print "calc_file_size : $dir, files = $#files\n"; # if $opt_debug;
+ if (! -d $dir) {
+ print STDERR "$0: $dir is not a directory!\n";
+ return 0;
+ }
+ $size = 0;
+ @files = map { &globexpand(1, "$dir/$_"); } @files;
+ map {
+ @st = stat($_);
+ $size += $st[7];
+ } @files;
+ # print "size = $size\n" if ($opt_debug);
+ return $size;
+}
+
+# sub globtest {
+# my ($s1, $s2) = @_;
+# my @l1 = reverse(split("\\/", $s1));
+# my @l2 = reverse(split("\\/", $s2));
+# my $match = 1;
+# # pop @l1; pop @l2;
+# my $debug = 0;
+# print "l1 = (@l1), l2 = (@l2)\n" if ($debug);
+
+# while ($match) {
+# my $e1 = pop @l1;
+# my $e2 = pop @l2;
+# print "e1 = $e1, e2 = $e2\n" if ($debug);
+# last if ($e1 eq "" && $e2 eq "");
+
+# next if ($e1 eq $e2);
+# if ($e1 eq "*") {
+# return 1 if ($#l1 < 0);
+# $e1 = pop @l1;
+# print "e1 = $e1 $#l1 " if ($debug);
+# do {
+# $e2 = pop @l2;
+# print "e2 = $e2 " if ($debug);
+# } while ($e1 ne $e2 && $#l2 >= 0);
+# print "\n" if ($debug);
+# return ($e1 eq $e2 ? 1 : 0) if ($#l2 < 0);
+# }
+# if ($e2 eq "*") {
+# return 1 if ($#l2 < 0);
+# $e2 = pop @l2;
+# do {
+# $e1 = pop @l1;
+# } while ($e2 ne $e1 && $#l1 >= 0);
+# return ($e1 eq $e2 ? 1 : 0) if ($#l1 < 0);
+# }
+# $match = ($e1 eq $e2 ? 1 : 0);
+# }
+# print "returning $match\n" if ($debug);
+# return $match;
+# }
+
+sub regexpify_node {
+ my ($node, @stackdir) = @_;
+ my $relative = join "/", @stackdir;
+
+ @l2 = keys(%{$node});
+ # remove directories
+ @l2 = grep { ! (keys %{$node->{$_}}) } @l2;
+ if (@l2) {
+ opendir DIR, "$dir/$relative";
+ # do not forget to remove "." and ".."
+ my @l = readdir (DIR); shift @l; shift @l;
+ closedir DIR;
+ @l = grep { ! -d "$dir/$relative/$_" } @l;
+ # compare @l and keys(%{$node})
+ my (@l3, @l4);
+ @l3 = ();
+ @l4 = ();
+ my $diff = &diff_list(\@l, \@l2, \@l3, \@l4);
+ if ($diff) {
+ foreach $k (keys(%{$node})) {
+ delete $$node{$k} if (! (keys %{$node->{$k}}));;
+ }
+ $$node{'*'} = { };
+ }
+ }
+ else {
+
+ }
+}
+
+sub regexpify_recursive_node {
+ my ($node, @stackdir) = @_;
+ my $relative = join "/", @stackdir;
+
+ @l2 = keys(%{$node});
+ if (@l2) {
+ opendir DIR, "$dir/$relative";
+ # do not forget to remove "." and ".."
+ my @l = readdir (DIR); shift @l; shift @l;
+ closedir DIR;
+ # compare @l and keys(%{$node})
+ my (@l3, @l4);
+ @l3 = ();
+ @l4 = ();
+ my $diff = &diff_list(\@l, \@l2, \@l3, \@l4);
+ if ($diff) {
+ my $test = 1;
+ foreach $k (keys(%{$node})) {
+ $test = $test && ! $node->{$k}->{'__noregexpify'};
+ }
+ if ($test) {
+ foreach $k (keys(%{$node})) {
+ delete $$node{$k};
+ }
+ $$node{'*'} = { };
+ }
+ } else {
+ $node->{'__noregexpify'} = 1;
+ }
+ }
+ else {
+
+ }
+}
+
+sub regexpify_cleanup {
+ my ($node, @stackdir) = @_;
+ if ($node->{'__noregexpify'}) {
+ delete $node->{'__noregexpify'};
+ }
+}
+
+sub regexpify {
+ my ($recursive, $texdir, @files) = @_;
+ my ($node);
+ local $dir = $texdir;
+
+ $node = &FileUtils::build_tree(@files);
+
+ if ($recursive) {
+ &FileUtils::walk_tree($node, '', \&regexpify_recursive_node);
+ &FileUtils::walk_tree($node, '', \&regexpify_cleanup);
+ }
+ else {
+ &FileUtils::walk_tree($node, '', \&regexpify_node);
+ }
+ return &FileUtils::tree2list($node);
+}
+
+# Print Perl backtrace, for debugging.
+sub backtrace {
+ my $subr;
+ my $stackframe = 0;
+ while (($pkg,$filename,$line,$subr) = caller ($stackframe)) {
+ print "$filename:$line: $pkg::$subr called\n";
+ $stackframe++;
+ }
+}
+
+END { }
+
+1;
diff --git a/Build/tools/MakeImages.sh b/Build/tools/MakeImages.sh
new file mode 100755
index 00000000000..bcc9f5b8854
--- /dev/null
+++ b/Build/tools/MakeImages.sh
@@ -0,0 +1,220 @@
+#!/bin/sh
+# $Id$
+#
+# Create the .iso file system images for TeX Live:
+# a) live: the complete uncompressed system (for DVD)
+# b) inst: compressed zip files and installer only (CD)
+#
+# In 2003, we also produced:
+# c) demo: live subset which can be run as is (CD)
+# but this was dropped in 2004.
+#
+# Copyright (c) Sebastian Rahtz 2003, 2004, 2005, 2006.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+#
+# Send bug reports or suggestions to tex-live@tug.org.
+
+unset CDPATH # avoid output from cd
+umask 0
+
+HERE=`cd \`dirname $0\` && /bin/pwd`
+cd $HERE || exit 1 # the Tools directory
+source=`cd .. && /bin/pwd`
+
+NAME=texlivetest
+V=2006
+D=`date +%Y%m%d`
+
+debug=${OVERRIDE_DEBUG-false}
+target=/home/ftp/texlive/Images/test
+work=/var/tmp/TL_$$
+zippath=/usr/local/bin
+quiet= # for passing to mkisofs
+makelive=true
+makeinst=true
+makedemo=false
+
+while test $# -gt 0; do
+ case $1 in
+ --debug) debug=true; quiet=;;
+ --noinst) makeinst=false;;
+ --nolive) makelive=false;;
+ --quiet) quiet=-quiet;;
+ --source=*) source=`echo $1 | sed 's/.*=//'`;;
+ --work=*) work=`echo $1 | sed 's/.*=//'`;;
+ --target=*) target=`echo $1 | sed 's/.*=//'`;;
+ --zippath=*) zippath=`echo $1 | sed 's/.*=//'`;;
+ *) break;;
+ esac
+ shift
+done
+
+if $debug; then
+ echo "source = $source"
+ echo "target = $target"
+ echo "work = $work"
+fi
+mkdir -p $target
+
+common_mkisofs_options=" $quiet -pad -J -dir-mode 0755 -r \
+ -copyright LICENSE.TL \
+ -x install-live.sh -x install-compr.sh \
+ -x install-pkg-compr.sh -x install-pkg-live.sh \
+ -x ./support/tests \
+ -x Tools \
+ -x .svn \
+"
+
+#
+MAKELIVE () {
+live_iso=$target/$NAME$V-live-$D.iso
+echo "--- `date` Writing complete live image to $live_iso."
+
+# Basically copy the source directory.
+(cd $source || exit 1
+ # Complication: get the right install-tl.sh.
+ rm -f install-tl.sh install-pkg.sh
+ cp -p install-live.sh install-tl.sh
+ cp -p install-pkg-live.sh install-pkg.sh
+
+ # Another complication: getting the release date into 00LIVE.TL.
+ rm -f 00LIVE.TL
+ svn update 00LIVE.TL
+ (echo; echo "Release date: $D.`date +%H`") >>00LIVE.TL
+
+ # remove old images.
+ rm -f $target/$NAME$V-live-*.iso $target/$NAME$V-live-*.iso.md5
+
+ # make new image, excluding the compressed stuff and more,
+ # and moving everything to a texlive/ subdirectory,
+ # since that's how we release it on the DVD.
+ mkisofs $common_mkisofs_options -root texlive -x 00INST.TL \
+ -o $live_iso .
+ md5sum $live_iso >$live_iso.md5
+ rm -f install-tl.sh install-pkg.sh
+)
+
+# make symlink with short name, that we use in /etc/fstab.
+rm -f $target/$NAME-live.iso $target/$NAME-live.iso.md5
+ln -s `basename $live_iso` $target/$NAME-live.iso
+ln -s `basename $live_iso`.md5 $target/$NAME-live.iso.md5
+ls -l $live_iso
+}
+
+
+#
+MAKEINST () {
+inst_iso=$target/$NAME$V-inst-$D.iso
+echo "--- `date` Writing compressed/installable Unix image to $inst_iso."
+
+WORK=$work/TL
+test -d $WORK && rm -rf $WORK
+mkdir -p $WORK
+
+$debug && echo Copy top-level files
+cd $source
+tar cf - \
+ support \
+ .mkisofsrc config.* autorun.inf \
+ install-compr.sh install-pkg-compr.sh common.sh utils.sh \
+ COPYING \
+ LICENSE.TL \
+ README.* \
+ setup-win32/help/* \
+ setup-win32/msgs/* \
+ setup-win32/* \
+ Tools \
+ source \
+ texmf-doc/doc/*/texlive-* \
+ 00INST.TL *html \
+ | (cd $WORK && tar xf - )
+
+# initial texmf-var
+mkdir $WORK/texmf-var
+cd $source/texmf-dist || exit 1
+tar cf - \
+ tex/plain/config/language.def \
+ tex/context/config/cont-usr.tex \
+| (cd $WORK/texmf-var; tar xf - )
+cd $source/texmf || exit 1
+# updmap.cfg gets generated at install time, we don't want to copy the
+# one from the distribution.
+tar cf - \
+ web2c/mktex.cnf \
+ dvips/config/config.ps \
+ dvipdfm/config/config \
+ tex/generic/config/pdftexconfig.tex \
+ xdvi/XDvi \
+ | (cd $WORK/texmf-var; tar xf - )
+chmod -R u+rw $WORK/texmf-var # the originals are mostly 444
+
+# make zip file out of texmf-var, so we don't have an ersatz tree
+# hanging around in the image to confuse users.
+mkdir -p $WORK/archive
+cd $WORK/texmf-var || exit 1
+zip -qr $WORK/archive/texmf-var.zip .
+cd $WORK && rm -rf texmf-var
+
+$debug && echo Prepare zip files...
+PATH=$PATH:$zippath
+export PATH
+cd $source || exit 1
+# people want to get the windows binaries, so don't exclude everything.
+# bzip2, perl, windvi, lib-* -- basically required.
+# Fabrice suggests dumping the below, but since we seem to have room for
+# now, let's include them. xemacs is the biggie.
+# w32progs="diff|grep|gsview|imagemagick|patch|sed|wget|xemacs"
+w32progs="xemacs"
+for i in texmf/lists/*; do
+ # skip windows binaries for unix inst cd. Since the windows installer
+ # requires cab files, we can't put them on one CD any more, no space.
+ # All the lib-* packages are xemtex things, strange but true.
+ echo "$i" | egrep "bin-($w32progs)|\.win32-static" >/dev/null \
+ && continue
+
+ I=`basename $i`
+ cat $i | zip -y -q -r $WORK/archive/$I.zip -@
+done
+
+# copy tpm directories
+cd $source
+tar cf - texmf/lists texmf/tpm texmf-dist/tpm texmf-doc/tpm \
+ | (cd $WORK; tar xf - )
+
+cd $WORK || exit 1
+
+# fix up top level.
+rm -f install-tl.sh install-pkg.sh
+mv install-compr.sh install-tl.sh
+mv install-pkg-compr.sh install-pkg.sh
+chmod a+w 00INST.TL
+(echo; echo "Release date: $D.`date +%H`") >>00INST.TL
+
+rm -f $target/$NAME$V-inst-*.iso $target/$NAME$V-inst-*.iso.md5
+mkisofs $common_mkisofs_options -x 00LIVE.TL \
+ -o $inst_iso .
+md5sum $inst_iso >$inst_iso.md5
+
+# symlink with short name.
+rm -f $target/$NAME-inst.iso $target/$NAME-inst.iso.md5
+ln -s `basename $inst_iso` $target/$NAME-inst.iso
+ln -s `basename $inst_iso`.md5 $target/$NAME-inst.iso.md5
+}
+
+$makelive && MAKELIVE
+$makeinst && MAKEINST
+
+rm -rf $work $WORK
diff --git a/Build/tools/README b/Build/tools/README
new file mode 100644
index 00000000000..e950d928e6b
--- /dev/null
+++ b/Build/tools/README
@@ -0,0 +1,83 @@
+(public domain -- originally written in 2004 by Karl Berry.)
+
+The scripts here relate to building or verifying TeX Live itself.
+
+tlrebuild - master script to check package files (tpm-check),
+ update them (update-tpm), update the lists files generated from the
+ tpm's for the Unix installer (update-lists),
+ and make the ISO image (MakeImages.sh).
+
+tpm-by-size - reports packages by space consumed.
+
+tpm-ctan-check - check that TL is up to date wrt CTAN.
+
+update-auto - check for various sources external to TeX Live being
+ changed, such as config.guess, texinfo.tex, etc.
+
+update-lists - update texmf/lists/* files from all the tpm's.
+
+update-tpm - regenerate tpm files via tpm-factory.pl.
+
+htmltext - simplistic creation of plain text from HTML, used for the
+ top-level doc.
+
+mkdocindex - builds top-level doc.html file.
+
+--
+
+Instructions from Sebastian (5jun04) on updating packages from ctan to
+TeX Live; encapsulated in the ./ctan2tl script, but don't run it blindly.
+
+a) grab the package X to Build/cdbuild/raw as a zip archive: gets $X.zip
+
+b) unpack zip: makes $X
+
+c) run
+ ../ctan2tds.pl $X
+ which makes ../cooked/X
+
+d) cd ../cooked: check $X tree is OK
+
+e) ../place $X: copies this tree to main texmf-dist, updates/creates
+ TPM, updates/creates list file
+ (this includes running tpm-factory)
+
+f) p4 revert -a
+ p4 submit
+
+--
+The difference between Map and MixedMap, from te:
+
+ The purpose of MixedMap is to help people who have printers which render
+ the type1 versions of the fonts worse than (mode-tuned) versions of
+ type3 fonts. The entries from MixedMap are just) not added to
+ psfonts_pk.map. That's the only difference.
+
+--
+pdftex update:
+\cp -f Annou* NEWS README /home/karl/src/Master/texmf/doc/pdftex
+cd !$
+p4update Annou* NEWS README
+
+cd manual
+\cp -f * /home/karl/src/Master/texmf/doc/pdftex/manual
+cd !$
+make
+p4update *
+
+# texmf is copies of various .ini's, ignore.
+
+
+on new architecture, or version change, must edit:
+Master/utils.sh: platform_guess() Sys variable setting.
+Master/common.sh:
+ setvars - name
+ menu_this_platform - list
+ screen_5 - text, must match
+Master/Tools/Tpm.pm: system list
+
+
+
+new year:
+- MakeImages.sh
+- texmf.cnf
diff --git a/Build/tools/RunTPM b/Build/tools/RunTPM
new file mode 100755
index 00000000000..7a73a7b8968
--- /dev/null
+++ b/Build/tools/RunTPM
@@ -0,0 +1,9 @@
+#!/bin/sh
+M=`cd \`dirname $0\`/.. && /bin/pwd`
+T=`cd \`dirname $0\` && /bin/pwd`
+perl $T/tpm-factory.pl --master=$M --tpm_dir=$M/texmf-dist/tpm --ftp_dir=/var/tmp \
+--clean \
+--arch=all \
+--patterns=auto \
+$*
+
diff --git a/Build/tools/Strict.pm b/Build/tools/Strict.pm
new file mode 100644
index 00000000000..583ceb4ec90
--- /dev/null
+++ b/Build/tools/Strict.pm
@@ -0,0 +1 @@
+return 1;
diff --git a/Build/tools/Tpm.pm b/Build/tools/Tpm.pm
new file mode 100644
index 00000000000..f620b611092
--- /dev/null
+++ b/Build/tools/Tpm.pm
@@ -0,0 +1,1754 @@
+# $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", "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",
+ "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("\
+<!DOCTYPE rdf:RDF SYSTEM \"../../Tools/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>864</TPM:Size>\
+ <TPM:Description></TPM:Description>\
+ <TPM:Build>\
+ <TPM:RunPatterns>${texmf}/tpm/${name}.tpm</TPM:RunPatterns>\
+ </TPM:Build>\
+ <TPM:RunFiles size=\"679\">${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 \"../../Tools/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") {
+ 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 (@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}) {
+ push @l, @{${$v}{"text"}};
+ }
+ }
+ }
+ 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});
+ 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 max_date
+{
+ my ($olddate, @files) = @_;
+ my ($f, $tpmdate);
+ #print " olddate was " . &formatdate(gmtime($oldate)) . ", files=@files\n";
+ foreach $f (@files) {
+ if ($f =~ m@^texmf-dist/tpm/.*\.tpm@) {
+ $tpmdate = (stat("$MasterDir/$f"))[9];
+ #print " tpm itself, found $tpmdate\n";
+ }
+ else {
+ my @st = stat("$MasterDir/$f");
+ #print " file $f is " . &formatdate(gmtime($st[9])) . "\n";
+ if ($st[9] > $olddate) {
+ #print " replacing\n";
+ $olddate = $st[9];
+ }
+ }
+ }
+ if ($olddate == 0) {
+ $olddate = $tpmdate;
+ }
+# print " newdate is " . &formatdate(gmtime($oldate)) . "\n";
+ return $olddate;
+}
+
+sub fixDate {
+ my ($self) = @_;
+ my $newdate = 0;
+ foreach my $s (@{$self->getFileList("BinFiles")}) {
+ if ($CurrentArch eq "all" || $s =~ m@/${CurrentArch}/@) {
+ $newdate = &max_date($newdate, ${$s}{"text"});
+ }
+ }
+ #print " newdate after bin: " . &formatdate(gmtime($newdate)) . "\n";
+ $newdate = &max_date($newdate, $self->getFileList("RunFiles"));
+ #print " newdate after run: " . &formatdate(gmtime($newdate)) . "\n";
+ $newdate = &max_date($newdate, $self->getFileList("DocFiles"));
+ #print " newdate after doc: " . &formatdate(gmtime($newdate)) . "\n";
+ $newdate = &max_date($newdate, $self->getFileList("SourceFiles"));
+ #print " newdate after source: " . &formatdate(gmtime($newdate)) . "\n";
+ $newdate = &max_date($newdate, $self->getFileList("RemoteFiles"));
+ #print " newdate after remote: " . &formatdate(gmtime($newdate)) . "\n";
+ $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 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;
diff --git a/Build/tools/XML/DOM.pm b/Build/tools/XML/DOM.pm
new file mode 100644
index 00000000000..df072c8c3b4
--- /dev/null
+++ b/Build/tools/XML/DOM.pm
@@ -0,0 +1,5185 @@
+################################################################################
+#
+# Perl module: XML::DOM
+#
+# By Enno Derksen
+#
+################################################################################
+#
+# To do:
+#
+# * optimize Attr if it only contains 1 Text node to hold the value
+# * fix setDocType!
+#
+# * BUG: setOwnerDocument - does not process default attr values correctly,
+# they still point to the old doc.
+# * change Exception mechanism
+# * maybe: more checking of sysId etc.
+# * NoExpand mode (don't know what else is useful)
+# * various odds and ends: see comments starting with "??"
+# * normalize(1) could also expand CDataSections and EntityReferences
+# * parse a DocumentFragment?
+# * encoding support
+#
+######################################################################
+
+######################################################################
+package XML::DOM;
+######################################################################
+
+use strict;
+
+use bytes;
+
+use vars qw( $VERSION @ISA @EXPORT
+ $IgnoreReadOnly $SafeMode $TagStyle
+ %DefaultEntities %DecodeDefaultEntity
+ $beautifying $current_indent $string_indent $current_print_level @need_indent
+ );
+use Carp;
+use XML::RegExp;
+
+BEGIN
+{
+ require XML::Parser;
+ $VERSION = '1.42';
+
+ my $needVersion = '2.28';
+ die "need at least XML::Parser version $needVersion (current=${XML::Parser::VERSION})"
+ unless $XML::Parser::VERSION >= $needVersion;
+
+ @ISA = qw( Exporter );
+
+ # Constants for XML::DOM Node types
+ @EXPORT = qw(
+ UNKNOWN_NODE
+ ELEMENT_NODE
+ ATTRIBUTE_NODE
+ TEXT_NODE
+ CDATA_SECTION_NODE
+ ENTITY_REFERENCE_NODE
+ ENTITY_NODE
+ PROCESSING_INSTRUCTION_NODE
+ COMMENT_NODE
+ DOCUMENT_NODE
+ DOCUMENT_TYPE_NODE
+ DOCUMENT_FRAGMENT_NODE
+ NOTATION_NODE
+ ELEMENT_DECL_NODE
+ ATT_DEF_NODE
+ XML_DECL_NODE
+ ATTLIST_DECL_NODE
+ );
+}
+
+#---- Constant definitions
+
+# Node types
+
+sub UNKNOWN_NODE () { 0 } # not in the DOM Spec
+
+sub ELEMENT_NODE () { 1 }
+sub ATTRIBUTE_NODE () { 2 }
+sub TEXT_NODE () { 3 }
+sub CDATA_SECTION_NODE () { 4 }
+sub ENTITY_REFERENCE_NODE () { 5 }
+sub ENTITY_NODE () { 6 }
+sub PROCESSING_INSTRUCTION_NODE () { 7 }
+sub COMMENT_NODE () { 8 }
+sub DOCUMENT_NODE () { 9 }
+sub DOCUMENT_TYPE_NODE () { 10}
+sub DOCUMENT_FRAGMENT_NODE () { 11}
+sub NOTATION_NODE () { 12}
+
+sub ELEMENT_DECL_NODE () { 13 } # not in the DOM Spec
+sub ATT_DEF_NODE () { 14 } # not in the DOM Spec
+sub XML_DECL_NODE () { 15 } # not in the DOM Spec
+sub ATTLIST_DECL_NODE () { 16 } # not in the DOM Spec
+
+%DefaultEntities =
+(
+ "quot" => '"',
+ "gt" => ">",
+ "lt" => "<",
+ "apos" => "'",
+ "amp" => "&"
+);
+
+%DecodeDefaultEntity =
+(
+ '"' => "&quot;",
+ ">" => "&gt;",
+ "<" => "&lt;",
+ "'" => "&apos;",
+ "&" => "&amp;"
+);
+
+$beautifying = 1;
+$current_indent = 0;
+$string_indent = " ";
+$current_print_level = 0;
+@need_indent = ();
+
+#
+# If you don't want DOM warnings to use 'warn', override this method like this:
+#
+# { # start block scope
+# local *XML::DOM::warning = \&my_warn;
+# ... your code here ...
+# } # end block scope (old XML::DOM::warning takes effect again)
+#
+sub warning # static
+{
+ warn @_;
+}
+
+#
+# This method defines several things in the caller's package, so you can use named constants to
+# access the array that holds the member data, i.e. $self->[_Data]. It assumes the caller's package
+# defines a class that is implemented as a blessed array reference.
+# Note that this is very similar to using 'use fields' and 'use base'.
+#
+# E.g. if $fields eq "Name Model", $parent eq "XML::DOM::Node" and
+# XML::DOM::Node had "A B C" as fields and it was called from package "XML::DOM::ElementDecl",
+# then this code would basically do the following:
+#
+# package XML::DOM::ElementDecl;
+#
+# sub _Name () { 3 } # Note that parent class had three fields
+# sub _Model () { 4 }
+#
+# # Maps constant names (without '_') to constant (int) value
+# %HFIELDS = ( %XML::DOM::Node::HFIELDS, Name => _Name, Model => _Model );
+#
+# # Define XML:DOM::ElementDecl as a subclass of XML::DOM::Node
+# @ISA = qw{ XML::DOM::Node };
+#
+# # The following function names can be exported into the user's namespace.
+# @EXPORT_OK = qw{ _Name _Model };
+#
+# # The following function names can be exported into the user's namespace
+# # with: import XML::DOM::ElementDecl qw( :Fields );
+# %EXPORT_TAGS = ( Fields => qw{ _Name _Model } );
+#
+sub def_fields # static
+{
+ my ($fields, $parent) = @_;
+
+ my ($pkg) = caller;
+
+ no strict 'refs';
+
+ my @f = split (/\s+/, $fields);
+ my $n = 0;
+
+ my %hfields;
+ if (defined $parent)
+ {
+ my %pf = %{"$parent\::HFIELDS"};
+ %hfields = %pf;
+
+ $n = scalar (keys %pf);
+ @{"$pkg\::ISA"} = ( $parent );
+ }
+
+ my $i = $n;
+ for (@f)
+ {
+ eval "sub $pkg\::_$_ () { $i }";
+ $hfields{$_} = $i;
+ $i++;
+ }
+ %{"$pkg\::HFIELDS"} = %hfields;
+ @{"$pkg\::EXPORT_OK"} = map { "_$_" } @f;
+
+ ${"$pkg\::EXPORT_TAGS"}{Fields} = [ map { "_$_" } @f ];
+}
+
+# sub blesh
+# {
+# my $hashref = shift;
+# my $class = shift;
+# no strict 'refs';
+# my $self = bless [\%{"$class\::FIELDS"}], $class;
+# if (defined $hashref)
+# {
+# for (keys %$hashref)
+# {
+# $self->{$_} = $hashref->{$_};
+# }
+# }
+# $self;
+# }
+
+# sub blesh2
+# {
+# my $hashref = shift;
+# my $class = shift;
+# no strict 'refs';
+# my $self = bless [\%{"$class\::FIELDS"}], $class;
+# if (defined $hashref)
+# {
+# for (keys %$hashref)
+# {
+# eval { $self->{$_} = $hashref->{$_}; };
+# croak "ERROR in field [$_] $@" if $@;
+# }
+# }
+# $self;
+#}
+
+#
+# CDATA section may not contain "]]>"
+#
+sub encodeCDATA
+{
+ my ($str) = shift;
+ $str =~ s/]]>/]]&gt;/go;
+ $str;
+}
+
+#
+# PI may not contain "?>"
+#
+sub encodeProcessingInstruction
+{
+ my ($str) = shift;
+ $str =~ s/\?>/?&gt;/go;
+ $str;
+}
+
+#
+#?? Not sure if this is right - must prevent double minus somehow...
+#
+sub encodeComment
+{
+ my ($str) = shift;
+ return undef unless defined $str;
+
+ $str =~ s/--/&#45;&#45;/go;
+ $str;
+}
+
+#
+# For debugging
+#
+sub toHex
+{
+ my $str = shift;
+ my $len = length($str);
+ my @a = unpack ("C$len", $str);
+ my $s = "";
+ for (@a)
+ {
+ $s .= sprintf ("%02x", $_);
+ }
+ $s;
+}
+
+#
+# 2nd parameter $default: list of Default Entity characters that need to be
+# converted (e.g. "&<" for conversion to "&amp;" and "&lt;" resp.)
+#
+sub encodeText
+{
+ my ($str, $default) = @_;
+ return undef unless defined $str;
+
+ if ($] >= 5.006) {
+ $str =~ s/([$default])|(]]>)/
+ defined ($1) ? $DecodeDefaultEntity{$1} : "]]&gt;" /egs;
+ }
+ else {
+ $str =~ s/([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)|([$default])|(]]>)/
+ defined($1) ? XmlUtf8Decode ($1) :
+ defined ($2) ? $DecodeDefaultEntity{$2} : "]]&gt;" /egs;
+ }
+
+#?? could there be references that should not be expanded?
+# e.g. should not replace &#nn; &#xAF; and &abc;
+# $str =~ s/&(?!($ReName|#[0-9]+|#x[0-9a-fA-F]+);)/&amp;/go;
+
+ $str;
+}
+
+#
+# Used by AttDef - default value
+#
+sub encodeAttrValue
+{
+ encodeText (shift, '"&<>');
+}
+
+#
+# Converts an integer (Unicode - ISO/IEC 10646) to a UTF-8 encoded character
+# sequence.
+# Used when converting e.g. &#123; or &#x3ff; to a string value.
+#
+# Algorithm borrowed from expat/xmltok.c/XmlUtf8Encode()
+#
+# not checking for bad characters: < 0, x00-x08, x0B-x0C, x0E-x1F, xFFFE-xFFFF
+#
+sub XmlUtf8Encode
+{
+ my $n = shift;
+ if ($n < 0x80)
+ {
+ return chr ($n);
+ }
+ elsif ($n < 0x800)
+ {
+ return pack ("CC", (($n >> 6) | 0xc0), (($n & 0x3f) | 0x80));
+ }
+ elsif ($n < 0x10000)
+ {
+ return pack ("CCC", (($n >> 12) | 0xe0), ((($n >> 6) & 0x3f) | 0x80),
+ (($n & 0x3f) | 0x80));
+ }
+ elsif ($n < 0x110000)
+ {
+ return pack ("CCCC", (($n >> 18) | 0xf0), ((($n >> 12) & 0x3f) | 0x80),
+ ((($n >> 6) & 0x3f) | 0x80), (($n & 0x3f) | 0x80));
+ }
+ croak "number is too large for Unicode [$n] in &XmlUtf8Encode";
+}
+
+#
+# Opposite of XmlUtf8Decode plus it adds prefix "&#" or "&#x" and suffix ";"
+# The 2nd parameter ($hex) indicates whether the result is hex encoded or not.
+#
+sub XmlUtf8Decode
+{
+ my ($str, $hex) = @_;
+ my $len = length ($str);
+ my $n;
+
+ if ($len == 2)
+ {
+ my @n = unpack "C2", $str;
+ $n = (($n[0] & 0x3f) << 6) + ($n[1] & 0x3f);
+ }
+ elsif ($len == 3)
+ {
+ my @n = unpack "C3", $str;
+ $n = (($n[0] & 0x1f) << 12) + (($n[1] & 0x3f) << 6) +
+ ($n[2] & 0x3f);
+ }
+ elsif ($len == 4)
+ {
+ my @n = unpack "C4", $str;
+ $n = (($n[0] & 0x0f) << 18) + (($n[1] & 0x3f) << 12) +
+ (($n[2] & 0x3f) << 6) + ($n[3] & 0x3f);
+ }
+ elsif ($len == 1) # just to be complete...
+ {
+ $n = ord ($str);
+ }
+ else
+ {
+ croak "bad value [$str] for XmlUtf8Decode";
+ }
+ $hex ? sprintf ("&#x%x;", $n) : "&#$n;";
+}
+
+$IgnoreReadOnly = 0;
+$SafeMode = 1;
+
+sub getIgnoreReadOnly
+{
+ $IgnoreReadOnly;
+}
+
+#
+# The global flag $IgnoreReadOnly is set to the specified value and the old
+# value of $IgnoreReadOnly is returned.
+#
+# To temporarily disable read-only related exceptions (i.e. when parsing
+# XML or temporarily), do the following:
+#
+# my $oldIgnore = XML::DOM::ignoreReadOnly (1);
+# ... do whatever you want ...
+# XML::DOM::ignoreReadOnly ($oldIgnore);
+#
+sub ignoreReadOnly
+{
+ my $i = $IgnoreReadOnly;
+ $IgnoreReadOnly = $_[0];
+ return $i;
+}
+
+#
+# XML spec seems to break its own rules... (see ENTITY xmlpio)
+#
+sub forgiving_isValidName
+{
+ $_[0] =~ /^$XML::RegExp::Name$/o;
+}
+
+#
+# Don't allow names starting with xml (either case)
+#
+sub picky_isValidName
+{
+ $_[0] =~ /^$XML::RegExp::Name$/o and $_[0] !~ /^xml/i;
+}
+
+# Be forgiving by default,
+*isValidName = \&forgiving_isValidName;
+
+sub allowReservedNames # static
+{
+ *isValidName = ($_[0] ? \&forgiving_isValidName : \&picky_isValidName);
+}
+
+sub getAllowReservedNames # static
+{
+ *isValidName == \&forgiving_isValidName;
+}
+
+#
+# Always compress empty tags by default
+# This is used by Element::print.
+#
+$TagStyle = sub { 0 };
+
+sub setTagCompression
+{
+ $TagStyle = shift;
+}
+
+######################################################################
+package XML::DOM::PrintToFileHandle;
+######################################################################
+
+#
+# Used by XML::DOM::Node::printToFileHandle
+#
+
+sub new
+{
+ my($class, $fn) = @_;
+ bless $fn, $class;
+}
+
+sub print
+{
+ my ($self, $str) = @_;
+ print $self $str;
+}
+
+######################################################################
+package XML::DOM::PrintToString;
+######################################################################
+
+use vars qw{ $Singleton };
+
+#
+# Used by XML::DOM::Node::toString to concatenate strings
+#
+
+sub new
+{
+ my($class) = @_;
+ my $str = "";
+ bless \$str, $class;
+}
+
+sub print
+{
+ my ($self, $str) = @_;
+ $$self .= $str;
+}
+
+sub toString
+{
+ my $self = shift;
+ $$self;
+}
+
+sub reset
+{
+ ${$_[0]} = "";
+}
+
+$Singleton = new XML::DOM::PrintToString;
+
+######################################################################
+package XML::DOM::DOMImplementation;
+######################################################################
+
+$XML::DOM::DOMImplementation::Singleton =
+ bless \$XML::DOM::DOMImplementation::Singleton, 'XML::DOM::DOMImplementation';
+
+sub hasFeature
+{
+ my ($self, $feature, $version) = @_;
+
+ uc($feature) eq 'XML' and ($version eq '1.0' || $version eq '');
+}
+
+
+######################################################################
+package XML::XQL::Node; # forward declaration
+######################################################################
+
+######################################################################
+package XML::DOM::Node;
+######################################################################
+
+use vars qw( @NodeNames @EXPORT @ISA %HFIELDS @EXPORT_OK @EXPORT_TAGS );
+
+BEGIN
+{
+ use XML::DOM::DOMException;
+ import Carp;
+
+ require FileHandle;
+
+ @ISA = qw( Exporter XML::XQL::Node );
+
+ # NOTE: SortKey is used in XML::XQL::Node.
+ # UserData is reserved for users (Hang your data here!)
+ XML::DOM::def_fields ("C A Doc Parent ReadOnly UsedIn Hidden SortKey UserData");
+
+ push (@EXPORT, qw(
+ UNKNOWN_NODE
+ ELEMENT_NODE
+ ATTRIBUTE_NODE
+ TEXT_NODE
+ CDATA_SECTION_NODE
+ ENTITY_REFERENCE_NODE
+ ENTITY_NODE
+ PROCESSING_INSTRUCTION_NODE
+ COMMENT_NODE
+ DOCUMENT_NODE
+ DOCUMENT_TYPE_NODE
+ DOCUMENT_FRAGMENT_NODE
+ NOTATION_NODE
+ ELEMENT_DECL_NODE
+ ATT_DEF_NODE
+ XML_DECL_NODE
+ ATTLIST_DECL_NODE
+ ));
+}
+
+#---- Constant definitions
+
+# Node types
+
+sub UNKNOWN_NODE () {0;} # not in the DOM Spec
+
+sub ELEMENT_NODE () {1;}
+sub ATTRIBUTE_NODE () {2;}
+sub TEXT_NODE () {3;}
+sub CDATA_SECTION_NODE () {4;}
+sub ENTITY_REFERENCE_NODE () {5;}
+sub ENTITY_NODE () {6;}
+sub PROCESSING_INSTRUCTION_NODE () {7;}
+sub COMMENT_NODE () {8;}
+sub DOCUMENT_NODE () {9;}
+sub DOCUMENT_TYPE_NODE () {10;}
+sub DOCUMENT_FRAGMENT_NODE () {11;}
+sub NOTATION_NODE () {12;}
+
+sub ELEMENT_DECL_NODE () {13;} # not in the DOM Spec
+sub ATT_DEF_NODE () {14;} # not in the DOM Spec
+sub XML_DECL_NODE () {15;} # not in the DOM Spec
+sub ATTLIST_DECL_NODE () {16;} # not in the DOM Spec
+
+@NodeNames = (
+ "UNKNOWN_NODE", # not in the DOM Spec!
+
+ "ELEMENT_NODE",
+ "ATTRIBUTE_NODE",
+ "TEXT_NODE",
+ "CDATA_SECTION_NODE",
+ "ENTITY_REFERENCE_NODE",
+ "ENTITY_NODE",
+ "PROCESSING_INSTRUCTION_NODE",
+ "COMMENT_NODE",
+ "DOCUMENT_NODE",
+ "DOCUMENT_TYPE_NODE",
+ "DOCUMENT_FRAGMENT_NODE",
+ "NOTATION_NODE",
+
+ "ELEMENT_DECL_NODE",
+ "ATT_DEF_NODE",
+ "XML_DECL_NODE",
+ "ATTLIST_DECL_NODE"
+ );
+
+sub decoupleUsedIn
+{
+ my $self = shift;
+ undef $self->[_UsedIn]; # was delete
+}
+
+sub getParentNode
+{
+ $_[0]->[_Parent];
+}
+
+sub appendChild
+{
+ my ($self, $node) = @_;
+
+ # REC 7473
+ if ($XML::DOM::SafeMode)
+ {
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+ }
+
+ my $doc = $self->[_Doc];
+
+ if ($node->isDocumentFragmentNode)
+ {
+ if ($XML::DOM::SafeMode)
+ {
+ for my $n (@{$node->[_C]})
+ {
+ croak new XML::DOM::DOMException (WRONG_DOCUMENT_ERR,
+ "nodes belong to different documents")
+ if $doc != $n->[_Doc];
+
+ croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR,
+ "node is ancestor of parent node")
+ if $n->isAncestor ($self);
+
+ croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR,
+ "bad node type")
+ if $self->rejectChild ($n);
+ }
+ }
+
+ my @list = @{$node->[_C]}; # don't try to compress this
+ for my $n (@list)
+ {
+ $n->setParentNode ($self);
+ }
+ push @{$self->[_C]}, @list;
+ }
+ else
+ {
+ if ($XML::DOM::SafeMode)
+ {
+ croak new XML::DOM::DOMException (WRONG_DOCUMENT_ERR,
+ "nodes belong to different documents")
+ if $doc != $node->[_Doc];
+
+ croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR,
+ "node is ancestor of parent node")
+ if $node->isAncestor ($self);
+
+ croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR,
+ "bad node type")
+ if $self->rejectChild ($node);
+ }
+ $node->setParentNode ($self);
+ push @{$self->[_C]}, $node;
+ }
+ $node;
+}
+
+sub getChildNodes
+{
+ # NOTE: if node can't have children, $self->[_C] is undef.
+ my $kids = $_[0]->[_C];
+
+ # Return a list if called in list context.
+ wantarray ? (defined ($kids) ? @{ $kids } : ()) :
+ (defined ($kids) ? $kids : $XML::DOM::NodeList::EMPTY);
+}
+
+sub hasChildNodes
+{
+ my $kids = $_[0]->[_C];
+ defined ($kids) && @$kids > 0;
+}
+
+# This method is overriden in Document
+sub getOwnerDocument
+{
+ $_[0]->[_Doc];
+}
+
+sub getFirstChild
+{
+ my $kids = $_[0]->[_C];
+ defined $kids ? $kids->[0] : undef;
+}
+
+sub getLastChild
+{
+ my $kids = $_[0]->[_C];
+ defined $kids ? $kids->[-1] : undef;
+}
+
+sub getPreviousSibling
+{
+ my $self = shift;
+
+ my $pa = $self->[_Parent];
+ return undef unless $pa;
+ my $index = $pa->getChildIndex ($self);
+ return undef unless $index;
+
+ $pa->getChildAtIndex ($index - 1);
+}
+
+sub getNextSibling
+{
+ my $self = shift;
+
+ my $pa = $self->[_Parent];
+ return undef unless $pa;
+
+ $pa->getChildAtIndex ($pa->getChildIndex ($self) + 1);
+}
+
+sub insertBefore
+{
+ my ($self, $node, $refNode) = @_;
+
+ return $self->appendChild ($node) unless $refNode; # append at the end
+
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+
+ my @nodes = ($node);
+ @nodes = @{$node->[_C]}
+ if $node->getNodeType == DOCUMENT_FRAGMENT_NODE;
+
+ my $doc = $self->[_Doc];
+
+ for my $n (@nodes)
+ {
+ croak new XML::DOM::DOMException (WRONG_DOCUMENT_ERR,
+ "nodes belong to different documents")
+ if $doc != $n->[_Doc];
+
+ croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR,
+ "node is ancestor of parent node")
+ if $n->isAncestor ($self);
+
+ croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR,
+ "bad node type")
+ if $self->rejectChild ($n);
+ }
+ my $index = $self->getChildIndex ($refNode);
+
+ croak new XML::DOM::DOMException (NOT_FOUND_ERR,
+ "reference node not found")
+ if $index == -1;
+
+ for my $n (@nodes)
+ {
+ $n->setParentNode ($self);
+ }
+
+ splice (@{$self->[_C]}, $index, 0, @nodes);
+ $node;
+}
+
+sub replaceChild
+{
+ my ($self, $node, $refNode) = @_;
+
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+
+ my @nodes = ($node);
+ @nodes = @{$node->[_C]}
+ if $node->getNodeType == DOCUMENT_FRAGMENT_NODE;
+
+ for my $n (@nodes)
+ {
+ croak new XML::DOM::DOMException (WRONG_DOCUMENT_ERR,
+ "nodes belong to different documents")
+ if $self->[_Doc] != $n->[_Doc];
+
+ croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR,
+ "node is ancestor of parent node")
+ if $n->isAncestor ($self);
+
+ croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR,
+ "bad node type")
+ if $self->rejectChild ($n);
+ }
+
+ my $index = $self->getChildIndex ($refNode);
+ croak new XML::DOM::DOMException (NOT_FOUND_ERR,
+ "reference node not found")
+ if $index == -1;
+
+ for my $n (@nodes)
+ {
+ $n->setParentNode ($self);
+ }
+ splice (@{$self->[_C]}, $index, 1, @nodes);
+
+ $refNode->removeChildHoodMemories;
+ $refNode;
+}
+
+sub removeChild
+{
+ my ($self, $node) = @_;
+
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+
+ my $index = $self->getChildIndex ($node);
+
+ croak new XML::DOM::DOMException (NOT_FOUND_ERR,
+ "reference node not found")
+ if $index == -1;
+
+ splice (@{$self->[_C]}, $index, 1, ());
+
+ $node->removeChildHoodMemories;
+ $node;
+}
+
+# Merge all subsequent Text nodes in this subtree
+sub normalize
+{
+ my ($self) = shift;
+ my $prev = undef; # previous Text node
+
+ return unless defined $self->[_C];
+
+ my @nodes = @{$self->[_C]};
+ my $i = 0;
+ my $n = @nodes;
+ while ($i < $n)
+ {
+ my $node = $self->getChildAtIndex($i);
+ my $type = $node->getNodeType;
+
+ if (defined $prev)
+ {
+ # It should not merge CDATASections. Dom Spec says:
+ # Adjacent CDATASections nodes are not merged by use
+ # of the Element.normalize() method.
+ if ($type == TEXT_NODE)
+ {
+ $prev->appendData ($node->getData);
+ $self->removeChild ($node);
+ $i--;
+ $n--;
+ }
+ else
+ {
+ $prev = undef;
+ if ($type == ELEMENT_NODE)
+ {
+ $node->normalize;
+ if (defined $node->[_A])
+ {
+ for my $attr (@{$node->[_A]->getValues})
+ {
+ $attr->normalize;
+ }
+ }
+ }
+ }
+ }
+ else
+ {
+ if ($type == TEXT_NODE)
+ {
+ $prev = $node;
+ }
+ elsif ($type == ELEMENT_NODE)
+ {
+ $node->normalize;
+ if (defined $node->[_A])
+ {
+ for my $attr (@{$node->[_A]->getValues})
+ {
+ $attr->normalize;
+ }
+ }
+ }
+ }
+ $i++;
+ }
+}
+
+#
+# Return all Element nodes in the subtree that have the specified tagName.
+# If tagName is "*", all Element nodes are returned.
+# NOTE: the DOM Spec does not specify a 3rd or 4th parameter
+#
+sub getElementsByTagName
+{
+ my ($self, $tagName, $recurse, $list) = @_;
+ $recurse = 1 unless defined $recurse;
+ $list = (wantarray ? [] : new XML::DOM::NodeList) unless defined $list;
+
+ return unless defined $self->[_C];
+
+ # preorder traversal: check parent node first
+ for my $kid (@{$self->[_C]})
+ {
+ if ($kid->isElementNode)
+ {
+ if ($tagName eq "*" || $tagName eq $kid->getTagName)
+ {
+ push @{$list}, $kid;
+ }
+ $kid->getElementsByTagName ($tagName, $recurse, $list) if $recurse;
+ }
+ }
+ wantarray ? @{ $list } : $list;
+}
+
+sub getNodeValue
+{
+ undef;
+}
+
+sub setNodeValue
+{
+ # no-op
+}
+
+#
+# Redefined by XML::DOM::Element
+#
+sub getAttributes
+{
+ undef;
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+sub setOwnerDocument
+{
+ my ($self, $doc) = @_;
+ $self->[_Doc] = $doc;
+
+ return unless defined $self->[_C];
+
+ for my $kid (@{$self->[_C]})
+ {
+ $kid->setOwnerDocument ($doc);
+ }
+}
+
+sub cloneChildren
+{
+ my ($self, $node, $deep) = @_;
+ return unless $deep;
+
+ return unless defined $self->[_C];
+
+ local $XML::DOM::IgnoreReadOnly = 1;
+
+ for my $kid (@{$node->[_C]})
+ {
+ my $newNode = $kid->cloneNode ($deep);
+ push @{$self->[_C]}, $newNode;
+ $newNode->setParentNode ($self);
+ }
+}
+
+#
+# For internal use only!
+#
+sub removeChildHoodMemories
+{
+ my ($self) = @_;
+
+ undef $self->[_Parent]; # was delete
+}
+
+#
+# Remove circular dependencies. The Node and its children should
+# not be used afterwards.
+#
+sub dispose
+{
+ my $self = shift;
+
+ $self->removeChildHoodMemories;
+
+ if (defined $self->[_C])
+ {
+ $self->[_C]->dispose;
+ undef $self->[_C]; # was delete
+ }
+ undef $self->[_Doc]; # was delete
+}
+
+#
+# For internal use only!
+#
+sub setParentNode
+{
+ my ($self, $parent) = @_;
+
+ # REC 7473
+ my $oldParent = $self->[_Parent];
+ if (defined $oldParent)
+ {
+ # remove from current parent
+ my $index = $oldParent->getChildIndex ($self);
+
+ # NOTE: we don't have to check if [_C] is defined,
+ # because were removing a child here!
+ splice (@{$oldParent->[_C]}, $index, 1, ());
+
+ $self->removeChildHoodMemories;
+ }
+ $self->[_Parent] = $parent;
+}
+
+#
+# This function can return 3 values:
+# 1: always readOnly
+# 0: never readOnly
+# undef: depends on parent node
+#
+# Returns 1 for DocumentType, Notation, Entity, EntityReference, Attlist,
+# ElementDecl, AttDef.
+# The first 4 are readOnly according to the DOM Spec, the others are always
+# children of DocumentType. (Naturally, children of a readOnly node have to be
+# readOnly as well...)
+# These nodes are always readOnly regardless of who their ancestors are.
+# Other nodes, e.g. Comment, are readOnly only if their parent is readOnly,
+# which basically means that one of its ancestors has to be one of the
+# aforementioned node types.
+# Document and DocumentFragment return 0 for obvious reasons.
+# Attr, Element, CDATASection, Text return 0. The DOM spec says that they can
+# be children of an Entity, but I don't think that that's possible
+# with the current XML::Parser.
+# Attr uses a {ReadOnly} property, which is only set if it's part of a AttDef.
+# Always returns 0 if ignoreReadOnly is set.
+#
+sub isReadOnly
+{
+ # default implementation for Nodes that are always readOnly
+ ! $XML::DOM::IgnoreReadOnly;
+}
+
+sub rejectChild
+{
+ 1;
+}
+
+sub getNodeTypeName
+{
+ $NodeNames[$_[0]->getNodeType];
+}
+
+sub getChildIndex
+{
+ my ($self, $node) = @_;
+ my $i = 0;
+
+ return -1 unless defined $self->[_C];
+
+ for my $kid (@{$self->[_C]})
+ {
+ return $i if $kid == $node;
+ $i++;
+ }
+ -1;
+}
+
+sub getChildAtIndex
+{
+ my $kids = $_[0]->[_C];
+ defined ($kids) ? $kids->[$_[1]] : undef;
+}
+
+sub isAncestor
+{
+ my ($self, $node) = @_;
+
+ do
+ {
+ return 1 if $self == $node;
+ $node = $node->[_Parent];
+ }
+ while (defined $node);
+
+ 0;
+}
+
+#
+# Added for optimization. Overriden in XML::DOM::Text
+#
+sub isTextNode
+{
+ 0;
+}
+
+#
+# Added for optimization. Overriden in XML::DOM::DocumentFragment
+#
+sub isDocumentFragmentNode
+{
+ 0;
+}
+
+#
+# Added for optimization. Overriden in XML::DOM::Element
+#
+sub isElementNode
+{
+ 0;
+}
+
+#
+# Add a Text node with the specified value or append the text to the
+# previous Node if it is a Text node.
+#
+sub addText
+{
+ # REC 9456 (if it was called)
+ my ($self, $str) = @_;
+
+ my $node = ${$self->[_C]}[-1]; # $self->getLastChild
+
+ if (defined ($node) && $node->isTextNode)
+ {
+ # REC 5475 (if it was called)
+ $node->appendData ($str);
+ }
+ else
+ {
+ $node = $self->[_Doc]->createTextNode ($str);
+ $self->appendChild ($node);
+ }
+ $node;
+}
+
+#
+# Add a CDATASection node with the specified value or append the text to the
+# previous Node if it is a CDATASection node.
+#
+sub addCDATA
+{
+ my ($self, $str) = @_;
+
+ my $node = ${$self->[_C]}[-1]; # $self->getLastChild
+
+ if (defined ($node) && $node->getNodeType == CDATA_SECTION_NODE)
+ {
+ $node->appendData ($str);
+ }
+ else
+ {
+ $node = $self->[_Doc]->createCDATASection ($str);
+ $self->appendChild ($node);
+ }
+}
+
+sub removeChildNodes
+{
+ my $self = shift;
+
+ my $cref = $self->[_C];
+ return unless defined $cref;
+
+ my $kid;
+ while ($kid = pop @{$cref})
+ {
+ undef $kid->[_Parent]; # was delete
+ }
+}
+
+sub toString
+{
+ my $self = shift;
+ my $pr = $XML::DOM::PrintToString::Singleton;
+ $pr->reset;
+ $self->print ($pr);
+ $pr->toString;
+}
+
+sub to_sax
+{
+ my $self = shift;
+ unshift @_, 'Handler' if (@_ == 1);
+ my %h = @_;
+
+ my $doch = exists ($h{DocumentHandler}) ? $h{DocumentHandler}
+ : $h{Handler};
+ my $dtdh = exists ($h{DTDHandler}) ? $h{DTDHandler}
+ : $h{Handler};
+ my $enth = exists ($h{EntityResolver}) ? $h{EntityResolver}
+ : $h{Handler};
+
+ $self->_to_sax ($doch, $dtdh, $enth);
+}
+
+sub printToFile
+{
+ my ($self, $fileName) = @_;
+ my $fh = new FileHandle ($fileName, "w") ||
+ croak "printToFile - can't open output file $fileName";
+
+ $self->print ($fh);
+ $fh->close;
+}
+
+#
+# Use print to print to a FileHandle object (see printToFile code)
+#
+sub printToFileHandle
+{
+ my ($self, $FH) = @_;
+ my $pr = new XML::DOM::PrintToFileHandle ($FH);
+ $self->print ($pr);
+}
+
+#
+# Used by AttDef::setDefault to convert unexpanded default attribute value
+#
+sub expandEntityRefs
+{
+ my ($self, $str) = @_;
+ my $doctype = $self->[_Doc]->getDoctype;
+
+ $str =~ s/&($XML::RegExp::Name|(#([0-9]+)|#x([0-9a-fA-F]+)));/
+ defined($2) ? XML::DOM::XmlUtf8Encode ($3 || hex ($4))
+ : expandEntityRef ($1, $doctype)/ego;
+ $str;
+}
+
+sub expandEntityRef
+{
+ my ($entity, $doctype) = @_;
+
+ my $expanded = $XML::DOM::DefaultEntities{$entity};
+ return $expanded if defined $expanded;
+
+ $expanded = $doctype->getEntity ($entity);
+ return $expanded->getValue if (defined $expanded);
+
+#?? is this an error?
+ croak "Could not expand entity reference of [$entity]\n";
+# return "&$entity;"; # entity not found
+}
+
+sub isHidden
+{
+ $_[0]->[_Hidden];
+}
+
+######################################################################
+package XML::DOM::Attr;
+######################################################################
+
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("Name Specified", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+use Carp;
+
+sub new
+{
+ my ($class, $doc, $name, $value, $specified) = @_;
+
+ if ($XML::DOM::SafeMode)
+ {
+ croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR,
+ "bad Attr name [$name]")
+ unless XML::DOM::isValidName ($name);
+ }
+
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_C] = new XML::DOM::NodeList;
+ $self->[_Name] = $name;
+
+ if (defined $value)
+ {
+ $self->setValue ($value);
+ $self->[_Specified] = (defined $specified) ? $specified : 1;
+ }
+ else
+ {
+ $self->[_Specified] = 0;
+ }
+ $self;
+}
+
+sub getNodeType
+{
+ ATTRIBUTE_NODE;
+}
+
+sub isSpecified
+{
+ $_[0]->[_Specified];
+}
+
+sub getName
+{
+ $_[0]->[_Name];
+}
+
+sub getValue
+{
+ my $self = shift;
+ my $value = "";
+
+ for my $kid (@{$self->[_C]})
+ {
+ $value .= $kid->getData if defined $kid->getData;
+ }
+ $value;
+}
+
+sub setValue
+{
+ my ($self, $value) = @_;
+
+ # REC 1147
+ $self->removeChildNodes;
+ $self->appendChild ($self->[_Doc]->createTextNode ($value));
+ $self->[_Specified] = 1;
+}
+
+sub getNodeName
+{
+ $_[0]->getName;
+}
+
+sub getNodeValue
+{
+ $_[0]->getValue;
+}
+
+sub setNodeValue
+{
+ $_[0]->setValue ($_[1]);
+}
+
+sub cloneNode
+{
+ my ($self) = @_; # parameter deep is ignored
+
+ my $node = $self->[_Doc]->createAttribute ($self->getName);
+ $node->[_Specified] = $self->[_Specified];
+ $node->[_ReadOnly] = 1 if $self->[_ReadOnly];
+
+ $node->cloneChildren ($self, 1);
+ $node;
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+#
+
+sub isReadOnly
+{
+ # ReadOnly property is set if it's part of a AttDef
+ ! $XML::DOM::IgnoreReadOnly && defined ($_[0]->[_ReadOnly]);
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ my $name = $self->[_Name];
+
+ $FILE->print ("$name=\"");
+ for my $kid (@{$self->[_C]})
+ {
+ if ($kid->getNodeType == TEXT_NODE)
+ {
+ $FILE->print (XML::DOM::encodeAttrValue ($kid->getData));
+ }
+ else # ENTITY_REFERENCE_NODE
+ {
+ $kid->print ($FILE);
+ }
+ }
+ $FILE->print ("\"");
+}
+
+sub rejectChild
+{
+ my $t = $_[1]->getNodeType;
+
+ $t != TEXT_NODE
+ && $t != ENTITY_REFERENCE_NODE;
+}
+
+######################################################################
+package XML::DOM::ProcessingInstruction;
+######################################################################
+
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("Target Data", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+use Carp;
+
+sub new
+{
+ my ($class, $doc, $target, $data, $hidden) = @_;
+
+ croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR,
+ "bad ProcessingInstruction Target [$target]")
+ unless (XML::DOM::isValidName ($target) && $target !~ /^xml$/io);
+
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_Target] = $target;
+ $self->[_Data] = $data;
+ $self->[_Hidden] = $hidden;
+ $self;
+}
+
+sub getNodeType
+{
+ PROCESSING_INSTRUCTION_NODE;
+}
+
+sub getTarget
+{
+ $_[0]->[_Target];
+}
+
+sub getData
+{
+ $_[0]->[_Data];
+}
+
+sub setData
+{
+ my ($self, $data) = @_;
+
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+
+ $self->[_Data] = $data;
+}
+
+sub getNodeName
+{
+ $_[0]->[_Target];
+}
+
+#
+# Same as getData
+#
+sub getNodeValue
+{
+ $_[0]->[_Data];
+}
+
+sub setNodeValue
+{
+ $_[0]->setData ($_[1]);
+}
+
+sub cloneNode
+{
+ my $self = shift;
+ $self->[_Doc]->createProcessingInstruction ($self->getTarget,
+ $self->getData,
+ $self->isHidden);
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+sub isReadOnly
+{
+ return 0 if $XML::DOM::IgnoreReadOnly;
+
+ my $pa = $_[0]->[_Parent];
+ defined ($pa) ? $pa->isReadOnly : 0;
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ $FILE->print ("<?");
+ $FILE->print ($self->[_Target]);
+ $FILE->print (" ");
+ $FILE->print (XML::DOM::encodeProcessingInstruction ($self->[_Data]));
+ $FILE->print ("?>");
+}
+
+sub _to_sax {
+ my ($self, $doch) = @_;
+ $doch->processing_instruction({Target => $self->getTarget, Data => $self->getData});
+}
+
+######################################################################
+package XML::DOM::Notation;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("Name Base SysId PubId", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+use Carp;
+
+sub new
+{
+ my ($class, $doc, $name, $base, $sysId, $pubId, $hidden) = @_;
+
+ croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR,
+ "bad Notation Name [$name]")
+ unless XML::DOM::isValidName ($name);
+
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_Name] = $name;
+ $self->[_Base] = $base;
+ $self->[_SysId] = $sysId;
+ $self->[_PubId] = $pubId;
+ $self->[_Hidden] = $hidden;
+ $self;
+}
+
+sub getNodeType
+{
+ NOTATION_NODE;
+}
+
+sub getPubId
+{
+ $_[0]->[_PubId];
+}
+
+sub setPubId
+{
+ $_[0]->[_PubId] = $_[1];
+}
+
+sub getSysId
+{
+ $_[0]->[_SysId];
+}
+
+sub setSysId
+{
+ $_[0]->[_SysId] = $_[1];
+}
+
+sub getName
+{
+ $_[0]->[_Name];
+}
+
+sub setName
+{
+ $_[0]->[_Name] = $_[1];
+}
+
+sub getBase
+{
+ $_[0]->[_Base];
+}
+
+sub getNodeName
+{
+ $_[0]->[_Name];
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ my $name = $self->[_Name];
+ my $sysId = $self->[_SysId];
+ my $pubId = $self->[_PubId];
+
+ $FILE->print ("<!NOTATION $name ");
+
+ if (defined $pubId)
+ {
+ $FILE->print (" PUBLIC \"$pubId\"");
+ }
+ if (defined $sysId)
+ {
+ $FILE->print (" SYSTEM \"$sysId\"");
+ }
+ $FILE->print (">");
+}
+
+sub cloneNode
+{
+ my ($self) = @_;
+ $self->[_Doc]->createNotation ($self->[_Name], $self->[_Base],
+ $self->[_SysId], $self->[_PubId],
+ $self->[_Hidden]);
+}
+
+sub to_expat
+{
+ my ($self, $iter) = @_;
+ $iter->Notation ($self->getName, $self->getBase,
+ $self->getSysId, $self->getPubId);
+}
+
+sub _to_sax
+{
+ my ($self, $doch, $dtdh, $enth) = @_;
+ $dtdh->notation_decl ( { Name => $self->getName,
+ Base => $self->getBase,
+ SystemId => $self->getSysId,
+ PublicId => $self->getPubId });
+}
+
+######################################################################
+package XML::DOM::Entity;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("NotationName Parameter Value Ndata SysId PubId", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+use Carp;
+
+sub new
+{
+ my ($class, $doc, $notationName, $value, $sysId, $pubId, $ndata, $isParam, $hidden) = @_;
+
+ croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR,
+ "bad Entity Name [$notationName]")
+ unless XML::DOM::isValidName ($notationName);
+
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_NotationName] = $notationName;
+ $self->[_Parameter] = $isParam;
+ $self->[_Value] = $value;
+ $self->[_Ndata] = $ndata;
+ $self->[_SysId] = $sysId;
+ $self->[_PubId] = $pubId;
+ $self->[_Hidden] = $hidden;
+ $self;
+#?? maybe Value should be a Text node
+}
+
+sub getNodeType
+{
+ ENTITY_NODE;
+}
+
+sub getPubId
+{
+ $_[0]->[_PubId];
+}
+
+sub getSysId
+{
+ $_[0]->[_SysId];
+}
+
+# Dom Spec says:
+# For unparsed entities, the name of the notation for the
+# entity. For parsed entities, this is null.
+
+#?? do we have unparsed entities?
+sub getNotationName
+{
+ $_[0]->[_NotationName];
+}
+
+sub getNodeName
+{
+ $_[0]->[_NotationName];
+}
+
+sub cloneNode
+{
+ my $self = shift;
+ $self->[_Doc]->createEntity ($self->[_NotationName], $self->[_Value],
+ $self->[_SysId], $self->[_PubId],
+ $self->[_Ndata], $self->[_Parameter], $self->[_Hidden]);
+}
+
+sub rejectChild
+{
+ return 1;
+#?? if value is split over subnodes, recode this section
+# also add: C => new XML::DOM::NodeList,
+
+ my $t = $_[1];
+
+ return $t == TEXT_NODE
+ || $t == ENTITY_REFERENCE_NODE
+ || $t == PROCESSING_INSTRUCTION_NODE
+ || $t == COMMENT_NODE
+ || $t == CDATA_SECTION_NODE
+ || $t == ELEMENT_NODE;
+}
+
+sub getValue
+{
+ $_[0]->[_Value];
+}
+
+sub isParameterEntity
+{
+ $_[0]->[_Parameter];
+}
+
+sub getNdata
+{
+ $_[0]->[_Ndata];
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ my $name = $self->[_NotationName];
+
+ my $par = $self->isParameterEntity ? "% " : "";
+
+ $FILE->print ("<!ENTITY $par$name");
+
+ my $value = $self->[_Value];
+ my $sysId = $self->[_SysId];
+ my $pubId = $self->[_PubId];
+ my $ndata = $self->[_Ndata];
+
+ if (defined $value)
+ {
+#?? Not sure what to do if it contains both single and double quote
+ $value = ($value =~ /\"/) ? "'$value'" : "\"$value\"";
+ $FILE->print (" $value");
+ }
+ if (defined $pubId)
+ {
+ $FILE->print (" PUBLIC \"$pubId\"");
+ }
+ elsif (defined $sysId)
+ {
+ $FILE->print (" SYSTEM");
+ }
+
+ if (defined $sysId)
+ {
+ $FILE->print (" \"$sysId\"");
+ }
+ $FILE->print (" NDATA $ndata") if defined $ndata;
+ $FILE->print (">");
+}
+
+sub to_expat
+{
+ my ($self, $iter) = @_;
+ my $name = ($self->isParameterEntity ? '%' : "") . $self->getNotationName;
+ $iter->Entity ($name,
+ $self->getValue, $self->getSysId, $self->getPubId,
+ $self->getNdata);
+}
+
+sub _to_sax
+{
+ my ($self, $doch, $dtdh, $enth) = @_;
+ my $name = ($self->isParameterEntity ? '%' : "") . $self->getNotationName;
+ $dtdh->entity_decl ( { Name => $name,
+ Value => $self->getValue,
+ SystemId => $self->getSysId,
+ PublicId => $self->getPubId,
+ Notation => $self->getNdata } );
+}
+
+######################################################################
+package XML::DOM::EntityReference;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("EntityName Parameter NoExpand", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+use Carp;
+
+sub new
+{
+ my ($class, $doc, $name, $parameter, $noExpand) = @_;
+
+ croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR,
+ "bad Entity Name [$name] in EntityReference")
+ unless XML::DOM::isValidName ($name);
+
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_EntityName] = $name;
+ $self->[_Parameter] = ($parameter || 0);
+ $self->[_NoExpand] = ($noExpand || 0);
+
+ $self;
+}
+
+sub getNodeType
+{
+ ENTITY_REFERENCE_NODE;
+}
+
+sub getNodeName
+{
+ $_[0]->[_EntityName];
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+sub getEntityName
+{
+ $_[0]->[_EntityName];
+}
+
+sub isParameterEntity
+{
+ $_[0]->[_Parameter];
+}
+
+sub getData
+{
+ my $self = shift;
+ my $name = $self->[_EntityName];
+ my $parameter = $self->[_Parameter];
+
+ my $data;
+ if ($self->[_NoExpand]) {
+ $data = "&$name;" if $name;
+ } else {
+ $data = $self->[_Doc]->expandEntity ($name, $parameter);
+ }
+
+ unless (defined $data)
+ {
+#?? this is probably an error, but perhaps requires check to NoExpand
+# will fix it?
+ my $pc = $parameter ? "%" : "&";
+ $data = "$pc$name;";
+ }
+ $data;
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ my $name = $self->[_EntityName];
+
+#?? or do we expand the entities?
+
+ my $pc = $self->[_Parameter] ? "%" : "&";
+ $FILE->print ("$pc$name;");
+}
+
+# Dom Spec says:
+# [...] but if such an Entity exists, then
+# the child list of the EntityReference node is the same as that of the
+# Entity node.
+#
+# The resolution of the children of the EntityReference (the replacement
+# value of the referenced Entity) may be lazily evaluated; actions by the
+# user (such as calling the childNodes method on the EntityReference
+# node) are assumed to trigger the evaluation.
+sub getChildNodes
+{
+ my $self = shift;
+ my $entity = $self->[_Doc]->getEntity ($self->[_EntityName]);
+ defined ($entity) ? $entity->getChildNodes : new XML::DOM::NodeList;
+}
+
+sub cloneNode
+{
+ my $self = shift;
+ $self->[_Doc]->createEntityReference ($self->[_EntityName],
+ $self->[_Parameter],
+ $self->[_NoExpand],
+ );
+}
+
+sub to_expat
+{
+ my ($self, $iter) = @_;
+ $iter->EntityRef ($self->getEntityName, $self->isParameterEntity);
+}
+
+sub _to_sax
+{
+ my ($self, $doch, $dtdh, $enth) = @_;
+ my @par = $self->isParameterEntity ? (Parameter => 1) : ();
+#?? not supported by PerlSAX: $self->isParameterEntity
+
+ $doch->entity_reference ( { Name => $self->getEntityName, @par } );
+}
+
+# NOTE: an EntityReference can't really have children, so rejectChild
+# is not reimplemented (i.e. it always returns 0.)
+
+######################################################################
+package XML::DOM::AttDef;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("Name Type Fixed Default Required Implied Quote", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+use Carp;
+
+#------------------------------------------------------------
+# Extra method implementations
+
+# AttDef is not part of DOM Spec
+sub new
+{
+ my ($class, $doc, $name, $attrType, $default, $fixed, $hidden) = @_;
+
+ croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR,
+ "bad Attr name in AttDef [$name]")
+ unless XML::DOM::isValidName ($name);
+
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_Name] = $name;
+ $self->[_Type] = $attrType;
+
+ if (defined $default)
+ {
+ if ($default eq "#REQUIRED")
+ {
+ $self->[_Required] = 1;
+ }
+ elsif ($default eq "#IMPLIED")
+ {
+ $self->[_Implied] = 1;
+ }
+ else
+ {
+ # strip off quotes - see Attlist handler in XML::Parser
+ # this regexp doesn't work with 5.8.0 unicode
+# $default =~ m#^(["'])(.*)['"]$#;
+# $self->[_Quote] = $1; # keep track of the quote character
+# $self->[_Default] = $self->setDefault ($2);
+
+ # workaround for 5.8.0 unicode
+ $default =~ s!^(["'])!!;
+ $self->[_Quote] = $1;
+ $default =~ s!(["'])$!!;
+ $self->[_Default] = $self->setDefault ($default);
+
+#?? should default value be decoded - what if it contains e.g. "&amp;"
+ }
+ }
+ $self->[_Fixed] = $fixed if defined $fixed;
+ $self->[_Hidden] = $hidden if defined $hidden;
+
+ $self;
+}
+
+sub getNodeType
+{
+ ATT_DEF_NODE;
+}
+
+sub getName
+{
+ $_[0]->[_Name];
+}
+
+# So it can be added to a NamedNodeMap
+sub getNodeName
+{
+ $_[0]->[_Name];
+}
+
+sub getType
+{
+ $_[0]->[_Type];
+}
+
+sub setType
+{
+ $_[0]->[_Type] = $_[1];
+}
+
+sub getDefault
+{
+ $_[0]->[_Default];
+}
+
+sub setDefault
+{
+ my ($self, $value) = @_;
+
+ # specified=0, it's the default !
+ my $attr = $self->[_Doc]->createAttribute ($self->[_Name], undef, 0);
+ $attr->[_ReadOnly] = 1;
+
+#?? this should be split over Text and EntityReference nodes, just like other
+# Attr nodes - just expand the text for now
+ $value = $self->expandEntityRefs ($value);
+ $attr->addText ($value);
+#?? reimplement in NoExpand mode!
+
+ $attr;
+}
+
+sub isFixed
+{
+ $_[0]->[_Fixed] || 0;
+}
+
+sub isRequired
+{
+ $_[0]->[_Required] || 0;
+}
+
+sub isImplied
+{
+ $_[0]->[_Implied] || 0;
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ my $name = $self->[_Name];
+ my $type = $self->[_Type];
+ my $fixed = $self->[_Fixed];
+ my $default = $self->[_Default];
+
+# $FILE->print ("$name $type");
+ # replaced line above with the two lines below
+ # seems to be a bug in perl 5.6.0 that causes
+ # test 3 of dom_jp_attr.t to fail?
+ $FILE->print ($name);
+ $FILE->print (" $type");
+
+ $FILE->print (" #FIXED") if defined $fixed;
+
+ if ($self->[_Required])
+ {
+ $FILE->print (" #REQUIRED");
+ }
+ elsif ($self->[_Implied])
+ {
+ $FILE->print (" #IMPLIED");
+ }
+ elsif (defined ($default))
+ {
+ my $quote = $self->[_Quote];
+ $FILE->print (" $quote");
+ for my $kid (@{$default->[_C]})
+ {
+ $kid->print ($FILE);
+ }
+ $FILE->print ($quote);
+ }
+}
+
+sub getDefaultString
+{
+ my $self = shift;
+ my $default;
+
+ if ($self->[_Required])
+ {
+ return "#REQUIRED";
+ }
+ elsif ($self->[_Implied])
+ {
+ return "#IMPLIED";
+ }
+ elsif (defined ($default = $self->[_Default]))
+ {
+ my $quote = $self->[_Quote];
+ $default = $default->toString;
+ return "$quote$default$quote";
+ }
+ undef;
+}
+
+sub cloneNode
+{
+ my $self = shift;
+ my $node = new XML::DOM::AttDef ($self->[_Doc], $self->[_Name], $self->[_Type],
+ undef, $self->[_Fixed]);
+
+ $node->[_Required] = 1 if $self->[_Required];
+ $node->[_Implied] = 1 if $self->[_Implied];
+ $node->[_Fixed] = $self->[_Fixed] if defined $self->[_Fixed];
+ $node->[_Hidden] = $self->[_Hidden] if defined $self->[_Hidden];
+
+ if (defined $self->[_Default])
+ {
+ $node->[_Default] = $self->[_Default]->cloneNode(1);
+ }
+ $node->[_Quote] = $self->[_Quote];
+
+ $node;
+}
+
+sub setOwnerDocument
+{
+ my ($self, $doc) = @_;
+ $self->SUPER::setOwnerDocument ($doc);
+
+ if (defined $self->[_Default])
+ {
+ $self->[_Default]->setOwnerDocument ($doc);
+ }
+}
+
+######################################################################
+package XML::DOM::AttlistDecl;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ import XML::DOM::AttDef qw{ :Fields };
+
+ XML::DOM::def_fields ("ElementName", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+use Carp;
+
+#------------------------------------------------------------
+# Extra method implementations
+
+# AttlistDecl is not part of the DOM Spec
+sub new
+{
+ my ($class, $doc, $name) = @_;
+
+ croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR,
+ "bad Element TagName [$name] in AttlistDecl")
+ unless XML::DOM::isValidName ($name);
+
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_C] = new XML::DOM::NodeList;
+ $self->[_ReadOnly] = 1;
+ $self->[_ElementName] = $name;
+
+ $self->[_A] = new XML::DOM::NamedNodeMap (Doc => $doc,
+ ReadOnly => 1,
+ Parent => $self);
+
+ $self;
+}
+
+sub getNodeType
+{
+ ATTLIST_DECL_NODE;
+}
+
+sub getName
+{
+ $_[0]->[_ElementName];
+}
+
+sub getNodeName
+{
+ $_[0]->[_ElementName];
+}
+
+sub getAttDef
+{
+ my ($self, $attrName) = @_;
+ $self->[_A]->getNamedItem ($attrName);
+}
+
+sub addAttDef
+{
+ my ($self, $attrName, $type, $default, $fixed, $hidden) = @_;
+ my $node = $self->getAttDef ($attrName);
+
+ if (defined $node)
+ {
+ # data will be ignored if already defined
+ my $elemName = $self->getName;
+ XML::DOM::warning ("multiple definitions of attribute $attrName for element $elemName, only first one is recognized");
+ }
+ else
+ {
+ $node = new XML::DOM::AttDef ($self->[_Doc], $attrName, $type,
+ $default, $fixed, $hidden);
+ $self->[_A]->setNamedItem ($node);
+ }
+ $node;
+}
+
+sub getDefaultAttrValue
+{
+ my ($self, $attr) = @_;
+ my $attrNode = $self->getAttDef ($attr);
+ (defined $attrNode) ? $attrNode->getDefault : undef;
+}
+
+sub cloneNode
+{
+ my ($self, $deep) = @_;
+ my $node = $self->[_Doc]->createAttlistDecl ($self->[_ElementName]);
+
+ $node->[_A] = $self->[_A]->cloneNode ($deep);
+ $node;
+}
+
+sub setOwnerDocument
+{
+ my ($self, $doc) = @_;
+ $self->SUPER::setOwnerDocument ($doc);
+
+ $self->[_A]->setOwnerDocument ($doc);
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ my $name = $self->getName;
+ my @attlist = @{$self->[_A]->getValues};
+
+ my $hidden = 1;
+ for my $att (@attlist)
+ {
+ unless ($att->[_Hidden])
+ {
+ $hidden = 0;
+ last;
+ }
+ }
+
+ unless ($hidden)
+ {
+ $FILE->print ("<!ATTLIST $name");
+
+ if (@attlist == 1)
+ {
+ $FILE->print (" ");
+ $attlist[0]->print ($FILE);
+ }
+ else
+ {
+ for my $attr (@attlist)
+ {
+ next if $attr->[_Hidden];
+
+ $FILE->print ("\x0A ");
+ $attr->print ($FILE);
+ }
+ }
+ $FILE->print (">");
+ }
+}
+
+sub to_expat
+{
+ my ($self, $iter) = @_;
+ my $tag = $self->getName;
+ for my $a ($self->[_A]->getValues)
+ {
+ my $default = $a->isImplied ? '#IMPLIED' :
+ ($a->isRequired ? '#REQUIRED' :
+ ($a->[_Quote] . $a->getDefault->getValue . $a->[_Quote]));
+
+ $iter->Attlist ($tag, $a->getName, $a->getType, $default, $a->isFixed);
+ }
+}
+
+sub _to_sax
+{
+ my ($self, $doch, $dtdh, $enth) = @_;
+ my $tag = $self->getName;
+ for my $a ($self->[_A]->getValues)
+ {
+ my $default = $a->isImplied ? '#IMPLIED' :
+ ($a->isRequired ? '#REQUIRED' :
+ ($a->[_Quote] . $a->getDefault->getValue . $a->[_Quote]));
+
+ $dtdh->attlist_decl ({ ElementName => $tag,
+ AttributeName => $a->getName,
+ Type => $a->[_Type],
+ Default => $default,
+ Fixed => $a->isFixed });
+ }
+}
+
+######################################################################
+package XML::DOM::ElementDecl;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("Name Model", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+use Carp;
+
+
+#------------------------------------------------------------
+# Extra method implementations
+
+# ElementDecl is not part of the DOM Spec
+sub new
+{
+ my ($class, $doc, $name, $model, $hidden) = @_;
+
+ croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR,
+ "bad Element TagName [$name] in ElementDecl")
+ unless XML::DOM::isValidName ($name);
+
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_Name] = $name;
+ $self->[_ReadOnly] = 1;
+ $self->[_Model] = $model;
+ $self->[_Hidden] = $hidden;
+ $self;
+}
+
+sub getNodeType
+{
+ ELEMENT_DECL_NODE;
+}
+
+sub getName
+{
+ $_[0]->[_Name];
+}
+
+sub getNodeName
+{
+ $_[0]->[_Name];
+}
+
+sub getModel
+{
+ $_[0]->[_Model];
+}
+
+sub setModel
+{
+ my ($self, $model) = @_;
+
+ $self->[_Model] = $model;
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ my $name = $self->[_Name];
+ my $model = $self->[_Model];
+
+ $FILE->print ("<!ELEMENT $name $model>")
+ unless $self->[_Hidden];
+}
+
+sub cloneNode
+{
+ my $self = shift;
+ $self->[_Doc]->createElementDecl ($self->[_Name], $self->[_Model],
+ $self->[_Hidden]);
+}
+
+sub to_expat
+{
+#?? add support for Hidden?? (allover, also in _to_sax!!)
+
+ my ($self, $iter) = @_;
+ $iter->Element ($self->getName, $self->getModel);
+}
+
+sub _to_sax
+{
+ my ($self, $doch, $dtdh, $enth) = @_;
+ $dtdh->element_decl ( { Name => $self->getName,
+ Model => $self->getModel } );
+}
+
+######################################################################
+package XML::DOM::Element;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("TagName", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+use XML::DOM::NamedNodeMap;
+use Carp;
+
+sub new
+{
+ my ($class, $doc, $tagName) = @_;
+
+ if ($XML::DOM::SafeMode)
+ {
+ croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR,
+ "bad Element TagName [$tagName]")
+ unless XML::DOM::isValidName ($tagName);
+ }
+
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_C] = new XML::DOM::NodeList;
+ $self->[_TagName] = $tagName;
+
+# Now we're creating the NamedNodeMap only when needed (REC 2313 => 1147)
+# $self->[_A] = new XML::DOM::NamedNodeMap (Doc => $doc,
+# Parent => $self);
+
+ $self;
+}
+
+sub getNodeType
+{
+ ELEMENT_NODE;
+}
+
+sub getTagName
+{
+ $_[0]->[_TagName];
+}
+
+sub getNodeName
+{
+ $_[0]->[_TagName];
+}
+
+sub getAttributeNode
+{
+ my ($self, $name) = @_;
+ return undef unless defined $self->[_A];
+
+ $self->getAttributes->{$name};
+}
+
+sub getAttribute
+{
+ my ($self, $name) = @_;
+ my $attr = $self->getAttributeNode ($name);
+ (defined $attr) ? $attr->getValue : "";
+}
+
+sub setAttribute
+{
+ my ($self, $name, $val) = @_;
+
+ croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR,
+ "bad Attr Name [$name]")
+ unless XML::DOM::isValidName ($name);
+
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+
+ my $node = $self->getAttributes->{$name};
+ if (defined $node)
+ {
+ $node->setValue ($val);
+ }
+ else
+ {
+ $node = $self->[_Doc]->createAttribute ($name, $val);
+ $self->[_A]->setNamedItem ($node);
+ }
+}
+
+sub setAttributeNode
+{
+ my ($self, $node) = @_;
+ my $attr = $self->getAttributes;
+ my $name = $node->getNodeName;
+
+ # REC 1147
+ if ($XML::DOM::SafeMode)
+ {
+ croak new XML::DOM::DOMException (WRONG_DOCUMENT_ERR,
+ "nodes belong to different documents")
+ if $self->[_Doc] != $node->[_Doc];
+
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+
+ my $attrParent = $node->[_UsedIn];
+ croak new XML::DOM::DOMException (INUSE_ATTRIBUTE_ERR,
+ "Attr is already used by another Element")
+ if (defined ($attrParent) && $attrParent != $attr);
+ }
+
+ my $other = $attr->{$name};
+ $attr->removeNamedItem ($name) if defined $other;
+
+ $attr->setNamedItem ($node);
+
+ $other;
+}
+
+sub removeAttributeNode
+{
+ my ($self, $node) = @_;
+
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+
+ my $attr = $self->[_A];
+ unless (defined $attr)
+ {
+ croak new XML::DOM::DOMException (NOT_FOUND_ERR);
+ return undef;
+ }
+
+ my $name = $node->getNodeName;
+ my $attrNode = $attr->getNamedItem ($name);
+
+#?? should it croak if it's the default value?
+ croak new XML::DOM::DOMException (NOT_FOUND_ERR)
+ unless $node == $attrNode;
+
+ # Not removing anything if it's the default value already
+ return undef unless $node->isSpecified;
+
+ $attr->removeNamedItem ($name);
+
+ # Substitute with default value if it's defined
+ my $default = $self->getDefaultAttrValue ($name);
+ if (defined $default)
+ {
+ local $XML::DOM::IgnoreReadOnly = 1;
+
+ $default = $default->cloneNode (1);
+ $attr->setNamedItem ($default);
+ }
+ $node;
+}
+
+sub removeAttribute
+{
+ my ($self, $name) = @_;
+ my $attr = $self->[_A];
+ unless (defined $attr)
+ {
+ croak new XML::DOM::DOMException (NOT_FOUND_ERR);
+ return;
+ }
+
+ my $node = $attr->getNamedItem ($name);
+ if (defined $node)
+ {
+#?? could use dispose() to remove circular references for gc, but what if
+#?? somebody is referencing it?
+ $self->removeAttributeNode ($node);
+ }
+}
+
+sub cloneNode
+{
+ my ($self, $deep) = @_;
+ my $node = $self->[_Doc]->createElement ($self->getTagName);
+
+ # Always clone the Attr nodes, even if $deep == 0
+ if (defined $self->[_A])
+ {
+ $node->[_A] = $self->[_A]->cloneNode (1); # deep=1
+ $node->[_A]->setParentNode ($node);
+ }
+
+ $node->cloneChildren ($self, $deep);
+ $node;
+}
+
+sub getAttributes
+{
+ $_[0]->[_A] ||= XML::DOM::NamedNodeMap->new (Doc => $_[0]->[_Doc],
+ Parent => $_[0]);
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+# Added for convenience
+sub setTagName
+{
+ my ($self, $tagName) = @_;
+
+ croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR,
+ "bad Element TagName [$tagName]")
+ unless XML::DOM::isValidName ($tagName);
+
+ $self->[_TagName] = $tagName;
+}
+
+sub isReadOnly
+{
+ 0;
+}
+
+# Added for optimization.
+sub isElementNode
+{
+ 1;
+}
+
+sub rejectChild
+{
+ my $t = $_[1]->getNodeType;
+
+ $t != TEXT_NODE
+ && $t != ENTITY_REFERENCE_NODE
+ && $t != PROCESSING_INSTRUCTION_NODE
+ && $t != COMMENT_NODE
+ && $t != CDATA_SECTION_NODE
+ && $t != ELEMENT_NODE;
+}
+
+sub getDefaultAttrValue
+{
+ my ($self, $attr) = @_;
+ $self->[_Doc]->getDefaultAttrValue ($self->[_TagName], $attr);
+}
+
+sub dispose
+{
+ my $self = shift;
+
+ $self->[_A]->dispose if defined $self->[_A];
+ $self->SUPER::dispose;
+}
+
+sub setOwnerDocument
+{
+ my ($self, $doc) = @_;
+ $self->SUPER::setOwnerDocument ($doc);
+
+ $self->[_A]->setOwnerDocument ($doc) if defined $self->[_A];
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ my $name = $self->[_TagName];
+
+ if ($XML::DOM::beautifying) {
+ for (my $i = 0; $i < $XML::DOM::current_indent; $i++) {
+ $FILE->print ($XML::DOM::string_indent);
+ }
+ }
+
+ $FILE->print ("<$name");
+
+ if (defined $self->[_A])
+ {
+ for my $att (@{$self->[_A]->getValues})
+ {
+ # skip un-specified (default) Attr nodes
+ if ($att->isSpecified)
+ {
+ $FILE->print (" ");
+ $att->print ($FILE);
+ }
+ }
+ }
+
+ my @kids = @{$self->[_C]};
+ if (@kids > 0)
+ {
+ $FILE->print (">");
+ $XML::DOM::current_print_level++;
+ if ($XML::DOM::beautifying)
+ {
+ if ($#kids > 0 || ! $kids[0]->isTextNode)
+ {
+ $FILE->print ("\n");
+ }
+ $XML::DOM::current_indent++;
+ }
+ for my $kid (@kids)
+ {
+ $kid->print ($FILE);
+ }
+ if ($XML::DOM::beautifying)
+ {
+ $XML::DOM::current_indent--;
+ if ($#kids > 0|| ($#kids == 0 && ! $kids[0]->isTextNode) || $XML::DOM::need_indent[$XML::DOM::current_print_level])
+ {
+ for (my $i = 0; $i < $XML::DOM::current_indent; $i++)
+ {
+ $FILE->print ($XML::DOM::string_indent);
+ }
+ }
+ $XML::DOM::need_indent[$XML::DOM::current_print_level] = 0;
+ }
+ $FILE->print ("</$name>");
+ $XML::DOM::current_print_level--;
+ if ($XML::DOM::beautifying)
+ {
+ $FILE->print ("\n");
+ }
+ }
+ else
+ {
+ my $style = &$XML::DOM::TagStyle ($name, $self);
+ if ($style == 0)
+ {
+ $FILE->print ("/>");
+ }
+ elsif ($style == 1)
+ {
+ $FILE->print ("></$name>");
+ }
+ else
+ {
+ $FILE->print (" />");
+ }
+ if ($XML::DOM::beautifying)
+ {
+ $FILE->print ("\n");
+ }
+ }
+}
+
+sub check
+{
+ my ($self, $checker) = @_;
+ die "Usage: \$xml_dom_elem->check (\$checker)" unless $checker;
+
+ $checker->InitDomElem;
+ $self->to_expat ($checker);
+ $checker->FinalDomElem;
+}
+
+sub to_expat
+{
+ my ($self, $iter) = @_;
+
+ my $tag = $self->getTagName;
+ $iter->Start ($tag);
+
+ if (defined $self->[_A])
+ {
+ for my $attr ($self->[_A]->getValues)
+ {
+ $iter->Attr ($tag, $attr->getName, $attr->getValue, $attr->isSpecified);
+ }
+ }
+
+ $iter->EndAttr;
+
+ for my $kid ($self->getChildNodes)
+ {
+ $kid->to_expat ($iter);
+ }
+
+ $iter->End;
+}
+
+sub _to_sax
+{
+ my ($self, $doch, $dtdh, $enth) = @_;
+
+ my $tag = $self->getTagName;
+
+ my @attr = ();
+ my $attrOrder;
+ my $attrDefaulted;
+
+ if (defined $self->[_A])
+ {
+ my @spec = (); # names of specified attributes
+ my @unspec = (); # names of defaulted attributes
+
+ for my $attr ($self->[_A]->getValues)
+ {
+ my $attrName = $attr->getName;
+ push @attr, $attrName, $attr->getValue;
+ if ($attr->isSpecified)
+ {
+ push @spec, $attrName;
+ }
+ else
+ {
+ push @unspec, $attrName;
+ }
+ }
+ $attrOrder = [ @spec, @unspec ];
+ $attrDefaulted = @spec;
+ }
+ $doch->start_element (defined $attrOrder ?
+ { Name => $tag,
+ Attributes => { @attr },
+ AttributeOrder => $attrOrder,
+ Defaulted => $attrDefaulted
+ } :
+ { Name => $tag,
+ Attributes => { @attr }
+ }
+ );
+
+ for my $kid ($self->getChildNodes)
+ {
+ $kid->_to_sax ($doch, $dtdh, $enth);
+ }
+
+ $doch->end_element ( { Name => $tag } );
+}
+
+######################################################################
+package XML::DOM::CharacterData;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("Data", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+use Carp;
+
+
+#
+# CharacterData nodes should never be created directly, only subclassed!
+#
+sub new
+{
+ my ($class, $doc, $data) = @_;
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_Data] = $data;
+ $self;
+}
+
+sub appendData
+{
+ my ($self, $data) = @_;
+
+ if ($XML::DOM::SafeMode)
+ {
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+ }
+ $self->[_Data] .= $data;
+}
+
+sub deleteData
+{
+ my ($self, $offset, $count) = @_;
+
+ croak new XML::DOM::DOMException (INDEX_SIZE_ERR,
+ "bad offset [$offset]")
+ if ($offset < 0 || $offset >= length ($self->[_Data]));
+#?? DOM Spec says >, but >= makes more sense!
+
+ croak new XML::DOM::DOMException (INDEX_SIZE_ERR,
+ "negative count [$count]")
+ if $count < 0;
+
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+
+ substr ($self->[_Data], $offset, $count) = "";
+}
+
+sub getData
+{
+ $_[0]->[_Data];
+}
+
+sub getLength
+{
+ length $_[0]->[_Data];
+}
+
+sub insertData
+{
+ my ($self, $offset, $data) = @_;
+
+ croak new XML::DOM::DOMException (INDEX_SIZE_ERR,
+ "bad offset [$offset]")
+ if ($offset < 0 || $offset >= length ($self->[_Data]));
+#?? DOM Spec says >, but >= makes more sense!
+
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+
+ substr ($self->[_Data], $offset, 0) = $data;
+}
+
+sub replaceData
+{
+ my ($self, $offset, $count, $data) = @_;
+
+ croak new XML::DOM::DOMException (INDEX_SIZE_ERR,
+ "bad offset [$offset]")
+ if ($offset < 0 || $offset >= length ($self->[_Data]));
+#?? DOM Spec says >, but >= makes more sense!
+
+ croak new XML::DOM::DOMException (INDEX_SIZE_ERR,
+ "negative count [$count]")
+ if $count < 0;
+
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+
+ substr ($self->[_Data], $offset, $count) = $data;
+}
+
+sub setData
+{
+ my ($self, $data) = @_;
+
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+
+ $self->[_Data] = $data;
+}
+
+sub substringData
+{
+ my ($self, $offset, $count) = @_;
+ my $data = $self->[_Data];
+
+ croak new XML::DOM::DOMException (INDEX_SIZE_ERR,
+ "bad offset [$offset]")
+ if ($offset < 0 || $offset >= length ($data));
+#?? DOM Spec says >, but >= makes more sense!
+
+ croak new XML::DOM::DOMException (INDEX_SIZE_ERR,
+ "negative count [$count]")
+ if $count < 0;
+
+ substr ($data, $offset, $count);
+}
+
+sub getNodeValue
+{
+ $_[0]->getData;
+}
+
+sub setNodeValue
+{
+ $_[0]->setData ($_[1]);
+}
+
+######################################################################
+package XML::DOM::CDATASection;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::CharacterData qw( :DEFAULT :Fields );
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("", "XML::DOM::CharacterData");
+}
+
+use XML::DOM::DOMException;
+
+sub getNodeName
+{
+ "#cdata-section";
+}
+
+sub getNodeType
+{
+ CDATA_SECTION_NODE;
+}
+
+sub cloneNode
+{
+ my $self = shift;
+ $self->[_Doc]->createCDATASection ($self->getData);
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+sub isReadOnly
+{
+ 0;
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+ $FILE->print ("<![CDATA[");
+ $FILE->print (XML::DOM::encodeCDATA ($self->getData));
+ $FILE->print ("]]>");
+}
+
+sub to_expat
+{
+ my ($self, $iter) = @_;
+ $iter->CData ($self->getData);
+}
+
+sub _to_sax
+{
+ my ($self, $doch, $dtdh, $enth) = @_;
+ $doch->start_cdata;
+ $doch->characters ( { Data => $self->getData } );
+ $doch->end_cdata;
+}
+
+######################################################################
+package XML::DOM::Comment;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::CharacterData qw( :DEFAULT :Fields );
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("", "XML::DOM::CharacterData");
+}
+
+use XML::DOM::DOMException;
+use Carp;
+
+#?? setData - could check comment for double minus
+
+sub getNodeType
+{
+ COMMENT_NODE;
+}
+
+sub getNodeName
+{
+ "#comment";
+}
+
+sub cloneNode
+{
+ my $self = shift;
+ $self->[_Doc]->createComment ($self->getData);
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+sub isReadOnly
+{
+ return 0 if $XML::DOM::IgnoreReadOnly;
+
+ my $pa = $_[0]->[_Parent];
+ defined ($pa) ? $pa->isReadOnly : 0;
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+ my $comment = XML::DOM::encodeComment ($self->[_Data]);
+
+ $FILE->print ("<!--$comment-->");
+}
+
+sub to_expat
+{
+ my ($self, $iter) = @_;
+ $iter->Comment ($self->getData);
+}
+
+sub _to_sax
+{
+ my ($self, $doch, $dtdh, $enth) = @_;
+ $doch->comment ( { Data => $self->getData });
+}
+
+######################################################################
+package XML::DOM::Text;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::CharacterData qw( :DEFAULT :Fields );
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("", "XML::DOM::CharacterData");
+}
+
+use XML::DOM::DOMException;
+use Carp;
+
+sub getNodeType
+{
+ TEXT_NODE;
+}
+
+sub getNodeName
+{
+ "#text";
+}
+
+sub splitText
+{
+ my ($self, $offset) = @_;
+
+ my $data = $self->getData;
+ croak new XML::DOM::DOMException (INDEX_SIZE_ERR,
+ "bad offset [$offset]")
+ if ($offset < 0 || $offset >= length ($data));
+#?? DOM Spec says >, but >= makes more sense!
+
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR,
+ "node is ReadOnly")
+ if $self->isReadOnly;
+
+ my $rest = substr ($data, $offset);
+
+ $self->setData (substr ($data, 0, $offset));
+ my $node = $self->[_Doc]->createTextNode ($rest);
+
+ # insert new node after this node
+ $self->[_Parent]->insertBefore ($node, $self->getNextSibling);
+
+ $node;
+}
+
+sub cloneNode
+{
+ my $self = shift;
+ $self->[_Doc]->createTextNode ($self->getData);
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+sub isReadOnly
+{
+ 0;
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+ my ($s) = XML::DOM::encodeText ($self->getData, '<&>"');
+ if ($XML::DOM::beautifying)
+ {
+ $s =~ s@^[\s\n]*(.*)[\s\n]*$@\1@so;
+ $s =~ s@\n\s*@\n@gm;
+ if (length($s) + $XML::DOM::current_print_level > 48)
+ {
+ $XML::DOM::need_indent[$XML::DOM::current_print_level] = 1;
+ $s = "\n$s\n";
+ $s =~ s@\n\n$@\n@;
+ }
+ else
+ {
+ $XML::DOM::need_indent[$XML::DOM::current_print_level] = 0;
+ $s =~ s@\n$@@;
+ }
+ }
+ $FILE->print ($s);
+}
+
+sub isTextNode
+{
+ 1;
+}
+
+sub to_expat
+{
+ my ($self, $iter) = @_;
+ $iter->Char ($self->getData);
+}
+
+sub _to_sax
+{
+ my ($self, $doch, $dtdh, $enth) = @_;
+ $doch->characters ( { Data => $self->getData } );
+}
+
+######################################################################
+package XML::DOM::XMLDecl;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("Version Encoding Standalone", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+
+
+#------------------------------------------------------------
+# Extra method implementations
+
+# XMLDecl is not part of the DOM Spec
+sub new
+{
+ my ($class, $doc, $version, $encoding, $standalone) = @_;
+
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_Version] = $version if defined $version;
+ $self->[_Encoding] = $encoding if defined $encoding;
+ $self->[_Standalone] = $standalone if defined $standalone;
+
+ $self;
+}
+
+sub setVersion
+{
+ if (defined $_[1])
+ {
+ $_[0]->[_Version] = $_[1];
+ }
+ else
+ {
+ undef $_[0]->[_Version]; # was delete
+ }
+}
+
+sub getVersion
+{
+ $_[0]->[_Version];
+}
+
+sub setEncoding
+{
+ if (defined $_[1])
+ {
+ $_[0]->[_Encoding] = $_[1];
+ }
+ else
+ {
+ undef $_[0]->[_Encoding]; # was delete
+ }
+}
+
+sub getEncoding
+{
+ $_[0]->[_Encoding];
+}
+
+sub setStandalone
+{
+ if (defined $_[1])
+ {
+ $_[0]->[_Standalone] = $_[1];
+ }
+ else
+ {
+ undef $_[0]->[_Standalone]; # was delete
+ }
+}
+
+sub getStandalone
+{
+ $_[0]->[_Standalone];
+}
+
+sub getNodeType
+{
+ XML_DECL_NODE;
+}
+
+sub cloneNode
+{
+ my $self = shift;
+
+ new XML::DOM::XMLDecl ($self->[_Doc], $self->[_Version],
+ $self->[_Encoding], $self->[_Standalone]);
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ my $version = $self->[_Version];
+ my $encoding = $self->[_Encoding];
+ my $standalone = $self->[_Standalone];
+ $standalone = ($standalone ? "yes" : "no") if defined $standalone;
+
+ $FILE->print ("<?xml");
+ $FILE->print (" version=\"$version\"") if defined $version;
+ $FILE->print (" encoding=\"$encoding\"") if defined $encoding;
+ $FILE->print (" standalone=\"$standalone\"") if defined $standalone;
+ $FILE->print ("?>");
+}
+
+sub to_expat
+{
+ my ($self, $iter) = @_;
+ $iter->XMLDecl ($self->getVersion, $self->getEncoding, $self->getStandalone);
+}
+
+sub _to_sax
+{
+ my ($self, $doch, $dtdh, $enth) = @_;
+ $dtdh->xml_decl ( { Version => $self->getVersion,
+ Encoding => $self->getEncoding,
+ Standalone => $self->getStandalone } );
+}
+
+######################################################################
+package XML::DOM::DocumentFragment;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+
+sub new
+{
+ my ($class, $doc) = @_;
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_C] = new XML::DOM::NodeList;
+ $self;
+}
+
+sub getNodeType
+{
+ DOCUMENT_FRAGMENT_NODE;
+}
+
+sub getNodeName
+{
+ "#document-fragment";
+}
+
+sub cloneNode
+{
+ my ($self, $deep) = @_;
+ my $node = $self->[_Doc]->createDocumentFragment;
+
+ $node->cloneChildren ($self, $deep);
+ $node;
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+sub isReadOnly
+{
+ 0;
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ for my $node (@{$self->[_C]})
+ {
+ $node->print ($FILE);
+ }
+}
+
+sub rejectChild
+{
+ my $t = $_[1]->getNodeType;
+
+ $t != TEXT_NODE
+ && $t != ENTITY_REFERENCE_NODE
+ && $t != PROCESSING_INSTRUCTION_NODE
+ && $t != COMMENT_NODE
+ && $t != CDATA_SECTION_NODE
+ && $t != ELEMENT_NODE;
+}
+
+sub isDocumentFragmentNode
+{
+ 1;
+}
+
+######################################################################
+package XML::DOM::DocumentType; # forward declaration
+######################################################################
+
+######################################################################
+package XML::DOM::Document;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ XML::DOM::def_fields ("Doctype XmlDecl", "XML::DOM::Node");
+}
+
+use Carp;
+use XML::DOM::NodeList;
+use XML::DOM::DOMException;
+
+sub new
+{
+ my ($class) = @_;
+ my $self = bless [], $class;
+
+ # keep Doc pointer, even though getOwnerDocument returns undef
+ $self->[_Doc] = $self;
+ $self->[_C] = new XML::DOM::NodeList;
+ $self;
+}
+
+sub getNodeType
+{
+ DOCUMENT_NODE;
+}
+
+sub getNodeName
+{
+ "#document";
+}
+
+#?? not sure about keeping a fixed order of these nodes....
+sub getDoctype
+{
+ $_[0]->[_Doctype];
+}
+
+sub getDocumentElement
+{
+ my ($self) = @_;
+ for my $kid (@{$self->[_C]})
+ {
+ return $kid if $kid->isElementNode;
+ }
+ undef;
+}
+
+sub getOwnerDocument
+{
+ undef;
+}
+
+sub getImplementation
+{
+ $XML::DOM::DOMImplementation::Singleton;
+}
+
+#
+# Added extra parameters ($val, $specified) that are passed straight to the
+# Attr constructor
+#
+sub createAttribute
+{
+ new XML::DOM::Attr (@_);
+}
+
+sub createCDATASection
+{
+ new XML::DOM::CDATASection (@_);
+}
+
+sub createComment
+{
+ new XML::DOM::Comment (@_);
+
+}
+
+sub createElement
+{
+ new XML::DOM::Element (@_);
+}
+
+sub createTextNode
+{
+ new XML::DOM::Text (@_);
+}
+
+sub createProcessingInstruction
+{
+ new XML::DOM::ProcessingInstruction (@_);
+}
+
+sub createEntityReference
+{
+ new XML::DOM::EntityReference (@_);
+}
+
+sub createDocumentFragment
+{
+ new XML::DOM::DocumentFragment (@_);
+}
+
+sub createDocumentType
+{
+ new XML::DOM::DocumentType (@_);
+}
+
+sub cloneNode
+{
+ my ($self, $deep) = @_;
+ my $node = new XML::DOM::Document;
+
+ $node->cloneChildren ($self, $deep);
+
+ my $xmlDecl = $self->[_XmlDecl];
+ $node->[_XmlDecl] = $xmlDecl->cloneNode ($deep) if defined $xmlDecl;
+
+ $node;
+}
+
+sub appendChild
+{
+ my ($self, $node) = @_;
+
+ # Extra check: make sure we don't end up with more than one Element.
+ # Don't worry about multiple DocType nodes, because DocumentFragment
+ # can't contain DocType nodes.
+
+ my @nodes = ($node);
+ @nodes = @{$node->[_C]}
+ if $node->getNodeType == DOCUMENT_FRAGMENT_NODE;
+
+ my $elem = 0;
+ for my $n (@nodes)
+ {
+ $elem++ if $n->isElementNode;
+ }
+
+ if ($elem > 0 && defined ($self->getDocumentElement))
+ {
+ croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR,
+ "document can have only one Element");
+ }
+ $self->SUPER::appendChild ($node);
+}
+
+sub insertBefore
+{
+ my ($self, $node, $refNode) = @_;
+
+ # Extra check: make sure sure we don't end up with more than 1 Elements.
+ # Don't worry about multiple DocType nodes, because DocumentFragment
+ # can't contain DocType nodes.
+
+ my @nodes = ($node);
+ @nodes = @{$node->[_C]}
+ if $node->getNodeType == DOCUMENT_FRAGMENT_NODE;
+
+ my $elem = 0;
+ for my $n (@nodes)
+ {
+ $elem++ if $n->isElementNode;
+ }
+
+ if ($elem > 0 && defined ($self->getDocumentElement))
+ {
+ croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR,
+ "document can have only one Element");
+ }
+ $self->SUPER::insertBefore ($node, $refNode);
+}
+
+sub replaceChild
+{
+ my ($self, $node, $refNode) = @_;
+
+ # Extra check: make sure sure we don't end up with more than 1 Elements.
+ # Don't worry about multiple DocType nodes, because DocumentFragment
+ # can't contain DocType nodes.
+
+ my @nodes = ($node);
+ @nodes = @{$node->[_C]}
+ if $node->getNodeType == DOCUMENT_FRAGMENT_NODE;
+
+ my $elem = 0;
+ $elem-- if $refNode->isElementNode;
+
+ for my $n (@nodes)
+ {
+ $elem++ if $n->isElementNode;
+ }
+
+ if ($elem > 0 && defined ($self->getDocumentElement))
+ {
+ croak new XML::DOM::DOMException (HIERARCHY_REQUEST_ERR,
+ "document can have only one Element");
+ }
+ $self->SUPER::replaceChild ($node, $refNode);
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+sub isReadOnly
+{
+ 0;
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ my $xmlDecl = $self->getXMLDecl;
+ if (defined $xmlDecl)
+ {
+ $xmlDecl->print ($FILE);
+ $FILE->print ("\x0A");
+ }
+
+ for my $node (@{$self->[_C]})
+ {
+ $node->print ($FILE);
+ $FILE->print ("\x0A");
+ }
+}
+
+sub setDoctype
+{
+ my ($self, $doctype) = @_;
+ my $oldDoctype = $self->[_Doctype];
+ if (defined $oldDoctype)
+ {
+ $self->replaceChild ($doctype, $oldDoctype);
+ }
+ else
+ {
+#?? before root element, but after XmlDecl !
+ $self->appendChild ($doctype);
+ }
+ $_[0]->[_Doctype] = $_[1];
+}
+
+sub removeDoctype
+{
+ my $self = shift;
+ my $doctype = $self->removeChild ($self->[_Doctype]);
+
+ undef $self->[_Doctype]; # was delete
+ $doctype;
+}
+
+sub rejectChild
+{
+ my $t = $_[1]->getNodeType;
+ $t != ELEMENT_NODE
+ && $t != PROCESSING_INSTRUCTION_NODE
+ && $t != COMMENT_NODE
+ && $t != DOCUMENT_TYPE_NODE;
+}
+
+sub expandEntity
+{
+ my ($self, $ent, $param) = @_;
+ my $doctype = $self->getDoctype;
+
+ (defined $doctype) ? $doctype->expandEntity ($ent, $param) : undef;
+}
+
+sub getDefaultAttrValue
+{
+ my ($self, $elem, $attr) = @_;
+
+ my $doctype = $self->getDoctype;
+
+ (defined $doctype) ? $doctype->getDefaultAttrValue ($elem, $attr) : undef;
+}
+
+sub getEntity
+{
+ my ($self, $entity) = @_;
+
+ my $doctype = $self->getDoctype;
+
+ (defined $doctype) ? $doctype->getEntity ($entity) : undef;
+}
+
+sub dispose
+{
+ my $self = shift;
+
+ $self->[_XmlDecl]->dispose if defined $self->[_XmlDecl];
+ undef $self->[_XmlDecl]; # was delete
+ undef $self->[_Doctype]; # was delete
+ $self->SUPER::dispose;
+}
+
+sub setOwnerDocument
+{
+ # Do nothing, you can't change the owner document!
+#?? could throw exception...
+}
+
+sub getXMLDecl
+{
+ $_[0]->[_XmlDecl];
+}
+
+sub setXMLDecl
+{
+ $_[0]->[_XmlDecl] = $_[1];
+}
+
+sub createXMLDecl
+{
+ new XML::DOM::XMLDecl (@_);
+}
+
+sub createNotation
+{
+ new XML::DOM::Notation (@_);
+}
+
+sub createElementDecl
+{
+ new XML::DOM::ElementDecl (@_);
+}
+
+sub createAttlistDecl
+{
+ new XML::DOM::AttlistDecl (@_);
+}
+
+sub createEntity
+{
+ new XML::DOM::Entity (@_);
+}
+
+sub createChecker
+{
+ my $self = shift;
+ my $checker = XML::Checker->new;
+
+ $checker->Init;
+ my $doctype = $self->getDoctype;
+ $doctype->to_expat ($checker) if $doctype;
+ $checker->Final;
+
+ $checker;
+}
+
+sub check
+{
+ my ($self, $checker) = @_;
+ $checker ||= XML::Checker->new;
+
+ $self->to_expat ($checker);
+}
+
+sub to_expat
+{
+ my ($self, $iter) = @_;
+
+ $iter->Init;
+
+ for my $kid ($self->getChildNodes)
+ {
+ $kid->to_expat ($iter);
+ }
+ $iter->Final;
+}
+
+sub check_sax
+{
+ my ($self, $checker) = @_;
+ $checker ||= XML::Checker->new;
+
+ $self->to_sax (Handler => $checker);
+}
+
+sub _to_sax
+{
+ my ($self, $doch, $dtdh, $enth) = @_;
+
+ $doch->start_document;
+
+ for my $kid ($self->getChildNodes)
+ {
+ $kid->_to_sax ($doch, $dtdh, $enth);
+ }
+ $doch->end_document;
+}
+
+######################################################################
+package XML::DOM::DocumentType;
+######################################################################
+use vars qw{ @ISA @EXPORT_OK %EXPORT_TAGS %HFIELDS };
+
+BEGIN
+{
+ import XML::DOM::Node qw( :DEFAULT :Fields );
+ import XML::DOM::Document qw( :Fields );
+ XML::DOM::def_fields ("Entities Notations Name SysId PubId Internal", "XML::DOM::Node");
+}
+
+use XML::DOM::DOMException;
+use XML::DOM::NamedNodeMap;
+
+sub new
+{
+ my $class = shift;
+ my $doc = shift;
+
+ my $self = bless [], $class;
+
+ $self->[_Doc] = $doc;
+ $self->[_ReadOnly] = 1;
+ $self->[_C] = new XML::DOM::NodeList;
+
+ $self->[_Entities] = new XML::DOM::NamedNodeMap (Doc => $doc,
+ Parent => $self,
+ ReadOnly => 1);
+ $self->[_Notations] = new XML::DOM::NamedNodeMap (Doc => $doc,
+ Parent => $self,
+ ReadOnly => 1);
+ $self->setParams (@_);
+ $self;
+}
+
+sub getNodeType
+{
+ DOCUMENT_TYPE_NODE;
+}
+
+sub getNodeName
+{
+ $_[0]->[_Name];
+}
+
+sub getName
+{
+ $_[0]->[_Name];
+}
+
+sub getEntities
+{
+ $_[0]->[_Entities];
+}
+
+sub getNotations
+{
+ $_[0]->[_Notations];
+}
+
+sub setParentNode
+{
+ my ($self, $parent) = @_;
+ $self->SUPER::setParentNode ($parent);
+
+ $parent->[_Doctype] = $self
+ if $parent->getNodeType == DOCUMENT_NODE;
+}
+
+sub cloneNode
+{
+ my ($self, $deep) = @_;
+
+ my $node = new XML::DOM::DocumentType ($self->[_Doc], $self->[_Name],
+ $self->[_SysId], $self->[_PubId],
+ $self->[_Internal]);
+
+#?? does it make sense to make a shallow copy?
+
+ # clone the NamedNodeMaps
+ $node->[_Entities] = $self->[_Entities]->cloneNode ($deep);
+
+ $node->[_Notations] = $self->[_Notations]->cloneNode ($deep);
+
+ $node->cloneChildren ($self, $deep);
+
+ $node;
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+sub getSysId
+{
+ $_[0]->[_SysId];
+}
+
+sub getPubId
+{
+ $_[0]->[_PubId];
+}
+
+sub getInternal
+{
+ $_[0]->[_Internal];
+}
+
+sub setSysId
+{
+ $_[0]->[_SysId] = $_[1];
+}
+
+sub setPubId
+{
+ $_[0]->[_PubId] = $_[1];
+}
+
+sub setInternal
+{
+ $_[0]->[_Internal] = $_[1];
+}
+
+sub setName
+{
+ $_[0]->[_Name] = $_[1];
+}
+
+sub removeChildHoodMemories
+{
+ my ($self, $dontWipeReadOnly) = @_;
+
+ my $parent = $self->[_Parent];
+ if (defined $parent && $parent->getNodeType == DOCUMENT_NODE)
+ {
+ undef $parent->[_Doctype]; # was delete
+ }
+ $self->SUPER::removeChildHoodMemories;
+}
+
+sub dispose
+{
+ my $self = shift;
+
+ $self->[_Entities]->dispose;
+ $self->[_Notations]->dispose;
+ $self->SUPER::dispose;
+}
+
+sub setOwnerDocument
+{
+ my ($self, $doc) = @_;
+ $self->SUPER::setOwnerDocument ($doc);
+
+ $self->[_Entities]->setOwnerDocument ($doc);
+ $self->[_Notations]->setOwnerDocument ($doc);
+}
+
+sub expandEntity
+{
+ my ($self, $ent, $param) = @_;
+
+ my $kid = $self->[_Entities]->getNamedItem ($ent);
+ return $kid->getValue
+ if (defined ($kid) && $param == $kid->isParameterEntity);
+
+ undef; # entity not found
+}
+
+sub getAttlistDecl
+{
+ my ($self, $elemName) = @_;
+ for my $kid (@{$_[0]->[_C]})
+ {
+ return $kid if ($kid->getNodeType == ATTLIST_DECL_NODE &&
+ $kid->getName eq $elemName);
+ }
+ undef; # not found
+}
+
+sub getElementDecl
+{
+ my ($self, $elemName) = @_;
+ for my $kid (@{$_[0]->[_C]})
+ {
+ return $kid if ($kid->getNodeType == ELEMENT_DECL_NODE &&
+ $kid->getName eq $elemName);
+ }
+ undef; # not found
+}
+
+sub addElementDecl
+{
+ my ($self, $name, $model, $hidden) = @_;
+ my $node = $self->getElementDecl ($name);
+
+#?? could warn
+ unless (defined $node)
+ {
+ $node = $self->[_Doc]->createElementDecl ($name, $model, $hidden);
+ $self->appendChild ($node);
+ }
+ $node;
+}
+
+sub addAttlistDecl
+{
+ my ($self, $name) = @_;
+ my $node = $self->getAttlistDecl ($name);
+
+ unless (defined $node)
+ {
+ $node = $self->[_Doc]->createAttlistDecl ($name);
+ $self->appendChild ($node);
+ }
+ $node;
+}
+
+sub addNotation
+{
+ my $self = shift;
+ my $node = $self->[_Doc]->createNotation (@_);
+ $self->[_Notations]->setNamedItem ($node);
+ $node;
+}
+
+sub addEntity
+{
+ my $self = shift;
+ my $node = $self->[_Doc]->createEntity (@_);
+
+ $self->[_Entities]->setNamedItem ($node);
+ $node;
+}
+
+# All AttDefs for a certain Element are merged into a single ATTLIST
+sub addAttDef
+{
+ my $self = shift;
+ my $elemName = shift;
+
+ # create the AttlistDecl if it doesn't exist yet
+ my $attListDecl = $self->addAttlistDecl ($elemName);
+ $attListDecl->addAttDef (@_);
+}
+
+sub getDefaultAttrValue
+{
+ my ($self, $elem, $attr) = @_;
+ my $elemNode = $self->getAttlistDecl ($elem);
+ (defined $elemNode) ? $elemNode->getDefaultAttrValue ($attr) : undef;
+}
+
+sub getEntity
+{
+ my ($self, $entity) = @_;
+ $self->[_Entities]->getNamedItem ($entity);
+}
+
+sub setParams
+{
+ my ($self, $name, $sysid, $pubid, $internal) = @_;
+
+ $self->[_Name] = $name;
+
+#?? not sure if we need to hold on to these...
+ $self->[_SysId] = $sysid if defined $sysid;
+ $self->[_PubId] = $pubid if defined $pubid;
+ $self->[_Internal] = $internal if defined $internal;
+
+ $self;
+}
+
+sub rejectChild
+{
+ # DOM Spec says: DocumentType -- no children
+ not $XML::DOM::IgnoreReadOnly;
+}
+
+sub print
+{
+ my ($self, $FILE) = @_;
+
+ my $name = $self->[_Name];
+
+ my $sysId = $self->[_SysId];
+ my $pubId = $self->[_PubId];
+
+ $FILE->print ("<!DOCTYPE $name");
+ if (defined $pubId)
+ {
+ $FILE->print (" PUBLIC \"$pubId\" \"$sysId\"");
+ }
+ elsif (defined $sysId)
+ {
+ $FILE->print (" SYSTEM \"$sysId\"");
+ }
+
+ my @entities = @{$self->[_Entities]->getValues};
+ my @notations = @{$self->[_Notations]->getValues};
+ my @kids = @{$self->[_C]};
+
+ if (@entities || @notations || @kids)
+ {
+ $FILE->print (" [\x0A");
+
+ for my $kid (@entities)
+ {
+ next if $kid->[_Hidden];
+
+ $FILE->print (" ");
+ $kid->print ($FILE);
+ $FILE->print ("\x0A");
+ }
+
+ for my $kid (@notations)
+ {
+ next if $kid->[_Hidden];
+
+ $FILE->print (" ");
+ $kid->print ($FILE);
+ $FILE->print ("\x0A");
+ }
+
+ for my $kid (@kids)
+ {
+ next if $kid->[_Hidden];
+
+ $FILE->print (" ");
+ $kid->print ($FILE);
+ $FILE->print ("\x0A");
+ }
+ $FILE->print ("]");
+ }
+ $FILE->print (">");
+}
+
+sub to_expat
+{
+ my ($self, $iter) = @_;
+
+ $iter->Doctype ($self->getName, $self->getSysId, $self->getPubId, $self->getInternal);
+
+ for my $ent ($self->getEntities->getValues)
+ {
+ next if $ent->[_Hidden];
+ $ent->to_expat ($iter);
+ }
+
+ for my $nota ($self->getNotations->getValues)
+ {
+ next if $nota->[_Hidden];
+ $nota->to_expat ($iter);
+ }
+
+ for my $kid ($self->getChildNodes)
+ {
+ next if $kid->[_Hidden];
+ $kid->to_expat ($iter);
+ }
+}
+
+sub _to_sax
+{
+ my ($self, $doch, $dtdh, $enth) = @_;
+
+ $dtdh->doctype_decl ( { Name => $self->getName,
+ SystemId => $self->getSysId,
+ PublicId => $self->getPubId,
+ Internal => $self->getInternal });
+
+ for my $ent ($self->getEntities->getValues)
+ {
+ next if $ent->[_Hidden];
+ $ent->_to_sax ($doch, $dtdh, $enth);
+ }
+
+ for my $nota ($self->getNotations->getValues)
+ {
+ next if $nota->[_Hidden];
+ $nota->_to_sax ($doch, $dtdh, $enth);
+ }
+
+ for my $kid ($self->getChildNodes)
+ {
+ next if $kid->[_Hidden];
+ $kid->_to_sax ($doch, $dtdh, $enth);
+ }
+}
+
+######################################################################
+package XML::DOM::Parser;
+######################################################################
+use vars qw ( @ISA );
+@ISA = qw( XML::Parser );
+
+sub new
+{
+ my ($class, %args) = @_;
+
+ $args{Style} = 'Dom';
+ $class->SUPER::new (%args);
+}
+
+# This method needed to be overriden so we can restore some global
+# variables when an exception is thrown
+sub parse
+{
+ my $self = shift;
+
+ local $XML::Parser::Dom::_DP_doc;
+ local $XML::Parser::Dom::_DP_elem;
+ local $XML::Parser::Dom::_DP_doctype;
+ local $XML::Parser::Dom::_DP_in_prolog;
+ local $XML::Parser::Dom::_DP_end_doc;
+ local $XML::Parser::Dom::_DP_saw_doctype;
+ local $XML::Parser::Dom::_DP_in_CDATA;
+ local $XML::Parser::Dom::_DP_keep_CDATA;
+ local $XML::Parser::Dom::_DP_last_text;
+
+
+ # Temporarily disable checks that Expat already does (for performance)
+ local $XML::DOM::SafeMode = 0;
+ # Temporarily disable ReadOnly checks
+ local $XML::DOM::IgnoreReadOnly = 1;
+
+ my $ret;
+ eval {
+ $ret = $self->SUPER::parse (@_);
+ };
+ my $err = $@;
+
+ if ($err)
+ {
+ my $doc = $XML::Parser::Dom::_DP_doc;
+ if ($doc)
+ {
+ $doc->dispose;
+ }
+ die $err;
+ }
+
+ $ret;
+}
+
+my $LWP_USER_AGENT;
+sub set_LWP_UserAgent
+{
+ $LWP_USER_AGENT = shift;
+}
+
+sub parsefile
+{
+ my $self = shift;
+ my $url = shift;
+
+ # Any other URL schemes?
+ if ($url =~ /^(https?|ftp|wais|gopher|file):/)
+ {
+ # Read the file from the web with LWP.
+ #
+ # Note that we read in the entire file, which may not be ideal
+ # for large files. LWP::UserAgent also provides a callback style
+ # request, which we could convert to a stream with a fork()...
+
+ my $result;
+# eval
+# {
+# use LWP::UserAgent;
+
+# my $ua = $self->{LWP_UserAgent};
+# unless (defined $ua)
+# {
+# unless (defined $LWP_USER_AGENT)
+# {
+# $LWP_USER_AGENT = LWP::UserAgent->new;
+
+# # Load proxy settings from environment variables, i.e.:
+# # http_proxy, ftp_proxy, no_proxy etc. (see LWP::UserAgent(3))
+# # You need these to go thru firewalls.
+# $LWP_USER_AGENT->env_proxy;
+# }
+# $ua = $LWP_USER_AGENT;
+# }
+# my $req = new HTTP::Request 'GET', $url;
+# my $response = $ua->request ($req);
+
+# # Parse the result of the HTTP request
+# $result = $self->parse ($response->content, @_);
+# };
+ if ($@)
+ {
+ die "Couldn't parsefile [$url] with LWP: $@";
+ }
+ return $result;
+ }
+ else
+ {
+ return $self->SUPER::parsefile ($url, @_);
+ }
+}
+
+######################################################################
+package XML::Parser::Dom;
+######################################################################
+
+BEGIN
+{
+ import XML::DOM::Node qw( :Fields );
+ import XML::DOM::CharacterData qw( :Fields );
+}
+
+use vars qw( $_DP_doc
+ $_DP_elem
+ $_DP_doctype
+ $_DP_in_prolog
+ $_DP_end_doc
+ $_DP_saw_doctype
+ $_DP_in_CDATA
+ $_DP_keep_CDATA
+ $_DP_last_text
+ $_DP_level
+ $_DP_expand_pent
+ );
+
+# This adds a new Style to the XML::Parser class.
+# From now on you can say: $parser = new XML::Parser ('Style' => 'Dom' );
+# but that is *NOT* how a regular user should use it!
+$XML::Parser::Built_In_Styles{Dom} = 1;
+
+sub Init
+{
+ $_DP_elem = $_DP_doc = new XML::DOM::Document();
+ $_DP_doctype = new XML::DOM::DocumentType ($_DP_doc);
+ $_DP_doc->setDoctype ($_DP_doctype);
+ $_DP_keep_CDATA = $_[0]->{KeepCDATA};
+
+ # Prepare for document prolog
+ $_DP_in_prolog = 1;
+
+ # We haven't passed the root element yet
+ $_DP_end_doc = 0;
+
+ # Expand parameter entities in the DTD by default
+
+ $_DP_expand_pent = defined $_[0]->{ExpandParamEnt} ?
+ $_[0]->{ExpandParamEnt} : 1;
+ if ($_DP_expand_pent)
+ {
+ $_[0]->{DOM_Entity} = {};
+ }
+
+ $_DP_level = 0;
+
+ undef $_DP_last_text;
+}
+
+sub Final
+{
+ unless ($_DP_saw_doctype)
+ {
+ my $doctype = $_DP_doc->removeDoctype;
+ $doctype->dispose;
+ }
+ $_DP_doc;
+}
+
+sub Char
+{
+ my $str = $_[1];
+
+ if ($_DP_in_CDATA && $_DP_keep_CDATA)
+ {
+ undef $_DP_last_text;
+ # Merge text with previous node if possible
+ $_DP_elem->addCDATA ($str);
+ }
+ else
+ {
+ # Merge text with previous node if possible
+ # Used to be: $expat->{DOM_Element}->addText ($str);
+ if ($_DP_last_text)
+ {
+ $_DP_last_text->[_Data] .= $str;
+ }
+ else
+ {
+ $_DP_last_text = $_DP_doc->createTextNode ($str);
+ $_DP_last_text->[_Parent] = $_DP_elem;
+ push @{$_DP_elem->[_C]}, $_DP_last_text;
+ }
+ }
+}
+
+sub Start
+{
+ my ($expat, $elem, @attr) = @_;
+ my $parent = $_DP_elem;
+ my $doc = $_DP_doc;
+
+ if ($parent == $doc)
+ {
+ # End of document prolog, i.e. start of first Element
+ $_DP_in_prolog = 0;
+ }
+
+ undef $_DP_last_text;
+ my $node = $doc->createElement ($elem);
+ $_DP_elem = $node;
+ $parent->appendChild ($node);
+
+ my $n = @attr;
+ return unless $n;
+
+ # Add attributes
+ my $first_default = $expat->specified_attr;
+ my $i = 0;
+ while ($i < $n)
+ {
+ my $specified = $i < $first_default;
+ my $name = $attr[$i++];
+ undef $_DP_last_text;
+ my $attr = $doc->createAttribute ($name, $attr[$i++], $specified);
+ $node->setAttributeNode ($attr);
+ }
+}
+
+sub End
+{
+ $_DP_elem = $_DP_elem->[_Parent];
+ undef $_DP_last_text;
+
+ # Check for end of root element
+ $_DP_end_doc = 1 if ($_DP_elem == $_DP_doc);
+}
+
+# Called at end of file, i.e. whitespace following last closing tag
+# Also for Entity references
+# May also be called at other times...
+sub Default
+{
+ my ($expat, $str) = @_;
+
+# shift; deb ("Default", @_);
+
+ if ($_DP_in_prolog) # still processing Document prolog...
+ {
+#?? could try to store this text later
+#?? I've only seen whitespace here so far
+ }
+ elsif (!$_DP_end_doc) # ignore whitespace at end of Document
+ {
+# if ($expat->{NoExpand})
+# {
+ # Got a TextDecl (<?xml ...?>) from an external entity here once
+
+ # create non-parameter entity reference, correct?
+ return unless $str =~ s!^&!!;
+ return unless $str =~ s!;$!!;
+ $_DP_elem->appendChild (
+ $_DP_doc->createEntityReference ($str,0,$expat->{NoExpand}));
+ undef $_DP_last_text;
+# }
+# else
+# {
+# $expat->{DOM_Element}->addText ($str);
+# }
+ }
+}
+
+# XML::Parser 2.19 added support for CdataStart and CdataEnd handlers
+# If they are not defined, the Default handler is called instead
+# with the text "<![CDATA[" and "]]"
+sub CdataStart
+{
+ $_DP_in_CDATA = 1;
+}
+
+sub CdataEnd
+{
+ $_DP_in_CDATA = 0;
+}
+
+my $START_MARKER = "__DOM__START__ENTITY__";
+my $END_MARKER = "__DOM__END__ENTITY__";
+
+sub Comment
+{
+ undef $_DP_last_text;
+
+ # These comments were inserted by ExternEnt handler
+ if ($_[1] =~ /(?:($START_MARKER)|($END_MARKER))/)
+ {
+ if ($1) # START
+ {
+ $_DP_level++;
+ }
+ else
+ {
+ $_DP_level--;
+ }
+ }
+ else
+ {
+ my $comment = $_DP_doc->createComment ($_[1]);
+ $_DP_elem->appendChild ($comment);
+ }
+}
+
+sub deb
+{
+# return;
+
+ my $name = shift;
+ print "$name (" . join(",", map {defined($_)?$_ : "(undef)"} @_) . ")\n";
+}
+
+sub Doctype
+{
+ my $expat = shift;
+# deb ("Doctype", @_);
+
+ $_DP_doctype->setParams (@_);
+ $_DP_saw_doctype = 1;
+}
+
+sub Attlist
+{
+ my $expat = shift;
+# deb ("Attlist", @_);
+
+ $_[5] = "Hidden" unless $_DP_expand_pent || $_DP_level == 0;
+ $_DP_doctype->addAttDef (@_);
+}
+
+sub XMLDecl
+{
+ my $expat = shift;
+# deb ("XMLDecl", @_);
+
+ undef $_DP_last_text;
+ $_DP_doc->setXMLDecl (new XML::DOM::XMLDecl ($_DP_doc, @_));
+}
+
+sub Entity
+{
+ my $expat = shift;
+# deb ("Entity", @_);
+
+ # check to see if Parameter Entity
+ if ($_[5])
+ {
+
+ if (defined $_[2]) # was sysid specified?
+ {
+ # Store the Entity mapping for use in ExternEnt
+ if (exists $expat->{DOM_Entity}->{$_[2]})
+ {
+ # If this ever happens, the name of entity may be the wrong one
+ # when writing out the Document.
+ XML::DOM::warning ("Entity $_[2] is known as %$_[0] and %" .
+ $expat->{DOM_Entity}->{$_[2]});
+ }
+ else
+ {
+ $expat->{DOM_Entity}->{$_[2]} = $_[0];
+ }
+ #?? remove this block when XML::Parser has better support
+ }
+ }
+
+ # no value on things with sysId
+ if (defined $_[2] && defined $_[1])
+ {
+ # print STDERR "XML::DOM Warning $_[0] had both value($_[1]) And SYSId ($_[2]), removing value.\n";
+ $_[1] = undef;
+ }
+
+ undef $_DP_last_text;
+
+ $_[6] = "Hidden" unless $_DP_expand_pent || $_DP_level == 0;
+ $_DP_doctype->addEntity (@_);
+}
+
+#
+# Unparsed is called when it encounters e.g:
+#
+# <!ENTITY logo SYSTEM "http://server/logo.gif" NDATA gif>
+#
+sub Unparsed
+{
+ Entity (@_); # same as regular ENTITY, as far as DOM is concerned
+}
+
+sub Element
+{
+ shift;
+# deb ("Element", @_);
+
+ # put in to convert XML::Parser::ContentModel object to string
+ # ($_[1] used to be a string in XML::Parser 2.27 and
+ # dom_attr.t fails if we don't stringify here)
+ $_[1] = "$_[1]";
+
+ undef $_DP_last_text;
+ push @_, "Hidden" unless $_DP_expand_pent || $_DP_level == 0;
+ $_DP_doctype->addElementDecl (@_);
+}
+
+sub Notation
+{
+ shift;
+# deb ("Notation", @_);
+
+ undef $_DP_last_text;
+ $_[4] = "Hidden" unless $_DP_expand_pent || $_DP_level == 0;
+ $_DP_doctype->addNotation (@_);
+}
+
+sub Proc
+{
+ shift;
+# deb ("Proc", @_);
+
+ undef $_DP_last_text;
+ push @_, "Hidden" unless $_DP_expand_pent || $_DP_level == 0;
+ $_DP_elem->appendChild ($_DP_doc->createProcessingInstruction (@_));
+}
+
+#
+# ExternEnt is called when an external entity, such as:
+#
+# <!ENTITY externalEntity PUBLIC "-//Enno//TEXT Enno's description//EN"
+# "http://server/descr.txt">
+#
+# is referenced in the document, e.g. with: &externalEntity;
+# If ExternEnt is not specified, the entity reference is passed to the Default
+# handler as e.g. "&externalEntity;", where an EntityReference object is added.
+#
+# Also for %externalEntity; references in the DTD itself.
+#
+# It can also be called when XML::Parser parses the DOCTYPE header
+# (just before calling the DocType handler), when it contains a
+# reference like "docbook.dtd" below:
+#
+# <!DOCTYPE book PUBLIC "-//Norman Walsh//DTD DocBk XML V3.1.3//EN"
+# "docbook.dtd" [
+# ... rest of DTD ...
+#
+sub ExternEnt
+{
+ my ($expat, $base, $sysid, $pubid) = @_;
+# deb ("ExternEnt", @_);
+
+ # ?? (tjmather) i think there is a problem here
+ # with XML::Parser > 2.27 since file_ext_ent_handler
+ # now returns a IO::File object instead of a content string
+
+ # Invoke XML::Parser's default ExternEnt handler
+ my $content;
+ if ($XML::Parser::have_LWP)
+ {
+ $content = XML::Parser::lwp_ext_ent_handler (@_);
+ }
+ else
+ {
+ $content = XML::Parser::file_ext_ent_handler (@_);
+ }
+
+ if ($_DP_expand_pent)
+ {
+ return $content;
+ }
+ else
+ {
+ my $entname = $expat->{DOM_Entity}->{$sysid};
+ if (defined $entname)
+ {
+ $_DP_doctype->appendChild ($_DP_doc->createEntityReference ($entname, 1, $expat->{NoExpand}));
+ # Wrap the contents in special comments, so we know when we reach the
+ # end of parsing the entity. This way we can omit the contents from
+ # the DTD, when ExpandParamEnt is set to 0.
+
+ return "<!-- $START_MARKER sysid=[$sysid] -->" .
+ $content . "<!-- $END_MARKER sysid=[$sysid] -->";
+ }
+ else
+ {
+ # We either read the entity ref'd by the system id in the
+ # <!DOCTYPE> header, or the entity was undefined.
+ # In either case, don't bother with maintaining the entity
+ # reference, just expand the contents.
+ return "<!-- $START_MARKER sysid=[DTD] -->" .
+ $content . "<!-- $END_MARKER sysid=[DTD] -->";
+ }
+ }
+}
+
+1; # module return code
+
+__END__
+
+=head1 NAME
+
+XML::DOM - A perl module for building DOM Level 1 compliant document structures
+
+=head1 SYNOPSIS
+
+ use XML::DOM;
+
+ my $parser = new XML::DOM::Parser;
+ my $doc = $parser->parsefile ("file.xml");
+
+ # print all HREF attributes of all CODEBASE elements
+ my $nodes = $doc->getElementsByTagName ("CODEBASE");
+ my $n = $nodes->getLength;
+
+ for (my $i = 0; $i < $n; $i++)
+ {
+ my $node = $nodes->item ($i);
+ my $href = $node->getAttributeNode ("HREF");
+ print $href->getValue . "\n";
+ }
+
+ # Print doc file
+ $doc->printToFile ("out.xml");
+
+ # Print to string
+ print $doc->toString;
+
+ # Avoid memory leaks - cleanup circular references for garbage collection
+ $doc->dispose;
+
+=head1 DESCRIPTION
+
+This module extends the XML::Parser module by Clark Cooper.
+The XML::Parser module is built on top of XML::Parser::Expat,
+which is a lower level interface to James Clark's expat library.
+
+XML::DOM::Parser is derived from XML::Parser. It parses XML strings or files
+and builds a data structure that conforms to the API of the Document Object
+Model as described at http://www.w3.org/TR/REC-DOM-Level-1.
+See the XML::Parser manpage for other available features of the
+XML::DOM::Parser class.
+Note that the 'Style' property should not be used (it is set internally.)
+
+The XML::Parser I<NoExpand> option is more or less supported, in that it will
+generate EntityReference objects whenever an entity reference is encountered
+in character data. I'm not sure how useful this is. Any comments are welcome.
+
+As described in the synopsis, when you create an XML::DOM::Parser object,
+the parse and parsefile methods create an I<XML::DOM::Document> object
+from the specified input. This Document object can then be examined, modified and
+written back out to a file or converted to a string.
+
+When using XML::DOM with XML::Parser version 2.19 and up, setting the
+XML::DOM::Parser option I<KeepCDATA> to 1 will store CDATASections in
+CDATASection nodes, instead of converting them to Text nodes.
+Subsequent CDATASection nodes will be merged into one. Let me know if this
+is a problem.
+
+When using XML::Parser 2.27 and above, you can suppress expansion of
+parameter entity references (e.g. %pent;) in the DTD, by setting I<ParseParamEnt>
+to 1 and I<ExpandParamEnt> to 0. See L<Hidden Nodes|/_Hidden_Nodes_> for details.
+
+A Document has a tree structure consisting of I<Node> objects. A Node may contain
+other nodes, depending on its type.
+A Document may have Element, Text, Comment, and CDATASection nodes.
+Element nodes may have Attr, Element, Text, Comment, and CDATASection nodes.
+The other nodes may not have any child nodes.
+
+This module adds several node types that are not part of the DOM spec (yet.)
+These are: ElementDecl (for <!ELEMENT ...> declarations), AttlistDecl (for
+<!ATTLIST ...> declarations), XMLDecl (for <?xml ...?> declarations) and AttDef
+(for attribute definitions in an AttlistDecl.)
+
+=head1 XML::DOM Classes
+
+The XML::DOM module stores XML documents in a tree structure with a root node
+of type XML::DOM::Document. Different nodes in tree represent different
+parts of the XML file. The DOM Level 1 Specification defines the following
+node types:
+
+=over 4
+
+=item * L<XML::DOM::Node> - Super class of all node types
+
+=item * L<XML::DOM::Document> - The root of the XML document
+
+=item * L<XML::DOM::DocumentType> - Describes the document structure: <!DOCTYPE root [ ... ]>
+
+=item * L<XML::DOM::Element> - An XML element: <elem attr="val"> ... </elem>
+
+=item * L<XML::DOM::Attr> - An XML element attribute: name="value"
+
+=item * L<XML::DOM::CharacterData> - Super class of Text, Comment and CDATASection
+
+=item * L<XML::DOM::Text> - Text in an XML element
+
+=item * L<XML::DOM::CDATASection> - Escaped block of text: <![CDATA[ text ]]>
+
+=item * L<XML::DOM::Comment> - An XML comment: <!-- comment -->
+
+=item * L<XML::DOM::EntityReference> - Refers to an ENTITY: &ent; or %ent;
+
+=item * L<XML::DOM::Entity> - An ENTITY definition: <!ENTITY ...>
+
+=item * L<XML::DOM::ProcessingInstruction> - <?PI target>
+
+=item * L<XML::DOM::DocumentFragment> - Lightweight node for cut & paste
+
+=item * L<XML::DOM::Notation> - An NOTATION definition: <!NOTATION ...>
+
+=back
+
+In addition, the XML::DOM module contains the following nodes that are not part
+of the DOM Level 1 Specification:
+
+=over 4
+
+=item * L<XML::DOM::ElementDecl> - Defines an element: <!ELEMENT ...>
+
+=item * L<XML::DOM::AttlistDecl> - Defines one or more attributes in an <!ATTLIST ...>
+
+=item * L<XML::DOM::AttDef> - Defines one attribute in an <!ATTLIST ...>
+
+=item * L<XML::DOM::XMLDecl> - An XML declaration: <?xml version="1.0" ...>
+
+=back
+
+Other classes that are part of the DOM Level 1 Spec:
+
+=over 4
+
+=item * L<XML::DOM::Implementation> - Provides information about this implementation. Currently it doesn't do much.
+
+=item * L<XML::DOM::NodeList> - Used internally to store a node's child nodes. Also returned by getElementsByTagName.
+
+=item * L<XML::DOM::NamedNodeMap> - Used internally to store an element's attributes.
+
+=back
+
+Other classes that are not part of the DOM Level 1 Spec:
+
+=over 4
+
+=item * L<XML::DOM::Parser> - An non-validating XML parser that creates XML::DOM::Documents
+
+=item * L<XML::DOM::ValParser> - A validating XML parser that creates XML::DOM::Documents. It uses L<XML::Checker> to check against the DocumentType (DTD)
+
+=item * L<XML::Handler::BuildDOM> - A PerlSAX handler that creates XML::DOM::Documents.
+
+=back
+
+=head1 XML::DOM package
+
+=over 4
+
+=item Constant definitions
+
+The following predefined constants indicate which type of node it is.
+
+=back
+
+ UNKNOWN_NODE (0) The node type is unknown (not part of DOM)
+
+ ELEMENT_NODE (1) The node is an Element.
+ ATTRIBUTE_NODE (2) The node is an Attr.
+ TEXT_NODE (3) The node is a Text node.
+ CDATA_SECTION_NODE (4) The node is a CDATASection.
+ ENTITY_REFERENCE_NODE (5) The node is an EntityReference.
+ ENTITY_NODE (6) The node is an Entity.
+ PROCESSING_INSTRUCTION_NODE (7) The node is a ProcessingInstruction.
+ COMMENT_NODE (8) The node is a Comment.
+ DOCUMENT_NODE (9) The node is a Document.
+ DOCUMENT_TYPE_NODE (10) The node is a DocumentType.
+ DOCUMENT_FRAGMENT_NODE (11) The node is a DocumentFragment.
+ NOTATION_NODE (12) The node is a Notation.
+
+ ELEMENT_DECL_NODE (13) The node is an ElementDecl (not part of DOM)
+ ATT_DEF_NODE (14) The node is an AttDef (not part of DOM)
+ XML_DECL_NODE (15) The node is an XMLDecl (not part of DOM)
+ ATTLIST_DECL_NODE (16) The node is an AttlistDecl (not part of DOM)
+
+ Usage:
+
+ if ($node->getNodeType == ELEMENT_NODE)
+ {
+ print "It's an Element";
+ }
+
+B<Not In DOM Spec>: The DOM Spec does not mention UNKNOWN_NODE and,
+quite frankly, you should never encounter it. The last 4 node types were added
+to support the 4 added node classes.
+
+=head2 Global Variables
+
+=over 4
+
+=item $VERSION
+
+The variable $XML::DOM::VERSION contains the version number of this
+implementation, e.g. "1.42".
+
+=back
+
+=head2 METHODS
+
+These methods are not part of the DOM Level 1 Specification.
+
+=over 4
+
+=item getIgnoreReadOnly and ignoreReadOnly (readOnly)
+
+The DOM Level 1 Spec does not allow you to edit certain sections of the document,
+e.g. the DocumentType, so by default this implementation throws DOMExceptions
+(i.e. NO_MODIFICATION_ALLOWED_ERR) when you try to edit a readonly node.
+These readonly checks can be disabled by (temporarily) setting the global
+IgnoreReadOnly flag.
+
+The ignoreReadOnly method sets the global IgnoreReadOnly flag and returns its
+previous value. The getIgnoreReadOnly method simply returns its current value.
+
+ my $oldIgnore = XML::DOM::ignoreReadOnly (1);
+ eval {
+ ... do whatever you want, catching any other exceptions ...
+ };
+ XML::DOM::ignoreReadOnly ($oldIgnore); # restore previous value
+
+Another way to do it, using a local variable:
+
+ { # start new scope
+ local $XML::DOM::IgnoreReadOnly = 1;
+ ... do whatever you want, don't worry about exceptions ...
+ } # end of scope ($IgnoreReadOnly is set back to its previous value)
+
+
+=item isValidName (name)
+
+Whether the specified name is a valid "Name" as specified in the XML spec.
+Characters with Unicode values > 127 are now also supported.
+
+=item getAllowReservedNames and allowReservedNames (boolean)
+
+The first method returns whether reserved names are allowed.
+The second takes a boolean argument and sets whether reserved names are allowed.
+The initial value is 1 (i.e. allow reserved names.)
+
+The XML spec states that "Names" starting with (X|x)(M|m)(L|l)
+are reserved for future use. (Amusingly enough, the XML version of the XML spec
+(REC-xml-19980210.xml) breaks that very rule by defining an ENTITY with the name
+'xmlpio'.)
+A "Name" in this context means the Name token as found in the BNF rules in the
+XML spec.
+
+XML::DOM only checks for errors when you modify the DOM tree, not when the
+DOM tree is built by the XML::DOM::Parser.
+
+=item setTagCompression (funcref)
+
+There are 3 possible styles for printing empty Element tags:
+
+=over 4
+
+=item Style 0
+
+ <empty/> or <empty attr="val"/>
+
+XML::DOM uses this style by default for all Elements.
+
+=item Style 1
+
+ <empty></empty> or <empty attr="val"></empty>
+
+=item Style 2
+
+ <empty /> or <empty attr="val" />
+
+This style is sometimes desired when using XHTML.
+(Note the extra space before the slash "/")
+See L<http://www.w3.org/TR/xhtml1> Appendix C for more details.
+
+=back
+
+By default XML::DOM compresses all empty Element tags (style 0.)
+You can control which style is used for a particular Element by calling
+XML::DOM::setTagCompression with a reference to a function that takes
+2 arguments. The first is the tag name of the Element, the second is the
+XML::DOM::Element that is being printed.
+The function should return 0, 1 or 2 to indicate which style should be used to
+print the empty tag. E.g.
+
+ XML::DOM::setTagCompression (\&my_tag_compression);
+
+ sub my_tag_compression
+ {
+ my ($tag, $elem) = @_;
+
+ # Print empty br, hr and img tags like this: <br />
+ return 2 if $tag =~ /^(br|hr|img)$/;
+
+ # Print other empty tags like this: <empty></empty>
+ return 1;
+ }
+
+=back
+
+=head1 IMPLEMENTATION DETAILS
+
+=over 4
+
+=item * Perl Mappings
+
+The value undef was used when the DOM Spec said null.
+
+The DOM Spec says: Applications must encode DOMString using UTF-16 (defined in
+Appendix C.3 of [UNICODE] and Amendment 1 of [ISO-10646]).
+In this implementation we use plain old Perl strings encoded in UTF-8 instead of
+UTF-16.
+
+=item * Text and CDATASection nodes
+
+The Expat parser expands EntityReferences and CDataSection sections to
+raw strings and does not indicate where it was found.
+This implementation does therefore convert both to Text nodes at parse time.
+CDATASection and EntityReference nodes that are added to an existing Document
+(by the user) will be preserved.
+
+Also, subsequent Text nodes are always merged at parse time. Text nodes that are
+added later can be merged with the normalize method. Consider using the addText
+method when adding Text nodes.
+
+=item * Printing and toString
+
+When printing (and converting an XML Document to a string) the strings have to
+encoded differently depending on where they occur. E.g. in a CDATASection all
+substrings are allowed except for "]]>". In regular text, certain characters are
+not allowed, e.g. ">" has to be converted to "&gt;".
+These routines should be verified by someone who knows the details.
+
+=item * Quotes
+
+Certain sections in XML are quoted, like attribute values in an Element.
+XML::Parser strips these quotes and the print methods in this implementation
+always uses double quotes, so when parsing and printing a document, single quotes
+may be converted to double quotes. The default value of an attribute definition
+(AttDef) in an AttlistDecl, however, will maintain its quotes.
+
+=item * AttlistDecl
+
+Attribute declarations for a certain Element are always merged into a single
+AttlistDecl object.
+
+=item * Comments
+
+Comments in the DOCTYPE section are not kept in the right place. They will become
+child nodes of the Document.
+
+=item * Hidden Nodes
+
+Previous versions of XML::DOM would expand parameter entity references
+(like B<%pent;>), so when printing the DTD, it would print the contents
+of the external entity, instead of the parameter entity reference.
+With this release (1.27), you can prevent this by setting the XML::DOM::Parser
+options ParseParamEnt => 1 and ExpandParamEnt => 0.
+
+When it is parsing the contents of the external entities, it *DOES* still add
+the nodes to the DocumentType, but it marks these nodes by setting
+the 'Hidden' property. In addition, it adds an EntityReference node to the
+DocumentType node.
+
+When printing the DocumentType node (or when using to_expat() or to_sax()),
+the 'Hidden' nodes are suppressed, so you will see the parameter entity
+reference instead of the contents of the external entities. See test case
+t/dom_extent.t for an example.
+
+The reason for adding the 'Hidden' nodes to the DocumentType node, is that
+the nodes may contain <!ENTITY> definitions that are referenced further
+in the document. (Simply not adding the nodes to the DocumentType could
+cause such entity references to be expanded incorrectly.)
+
+Note that you need XML::Parser 2.27 or higher for this to work correctly.
+
+=back
+
+=head1 SEE ALSO
+
+The Japanese version of this document by Takanori Kawai (Hippo2000)
+at L<http://member.nifty.ne.jp/hippo2000/perltips/xml/dom.htm>
+
+The DOM Level 1 specification at L<http://www.w3.org/TR/REC-DOM-Level-1>
+
+The XML spec (Extensible Markup Language 1.0) at L<http://www.w3.org/TR/REC-xml>
+
+The L<XML::Parser> and L<XML::Parser::Expat> manual pages.
+
+L<XML::LibXML> also provides a DOM Parser, and is significantly faster
+than XML::DOM, and is under active development. It requires that you
+download the Gnome libxml library.
+
+L<XML::GDOME> will provide the DOM Level 2 Core API, and should be
+as fast as XML::LibXML, but more robust, since it uses the memory
+management functions of libgdome. For more details see
+L<http://tjmather.com/xml-gdome/>
+
+=head1 CAVEATS
+
+The method getElementsByTagName() does not return a "live" NodeList.
+Whether this is an actual caveat is debatable, but a few people on the
+www-dom mailing list seemed to think so. I haven't decided yet. It's a pain
+to implement, it slows things down and the benefits seem marginal.
+Let me know what you think.
+
+=head1 AUTHOR
+
+Enno Derksen is the original author.
+
+Send patches to T.J. Mather at <F<tjmather@maxmind.com>>.
+
+Paid support is available from directly from the maintainers of this package.
+Please see L<http://www.maxmind.com/app/opensourceservices> for more details.
+
+Thanks to Clark Cooper for his help with the initial version.
+
+=cut
diff --git a/Build/tools/XML/DOM/DOMException.pm b/Build/tools/XML/DOM/DOMException.pm
new file mode 100644
index 00000000000..d49c69859a4
--- /dev/null
+++ b/Build/tools/XML/DOM/DOMException.pm
@@ -0,0 +1,88 @@
+######################################################################
+package XML::DOM::DOMException;
+######################################################################
+
+use Exporter;
+
+use overload '""' => \&stringify;
+use vars qw ( @ISA @EXPORT @ErrorNames );
+
+BEGIN
+{
+ @ISA = qw( Exporter );
+ @EXPORT = qw( INDEX_SIZE_ERR
+ DOMSTRING_SIZE_ERR
+ HIERARCHY_REQUEST_ERR
+ WRONG_DOCUMENT_ERR
+ INVALID_CHARACTER_ERR
+ NO_DATA_ALLOWED_ERR
+ NO_MODIFICATION_ALLOWED_ERR
+ NOT_FOUND_ERR
+ NOT_SUPPORTED_ERR
+ INUSE_ATTRIBUTE_ERR
+ );
+}
+
+sub UNKNOWN_ERR () {0;} # not in the DOM Spec!
+sub INDEX_SIZE_ERR () {1;}
+sub DOMSTRING_SIZE_ERR () {2;}
+sub HIERARCHY_REQUEST_ERR () {3;}
+sub WRONG_DOCUMENT_ERR () {4;}
+sub INVALID_CHARACTER_ERR () {5;}
+sub NO_DATA_ALLOWED_ERR () {6;}
+sub NO_MODIFICATION_ALLOWED_ERR () {7;}
+sub NOT_FOUND_ERR () {8;}
+sub NOT_SUPPORTED_ERR () {9;}
+sub INUSE_ATTRIBUTE_ERR () {10;}
+
+@ErrorNames = (
+ "UNKNOWN_ERR",
+ "INDEX_SIZE_ERR",
+ "DOMSTRING_SIZE_ERR",
+ "HIERARCHY_REQUEST_ERR",
+ "WRONG_DOCUMENT_ERR",
+ "INVALID_CHARACTER_ERR",
+ "NO_DATA_ALLOWED_ERR",
+ "NO_MODIFICATION_ALLOWED_ERR",
+ "NOT_FOUND_ERR",
+ "NOT_SUPPORTED_ERR",
+ "INUSE_ATTRIBUTE_ERR"
+ );
+sub new
+{
+ my ($type, $code, $msg) = @_;
+ my $self = bless {Code => $code}, $type;
+
+ $self->{Message} = $msg if defined $msg;
+
+# print "=> Exception: " . $self->stringify . "\n";
+ $self;
+}
+
+sub getCode
+{
+ $_[0]->{Code};
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+sub getName
+{
+ $ErrorNames[$_[0]->{Code}];
+}
+
+sub getMessage
+{
+ $_[0]->{Message};
+}
+
+sub stringify
+{
+ my $self = shift;
+
+ "XML::DOM::DOMException(Code=" . $self->getCode . ", Name=" .
+ $self->getName . ", Message=" . $self->getMessage . ")";
+}
+
+1; # package return code
diff --git a/Build/tools/XML/DOM/NamedNodeMap.pm b/Build/tools/XML/DOM/NamedNodeMap.pm
new file mode 100644
index 00000000000..3747d545f0a
--- /dev/null
+++ b/Build/tools/XML/DOM/NamedNodeMap.pm
@@ -0,0 +1,271 @@
+######################################################################
+package XML::DOM::NamedNodeMap;
+######################################################################
+
+use strict;
+
+use Carp;
+use XML::DOM::DOMException;
+use XML::DOM::NodeList;
+
+use vars qw( $Special );
+
+# Constant definition:
+# Note: a real Name should have at least 1 char, so nobody else should use this
+$Special = "";
+
+sub new
+{
+ my ($class, %args) = @_;
+
+ $args{Values} = new XML::DOM::NodeList;
+
+ # Store all NamedNodeMap properties in element $Special
+ bless { $Special => \%args}, $class;
+}
+
+sub getNamedItem
+{
+ # Don't return the $Special item!
+ ($_[1] eq $Special) ? undef : $_[0]->{$_[1]};
+}
+
+sub setNamedItem
+{
+ my ($self, $node) = @_;
+ my $prop = $self->{$Special};
+
+ my $name = $node->getNodeName;
+
+ if ($XML::DOM::SafeMode)
+ {
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR)
+ if $self->isReadOnly;
+
+ croak new XML::DOM::DOMException (WRONG_DOCUMENT_ERR)
+ if $node->[XML::DOM::Node::_Doc] != $prop->{Doc};
+
+ croak new XML::DOM::DOMException (INUSE_ATTRIBUTE_ERR)
+ if defined ($node->[XML::DOM::Node::_UsedIn]);
+
+ croak new XML::DOM::DOMException (INVALID_CHARACTER_ERR,
+ "can't add name with NodeName [$name] to NamedNodeMap")
+ if $name eq $Special;
+ }
+
+ my $values = $prop->{Values};
+ my $index = -1;
+
+ my $prev = $self->{$name};
+ if (defined $prev)
+ {
+ # decouple previous node
+ $prev->decoupleUsedIn;
+
+ # find index of $prev
+ $index = 0;
+ for my $val (@{$values})
+ {
+ last if ($val == $prev);
+ $index++;
+ }
+ }
+
+ $self->{$name} = $node;
+ $node->[XML::DOM::Node::_UsedIn] = $self;
+
+ if ($index == -1)
+ {
+ push (@{$values}, $node);
+ }
+ else # replace previous node with new node
+ {
+ splice (@{$values}, $index, 1, $node);
+ }
+
+ $prev;
+}
+
+sub removeNamedItem
+{
+ my ($self, $name) = @_;
+
+ # Be careful that user doesn't delete $Special node!
+ croak new XML::DOM::DOMException (NOT_FOUND_ERR)
+ if $name eq $Special;
+
+ my $node = $self->{$name};
+
+ croak new XML::DOM::DOMException (NOT_FOUND_ERR)
+ unless defined $node;
+
+ # The DOM Spec doesn't mention this Exception - I think it's an oversight
+ croak new XML::DOM::DOMException (NO_MODIFICATION_ALLOWED_ERR)
+ if $self->isReadOnly;
+
+ $node->decoupleUsedIn;
+ delete $self->{$name};
+
+ # remove node from Values list
+ my $values = $self->getValues;
+ my $index = 0;
+ for my $val (@{$values})
+ {
+ if ($val == $node)
+ {
+ splice (@{$values}, $index, 1, ());
+ last;
+ }
+ $index++;
+ }
+ $node;
+}
+
+# The following 2 are really bogus. DOM should use an iterator instead (Clark)
+
+sub item
+{
+ my ($self, $item) = @_;
+ $self->{$Special}->{Values}->[$item];
+}
+
+sub getLength
+{
+ my ($self) = @_;
+ my $vals = $self->{$Special}->{Values};
+ int (@$vals);
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+sub isReadOnly
+{
+ return 0 if $XML::DOM::IgnoreReadOnly;
+
+ my $used = $_[0]->{$Special}->{UsedIn};
+ defined $used ? $used->isReadOnly : 0;
+}
+
+sub cloneNode
+{
+ my ($self, $deep) = @_;
+ my $prop = $self->{$Special};
+
+ my $map = new XML::DOM::NamedNodeMap (Doc => $prop->{Doc});
+ # Not copying Parent property on purpose!
+
+ local $XML::DOM::IgnoreReadOnly = 1; # temporarily...
+
+ for my $val (@{$prop->{Values}})
+ {
+ my $key = $val->getNodeName;
+
+ my $newNode = $val->cloneNode ($deep);
+ $newNode->[XML::DOM::Node::_UsedIn] = $map;
+ $map->{$key} = $newNode;
+ push (@{$map->{$Special}->{Values}}, $newNode);
+ }
+
+ $map;
+}
+
+sub setOwnerDocument
+{
+ my ($self, $doc) = @_;
+ my $special = $self->{$Special};
+
+ $special->{Doc} = $doc;
+ for my $kid (@{$special->{Values}})
+ {
+ $kid->setOwnerDocument ($doc);
+ }
+}
+
+sub getChildIndex
+{
+ my ($self, $attr) = @_;
+ my $i = 0;
+ for my $kid (@{$self->{$Special}->{Values}})
+ {
+ return $i if $kid == $attr;
+ $i++;
+ }
+ -1; # not found
+}
+
+sub getValues
+{
+ wantarray ? @{ $_[0]->{$Special}->{Values} } : $_[0]->{$Special}->{Values};
+}
+
+# Remove circular dependencies. The NamedNodeMap and its values should
+# not be used afterwards.
+sub dispose
+{
+ my $self = shift;
+
+ for my $kid (@{$self->getValues})
+ {
+ undef $kid->[XML::DOM::Node::_UsedIn]; # was delete
+ $kid->dispose;
+ }
+
+ delete $self->{$Special}->{Doc};
+ delete $self->{$Special}->{Parent};
+ delete $self->{$Special}->{Values};
+
+ for my $key (keys %$self)
+ {
+ delete $self->{$key};
+ }
+}
+
+sub setParentNode
+{
+ $_[0]->{$Special}->{Parent} = $_[1];
+}
+
+sub getProperty
+{
+ $_[0]->{$Special}->{$_[1]};
+}
+
+#?? remove after debugging
+sub toString
+{
+ my ($self) = @_;
+ my $str = "NamedNodeMap[";
+ while (my ($key, $val) = each %$self)
+ {
+ if ($key eq $Special)
+ {
+ $str .= "##Special (";
+ while (my ($k, $v) = each %$val)
+ {
+ if ($k eq "Values")
+ {
+ $str .= $k . " => [";
+ for my $a (@$v)
+ {
+# $str .= $a->getNodeName . "=" . $a . ",";
+ $str .= $a->toString . ",";
+ }
+ $str .= "], ";
+ }
+ else
+ {
+ $str .= $k . " => " . $v . ", ";
+ }
+ }
+ $str .= "), ";
+ }
+ else
+ {
+ $str .= $key . " => " . $val . ", ";
+ }
+ }
+ $str . "]";
+}
+
+1; # package return code
diff --git a/Build/tools/XML/DOM/NodeList.pm b/Build/tools/XML/DOM/NodeList.pm
new file mode 100644
index 00000000000..81aad84881c
--- /dev/null
+++ b/Build/tools/XML/DOM/NodeList.pm
@@ -0,0 +1,46 @@
+######################################################################
+package XML::DOM::NodeList;
+######################################################################
+
+use vars qw ( $EMPTY );
+
+# Empty NodeList
+$EMPTY = new XML::DOM::NodeList;
+
+sub new
+{
+ bless [], $_[0];
+}
+
+sub item
+{
+ $_[0]->[$_[1]];
+}
+
+sub getLength
+{
+ int (@{$_[0]});
+}
+
+#------------------------------------------------------------
+# Extra method implementations
+
+sub dispose
+{
+ my $self = shift;
+ for my $kid (@{$self})
+ {
+ $kid->dispose;
+ }
+}
+
+sub setOwnerDocument
+{
+ my ($self, $doc) = @_;
+ for my $kid (@{$self})
+ {
+ $kid->setOwnerDocument ($doc);
+ }
+}
+
+1; # package return code
diff --git a/Build/tools/XML/DOM/PerlSAX.pm b/Build/tools/XML/DOM/PerlSAX.pm
new file mode 100644
index 00000000000..f025cce0afd
--- /dev/null
+++ b/Build/tools/XML/DOM/PerlSAX.pm
@@ -0,0 +1,47 @@
+package XML::DOM::PerlSAX;
+use strict;
+
+BEGIN
+{
+ if ($^W)
+ {
+ warn "XML::DOM::PerlSAX has been renamed to XML::Handler::BuildDOM, please modify your code accordingly.";
+ }
+}
+
+use XML::Handler::BuildDOM;
+use vars qw{ @ISA };
+@ISA = qw{ XML::Handler::BuildDOM };
+
+1; # package return code
+
+__END__
+
+=head1 NAME
+
+XML::DOM::PerlSAX - Old name of L<XML::Handler::BuildDOM>
+
+=head1 SYNOPSIS
+
+ See L<XML::DOM::BuildDOM>
+
+=head1 DESCRIPTION
+
+XML::DOM::PerlSAX was renamed to L<XML::Handler::BuildDOM> to comply
+with naming conventions for PerlSAX filters/handlers.
+
+For backward compatibility, this package will remain in existence
+(it simply includes XML::Handler::BuildDOM), but it will print a warning when
+running with I<'perl -w'>.
+
+=head1 AUTHOR
+
+Enno Derksen is the original author.
+
+Send bug reports, hints, tips, suggestions to T.J Mather at
+<F<tjmather@tjmather.com>>.
+
+=head1 SEE ALSO
+
+L<XML::Handler::BuildDOM>, L<XML::DOM>
+
diff --git a/Build/tools/XML/Handler/BuildDOM.pm b/Build/tools/XML/Handler/BuildDOM.pm
new file mode 100644
index 00000000000..e124f47ee49
--- /dev/null
+++ b/Build/tools/XML/Handler/BuildDOM.pm
@@ -0,0 +1,338 @@
+package XML::Handler::BuildDOM;
+use strict;
+use XML::DOM;
+
+#
+# TODO:
+# - add support for parameter entity references
+# - expand API: insert Elements in the tree or stuff into DocType etc.
+
+sub new
+{
+ my ($class, %args) = @_;
+ bless \%args, $class;
+}
+
+#-------- PerlSAX Handler methods ------------------------------
+
+sub start_document # was Init
+{
+ my $self = shift;
+
+ # Define Document if it's not set & not obtainable from Element or DocType
+ $self->{Document} ||=
+ (defined $self->{Element} ? $self->{Element}->getOwnerDocument : undef)
+ || (defined $self->{DocType} ? $self->{DocType}->getOwnerDocument : undef)
+ || new XML::DOM::Document();
+
+ $self->{Element} ||= $self->{Document};
+
+ unless (defined $self->{DocType})
+ {
+ $self->{DocType} = $self->{Document}->getDoctype
+ if defined $self->{Document};
+
+ unless (defined $self->{Doctype})
+ {
+#?? should be $doc->createDocType for extensibility!
+ $self->{DocType} = new XML::DOM::DocumentType ($self->{Document});
+ $self->{Document}->setDoctype ($self->{DocType});
+ }
+ }
+
+ # Prepare for document prolog
+ $self->{InProlog} = 1;
+
+ # We haven't passed the root element yet
+ $self->{EndDoc} = 0;
+
+ undef $self->{LastText};
+}
+
+sub end_document # was Final
+{
+ my $self = shift;
+ unless ($self->{SawDocType})
+ {
+ my $doctype = $self->{Document}->removeDoctype;
+ $doctype->dispose;
+#?? do we always want to destroy the Doctype?
+ }
+ $self->{Document};
+}
+
+sub characters # was Char
+{
+ my $self = $_[0];
+ my $str = $_[1]->{Data};
+
+ if ($self->{InCDATA} && $self->{KeepCDATA})
+ {
+ undef $self->{LastText};
+ # Merge text with previous node if possible
+ $self->{Element}->addCDATA ($str);
+ }
+ else
+ {
+ # Merge text with previous node if possible
+ # Used to be: $expat->{DOM_Element}->addText ($str);
+ if ($self->{LastText})
+ {
+ $self->{LastText}->appendData ($str);
+ }
+ else
+ {
+ $self->{LastText} = $self->{Document}->createTextNode ($str);
+ $self->{Element}->appendChild ($self->{LastText});
+ }
+ }
+}
+
+sub start_element # was Start
+{
+ my ($self, $hash) = @_;
+ my $elem = $hash->{Name};
+ my $attr = $hash->{Attributes};
+
+ my $parent = $self->{Element};
+ my $doc = $self->{Document};
+
+ if ($parent == $doc)
+ {
+ # End of document prolog, i.e. start of first Element
+ $self->{InProlog} = 0;
+ }
+
+ undef $self->{LastText};
+ my $node = $doc->createElement ($elem);
+ $self->{Element} = $node;
+ $parent->appendChild ($node);
+
+ my $i = 0;
+ my $n = scalar keys %$attr;
+ return unless $n;
+
+ if (exists $hash->{AttributeOrder})
+ {
+ my $defaulted = $hash->{Defaulted};
+ my @order = @{ $hash->{AttributeOrder} };
+
+ # Specified attributes
+ for (my $i = 0; $i < $defaulted; $i++)
+ {
+ my $a = $order[$i];
+ my $att = $doc->createAttribute ($a, $attr->{$a}, 1);
+ $node->setAttributeNode ($att);
+ }
+
+ # Defaulted attributes
+ for (my $i = $defaulted; $i < @order; $i++)
+ {
+ my $a = $order[$i];
+ my $att = $doc->createAttribute ($elem, $attr->{$a}, 0);
+ $node->setAttributeNode ($att);
+ }
+ }
+ else
+ {
+ # We're assuming that all attributes were specified (1)
+ for my $a (keys %$attr)
+ {
+ my $att = $doc->createAttribute ($a, $attr->{$a}, 1);
+ $node->setAttributeNode ($att);
+ }
+ }
+}
+
+sub end_element
+{
+ my $self = shift;
+ $self->{Element} = $self->{Element}->getParentNode;
+ undef $self->{LastText};
+
+ # Check for end of root element
+ $self->{EndDoc} = 1 if ($self->{Element} == $self->{Document});
+}
+
+sub entity_reference # was Default
+{
+ my $self = $_[0];
+ my $name = $_[1]->{Name};
+
+ $self->{Element}->appendChild (
+ $self->{Document}->createEntityReference ($name));
+ undef $self->{LastText};
+}
+
+sub start_cdata
+{
+ my $self = shift;
+ $self->{InCDATA} = 1;
+}
+
+sub end_cdata
+{
+ my $self = shift;
+ $self->{InCDATA} = 0;
+}
+
+sub comment
+{
+ my $self = $_[0];
+
+ local $XML::DOM::IgnoreReadOnly = 1;
+
+ undef $self->{LastText};
+ my $comment = $self->{Document}->createComment ($_[1]->{Data});
+ $self->{Element}->appendChild ($comment);
+}
+
+sub doctype_decl
+{
+ my ($self, $hash) = @_;
+
+ $self->{DocType}->setParams ($hash->{Name}, $hash->{SystemId},
+ $hash->{PublicId}, $hash->{Internal});
+ $self->{SawDocType} = 1;
+}
+
+sub attlist_decl
+{
+ my ($self, $hash) = @_;
+
+ local $XML::DOM::IgnoreReadOnly = 1;
+
+ $self->{DocType}->addAttDef ($hash->{ElementName},
+ $hash->{AttributeName},
+ $hash->{Type},
+ $hash->{Default},
+ $hash->{Fixed});
+}
+
+sub xml_decl
+{
+ my ($self, $hash) = @_;
+
+ local $XML::DOM::IgnoreReadOnly = 1;
+
+ undef $self->{LastText};
+ $self->{Document}->setXMLDecl (new XML::DOM::XMLDecl ($self->{Document},
+ $hash->{Version},
+ $hash->{Encoding},
+ $hash->{Standalone}));
+}
+
+sub entity_decl
+{
+ my ($self, $hash) = @_;
+
+ local $XML::DOM::IgnoreReadOnly = 1;
+
+ # Parameter Entities names are passed starting with '%'
+ my $parameter = 0;
+
+#?? parameter entities currently not supported by PerlSAX!
+
+ undef $self->{LastText};
+ $self->{DocType}->addEntity ($parameter, $hash->{Name}, $hash->{Value},
+ $hash->{SystemId}, $hash->{PublicId},
+ $hash->{Notation});
+}
+
+# Unparsed is called when it encounters e.g:
+#
+# <!ENTITY logo SYSTEM "http://server/logo.gif" NDATA gif>
+#
+sub unparsed_decl
+{
+ my ($self, $hash) = @_;
+
+ local $XML::DOM::IgnoreReadOnly = 1;
+
+ # same as regular ENTITY, as far as DOM is concerned
+ $self->entity_decl ($hash);
+}
+
+sub element_decl
+{
+ my ($self, $hash) = @_;
+
+ local $XML::DOM::IgnoreReadOnly = 1;
+
+ undef $self->{LastText};
+ $self->{DocType}->addElementDecl ($hash->{Name}, $hash->{Model});
+}
+
+sub notation_decl
+{
+ my ($self, $hash) = @_;
+
+ local $XML::DOM::IgnoreReadOnly = 1;
+
+ undef $self->{LastText};
+ $self->{DocType}->addNotation ($hash->{Name}, $hash->{Base},
+ $hash->{SystemId}, $hash->{PublicId});
+}
+
+sub processing_instruction
+{
+ my ($self, $hash) = @_;
+
+ local $XML::DOM::IgnoreReadOnly = 1;
+
+ undef $self->{LastText};
+ $self->{Element}->appendChild (new XML::DOM::ProcessingInstruction
+ ($self->{Document}, $hash->{Target}, $hash->{Data}));
+}
+
+return 1;
+
+__END__
+
+=head1 NAME
+
+XML::Handler::BuildDOM - PerlSAX handler that creates XML::DOM document structures
+
+=head1 SYNOPSIS
+
+ use XML::Handler::BuildDOM;
+ use XML::Parser::PerlSAX;
+
+ my $handler = new XML::Handler::BuildDOM (KeepCDATA => 1);
+ my $parser = new XML::Parser::PerlSAX (Handler => $handler);
+
+ my $doc = $parser->parsefile ("file.xml");
+
+=head1 DESCRIPTION
+
+XML::Handler::BuildDOM creates L<XML::DOM> document structures
+(i.e. L<XML::DOM::Document>) from PerlSAX events.
+
+This class used to be called L<XML::PerlSAX::DOM> prior to libxml-enno 1.0.1.
+
+=head2 CONSTRUCTOR OPTIONS
+
+The XML::Handler::BuildDOM constructor supports the following options:
+
+=over 4
+
+=item * KeepCDATA => 1
+
+If set to 0 (default), CDATASections will be converted to regular text.
+
+=item * Document => $doc
+
+If undefined, start_document will extract it from Element or DocType (if set),
+otherwise it will create a new XML::DOM::Document.
+
+=item * Element => $elem
+
+If undefined, it is set to Document. This will be the insertion point (or parent)
+for the nodes defined by the following callbacks.
+
+=item * DocType => $doctype
+
+If undefined, start_document will extract it from Document (if possible).
+Otherwise it adds a new XML::DOM::DocumentType to the Document.
+
+=back
diff --git a/Build/tools/check1 b/Build/tools/check1
new file mode 100644
index 00000000000..3302043187c
--- /dev/null
+++ b/Build/tools/check1
@@ -0,0 +1,11 @@
+grep Package ../texmf/tpm/collection*tpm | grep name= | sed 's/.*Package name=.//' | sed 's/\".*//' > 2
+grep Documentation ../texmf/tpm/collection*tpm | grep name= | sed 's/.*Documentation name=.//' | sed 's/\".*//' >> 2
+grep TLCore ../texmf/tpm/collection*tpm | grep name= | sed 's/.*TLCore name=.//' | sed 's/\".*//' >> 2
+sort -u 2 > 3
+mv 3 2
+ls ../texmf-dist/tpm/ | sed 's/\.tpm//' > 1
+ls ../texmf/tpm/ | sed 's/\.tpm//' >> 1
+ls ../texmf-doc/tpm/ | sed 's/\.tpm//' >> 1
+sort 1 > 3
+mv 3 1
+diff 1 2 > 3
diff --git a/Build/tools/collection2list.xsl b/Build/tools/collection2list.xsl
new file mode 100644
index 00000000000..af7f86ba404
--- /dev/null
+++ b/Build/tools/collection2list.xsl
@@ -0,0 +1,92 @@
+<!-- $Id$
+ Written by Sebastian Rahtz. Public domain. -->
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:exsl="http://exslt.org/common"
+ exclude-result-prefixes="exsl"
+ extension-element-prefixes="exsl"
+ xmlns:TPM="http://texlive.dante.de/"
+ version="1.0">
+
+<xsl:output method="xml" omit-xml-declaration="yes"/>
+
+<xsl:strip-space elements="*"/>
+
+<!-- assume the current directory is Master, as Tools/update arranges. -->
+<xsl:param name="ROOT">.</xsl:param>
+
+<xsl:variable name="Master">
+ <xsl:value-of select="$ROOT"/>/texmf/lists/</xsl:variable>
+<xsl:variable name="COL">texmf/tpm/</xsl:variable>
+<xsl:variable name="LISTS">texmf/lists/</xsl:variable>
+
+<xsl:template match="/">
+ <!--
+ <xsl:message>Write <xsl:value-of select="concat($Master,.//TPM:Name)"/></xsl:message>
+-->
+ <exsl:document href="{concat($Master,//TPM:Name)}" method="text">
+<xsl:text>*Title: </xsl:text>
+ <xsl:value-of select="normalize-space(.//TPM:Title)"/>
+<xsl:text>&#10;</xsl:text>
+<xsl:text>*Size: </xsl:text>
+ <xsl:call-template name="findSize"/>
+ <xsl:text>&#10;</xsl:text>
+ <xsl:apply-templates select=".//TPM:Requires"/>
+ <xsl:apply-templates select=".//TPM:DocFiles"/><xsl:text>&#10;</xsl:text>
+ <xsl:apply-templates select=".//TPM:SourceFiles"/><xsl:text>&#10;</xsl:text>
+ <xsl:apply-templates select=".//TPM:RunFiles"/><xsl:text>&#10;</xsl:text>
+ <xsl:text>&#10;</xsl:text>
+ <xsl:value-of select="$LISTS"/>
+ <xsl:value-of select=".//TPM:Name"/>
+ <xsl:text>&#10;</xsl:text>
+ </exsl:document>
+</xsl:template>
+
+<xsl:template match="TPM:DocFiles|TPM:SourceFiles|TPM:RunFiles">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+</xsl:template>
+
+<xsl:template match="TPM:Requires">
+<xsl:for-each select="TPM:Documentation|TPM:Package|TPM:TLCore">
+<xsl:sort select="normalize-space(@name)"/>
+<xsl:text>+</xsl:text>
+<xsl:value-of select="translate(normalize-space(@name),' ','&#10;')"/>
+<xsl:text>&#10;</xsl:text>
+</xsl:for-each>
+<xsl:for-each select="TPM:Collection">
+<xsl:text>-</xsl:text>
+<xsl:value-of select="translate(normalize-space(@name),' ','&#10;')"/>
+<xsl:text>&#10;</xsl:text>
+</xsl:for-each>
+</xsl:template>
+
+<xsl:template name="findSize">
+ <xsl:variable name="Sizes">
+ <Sizes>
+ <Size><xsl:value-of select=".//TPM:Size"/></Size>
+ <xsl:for-each select=".//TPM:Requires">
+ <xsl:for-each select="TPM:Documentation">
+ <xsl:for-each
+ select="document(concat($ROOT,'/texmf-doc/tpm/',@name,'.tpm'))">
+ <Size><xsl:value-of select=".//TPM:Size"/></Size>
+ </xsl:for-each>
+ </xsl:for-each>
+ <xsl:for-each select="TPM:Package">
+ <xsl:for-each
+ select="document(concat($ROOT,'/texmf-dist/tpm/',@name,'.tpm'))">
+ <Size><xsl:value-of select=".//TPM:Size"/></Size>
+ </xsl:for-each>
+ </xsl:for-each>
+ <xsl:for-each select="TPM:Core">
+ <xsl:for-each
+ select="document(concat($ROOT,'/texmf/tpm/',@name,'.tpm'))">
+ <Size><xsl:value-of select=".//TPM:Size"/></Size>
+ </xsl:for-each>
+ </xsl:for-each>
+ </xsl:for-each>
+ </Sizes>
+ </xsl:variable>
+<xsl:value-of select="sum(exsl:node-set($Sizes)//Size)"/>
+</xsl:template>
+
+</xsl:stylesheet>
diff --git a/Build/tools/ctan2tl b/Build/tools/ctan2tl
new file mode 100755
index 00000000000..05eeaee2212
--- /dev/null
+++ b/Build/tools/ctan2tl
@@ -0,0 +1,124 @@
+#!/bin/sh
+# $Id: //depot/Master/Tools/ctan2tl#23 $
+# Public domain. Originally written 2005, Karl Berry.
+#
+# Takes a ctan directory, pushes it into TL. Just an initial attempt.
+# --no-place to avoid final place invocation (p4 operations).
+# See ./README for a bit more info.
+
+mydir=`dirname $0` # Master/Tools
+cd $mydir/../../Build/cdbuild/raw || exit 1
+
+if test "x$1" = x--place; then
+ place=true
+ shift
+else
+ place=false
+fi
+
+if test "x$1" = x--no-ctan; then
+ copy_from_ctan=false
+ shift
+else
+ copy_from_ctan=true
+fi
+
+if test ! -d $1; then
+ echo "$0: $1 not a directory." >&2
+ exit 1
+fi
+
+# xx this should be a separate script, also used by tpm-ctan-check.
+pkg=`basename $1`
+
+if $copy_from_ctan; then
+case "$pkg" in
+ biblio) pkg=beebe;;
+ fourier-GUT) pkg=fourier;;
+ generic) pkg=genmisc;; # $ctan/macros/generic
+ ha-prosper) pkg=HA-prosper;;
+ misc) pkg=ltxmisc;; # until we do real misc package.
+ tex-references) pkg=tex-refs;;
+ velthuis) pkg=devanagr;;
+ voss) pkg=voss-de;;
+esac
+
+# lshort is arranged by language.
+pkgdir=`dirname $1`
+up=`basename $pkgdir`
+test "$up" = lshort && pkg=lshort-$pkg
+
+# esint is split into two.
+test "$pkg" = esint && test "$up" = ps-type1 && pkg=esint-type1
+
+# vntex is in an unpacked subdir.
+test "$pkg" = unpacked && test "$up" = vntex && pkg=vntex
+
+# similarly for powerdot.
+test "$pkg" = distrib && test "$up" = powerdot && pkg=powerdot
+
+# powerdot-doc-vn is a couple subdirs down.
+test "$pkg" = doc-vn && test "$up" = contrib && pkg=powerdot-doc-vn
+
+# amslatex/vietnamese.
+test "$pkg" = vietnamese && test "$up" = amslatex && pkg=amsldoc-vn
+
+
+# remove whatever old stuff we might have.
+rm -rf $pkg
+
+if test "$pkg" = genmisc; then
+ # do not copy subdirs, symlinks, or any files but .sty and .tex
+ # (that is, no patch.doc or pmat.zip).
+ mkdir -p $pkg
+ cp -p \
+ `find $1/* '(' -type d -o -type l ')' -prune -o \
+ '(' -name '*.sty' -o -name *.tex ')' -print` \
+ $pkg
+else
+ # normal case
+ cp -pr $1 $pkg
+fi
+
+fi # end of copying from CTAN.
+
+
+printf "\n\f ctan2tds\n"
+rm -rf ../cooked/$pkg
+test -d ../cooked || mkdir ../cooked
+../ctan2tds.pl $pkg || exit 1
+
+cd ../cooked || exit 1
+printf "\n\f cooked\n"
+find -depth -type d | xargs rmdir 2>/dev/null
+find $pkg \! -type d -printf "%TY%Tm%Td.%TH%TM %p\n" | sort +1
+
+# compare to tpm.
+Master=../../../Master
+tpmfile=`ls $Master/texmf*/tpm/$pkg.tpm 2>/dev/null`
+if test -z "$tpmfile"; then
+ echo "$0: no tpm file for $pkg in `cd $Master; pwd`." >&2
+else
+ printf "\n\f compared to current tpm $tpmfile\n"
+ rm -f /tmp/pkgfiles.*
+ # remove leading text in case of lines starting with texmf.
+ # Then assume all actual files do start with texmf.
+ sed -n -e '/TPM:.*Files/,$s,^texmf,./texmf,p' $tpmfile \
+ | grep -v '\.tpm$' \
+ | sort >/tmp/pkgfiles.tpm
+ #
+ # list of files in the new package we've just cooked.
+ (cd $pkg && find \! -type d -print) | grep -v '/cooked/' \
+ | sort >/tmp/pkgfiles.tl
+ #
+ comm -3 /tmp/pkgfiles.tpm /tmp/pkgfiles.tl
+fi
+
+$place || exit 0
+
+printf "\n\f place\n"
+rm -rf $pkg.done
+../place $pkg
+p4 revert -a
+
+rm -rf ../raw/$pkg
diff --git a/Build/tools/global-replace.pl b/Build/tools/global-replace.pl
new file mode 100644
index 00000000000..815f089f4a8
--- /dev/null
+++ b/Build/tools/global-replace.pl
@@ -0,0 +1,149 @@
+: #-*- Perl -*-
+
+### global-modify --- modify the contents of a file by a Perl expression
+
+## Copyright (C) 1999 Martin Buchholz.
+## Copyright (C) 2001 Ben Wing.
+
+## Authors: Martin Buchholz <martin@xemacs.org>, Ben Wing <ben@xemacs.org>
+## Maintainer: Ben Wing <ben@xemacs.org>
+## Current Version: 1.0, May 5, 2001
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with XEmacs; see the file COPYING. If not, write to the Free
+# Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+# 02111-1307, USA.
+
+eval 'exec perl -w -S $0 ${1+"$@"}'
+ if 0;
+
+use strict;
+use FileHandle;
+use Carp;
+use Getopt::Long;
+use File::Basename;
+
+(my $myName = $0) =~ s@.*/@@; my $usage="
+Usage: $myName [--help] [--backup-dir=DIR] [--line-mode] [--hunk-mode]
+ PERLEXPR FILE ...
+
+Globally modify a file, either line by line or in one big hunk.
+
+Typical usage is like this:
+
+[with GNU print, GNU xargs: guaranteed to handle spaces, quotes, etc.
+ in file names]
+
+find . -name '*.[ch]' -print0 | xargs -0 $0 's/\bCONST\b/const/g'\n
+
+[with non-GNU print, xargs]
+
+find . -name '*.[ch]' -print | xargs $0 's/\bCONST\b/const/g'\n
+
+
+The file is read in, either line by line (with --line-mode specified)
+or in one big hunk (with --hunk-mode specified; it's the default), and
+the Perl expression is then evalled with \$_ set to the line or hunk of
+text, including the terminating newline if there is one. It should
+destructively modify the value there, storing the changed result in \$_.
+
+Files in which any modifications are made are backed up to the directory
+specified using --backup-dir, or to `backup' by default. To disable this,
+use --backup-dir= with no argument.
+
+Hunk mode is the default because it is MUCH MUCH faster than line-by-line.
+Use line-by-line only when it matters, e.g. you want to do a replacement
+only once per line (the default without the `g' argument). Conversely,
+when using hunk mode, *ALWAYS* use `g'; otherwise, you will only make one
+replacement in the entire file!
+";
+
+my %options = ();
+$Getopt::Long::ignorecase = 0;
+&GetOptions (
+ \%options,
+ 'help', 'backup-dir=s', 'line-mode', 'hunk-mode',
+);
+
+while (<STDIN>) {
+ chomp;
+ if (-f ) {
+ push @ARGV, $_;
+ }
+}
+print "argv = @ARGV\n";
+die $usage if $options{"help"} or @ARGV <= 1;
+my $code = shift;
+
+die $usage if grep (-d || ! -w, @ARGV);
+
+sub SafeOpen {
+ open ((my $fh = new FileHandle), $_[0]);
+ confess "Can't open $_[0]: $!" if ! defined $fh;
+ return $fh;
+}
+
+sub SafeClose {
+ close $_[0] or confess "Can't close $_[0]: $!";
+}
+
+sub FileContents {
+ my $fh = SafeOpen ("< $_[0]");
+ my $olddollarslash = $/;
+ local $/ = undef;
+ my $contents = <$fh>;
+ $/ = $olddollarslash;
+ return $contents;
+}
+
+sub WriteStringToFile {
+ my $fh = SafeOpen ("> $_[0]");
+ binmode $fh;
+ print $fh $_[1] or confess "$_[0]: $!\n";
+ SafeClose $fh;
+}
+
+foreach my $file (@ARGV) {
+ my $changed_p = 0;
+ my $new_contents = "";
+ if ($options{"line-mode"}) {
+ my $fh = SafeOpen $file;
+ while (<$fh>) {
+ my $save_line = $_;
+ eval $code;
+ $changed_p = 1 if $save_line ne $_;
+ $new_contents .= $_;
+ }
+ } else {
+ my $orig_contents = $_ = FileContents $file;
+ eval $code;
+ if ($_ ne $orig_contents) {
+ $changed_p = 1;
+ $new_contents = $_;
+ }
+ }
+
+ if ($changed_p) {
+ my $backdir = $options{"backup-dir"};
+ $backdir = "backup" if !defined ($backdir);
+ if ($backdir) {
+ my ($name, $path, $suffix) = fileparse ($file, "");
+ my $backfulldir = $path . $backdir;
+ my $backfile = "$backfulldir/$name";
+ mkdir $backfulldir, 0755 unless -d $backfulldir;
+ print "modifying $file (original saved in $backfile)\n";
+ rename $file, $backfile;
+ }
+ WriteStringToFile ($file, $new_contents);
+ }
+}
diff --git a/Build/tools/htmltext b/Build/tools/htmltext
new file mode 100755
index 00000000000..c41eb2490fe
--- /dev/null
+++ b/Build/tools/htmltext
@@ -0,0 +1,23 @@
+#!/bin/sh
+# $Id$
+# Public domain. Originally written 2003, Karl Berry.
+# Dump a url (or -stdin) to text using lynx.
+
+PATH=/usr/local/bin:$PATH
+
+HOME=/tmp; export HOME
+TERM=vt100; export TERM
+: ${LYNX_CFG=/home/tug/.lynxcfg}; export LYNX_CFG
+# just contains the line JUSTIFY:FALSE.
+
+test $# -eq 0 && set - -stdin
+
+for url in "$@"; do
+ # when we add -width=79, tables are formatted badly.
+ # -dump lists url's like this with -stdin (lynx 2.8.4, linux):
+ # file://localhost/tmp/89inmk/FAQ/german
+ # Since the reference list is useful, we fix it up by hand instead of
+ # using -nolist.
+ lynx -dump -nocolor -hiddenlinks=ignore "$url" \
+ | sed 's,file://localhost/tmp/[a-zA-Z0-9]*/,,'
+done
diff --git a/Build/tools/mkdocindex b/Build/tools/mkdocindex
new file mode 100755
index 00000000000..cc83a522810
--- /dev/null
+++ b/Build/tools/mkdocindex
@@ -0,0 +1,165 @@
+#!/usr/local/bin/perl
+# $Id: //depot/Master/Tools/mkdocindex#2 $
+# Make index file of all HTML and PDF documentation.
+# Originally written 2004, Karl Berry. Public domain.
+
+exit (&main ());
+
+sub main
+{
+ (my $progname = $0) =~ s,^.*/,,;
+ umask (0);
+
+ chomp (my $mydir = `dirname $0`); # Tools
+ chdir ("$mydir/..") || exit 1; # Master
+
+ # shell fragment we use to find doc files in a directory.
+ $FIND_POST = " \\( -name \\*.html -o -name \\*.pdf \\) "
+ . " | sort -f -t/ +3 |";
+
+ print <<END_HEADER;
+<html>
+<body>
+<h1>TeX Live documentation</h2>
+
+<a name="packagedoc"></a>
+<h2>1. Package documentation</h2>
+
+<p>This section lists links to all HTML and PDF files for packages (in
+the <a href="texmf/">texmf</a> and <a href="texmf-dist/">texmf-dist</a>
+directories), sorted by package name.
+
+<p><a href="#guidedoc">Jump to guide documentation</a>.
+END_HEADER
+
+ &do_package_list ();
+
+ print <<END_BETWEEN;
+<a name="guidedoc"></a>
+<h2>2. Guide documentation</h2>
+
+<p>This section lists links to all guides, that is, packages consisting
+only of documentation (in the <a href="texmf-doc/">texmf-doc</a>
+directory), sorted by language.
+
+<p><a href="#packagedoc">Jump to package documentation</a>.
+END_BETWEEN
+
+ &do_guide_list ();
+
+ chomp (my $date = `date`);
+ print <<END_TRAILER;
+<hr>
+<small>Generated $date by $progname.</small>
+</body></html>
+END_TRAILER
+
+ return 0;
+}
+
+
+
+# Package doc (texmf and texmf-dist), by package.
+#
+sub do_package_list
+{
+ &do_filelist ("find texmf/doc texmf-dist/doc $FIND_POST");
+}
+
+
+
+# Guide doc (texmf-doc), by language. In order to generate a list of
+# all the languages at the beginning, we generate everything before
+# writing anything.
+#
+sub do_guide_list
+{
+ # each subdir in texmf-doc is a language, except general.
+ my @langs = map { s,.*/,,; $_ } glob ("texmf-doc/doc/*");
+ my @langs = grep { $_ ne "general" } @langs;
+
+ print "\n<p>Languages:\n<ul>\n";
+ print map { qq!<li><a href="#$_">$_</a>\n! } @langs;
+ print "</ul>\n";
+
+ $count = 0; # for subsection numbers
+ for my $lang (@langs) {
+ $count++;
+ print qq!<a name="#$lang"></a>\n!;
+ print qq!<h3>2.$count <a href="texmf-doc/doc/$lang/">$lang</a></h3>\n!;
+
+ &do_filelist ("find texmf-doc/doc/$lang $FIND_POST");
+ }
+}
+
+
+
+# Process all files resulting from OPENCMD.
+#
+sub do_filelist
+{
+ my ($opencmd) = @_;
+
+ print "\n<ol>\n";
+ my $prevdir = "";
+ my @entries = ();
+
+ $FILELIST = $opencmd;
+ open (FILELIST) || die "open($FILELIST) failed: $!";
+ while (<FILELIST>) {
+ chomp;
+ # collect all files for a given directory
+ (my $thisdir = $_) =~ s,/[^/]*$,,;
+
+ if ($thisdir eq $prevdir) {
+ push (@entries, $_);
+ } else {
+ &do_directory ($prevdir, @entries) if $prevdir; # avoid first empty
+ $prevdir = $thisdir;
+ @entries = ($_);
+ }
+ }
+ close (FILELIST) || warn "close($FILELIST) failed: $!";
+
+ &do_directory ($prevdir, @entries); # include last
+
+ print "\n</ol>\n";
+}
+
+
+
+# Print doc ENTRIES in DIR.
+#
+sub do_directory
+{
+ my ($dir,@entries) = @_;
+
+ # $dir includes the texmf tree, e.g.,
+ # texmf-dist/doc/allrunes
+ # This is too ugly. We just want to show allrunes, especially since
+ # that's what we sorted by.
+ my (undef,undef,$nicename) = split (/\//, $dir, 3);
+
+ print qq!<li><b><a href="$dir">$nicename</a>!;
+
+ # if we have an index.html or a live.html, make things nicer.
+ if (grep { m,/(index|live)\.html$, } @entries) {
+ # first remove all .html's.
+ @entries = grep { $_ !~ /\.html$/
+ || $_ =~ m,/(index|live)\.html, } @entries;
+
+ # if only one entry left, remove it, the directory link suffices.
+ @entries = () if $entries[0] =~ m,/index\.html$, && @entries == 1;
+ }
+
+ # if we're going to print anything, insert punctuation.
+ print ":" if @entries;
+ print "</b><small>\n";
+
+ for my $e (@entries) {
+ (my $basename = $e) =~ s,.*/,,;
+ print qq! <a href="$e">$basename</a>\n!;
+ }
+
+ print " </small>\n\n";
+}
diff --git a/Build/tools/p4changelog b/Build/tools/p4changelog
new file mode 100755
index 00000000000..558dc274ec1
--- /dev/null
+++ b/Build/tools/p4changelog
@@ -0,0 +1,89 @@
+#!/bin/sh
+# $Id$
+# Public domain. Originally written 2004, Karl Berry.
+# Get change info from p4 describe and p4 changes.
+
+umask 0
+
+debug=${OVERRIDE_DEBUG-false}
+
+mydir=`dirname $0` # Master/Tools
+outdir=`cd $mydir/../../Build/cdbuild/logs && pwd`
+outfile=$outdir/log
+
+line=`grep '^Change' $outfile | head -1`
+lastlogged=`echo "$line" | awk '{print $2}'`
+echo "$lastlogged" | egrep '^[0-9]+$' >/dev/null \
+|| { echo "$0: no change number in Change line of $outfile: $line";
+ exit 1; }
+nextneeded=`expr $lastlogged + 1`
+lastchange=`p4 changes -m 1 -s submitted | awk '{print $2}'`
+
+echo "lastlogged=$lastlogged, nextneeded=$nextneeded, lastchange=$lastchange"
+
+# nothing submitted since last change?
+test $lastchange -lt $nextneeded && exit 0
+
+rotate=false
+for c in `seq $lastchange -1 $nextneeded`; do
+ echo " getting change $c"
+ # rotate if crossed a 500-change mark.
+ echo $c | grep '[05]00$' >/dev/null && rotate=true
+
+ p4 describe -ds $c 2>&1 \
+ | sed -e 's,^\.\.\. //depot/, ,' -e '/^Differences/,$d' \
+ | awk '/^Affected files/ { printf "%s", $0; next } {print}' \
+ >>$outfile.temp
+done
+
+# we'll update $outfile.
+echo "p4 edit $outfile..."
+$debug || p4 edit $outfile
+
+if $rotate; then
+ echo "rotating $lastlogged..."
+ mv $outfile $outfile.$lastlogged
+ gzip $outfile.$lastlogged
+ chmod 444 $outfile.$lastlogged.gz
+ ls -l $outfile.$lastlogged.gz
+ $debug || p4 add $outfile.$lastlogged.gz
+ cp /dev/null $outfile
+fi
+
+# prepend new changes to current log, put into p4.
+cat $outfile.temp $outfile >$outfile.temp2
+
+if $debug; then
+ for f in $outfile $outfile.temp $outfile.temp2; do
+ echo
+ (cd `dirname $f` && ls -l `basename $f`)
+ head -1 $f
+ grep '^Change' $f | tail -1
+ done
+
+ exit 0
+fi
+
+mv $outfile.temp2 $outfile
+echo "p4 submit..."
+p4 change -o \
+| sed "s!<enter description here>!regenerated by $0!" \
+| p4 submit -i
+
+cat $outfile.temp # show it to me
+rm -f $outfile.temp
+
+exit 0
+
+# this was how we grabbed all the old entries to get things started.
+for c in `seq 5150 -1 1`; do
+ expr $c % 500 >/dev/null \
+ || { outfile=$outdir/out.$c; cp /dev/null $outfile; }
+
+ # minimal diff, remove even that (hunk counts) with sed,
+ # remove newline from "Affected files" line.
+ p4 describe -ds $c 2>&1 \
+ | sed -e 's,^\.\.\. //depot/, ,' -e '/^Differences/,$d' \
+ | awk '/^Affected files/ { printf "%s", $0; next } {print}' \
+ >>$outfile
+done
diff --git a/Build/tools/scheme2list.xsl b/Build/tools/scheme2list.xsl
new file mode 100644
index 00000000000..f024cd67fb5
--- /dev/null
+++ b/Build/tools/scheme2list.xsl
@@ -0,0 +1,83 @@
+<!-- $Id$
+ Written by Sebastian Rahtz. Public domain. -->
+
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:exsl="http://exslt.org/common"
+ exclude-result-prefixes="exsl"
+ extension-element-prefixes="exsl"
+ xmlns:TPM="http://texlive.dante.de/"
+ version="1.0">
+
+<xsl:output method="text" omit-xml-declaration="yes"/>
+
+<xsl:strip-space elements="*"/>
+
+<!-- assume the current directory is Master, as Tools/update arranges. -->
+<xsl:param name="ROOT">.</xsl:param>
+
+<xsl:variable name="Master">
+ <xsl:value-of select="$ROOT"/>/texmf/lists/</xsl:variable>
+<xsl:variable name="TPM">
+ <xsl:value-of select="$ROOT"/>/texmf/tpm/</xsl:variable>
+<xsl:variable name="COL">texmf/tpm/</xsl:variable>
+<xsl:variable name="LISTS">texmf/lists/</xsl:variable>
+
+<xsl:template match="/">
+ <!-- <xsl:message>Write <xsl:value-of select="concat($Master,.//TPM:Name)"/>.scheme</xsl:message>-->
+ <exsl:document href="{concat($Master,//TPM:Name)}.scheme" method="text">
+<xsl:text>*Title: </xsl:text>
+ <xsl:value-of select="normalize-space(.//TPM:Title)"/>
+<xsl:text>&#10;</xsl:text>
+<xsl:text>*Size: </xsl:text>
+<xsl:value-of select=".//TPM:Size"/>
+ <xsl:text>&#10;</xsl:text>
+ <xsl:apply-templates select=".//TPM:Requires"/>
+ <xsl:apply-templates select=".//TPM:DocFiles"/><xsl:text>&#10;</xsl:text>
+ <xsl:apply-templates select=".//TPM:SourceFiles"/><xsl:text>&#10;</xsl:text>
+ <xsl:apply-templates select=".//TPM:RunFiles"/><xsl:text>&#10;</xsl:text>
+ <xsl:apply-templates select=".//TPM:BinFiles"/>
+ <xsl:text>&#10;</xsl:text>
+ <xsl:value-of select="$LISTS"/>
+ <xsl:value-of select=".//TPM:Name"/>
+ <xsl:text>.scheme&#10;</xsl:text>
+ </exsl:document>
+</xsl:template>
+
+<xsl:template match="TPM:DocFiles|TPM:SourceFiles|TPM:RunFiles">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+</xsl:template>
+
+<xsl:template match="TPM:BinFiles">
+ <!-- <xsl:message>Write <xsl:value-of
+ select="concat($Master,//TPM:Name)"/>
+ <xsl:text>.vlist.</xsl:text>
+ <xsl:value-of select="@arch"/></xsl:message>
+-->
+ <exsl:document method="text" href="{$Master}{//TPM:Name}.vlist.{@arch}">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+<xsl:text>&#10;</xsl:text>
+<xsl:value-of select="concat($LISTS,//TPM:Name)"/>
+ <xsl:text>.vlist.</xsl:text>
+ <xsl:value-of select="@arch"/>
+<xsl:text>&#10;</xsl:text>
+</exsl:document>
+</xsl:template>
+
+<xsl:template match="TPM:Requires">
+<xsl:for-each select="TPM:Package">
+<xsl:sort select="normalize-space(@name)"/>
+<xsl:text>+</xsl:text>
+<xsl:value-of select="translate(normalize-space(@name),' ','&#10;')"/>
+<xsl:text>&#10;</xsl:text>
+</xsl:for-each>
+<xsl:for-each select="TPM:TLCore">
+<xsl:sort select="normalize-space(@name)"/>
+<xsl:text>-</xsl:text>
+<xsl:value-of select="translate(normalize-space(@name),' ','&#10;')"/>
+<xsl:text>&#10;</xsl:text>
+</xsl:for-each>
+</xsl:template>
+
+
+</xsl:stylesheet>
diff --git a/Build/tools/tlrebuild b/Build/tools/tlrebuild
new file mode 100755
index 00000000000..e44831a78e7
--- /dev/null
+++ b/Build/tools/tlrebuild
@@ -0,0 +1,126 @@
+#!/bin/sh
+# $Id$
+# Originally written 2004, Karl Berry. Public domain.
+#
+# Rebuild the TeX Live distribution -- no actual recompilation of
+# sources (run bash Build.sh for that), but all the infrastructure files.
+
+mydir=`dirname $0`
+tools=`cd $mydir && pwd`
+PATH=$tools:$PATH; export PATH
+umask 0
+
+if test x$1 = x--no-tpm; then
+ no_tpm=true
+ shift
+else
+ no_tpm=false
+fi
+#
+if test x$1 = x--no-images; then
+ no_images=true
+ shift
+else
+ no_images=false
+fi
+#
+if test x$1 = x--no-test; then
+ no_test=true
+ shift
+else
+ no_test=false
+fi
+
+message() \
+{
+ printf "\f\n`date` $0: $*...\n"
+}
+
+# don't work with old stuff.
+master=`cd $tools/.. && pwd`
+top=`cd $master/.. && pwd`
+message "svn update"
+(cd $top && svn update) || exit 1
+
+if $no_tpm; then :; else
+# have to run multiple times to make the sizes converge, since the .tpm
+# file is itself one of the files in the package.
+# Fabrice says four times is the magic number.
+message "update-tpm regeneration #1"
+(update-tpm
+message "#2"
+ update-tpm
+message "#3"
+ update-tpm
+message "#4"
+ update-tpm || exit 1) | grep -v '^Writing '
+
+# sanity check of tpms, hopefully nothing to report after the update.
+message "tpm-check"
+tpm-check || exit 1
+
+for dir in texmf/tpm texmf-dist/tpm texmf-doc/tpm; do
+ cd $master/$dir || exit 1
+ message "$dir: finding changed tpms"
+ for f in "$@"; do
+ diff="`svn --diff-cmd=diff -x -u0 diff $f`"
+ diff_without_date=`echo "$diff" | egrep -v '^[-+=@]{2,3}|TPM:Date|^Index'`
+ if test -z "$diff"; then
+ svn revert $f
+ elif test -z "$diff_without_date"; then
+ # checking to see if this ever happens; the date should be stable?
+ echo "$f diff only in date, reverted: $diff"
+ svn revert $f
+ else
+ echo " $f diff:"
+ echo "$diff"
+ fi
+ done
+
+# # new tpms not in depot xx must svn add/remove somehow
+# message "$dir: finding new tpms"
+# find . -type f | p4 -x - add 2>&1 \
+# | egrep -v 'already opened|add.*existing file'
+#
+# message "$dir: finding obsolete tpms"
+# p4 diff -sd ... | p4 -x - delete # old tpms no longer needed
+
+ svn commit -m'tlrebuild [tpm] autoupdate'
+
+ # keep writable for next time, trying to have rahtz/staw share /home/tlprod.
+ chmod a+rw * >&/dev/null
+done
+
+# lists files used by the Unix installer.
+message "update-lists for Unix installer"
+update-lists || exit 1
+
+message "ls-R updates"
+update-lsr
+
+fi # end --no-tpm
+
+#
+$no_images && exit 0
+
+message "making ISO images"
+MakeImages.sh --debug --target=/home/ftp/texlive/Images/test
+
+
+$no_test && exit 0
+
+message "doing test installation"
+instdir=/home/ftp/texlive/Contents/testinstalled
+rm -rf $instdir
+
+cd $master || exit
+# D/1/$instdir/R -- target directory
+# I -- do installation
+time nice sh ./install-live.sh <<EOF
+D
+1
+$instdir
+R
+I
+EOF
+chmod -R a+rwX $instdir
diff --git a/Build/tools/tpm-by-size b/Build/tools/tpm-by-size
new file mode 100755
index 00000000000..a1dde1fcc70
--- /dev/null
+++ b/Build/tools/tpm-by-size
@@ -0,0 +1,16 @@
+#!/bin/sh
+# $Id: //depot/Master/Tools/tpm-by-size#1 $
+# Public domain. Originally written 2004, Karl Berry.
+#
+# Simplistic script to get an idea of the biggest space consumers.
+# Just looks at the size fields in the tpm files.
+
+mydir=`dirname $0`
+cd $mydir/.. || exit 1 # assume invoked from Master/Tools
+
+find texmf*/tpm -type f \
+| xargs grep '<TPM:Size>' \
+| sed -e 's/<TPM:Size>/ /' -e 's,</TPM:Size>,,' -e 's,\.tpm:,,' \
+| awk ' {printf "%7d %s\n", $2/1024, $1; total+=$2}
+ END {printf "%7d total\n", total/1024}' \
+| sort -nr
diff --git a/Build/tools/tpm-check b/Build/tools/tpm-check
new file mode 100755
index 00000000000..f008cc26cf7
--- /dev/null
+++ b/Build/tools/tpm-check
@@ -0,0 +1,36 @@
+#!/bin/sh
+# $Id$
+# Public domain. Originally written 2004, Karl Berry.
+# Do TPM sanity checks.
+
+mydir=`dirname $0`
+master=`cd $mydir/.. && pwd`
+tools=$master/Tools
+
+# if get an XML syntax error, set to --debug to see which .tpm it comes from.
+verbose=${OVERRIDE_VERBOSE-}
+
+if test "x$1" = x--type; then
+ shift
+ type=$1
+ shift
+else
+ type=all
+fi
+
+test $# -eq 0 && set - dep cov
+
+for check in "$@"; do # around 1300 dup's, so don't bother with that one
+ printf "\f\n"
+ echo "$0: checking $check..."
+ perl $tools/tpm-factory.pl $verbose \
+ --master_dir=$master --ftp_dir=/tmp/ \
+ --check=$check --arch=all --type=$type
+done
+
+# Without --clean, buildPatternsPackage (for example) doesn't get called.
+# With --clean, all tpm's need to be rw.
+# Therefore, the procedure is: change code,
+# run update-tpm TLCore (or whatever),
+# run tpm-check cov (or whatever).
+# Painful.
diff --git a/Build/tools/tpm-ctan-check b/Build/tools/tpm-ctan-check
new file mode 100755
index 00000000000..dba82d98ab0
--- /dev/null
+++ b/Build/tools/tpm-ctan-check
@@ -0,0 +1,289 @@
+#!/usr/local/bin/perl
+# $Author: karl $ $Date: 2005/10/30 $ $Id: //depot/Master/Tools/tpm-ctan-check#158 $
+# Public domain. Originally written 2005, Karl Berry.
+# Check if a package in TL has any changes on CTAN. Just the beginnings.
+
+$CTAN = $ENV{"CTAN"} || "/home/ftp/tex-archive";
+chomp (my $mydir = `dirname $0`);
+chomp ($TL = `cd $mydir/..; pwd`);
+chdir ($TL) || die "chdir($TL) failed: $!";
+
+exit (&main ());
+
+sub main
+{
+ $OPT{"verbose"} = 1;
+
+ # xx read FILES.last7days, determine CTAN changes, map to TL packages
+ # xx alternatively, check all tpm's
+ if ($ARGV[0] eq "--karl") {
+ $OPT{"verbose"} = 0;
+
+ # xx but for now, just check the few packages we have worked with.
+ @ARGV = (
+ "12many", "ESIEEcv", "GuIT", "HA-prosper", "IEEEconf", "IEEEtran",
+ "SIstyle", "SIunits", "Tabbing", "Type1fonts",
+ "a0poster", "aastex", "abbr", "abstract",
+#"abstyles", not updated, but too old to matter
+ "accfonts", "acronym", "algorithm2e", "algorithms", "apacite",
+ "archaic", "arev",
+ "babel", "babelbib", "beebe", "betababel", "bibhtml", "bibleref",
+ "blacklettert1", "booklet", "breakurl", "bytefield" ,
+ "caption", "carlisle", "cbcoptic", "changebar", "chemcompounds",
+ "circ", "cjhebrew", "colortbl", "commath", "complexity",
+ "comprehensive", "computational-complexity", "csquotes", "curve",
+ "datetime", "devanagr", "dk-bib", "doipubmed", "dottex", "dtxtut",
+ "ednotes", "elpres", "endheads", "enumitem", "etaremune", "esint",
+ "esint-type1", "ethiop", "europecv", "exteps",
+ "featpost", "flagderiv", "floatflt", "floatrow", "flowfram",
+ "fltpoint", "fmtcount", "fncychap", "fontspec", "formular",
+ "fourier",
+ "genmisc", "glossary", "gost", "graphics", "graphicx-psmin",
+ "hyphen-base", "hyphen-basque", "hyphen-german", "hyphen-greek",
+ "hyphen-norwegian", "hyphen-ukenglish", "hyphen-usorbian",
+ "ibygrk", "iopart-num",
+ "koma-script",
+ "ledmac", "lfb", "lineno",
+ "lshort-bulgarian", "lshort-dutch", "lshort-english",
+ "lshort-finnish", "lshort-french", "lshort-german",
+ "lshort-italian", "lshort-japanese", "lshort-korean",
+ "lshort-mongolian", "lshort-polish", "lshort-portuguese",
+#"lshort-russian", # only zip files on CTAN
+ "lshort-slovak", "lshort-spanish",
+ "lshort-thai", "lshort-ukrainian", "lshort-vietnamese",
+ "ltabptch", "ltxmisc",
+#"malayalam", # missing C sources on CTAN, wrote author 5jun05.
+#"mathspic", # inside pictex, later
+ "makecell", "makeplot", "mathmode", "mcaption", "memoir",
+ "mhchem", "minitoc", "microtype", "mla-paper", "movie15",
+#"mpattern", # not up-to-date on CTAN, wrote author 28may05.
+ "nag", "ncclatex", "ncctools", "newlfm", "nomencl", "nomentbl",
+ "numprint",
+ "oberdiek", "octavo",
+ "pdf-trans", "pdfcprot", "perception", "perltex", "pgf",
+ "pictex", "placeins",
+ "plnfss", "poemscol", "powerdot", "powerdot-doc-vn",
+ "ppr-prv", "preview", "proof", "pstricks", "pstricks-add",
+ "pst-3d", "pst-barcode", "pst-blur", "pst-eucl",
+ "pst-labo", "pst-lens", "pst-osci", "pst-slpe",
+ "sciposter", "sectionbox", "seminar", "semioneside", "setspace",
+ "sf298", "sides", "sparklines", "sttools", "struktex",
+ "subfig", "sudoku", "svninfo",
+ "tabulary", "talk", "tamethebeast", "tex-refs", "texshade",
+ "textcase", "textpos", "thumbpdf", "bin-thumbpdf",
+ "titlesec", "tokenizer", "totpages", "trajan", "twoup",
+ "verse", "vhistory", "volumes",
+ "wrapfig",
+ "xcolor", "xkeyval"
+ );
+ }
+
+ my $errcount = 0;
+ for my $tpm (@ARGV) {
+
+ # look in our various hierarchies.
+ my $found = "";
+ for my $dir ("texmf-dist", "texmf-doc", "texmf") {
+ my $try = "$dir/tpm/$tpm.tpm";
+ if (-r $try) {
+ $found = $try;
+ last;
+ }
+ }
+
+ if ($found) {
+ print "checking $tpm..." if $OPT{"verbose"};
+ $errcount += &do_tpm ($found);
+ } else {
+ warn "$0: cannot find tpm file $tpm\n";
+ $errcount++;
+ }
+ }
+ return $errcount;
+}
+
+
+
+# Return 1 if TPM needs updating, 0 if ok.
+#
+sub do_tpm
+{
+ my ($tpm) = @_;
+ my $needed = 0;
+
+ my %tpm = &read_tpm ($tpm);
+
+ my @compared = ();
+
+ for my $file (@{$tpm{"files"}}) {
+ my $tl_file = "$TL/$file";
+ if (! -e $tl_file) {
+ warn "$tl_file: TL file missing\n";
+ next;
+ }
+
+ (my $basefile = $file) =~ s,^.*/,,;
+ chomp (my @ctan_files = `find $CTAN/$tpm{CTANDir}/ -name $basefile`);
+ # the trailing / is so if we happen to hit a symlink on CTAN, it'll
+ # go through.
+ next if @ctan_files > 1; # if more than one file by same name, skip
+
+ my $ctan_file = $ctan_files[0];
+ if (! -e $ctan_file) {
+ # maybe it'll be there with a case change in the name
+ chomp (@ctan_files = `find $CTAN/$tpm{CTANDir}/ -iname $basefile`);
+ next if @ctan_files > 1; # if more than one file by same name, skip
+ $ctan_file = $ctan_files[0];
+
+ if (! -e $ctan_file) {
+ # we generate lots of files, eg perlmacros.sty, so might skip.
+ warn "$ctan_file: CTAN file missing\n"
+ if $ctan_file && $ctan_file !~ /(cfg|dvi|sty|tex)$/;
+ next;
+ }
+ }
+
+ push (@compared, $basefile);
+ if (&files_differ ($tl_file, $ctan_file)) {
+ # we mostly regenerate pdf's for TL (sebastian thinks we should :), so
+ # don't complain if they are different. On the other hand, we
+ # don't always regenerate them, so might as well check first.
+ next if $tl_file =~ /\.pdf$/;
+
+ print "# $tpm\ndiff $ctan_file $tl_file\n";
+ $needed = 1;
+ last;
+ }
+ }
+
+ # xx check ctan dir for new files
+
+ if (@compared == 0) {
+ warn "\n$tpm: no files to compare in $CTAN/$tpm{CTANDir}, fixme!\n";
+ } elsif ($needed == 0) {
+ print "ok, " . (@compared + 0) . " compared (@compared)\n"
+ if $OPT{"verbose"};
+ }
+
+ return $needed;
+}
+
+
+
+# Return useful information from a TPM.
+#
+sub read_tpm
+{
+ my ($tpm) = @_;
+ my %ret;
+
+ local *TPM;
+ open (TPM, $tpm) || die "open($tpm) failed: $!\n";
+
+ my @files = ();
+ while (<TPM>) {
+ if (m!</TPM:.*Files!) { # might be on same line
+ $collecting = 0;
+ } elsif (/<TPM:.*Files/) {
+ $collecting = 1;
+ next;
+ }
+ if ($collecting) {
+ chomp;
+ push (@files, $_) if $_ !~ /\.tpm$/;
+ }
+ }
+ close (TPM) || warn "close($tpm) failed: $!\n";
+
+ warn "$tpm: no files found\n" if ! @files; # probably misparsed the tpm
+ $ret{"files"} = \@files;
+
+ (my $me = $tpm) =~ s,.*/,,;
+ $me =~ s/\.tpm$//;
+
+ (my $menobin = $me) =~ s,^bin-,,;
+ (my $menodash = $me) =~ s,^.*-,,;
+ (my $menopowerdot = $me) =~ s,^powerdot-,,;
+ (my $menotype1 = $me) =~ s,-type1$,,;
+
+ # xx how to really figure this out?
+ for my $dir (
+ "macros/latex/contrib/$me", # most everything
+ "macros/latex/contrib/\L$me", # HA-prosper
+ "macros/latex/contrib/powerdot/contrib/$menopowerdot", # powerdot-doc-vn
+ "macros/latex/exptl/$me", # semioneside
+ "macros/latex/required/$me", # babel
+ "macros/plain/$me", # plnfss
+ "macros/xetex/latex/$me", # xetex
+ "macros/generic/$me", # abbr
+ "macros/generic/diagrams/$me", # circ
+ "macros/$me", # eplain
+ "support/$me", # thumbpdf
+ "support/$menobin", # bin-thumbpdf
+ "language/vietnamese/$me/unpacked", # vntex
+ "language/hebrew/$me", # cjhebrew
+ "language/greek/package-babel/$me", # ibycus-babel
+ "language/coptic/$me", # cbcoptic
+ "info/math/voss/$me", # mathmode
+ "info/lshort/$menodash", # lshort-english
+ "info/bibtex/$me", # tamethebeast
+ "info/symbols/$me", # comprehensive
+ "info/$me", # Type1fonts
+ "graphics/$me", # sparklines
+ "graphics/metapost/contrib/macros/$me", # mpattern
+ "graphics/pstricks/contrib/$me", # pstricks-add
+ "fonts/$me", # MnSymbol
+ "fonts/gothic/$me", # blacklettert1
+ "fonts/greek/$me", # lfb
+ "fonts/ps-type1/$me", # cm-super
+ "fonts/ps-type1/$menotype1", # esint-type1
+ "fonts/utilities/$me", # accfonts
+ "biblio/bibtex/contrib/$me", # dk-bib
+ ) {
+ if (-d "$CTAN/$dir") {
+ $ret{"CTANDir"} = $dir;
+ last;
+ }
+ }
+
+ # names totally dissimilar
+ $ret{"CTANDir"} = "fonts/fourier-GUT" if $me eq "fourier";
+ $ret{"CTANDir"} = "info/biblio" if $me eq "beebe";
+ $ret{"CTANDir"} = "info/tex-references" if $me eq "tex-refs";
+ $ret{"CTANDir"} = "language/basque" if $me eq "hyphen-basque";
+ $ret{"CTANDir"} = "language/devanagari/velthuis" if $me eq "devanagr";
+ $ret{"CTANDir"} = "language/hyphenation" if $me eq "hyphen-german";
+ $ret{"CTANDir"} = "language/hyphenation/elhyphen" if $me eq "hyphen-greek";
+ $ret{"CTANDir"} = "macros/latex/contrib/misc" if $me eq "ltxmisc";
+ $ret{"CTANDir"} = "macros/generic" if $me eq "genmisc";
+
+ # do last, for sake of subdirs above.
+ $ret{"CTANDir"} = "language/hyphenation"
+ if $me =~ /^hyphen-/ && ! $ret{"CTANDir"};
+
+ die "$0: no CTAN directory for $me\n" if ! exists $ret{"CTANDir"};
+
+ return %ret;
+}
+
+
+
+# 0 if files are the same, 1 if they are different.
+#
+sub files_differ
+{
+ my ($tl_file,$ctan_file) = @_;
+#warn "comparing $tl_file $ctan_file\n";
+
+ my $different = 0;
+ if (-s $tl_file != -s $ctan_file) {
+ # sometimes what's checked into CTAN vs. TL differs in the eol
+ # conventions. Don't worry about that.
+ if (system ("diff -q --strip-trailing-cr $tl_file $ctan_file >/dev/null")
+ != 0) {
+ $different = 1;
+ }
+ }
+
+ return $different;
+}
diff --git a/Build/tools/tpm-delete b/Build/tools/tpm-delete
new file mode 100755
index 00000000000..50ecab33e20
--- /dev/null
+++ b/Build/tools/tpm-delete
@@ -0,0 +1,33 @@
+#!/bin/sh
+# $Id: //depot/Master/Tools/tpm-delete#1 $
+# Public domain. Originally written 2005, Karl Berry.
+#
+# Delete a tpm and the files it references from the repository.
+# Takes just the package name, no .tpm suffix, no type, no subdirs.
+
+mydir=`dirname $0` # Master/Tools
+
+Master=`cd $mydir/.. && pwd`
+cd $Master || exit 1
+
+for arg in "$@"; do
+ file="$arg.tpm"
+
+ if test -r texmf-dist/tpm/$arg.tpm; then
+ type=Package
+ elif test -r texmf/tpm/$arg.tpm; then
+ type=TLCore
+ elif test -r texmf-doc/tpm/$arg.tpm; then
+ type=Documentation
+ else
+ echo "$0: cannot find $file, goodbye." >&1
+ exit 1
+ fi
+
+ files=`./Tools/tpm-factory.pl \
+ --master_dir=$Master --dest_dir=/tmp --ftp_dir=/tmp \
+ --dry --remove --name=$type/$arg \
+ | sed 's/^would unlink //'`
+
+ p4 delete $files
+done
diff --git a/Build/tools/tpm-factory.pl b/Build/tools/tpm-factory.pl
new file mode 100755
index 00000000000..3e01e99689e
--- /dev/null
+++ b/Build/tools/tpm-factory.pl
@@ -0,0 +1,643 @@
+#!/usr/bin/env perl
+# $Id$
+# Public domain.
+#
+# TPM Build tool for TeXLive
+# Author: F. Popineau
+#
+# This file aims at automating tpm files maintenance
+# It's kind of a swiss-army knife so you can use it in several ways:
+#
+# Clean up a tpm file:
+# perl tpm-factory.pl --clean --name=Package/a0poster --patterns=auto
+# Clean up all Package (texmf-dist) tpm files
+# perl tpm-factory.pl --clean --type=Package --patterns=auto
+# perl tpm-factory.pl --clean --type=TLCore --patterns=from
+# The 'patterns' options tells to generate the files lists either
+# automatically (auto), from the patterns (from)
+# or to build patterns lists from files lists (to).
+# You can restrict the range of architectures with the --arch option.
+# By default --arch=all, but you can say --arch=win32,i386-linux too.
+#
+# Build a new tpm file from scratch:
+# perl tpm-factory.pl --new --name=Package/foo
+# This will build a new foo package, then you want to clean it up.
+#
+# Checking coverage:
+# perl tpm-factory.pl --check=cov --arch=all --type=Package
+# will check coverage inside the texmf-dist tree.
+#
+# Checking dependencies:
+# perl tpm-factory.pl --check=dep --arch=all --type=Package
+# will check dependencies inside the texmf-dist tree.
+#
+# Checking duplicates:
+# perl tpm-factory.pl --check=dup --arch=all --type=Package
+# will check duplicate file names inside the texmf-dist tree.
+#
+#
+
+BEGIN { # get our other local perl modules.
+ ($mydir = $0) =~ s,/[^/]*$,,;
+ unshift (@INC, $mydir);
+
+ $mydir = "c:/source/TeXLive/Master/Tools"; # fabrice
+ unshift (@INC, $mydir) if -d $mydir;
+}
+
+require "newgetopt.pl";
+use File::Basename;
+use Cwd;
+
+use FileUtils qw(canon_dir cleandir make_link newpath member
+ normalize substitute_var_val dirname diff_list remove_list
+ rec_rmdir sync_dir walk_dir start_redirection stop_redirection);
+use Tpm;
+
+File::Basename::fileparse_set_fstype('unix');
+
+use Strict;
+
+my $FtpDir = "c:/Inetpub/ftp/fptex";
+my $fpTeXVersion = "0.7";
+
+local $opt_check = 0;
+local $opt_ftp_dir = "${FtpDir}/${fpTeXVersion}";
+local $opt_arch;
+local $opt_log = 0;
+local $opt_verbose = 0;
+local $opt_tpm2zip = 0;
+local $opt_fixreq = 0;
+$opt_debug = 0; # global so Tpm.pm can access it.
+$opt_warnings = 0;
+
+# print "XML::Parser::VERSION = $XML::Parser::VERSION, XML::DOM::VERSION = $XML::DOM::VERSION\n";
+&main;
+
+1;
+
+sub help {
+ print <<END_HELP;
+Usage: $ARGV[0] [OPTION]...
+
+Handle TPM (TeX package metadata) operations.
+
+Main operation (these targets are exclusive!):
+ --tpm2zip build zip files out of a set of tpm files;
+ --check=<(dep|cov)> check dependencies or coverage for the tpm files.
+ --tpm_index rebuild the tpm.zip index file.
+ --new create a new tpm file from scratch
+ --clean clean up the tpm file
+ --remove [--dry] remove the tpm file and all files it may reference
+ [testing only]
+ --patterns=(from|to|auto) fix one or more tpm files
+ by automatically creating files lists,
+ by expanding patterns to files lists,
+ or regenerating patterns from files lists.
+
+Directories:
+ --master_dir=<path> root directory of the TeX distribution
+ [$opt_master_dir].
+ --dest_dir=<path> destination directory for the zip files
+ [$opt_ftp_dir].
+ --ftp_dir=<path> directory for ftp results
+ [$opt_ftp_dir].
+
+Packages:
+ --name=<pattern> process only the files matching the pattern;
+ --all process all package files;
+ --standalone process only standalone package files;
+ --arch=<(all|name)> process some or all architectures.
+
+Support commands:
+ --log=<file name> log activity to file
+ --debug turn on debug trace
+ --verbose some more messages
+ --warnings report empty fields Author, Version, ...
+ --help displays this help text and exits
+END_HELP
+}
+
+sub build_zip {
+ local ($tree,$tpmname) = @_;
+ print "building zip of $tree/tpm/$tpmname\n" if ($opt_verbose);
+ $tree =~ s@^$opt_master_dir/@@;
+ my $tpm = Tpm->new("$tree/tpm/$tpmname");
+
+ if ($opt_tpm2zip eq 'full') {
+ $tpm->Tpm2Zip($opt_ftp_dir, 'full', $opt_standalone);
+ }
+ else {
+ $tpm->Tpm2Zip($opt_ftp_dir, $opt_standalone);
+ }
+}
+
+sub read_dependencies {
+ local ($tree, $tpmname) = @_;
+ $tree =~ s@^$opt_master_dir/@@;
+ my $tpm = Tpm->new("$tree/tpm/$tpmname");
+ my %requires = $tpm->getHash("Requires");
+ my @reqlist = ();
+ foreach my $k (keys %requires) {
+ foreach my $e (@{$requires{$k}}) {
+ my $f = ${Tpm::TexmfTreeOfType}{$k} . "/tpm/$e.tpm";
+ if (-f "$opt_master_dir/$f") {
+ push @reqlist, $f ;
+ }
+ else {
+ push @{$wrong{"$tree/tpm/$tpmname"}}, "$f";
+ }
+ }
+ }
+ @{$req{"$tree/tpm/$tpmname"}} = @reqlist;
+# print "$tree$tpmname requires @reqlist\n";
+}
+
+sub collect_tpmfiles {
+ local ($tree, $tpmname) = @_;
+ $tree =~ s@^$opt_master_dir/@@;
+ if ("texmf/tpm/$tpmname" !~ m@^${Tpm::IgnoredFiles}$@) {
+ push @tpm_files, "$tree/tpm/$tpmname";
+ }
+}
+
+sub do_tree {
+ local ($tree, $fn) = @_;
+ print " Directory $tree\n" if ($opt_verbose);
+ while (<$tree/tpm/*.tpm>) {
+ my $tpmname = $_;
+ next if ($tpmname =~ m/~$/); # for emacs backups!
+# next if ($tree =~ /texmf$/ && $tpmname =~ m/xemtex/);
+# next if ($tpmname =~ m/-static/ && ! $opt_standalone);
+ $tpmname =~ s@^${tree}/tpm/@@;
+ print "Doing $tree/tpm/$tpmname\n" if ($opt_verbose);
+ &{$fn}($tree, $tpmname);
+ }
+}
+
+#
+# Check that every tpm package is required by another one at least
+#
+sub check_dependencies {
+ local (%req, @tpm_files, %wrong);
+ local ($s, $k, @l);
+
+ foreach my $tree (@{Tpm::TexmfTrees}) {
+ if (! -d "$opt_master_dir/$tree/tpm") {
+ printf STDERR "$0: $tree/tpm is not a tpm subdirectory, skipping!\n";
+ next;
+ }
+ $tree = "$opt_master_dir/$tree";
+ &do_tree($tree, \&read_dependencies);
+ &do_tree($tree, \&collect_tpmfiles);
+ }
+ # FIXME!!!
+ if (-f "$opt_master_dir/texmf/tpm/scheme-full.tpm") {
+ @l = ("texmf/tpm/scheme-full.tpm");
+ }
+ elsif (-f "$opt_master_dir/texmf/tpm/scheme-xemtex.tpm") {
+ @l = ("texmf/tpm/scheme-xemtex.tpm");
+ }
+ else {
+ die "No entry point, quitting...\n";
+ }
+ while ($#l >= 0) {
+ my $p = pop @l;
+# if (! -f "$opt_master_dir/$p") {
+# push @wrong, $p;
+# }
+# else {
+ &remove_list(\@tpm_files, "^" . $p . "\$");
+ push @l, @{$req{$p}};
+# print "p = $p, l = @l\n";
+# }
+ }
+ print "***********************************\n";
+ print "Wrong requirements: \n";
+ print "***********************************\n";
+ map { print "$_ (";
+ map { print "$_ "; } @{$wrong{$_}};
+ print ")\n"; } &FileUtils::sort_uniq(keys %wrong);
+ print "\n";
+ print "***********************************\n";
+ print "Packages not required by anything: \n";
+ print "***********************************\n";
+ map { print "$_\n"; } @tpm_files;
+ print "\n";
+ print "***********************************\n";
+}
+
+sub collect_files {
+ local ($d, @lf) = @_;
+ my ($f);
+ foreach $f (@lf) {
+ my $path = "$d/$f";
+ if (-f "$path") {
+ $path =~ s@^${opt_master_dir}/@@;
+ $path =~ s@\\@/@g;
+ unless ($path =~ m/^${Tpm::IgnoredFiles}$/) {
+ push @texmf_files, $path;
+ #warn "accepted $path\n";
+ } else {
+ ; #warn "ignored $path\n";
+ }
+ }
+ }
+}
+
+sub collect_coverage {
+ local ($tree, $tpmname) = @_;
+ if ("texmf/tpm/$tpmname" !~ m@^${Tpm::IgnoredFiles}$@) {
+ my $tpm = Tpm->new("$tree/tpm/$tpmname");
+ my @l = $tpm->getAllFileList();
+ print "Pushing $#l files from $tree/tpm/$tpmname\n" if $opt_debug;
+ push @tpm_files, @l;
+ }
+}
+
+sub find_multiple {
+ local (*files) = @_;
+ my (@l) = sort(@files);
+ my(@res, $e1, $e2);
+ @files = ( );
+ $e1 = pop(@l);
+ while ($e1) {
+ push @files, $e1;
+ while (($e2 = pop(@l)) eq $e1) {
+ push @res, $e2;
+ }
+ $e1 = $e2;
+ }
+ return @res;
+}
+
+#
+# Check that all files in tpm files exist
+# and that all files in the texmf tree
+# are requested by one tpm file.
+#
+sub check_coverage {
+ local (@texmf_files, @tpm_files);
+ my($s, @tree_list);
+
+ if ($opt_type eq 'TLCore' || $opt_type eq 'all') {
+ &walk_dir("$opt_master_dir/texmf", \&collect_files);
+ &walk_dir("$opt_master_dir/bin", \&collect_files);
+ &walk_dir("$opt_master_dir/xemtex", \&collect_files);
+ &walk_dir("$opt_master_dir/source", \&collect_files);
+ push @tree_list, "texmf";
+ }
+ if ($opt_type eq 'Package' || $opt_type eq 'all') {
+ &walk_dir("$opt_master_dir/texmf-dist", \&collect_files);
+ push @tree_list, "texmf-dist";
+ }
+ if ($opt_type eq 'Documentation' || $opt_type eq 'all') {
+ &walk_dir("$opt_master_dir/texmf-doc", \&collect_files);
+ push @tree_list, "texmf-doc";
+ }
+
+ foreach my $tree (@tree_list) {
+ if (! -d "$opt_master_dir/$tree/tpm") {
+ printf STDERR "$0: $tree/tpm is not a tpm subdirectory, skipping!\n";
+ next;
+ }
+ $tree = "$opt_master_dir/$tree";
+ &do_tree($tree, \&collect_coverage);
+ }
+
+ print "Found $#tpm_files files in tpm files.\n";
+ local (@doublons) = find_multiple(\@tpm_files);
+ print "*****************************************\n";
+ print "Files found multiple times in tpm files :\n";
+ map { print "$_\n"; } @doublons;
+ print "*****************************************\n";
+ local (@l1, @l2);
+ &diff_list(\@texmf_files, \@tpm_files, \@l1, \@l2);
+ print "*****************************************\n";
+ print "Files in texmf tree not in tpm files :\n";
+ map { print "$_\n"; } @l1;
+ print "*****************************************\n";
+ print "Files in tpm files not in texmf tree :\n";
+ print "*****************************************\n";
+ map { print "$_\n"; } @l2;
+ print "*****************************************\n";
+ print "With Regexp:\n";
+ print "*****************************************\n";
+
+ @l1 = &FileUtils::regexpify(1, $Tpm::MasterDir, @l1);
+ @l2 = &FileUtils::regexpify(1, $Tpm::MasterDir, @l2);
+ print "*****************************************\n";
+ print "Files in texmf tree not in tpm files :\n";
+ map { print "$_\n"; } (sort @l1);
+ print "*****************************************\n";
+ print "Files in tpm files not in texmf tree :\n";
+ print "*****************************************\n";
+ map { print "$_\n"; } (sort @l2);
+ print "*****************************************\n";
+
+}
+
+sub compare_extensions {
+ my ($ext1, $ext2);
+# print "a = $a, b = $b\n";
+ $ext1 = $2 if ($a =~ m/^(.*)\.([^\.]*)$/);
+ $ext2 = $2 if ($b =~ m/^(.*)\.([^\.]*)$/);
+# print "ext1 = $ext1, ext2 = $ext2 " . ($ext1 cmp $ext2) . "\n";
+ if ($ext1 && $ext2) {
+ return ($ext1 cmp $ext2);
+ }
+ elsif ($ext1) {
+ return -1;
+ }
+ elsif ($ext2) {
+ return 1;
+ }
+ else {
+ return $a cmp $b;
+ }
+}
+
+sub check_duplicates {
+ local (@texmf_files);
+ my %doublons;
+
+ if ($opt_type eq 'TLCore' || $opt_type eq 'all') {
+ &walk_dir("$opt_master_dir/texmf", \&collect_files);
+ }
+ if ($opt_type eq 'Package' || $opt_type eq 'all') {
+ &walk_dir("$opt_master_dir/texmf-dist", \&collect_files);
+ }
+ if ($opt_type eq 'Documentation' || $opt_type eq 'all') {
+ &walk_dir("$opt_master_dir/texmf-doc", \&collect_files);
+ }
+ map {
+ push @{$doublons{&FileUtils::basename($_)}}, $_;
+ } @texmf_files;
+ for my $k (keys %doublons) {
+ if ($#{$doublons{$k}} < 1) {
+ delete $doublons{$k};
+ }
+ }
+ for my $k (sort compare_extensions (keys %doublons)) {
+ print "$k:\n";
+ map {
+ my $date, $size;
+ my @t = stat("$opt_master_dir/" . $_);
+ $size = $t[7]; $date = &Tpm::printdate($t[9]);
+ print "\t$date\t$size\t$_\n"; } @{$doublons{$k}};
+ }
+}
+
+sub clean_tpm {
+ my @texmf_trees = () ;
+ if ($opt_type eq 'all') {
+ @texmf_trees = @{Tpm::TexmfTrees};
+ }
+ else {
+ @texmf_trees = ( ${Tpm::TexmfTreeOfType}{$opt_type} );
+ }
+ map { print "tree = $_\n"; } @texmf_trees;
+ foreach my $tree (@texmf_trees) {
+ if (! -d "$opt_master_dir/$tree/tpm") {
+ printf STDERR "$0: $tree/tpm is not a tpm subdirectory, skipping!\n";
+ next;
+ }
+ $tree = "$opt_master_dir/$tree";
+ &do_tree($tree, \&process_clean);
+ }
+}
+
+sub process_clean {
+ my ($tree, $tpmname) = @_;
+ $tpmname .= ".tpm" if ($tpmname !~ m/\.tpm$/);
+ my $tpm = Tpm->new("$tree/tpm/$tpmname");
+ $tpm->Clean($opt_patterns, $opt_fixreq);
+}
+
+sub process_remove {
+ my ($tree, $tpmname) = @_;
+ $tpmname .= ".tpm" if ($tpmname !~ m/\.tpm$/);
+ my $tpm = Tpm->new("$tree/tpm/$tpmname");
+ $tpm->Remove($opt_patterns, $opt_dry);
+}
+
+sub main {
+ # don't delay messages.
+ $| = 1;
+ select ((select (STDERR), $| = 1)[0]);
+
+ unless (&NGetOpt ("tpm2zip:s",
+ "clean",
+ "patterns=s",
+# "edit=s",
+ "tpm_dir=s",
+ "ftp_dir=s",
+ "master_dir=s",
+ "dest_dir=s",
+ "name=s",
+ "arch=s",
+ "check=s",
+ "tpm_index",
+ "type=s",
+ "fixreq",
+ "new",
+ "remove",
+ "dry",
+ "standalone", "log=s",
+ "verbose",
+ "debug", "help"))
+ {
+ print STDERR "Try `$0 --help'.\n";
+ exit 1;
+ }
+
+ if ($opt_help) {
+ &help;
+ exit 0;
+ }
+
+ if (($opt_name && $opt_type)
+ || ($opt_type && $opt_standalone)
+ || ($opt_type && $opt_standalone)) {
+ print STDERR "$0: `--type', `standalone' and `--name' are mutually exclusive.\n";
+ exit 1;
+ }
+
+ $opt_verbose = 1 if $opt_debug;
+
+ $opt_arch = "all" if (! $opt_arch);
+ if ($opt_arch =~ m/,/) {
+ my @l = split ",", $opt_arch;
+ map {
+ if (!&member($_, @Tpm::ArchList)) {
+ print STDERR "$0: $_ is not a valid architecture, aborting.\n";
+ exit 1;
+ }
+ } @l;
+ @Tpm::ArchList = @l;
+ $opt_arch = 'all';
+ }
+
+ if ($opt_arch
+ && !(($opt_arch eq "all")
+ || &member($opt_arch, @Tpm::ArchList))) {
+ print STDERR "$0: $opt_arch is neither `all' nor a valid architecture, aborting.\n";
+ exit 1;
+ }
+
+ $Tpm::CurrentArch = $opt_arch;
+
+# if ($opt_standalone && ($opt_ftp_dir =~ m@/$fpTeXVersion$@)) {
+# $opt_ftp_dir =~ s@/$fpTeXVersion$@/standalone@;
+# }
+
+ if ($opt_master_dir) {
+ die "$0: !!!Error: Master dir $opt_master_dir is not a directory!\n" if (! -d $opt_master_dir);
+ ${Tpm::MasterDir} = $opt_master_dir;
+ }
+ else {
+ $opt_master_dir = ${Tpm::MasterDir};
+ }
+
+ if ($opt_ftp_dir) {
+ die "$0: !!!Error: FTP dir $opt_ftp_dir is not a directory!\n" if (! -d $opt_ftp_dir);
+ }
+
+ if ($opt_log) {
+ # $logfile = "$topdir\\win32\\$opt_log";
+ if (! $opt_log =~ /\.log$/) {
+ $opt_log .= ".log";
+ }
+ # start redirection if asked
+ &start_redirection($opt_log);
+ }
+
+ if ($opt_tpm2zip eq '' || $opt_tpm2zip eq 'full') {
+
+ if ($opt_type) {
+ my @texmf_trees = () ;
+ if ($opt_type eq 'all') {
+ @texmf_trees = @{Tpm::TexmfTrees};
+ }
+ else {
+ @texmf_trees = ( ${Tpm::TexmfTreeOfType}{$opt_type} );
+ }
+ foreach my $tree (@texmf_trees) {
+ if (! -d "$opt_master_dir/$tree/tpm") {
+ printf STDERR "$0: $tree/tpm is not a tpm subdirectory, skipping!\n";
+ next;
+ }
+ $tree = "$opt_master_dir/$tree";
+ &do_tree($tree, \&build_zip);
+ }
+ # Copy TeXSetup in due place
+ my $src = "$opt_master_dir/bin/win32/TeXSetup.exe";
+ my $dst = "$opt_ftp_dir/TeXSetup.exe";
+ if (&FileUtils::newer($src, $dst) > 0) {
+ &FileUtils::copy($src, $dst);
+ }
+
+ #
+ # Rebuild tpm.zip file
+ #
+ unlink("${opt_ftp_dir}/tpm.zip");
+ $cwd = &getcwd();
+ chdir($opt_master_dir);
+ open ZIP, "| zip -9\@or ${opt_ftp_dir}/tpm.zip > nul";
+ foreach my $e (@{Tpm::TexmfTrees}) {
+ while (<$e/tpm/*.tpm>) {
+ print ZIP "$_\n" if (/\.tpm$/io);
+ print "$_\n" if (/\.tpm$/io and $opt_verbose);
+ }
+ }
+ close ZIP;
+ chdir($cwd);
+ print "File `${opt_ftp_dir}/tpm.zip' rebuilt.\n";
+ }
+ elsif ($opt_standalone) {
+ print "Doing standalone ...\n";
+ foreach $tpmname (@{Tpm::StandAlonePackages}) {
+ $tpmname =~ m@^(.*)/(.*)$@;
+ &build_zip(${Tpm::TexmfTreeOfType}{$1}, $2);
+ }
+ }
+ elsif ($opt_name) {
+ my ($tpmname, $tree);
+ $opt_name =~ m@^([^/]*)/([^/]*)$@x;
+ $tpmname = $2; $tree = ${Tpm::TexmfTreeOfType}{$1};
+ $tpmname .= ".tpm" if ($tpmname !~ m/\.tpm$/);
+ print "Doing $opt_master_dir/$tree/tpm/$tpmname\n";
+ if (! -f "$opt_master_dir/$tree/tpm/$tpmname") {
+ printf STDERR "$0: $opt_name non existent tpm file, aborting!\n";
+ exit 1;
+ }
+ &build_zip($tree, $tpmname);
+ }
+ }
+ elsif ($opt_tpm_index) {
+ #
+ # Rebuild tpm.zip file
+ #
+ unlink("${opt_ftp_dir}/tpm.zip");
+ $cwd = &getcwd();
+ chdir($opt_master_dir);
+ open ZIP, "| zip -9\@or ${opt_ftp_dir}/tpm.zip > nul";
+ foreach my $e (@{Tpm::TexmfTrees}) {
+ while (<$e/tpm/*.tpm>) {
+ print ZIP "$_\n" if (/\.tpm$/io);
+ print "$_\n" if (/\.tpm$/io and $opt_verbose);
+ }
+ }
+ close ZIP;
+ chdir($cwd);
+ print "File `${opt_ftp_dir}/tpm.zip' rebuilt.\n";
+ }
+ elsif ($opt_clean) {
+ if ($opt_name) {
+ $opt_name =~ m@^(.*)[/\\]([^/]*)$@x;
+ my $tree = ${Tpm::TexmfTreeOfType}{$1};
+ &process_clean($tree, $2);
+ }
+ elsif ($opt_type) {
+ &clean_tpm;
+ }
+ }
+
+ # Check coverage for packages: do the tpm files cover
+ # the list of files in the texmf tree?
+ elsif ($opt_check && $opt_check =~ m/^cov/) {
+ print "Checking coverage:\n";
+ $opt_arch = "all";
+ &check_coverage;
+ }
+ # Check dependencies: are all the tpm packages required
+ # by some other package?
+ elsif ($opt_check && $opt_check =~ m/^dep/) {
+ print "Checking dependencies:\n";
+ &check_dependencies;
+ }
+ elsif ($opt_check && $opt_check =~ m/^dup/) {
+ print "Checking duplicates:\n";
+ &check_duplicates;
+ }
+ elsif ($opt_new) {
+ if ($opt_name) {
+ my $tpm = Tpm->fresh($opt_name);
+ $tpm->Clean($opt_patterns, $opt_fixreq);
+ }
+ }
+ elsif ($opt_remove) {
+ if ($opt_name) {
+ $opt_name =~ m@^(.*)[/\\]([^/]*)$@x;
+ my $tree = ${Tpm::TexmfTreeOfType}{$1};
+ my $name = $2;
+ &process_remove($tree, $name);
+ } else {
+ warn "$0: need --name=Type/pkgname with --remove.\n";
+ }
+ }
+
+ if ($opt_log) {
+ &stop_redirection($opt_log)
+ }
+}
diff --git a/Build/tools/tpm.dtd b/Build/tools/tpm.dtd
new file mode 100644
index 00000000000..955831795c4
--- /dev/null
+++ b/Build/tools/tpm.dtd
@@ -0,0 +1,74 @@
+<!ELEMENT rdf:RDF (rdf:Description) >
+<!ATTLIST rdf:RDF
+ xmlns:rdf CDATA #REQUIRED
+ xmlns:TPM CDATA #REQUIRED>
+<!ELEMENT rdf:Description
+ (TPM:Name, TPM:Type, TPM:Date, TPM:Version, TPM:Creator,
+ TPM:Title, TPM:Description, TPM:Author, TPM:Size, TPM:Flags?,
+ TPM:Build,
+ TPM:BinFiles*,TPM:RunFiles?,TPM:DocFiles?,TPM:SourceFiles?,
+ TPM:RemoteFiles?,
+ TPM:Requires?, TPM:RequiredBy?, TPM:Installation?,TPM:Provides?)>
+ <!ATTLIST rdf:Description about CDATA #REQUIRED >
+<!ELEMENT TPM:Name (#PCDATA)>
+<!ELEMENT TPM:Flags EMPTY>
+<!ATTLIST TPM:Flags
+ selectable CDATA #IMPLIED
+ default CDATA #IMPLIED
+ treeroot CDATA #IMPLIED
+>
+<!ELEMENT TPM:Type (#PCDATA)>
+<!ELEMENT TPM:Date (#PCDATA)>
+<!ELEMENT TPM:Version (#PCDATA)>
+<!ELEMENT TPM:Creator (#PCDATA)>
+<!ELEMENT TPM:Author (#PCDATA)>
+<!ELEMENT TPM:Requires (TPM:Documentation*,TPM:Package*,TPM:TLCore*,TPM:Collection*,TPM:Support*)>
+<!ELEMENT TPM:RequiredBy (#PCDATA)>
+<!ELEMENT TPM:Title (#PCDATA)>
+<!ELEMENT TPM:Size (#PCDATA)>
+<!ELEMENT TPM:Description (#PCDATA)>
+<!ATTLIST TPM:Description
+ xmlns:TPM CDATA #IMPLIED>
+<!ELEMENT TPM:Build
+ (TPM:BinPatterns?,TPM:RunPatterns?,TPM:DocPatterns?,
+ TPM:SourcePatterns?,TPM:RemotePatterns?)>
+<!ELEMENT TPM:BinPatterns (#PCDATA)>
+<!ELEMENT TPM:RunPatterns (#PCDATA)>
+<!ELEMENT TPM:DocPatterns (#PCDATA)>
+<!ELEMENT TPM:SourcePatterns (#PCDATA)>
+<!ELEMENT TPM:RemotePatterns (#PCDATA)>
+<!ELEMENT TPM:BinFiles (#PCDATA)>
+<!ELEMENT TPM:RunFiles (#PCDATA)>
+<!ELEMENT TPM:DocFiles (#PCDATA)>
+<!ELEMENT TPM:SourceFiles (#PCDATA)>
+<!ELEMENT TPM:RemoteFiles (#PCDATA)>
+<!ATTLIST TPM:BinFiles arch CDATA #REQUIRED>
+<!ATTLIST TPM:BinFiles size CDATA #REQUIRED>
+<!ATTLIST TPM:DocFiles size CDATA #REQUIRED>
+<!ATTLIST TPM:SourceFiles size CDATA #REQUIRED>
+<!ATTLIST TPM:RunFiles size CDATA #REQUIRED>
+<!ATTLIST TPM:RemoteFiles size CDATA #REQUIRED>
+<!ATTLIST TPM:BinFiles xmlns:TPM CDATA #IMPLIED>
+<!ATTLIST TPM:RunFiles xmlns:TPM CDATA #IMPLIED>
+<!ATTLIST TPM:DocFiles xmlns:TPM CDATA #IMPLIED>
+<!ATTLIST TPM:SourceFiles xmlns:TPM CDATA #IMPLIED>
+<!ATTLIST TPM:RemoteFiles xmlns:TPM CDATA #IMPLIED>
+<!ELEMENT TPM:TLCore EMPTY>
+ <!ATTLIST TPM:TLCore name CDATA #REQUIRED>
+<!ELEMENT TPM:Package EMPTY>
+ <!ATTLIST TPM:Package name CDATA #REQUIRED>
+<!ELEMENT TPM:Documentation EMPTY>
+ <!ATTLIST TPM:Documentation name CDATA #REQUIRED>
+<!ELEMENT TPM:Collection EMPTY>
+ <!ATTLIST TPM:Collection name CDATA #REQUIRED>
+<!ELEMENT TPM:Support EMPTY>
+ <!ATTLIST TPM:Support name CDATA #REQUIRED>
+<!ELEMENT TPM:Installation (TPM:Execute)*>
+<!ELEMENT TPM:Execute (#PCDATA)>
+<!ATTLIST TPM:Execute function CDATA #REQUIRED
+ mode CDATA #IMPLIED
+ parameter CDATA #REQUIRED>
+<!ELEMENT TPM:Provides (#PCDATA)>
+
+
+
diff --git a/Build/tools/tpm2binarytar.xsl b/Build/tools/tpm2binarytar.xsl
new file mode 100644
index 00000000000..fc674a6d3f4
--- /dev/null
+++ b/Build/tools/tpm2binarytar.xsl
@@ -0,0 +1,55 @@
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+ xmlns:exsl="http://exslt.org/common"
+ exclude-result-prefixes="exsl"
+ extension-element-prefixes="exsl"
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:TPM="http://texlive.dante.de/"
+ version="1.0">
+
+<xsl:output method="text" omit-xml-declaration="yes"/>
+<xsl:param name="Root"/>
+
+<xsl:strip-space elements="*"/>
+
+<xsl:template match="/">
+ <exsl:document method="text" href="{$Root}{//TPM:Name}.list">
+ <xsl:if test=".//TPM:BinFiles/text()">
+ <xsl:for-each select=".//TPM:BinFiles">
+ <exsl:document method="text" href="{$Root}/{//TPM:Name}-{@arch}.list">
+ <xsl:apply-templates select="text()"/>
+ <xsl:text>&#10;</xsl:text>
+ </exsl:document>
+ </xsl:for-each>
+ </xsl:if>
+ <xsl:if test=".//TPM:DocFiles/text()">
+ <xsl:apply-templates select=".//TPM:DocFiles"/>
+ <xsl:text>&#10;</xsl:text>
+ </xsl:if>
+ <xsl:if test=".//TPM:SourceFiles/text()">
+ <xsl:apply-templates select=".//TPM:SourceFiles"/>
+ <xsl:text>&#10;</xsl:text>
+ </xsl:if>
+ <xsl:if test=".//TPM:RunFiles/text()">
+ <xsl:apply-templates select=".//TPM:RunFiles"/>
+ <xsl:text>&#10;</xsl:text>
+ </xsl:if>
+</exsl:document>
+</xsl:template>
+
+<xsl:template match="TPM:BinFiles/text()">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+</xsl:template>
+
+<xsl:template match="TPM:DocFiles">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+</xsl:template>
+
+<xsl:template match="TPM:RunFiles">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+</xsl:template>
+
+<xsl:template match="TPM:SourceFiles">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+</xsl:template>
+
+</xsl:stylesheet>
diff --git a/Build/tools/tpm2list.xsl b/Build/tools/tpm2list.xsl
new file mode 100644
index 00000000000..db7919e96e1
--- /dev/null
+++ b/Build/tools/tpm2list.xsl
@@ -0,0 +1,98 @@
+<!-- $Id$
+ Written by Sebastian Rahtz. Public domain. -->
+
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+ xmlns:exsl="http://exslt.org/common"
+ exclude-result-prefixes="exsl"
+ extension-element-prefixes="exsl"
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:TPM="http://texlive.dante.de/"
+ version="1.0">
+
+<xsl:output method="xml" omit-xml-declaration="yes"/>
+
+<xsl:strip-space elements="*"/>
+
+<!-- assume the current directory is Master, as Tools/update arranges. -->
+<xsl:param name="ROOT">.</xsl:param>
+
+<xsl:variable name="Master">
+ <xsl:value-of select="$ROOT"/>/texmf/lists/</xsl:variable>
+<xsl:variable name="LISTS">texmf/lists/</xsl:variable>
+
+<xsl:template match="/">
+ <xsl:apply-templates select="rdf:RDF/rdf:Description"/>
+</xsl:template>
+
+<xsl:template match="rdf:Description">
+ <xsl:variable name="File">
+ <xsl:value-of select="TPM:Name"/>
+ </xsl:variable>
+ <xsl:apply-templates select="TPM:BinFiles"/>
+ <exsl:document omit-xml-declaration="yes" method="text" href="{concat($Master,$File)}">
+ <xsl:apply-templates select="TPM:Requires"/>
+ <xsl:apply-templates select="TPM:DocFiles"/><xsl:text>&#10;</xsl:text>
+ <xsl:apply-templates select="TPM:SourceFiles"/><xsl:text>&#10;</xsl:text>
+ <xsl:apply-templates select="TPM:RunFiles"/><xsl:text>&#10;</xsl:text>
+ <xsl:apply-templates select="TPM:Installation"/>
+<xsl:text>&#10;texmf</xsl:text>
+ <xsl:value-of select="substring-after($Master,'texmf')"/>
+ <xsl:value-of select="TPM:Name"/><xsl:text>&#10;</xsl:text></exsl:document>
+<!--
+ <xsl:message>Write <xsl:value-of
+ select="concat($Master,//TPM:Name)"/>
+ <xsl:text>.</xsl:text>
+ <xsl:value-of select="@arch"/></xsl:message>
+-->
+</xsl:template>
+
+<xsl:template match="TPM:BinFiles">
+ <exsl:document method="text" href="{$Master}{//TPM:Name}.{@arch}">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+<xsl:text>&#10;</xsl:text>
+<xsl:value-of
+ select="concat($LISTS,//TPM:Name)"/>
+ <xsl:text>.</xsl:text>
+ <xsl:value-of select="@arch"/>
+<xsl:text>&#10;</xsl:text>
+</exsl:document>
+</xsl:template>
+
+<xsl:template match="TPM:Name" mode="name">
+ <xsl:apply-templates/>
+</xsl:template>
+
+<xsl:template match="TPM:DocFiles|TPM:SourceFiles|TPM:RunFiles">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+</xsl:template>
+
+<xsl:template match="TPM:Installation">
+ <xsl:for-each select="TPM:Execute">
+ <xsl:variable name="Function">
+ <xsl:choose>
+ <xsl:when test="@mode='mixed' and @function='addMap'">
+ <xsl:text>addMixedMap</xsl:text>
+ </xsl:when>
+ <xsl:otherwise>
+ <xsl:value-of select="@function"/>
+ </xsl:otherwise>
+ </xsl:choose>
+ </xsl:variable>
+ <xsl:text>!</xsl:text>
+ <xsl:value-of select="$Function"/>
+ <xsl:text> </xsl:text>
+ <xsl:value-of select="@parameter"/>
+ <xsl:text>&#10;</xsl:text>
+ </xsl:for-each>
+</xsl:template>
+
+<xsl:template match="TPM:Requires">
+<xsl:for-each select="TPM:Package|TPM:TLCore">
+<xsl:sort select="normalize-space(@name)"/>
+<xsl:text>+</xsl:text>
+<xsl:value-of select="translate(normalize-space(@name),' ','&#10;')"/>
+<xsl:text>&#10;</xsl:text>
+</xsl:for-each>
+</xsl:template>
+
+</xsl:stylesheet>
diff --git a/Build/tools/tpm2tar.xsl b/Build/tools/tpm2tar.xsl
new file mode 100644
index 00000000000..aa8155445b6
--- /dev/null
+++ b/Build/tools/tpm2tar.xsl
@@ -0,0 +1,53 @@
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+ xmlns:exsl="http://exslt.org/common"
+ exclude-result-prefixes="exsl"
+ extension-element-prefixes="exsl"
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:TPM="http://texlive.dante.de/"
+ version="1.0">
+
+<xsl:output method="text" omit-xml-declaration="yes"/>
+<xsl:param name="Root"/>
+
+<xsl:strip-space elements="*"/>
+
+<xsl:template match="/">
+ <exsl:document method="text" href="{$Root}{//TPM:Name}.list">
+ <xsl:if test=".//TPM:BinFiles/text()">
+ <xsl:for-each select=".//TPM:BinFiles">
+ <xsl:apply-templates select="text()"/>
+ <xsl:text>&#10;</xsl:text>
+ </xsl:for-each>
+ </xsl:if>
+ <xsl:if test=".//TPM:DocFiles/text()">
+ <xsl:apply-templates select=".//TPM:DocFiles"/>
+ <xsl:text>&#10;</xsl:text>
+ </xsl:if>
+ <xsl:if test=".//TPM:SourceFiles/text()">
+ <xsl:apply-templates select=".//TPM:SourceFiles"/>
+ <xsl:text>&#10;</xsl:text>
+ </xsl:if>
+ <xsl:if test=".//TPM:RunFiles/text()">
+ <xsl:apply-templates select=".//TPM:RunFiles"/>
+ <xsl:text>&#10;</xsl:text>
+ </xsl:if>
+</exsl:document>
+</xsl:template>
+
+<xsl:template match="TPM:BinFiles/text()">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+</xsl:template>
+
+<xsl:template match="TPM:DocFiles">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+</xsl:template>
+
+<xsl:template match="TPM:RunFiles">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+</xsl:template>
+
+<xsl:template match="TPM:SourceFiles">
+ <xsl:value-of select="translate(normalize-space(.),' ','&#10;')"/>
+</xsl:template>
+
+</xsl:stylesheet>
diff --git a/Build/tools/tpmfromcat b/Build/tools/tpmfromcat
new file mode 100755
index 00000000000..c0630fda221
--- /dev/null
+++ b/Build/tools/tpmfromcat
@@ -0,0 +1,24 @@
+#!/bin/sh
+# read the CTAN catalogue and update the TPM files where possible
+Master=`cd \`dirname $0\`/.. && /bin/pwd`
+cd $Master || exit 1
+
+test $# -eq 0 && set - `find texmf-dist/tpm -name "*.tpm"`
+for i in "$@"; do
+ echo Try to update $i
+ p4 edit $i
+ N=`basename $i .tpm`
+ L=`echo $N | sed 's/\(.\).*/\1/'`
+ wget -q -O x.xml \
+http://cvs.sarovar.org/cgi-bin/cvsweb.cgi/~checkout~/texcatalogue/entries/$L/$N.xml?cvsroot=texcatalogue
+grep -q "<entry" x.xml || echo "<entry/>" > x.xml
+xmllint --dropdtd x.xml > /tmp/$N.xml
+ xsltproc \
+ -o $N.tpm \
+ --stringparam sarovar /tmp/$N.xml \
+ --stringparam authors `pwd`/texmf-doc/doc/english/catalogue/authors.xml \
+ `pwd`/Tools/tpmfromcat.xsl $i
+ xmllint --format $N.tpm > $i
+ rm x.xml /tmp/$N.xml $N.tpm
+done
+p4 revert -a
diff --git a/Build/tools/tpmfromcat.xsl b/Build/tools/tpmfromcat.xsl
new file mode 100644
index 00000000000..4276721c9c2
--- /dev/null
+++ b/Build/tools/tpmfromcat.xsl
@@ -0,0 +1,81 @@
+<?xml version="1.0" encoding="utf-8"?>
+<xsl:stylesheet
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:TPM="http://texlive.dante.de/"
+ xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+ exclude-result-prefixes="rdf TPM"
+ version="1.0">
+
+<xsl:output
+ method="xml"
+ indent="yes"
+ doctype-system="../../Tools/tpm.dtd"
+ />
+
+<xsl:param name="sarovar"/>
+<xsl:param name="authors"/>
+
+<xsl:template match="@*|processing-instruction()|comment()|text()" >
+ <xsl:copy/>
+</xsl:template>
+
+<xsl:template match="*" >
+ <xsl:copy>
+ <xsl:apply-templates
+ select="*|@*|processing-instruction()|comment()|text()" />
+ </xsl:copy>
+</xsl:template>
+
+<xsl:template match="TPM:Description">
+ <xsl:variable name="S">
+ <xsl:value-of select="document($sarovar)/entry/description"/>
+ </xsl:variable>
+ <TPM:Description>
+ <xsl:choose>
+ <xsl:when test="$S=''">
+ <xsl:apply-templates/>
+ </xsl:when>
+ <xsl:otherwise>
+ <xsl:value-of select="$S"/>
+ [description copied from TeX Catalogue]
+ </xsl:otherwise>
+ </xsl:choose>
+ </TPM:Description>
+</xsl:template>
+
+<xsl:template match="TPM:Title">
+ <xsl:variable name="S">
+ <xsl:value-of select="document($sarovar)/entry/caption"/>
+ </xsl:variable>
+ <TPM:Title>
+ <xsl:choose>
+ <xsl:when test="$S=''">
+ <xsl:apply-templates/>
+ </xsl:when>
+ <xsl:otherwise>
+ <xsl:value-of select="$S"/>
+ </xsl:otherwise>
+ </xsl:choose>
+ </TPM:Title>
+</xsl:template>
+
+<xsl:template match="TPM:Author">
+ <xsl:variable name="A">
+ <xsl:value-of select="document($sarovar)/entry/authorref/@id"/>
+ </xsl:variable>
+ <xsl:variable name="S">
+ <xsl:value-of select="document($authors)/authors/author[@id=$A]"/>
+ </xsl:variable>
+ <TPM:Author>
+ <xsl:choose>
+ <xsl:when test="$S=''">
+ <xsl:apply-templates/>
+ </xsl:when>
+ <xsl:otherwise>
+ <xsl:value-of select="$S"/>
+ </xsl:otherwise>
+ </xsl:choose>
+ </TPM:Author>
+</xsl:template>
+
+</xsl:stylesheet>
diff --git a/Build/tools/update-auto b/Build/tools/update-auto
new file mode 100755
index 00000000000..0edba3f363e
--- /dev/null
+++ b/Build/tools/update-auto
@@ -0,0 +1,217 @@
+#!/bin/sh
+# $Id$
+# Public domain. Originally written 2003, Karl Berry.
+#
+# Deal with files that are automatically updated in one way or another.
+#
+# We should rewrite this to use rdist or make or something, but we'll
+# stick with this kludgy approach as long as we have perforce.
+
+PATH=/usr/local/bin:$PATH; export PATH
+umask 0
+
+# most stuff in Master.
+Master=`cd \`dirname $0\`/.. && /bin/pwd`
+cd $Master || exit 1
+
+temp=/tmp/ua$$
+trap "rm -f $temp*" 0 1 2 15
+
+# autogenerate README.EN from readme.html.
+#
+./Tools/htmltext <readme.en.html >$temp
+if diff $temp README.EN; then
+ echo " README.EN ok."
+else
+ p4 edit README.EN || exit 1
+ mv $temp README.EN
+ #
+ printf "Change: new
+Description:
+\t$0 (from readme.en.html)
+Files:
+\t//depot/Master/README.EN
+" | p4 submit -i README.EN
+fi
+
+
+# English FAQ from ctan mirror on tug.org.
+#
+faqmaster=/home/ftp/tex-archive/help/uk-tex-faq
+faqslave=texmf-doc/doc/english/FAQ-en
+for f in $faqmaster/*; do
+ # ignore some of the generated files
+ echo $f | egrep '(tar.gz|dvi|ps|letterfaq.pdf)$' >/dev/null \
+ && continue
+
+ basef=`basename $f`
+ faqslavef=$faqslave/$basef
+ if diff $faqslavef $f; then
+ echo " $faqslavef ok."
+ else
+ p4 edit $faqslavef || exit 1
+ cp $f $faqslavef
+ printf "Change: new
+Description:
+\t$0 (from $f)
+Files:
+\t//depot/Master/$faqslavef
+" | p4 submit -i $faqslavef
+ fi
+done
+# for now, don't bother auto-updating the html files.
+
+
+# modes.mf from elsewhere on tug.org.
+#
+modesmaster=/home/ftp/tex/modes.mf
+modesslave=texmf-dist/metafont/misc/modes.mf
+#
+if diff $modesslave $modesmaster; then
+ echo " $modesslave ok."
+else
+ p4 edit $modesslave || exit 1
+ cp $modesmaster $modesslave
+ #
+ printf "Change: new
+Description:
+\t$0 (from `hostname`:$modesmaster)
+Files:
+\t//depot/Master/$modesslave
+" | p4 submit -i $modesslave
+fi
+
+
+# texinfo.tex from elsewhere on tug.org.
+#
+tximaster=/home/ftp/tex/texinfo.tex
+txislave=texmf-dist/tex/texinfo/texinfo.tex
+#
+if diff $txislave $tximaster; then
+ echo " $txislave ok."
+else
+ p4 edit $txislave || exit 1
+ cp $tximaster $txislave
+ #
+ printf "Change: new
+Description:
+\t$0 (from `hostname`:$tximaster)
+Files:
+\t//depot/Master/$txislave
+" | p4 submit -i $txislave
+fi
+
+
+# fontname from elsewhere on tug.org.
+#
+fontnamemaster=/home/httpd/html/fontname
+fontnamedocslave=texmf-dist/doc/fontname
+#
+for basef in ChangeLog Makefile bitstrea.aka \
+ fontname.pdf fontname.html fontname.texi; do
+ fontnameslavef=$fontnamedocslave/$basef
+ if diff $fontnameslavef $fontnamemaster/$basef; then
+ echo " $fontnameslavef ok."
+ else
+ p4 edit $fontnameslavef || exit 1
+ cp $fontnamemaster/$basef $fontnameslavef
+ printf "Change: new
+Description:
+\t$0 (from $basef)
+Files:
+\t//depot/Master/$fontnameslavef
+" | p4 submit -i $fontnameslavef
+ fi
+done
+
+
+# fontname runtime files.
+#
+fontnamemapslave=texmf-dist/fonts/map/fontname
+#
+files=`cd $fontnamemaster && ls *.map`
+for basef in $files; do
+ test $basef = wolfram.map && continue # obsolete for TL
+ fontnamemapslavef=$fontnamemapslave/$basef
+ if diff $fontnamemapslavef $fontnamemaster/$basef; then
+ echo " $fontnamemapslavef ok."
+ else
+ p4 edit $fontnamemapslavef || exit 1
+ cp $fontnamemaster/$basef $fontnamemapslavef
+ printf "Change: new
+Description:
+\t$0 (from $basef)
+Files:
+\t//depot/Master/$fontnamemapslavef
+" | p4 submit -i $fontnamemapslavef
+ fi
+done
+
+
+fontnameencslave=texmf-dist/fonts/enc/dvips/base
+#
+files=`cd $fontnamemaster && ls *.enc`
+for basef in $files; do
+ fontnameencslavef=$fontnameencslave/$basef
+ if diff $fontnameencslavef $fontnamemaster/$basef; then
+ echo " $fontnameencslavef ok."
+ else
+ p4 edit $fontnameencslavef || exit 1
+ cp $fontnamemaster/$basef $fontnameencslavef
+ printf "Change: new
+Description:
+\t$0 (from $basef)
+Files:
+\t//depot/Master/$fontnameencslavef
+" | p4 submit -i $fontnameencslavef
+ fi
+done
+
+
+# doc.html.
+doctemp=docnew.html
+./Tools/mkdocindex | tee $doctemp | grep -v '<small>Generated' >$doctemp.new
+grep -v '<small>Generated' doc.html >$doctemp.cur
+if diff $doctemp.cur $doctemp.new; then
+ echo " doc.html ok."
+else
+ p4 edit doc.html || exit 1
+ mv $doctemp doc.html
+ #
+ printf "Change: new
+Description:
+\t$0 (from mkdocindex)
+Files:
+\t//depot/Master/doc.html
+" | p4 submit -i doc.html
+fi
+rm $doctemp*
+
+
+# config.{guess,sub} from GNU.
+#
+updated=
+for gnuconf in config.guess config.sub; do
+ wget -O $temp "http://savannah.gnu.org/cgi-bin/viewcvs/*checkout*/config/config/$gnuconf?rev=HEAD&content-type=text/plain" >$temp.2 2>&1
+ if test ! -s $temp; then
+ echo "$0: skipping, could not retrieve $gnuconf:" >&2
+ cat $temp.2
+ continue
+ fi
+ if cmp -s $temp $gnuconf; then
+ echo " $gnuconf ok."
+ else
+ # autoupdate all copies in source.
+ (cd ..
+ alldev="Master/$gnuconf `find Build/source Build/source.development -name $gnuconf`"
+ for f in $alldev; do
+ echo " updating $f."
+ p4 edit $f || continue
+ cp -pf $temp $f
+ done
+ p4 change -o \
+ | sed "s!<enter description here>!$gnuconf update by $0!" \
+ | p4 submit -i
+ )
+ fi
+done
diff --git a/Build/tools/update-lists b/Build/tools/update-lists
new file mode 100755
index 00000000000..f262977f678
--- /dev/null
+++ b/Build/tools/update-lists
@@ -0,0 +1,44 @@
+#!/bin/sh
+# $Id$
+# Created by Sebastian Rahtz, long ago. Public domain.
+#
+# Update the texmf/lists/* files from all the tpm's.
+
+M=`cd \`dirname $0\` && /bin/pwd`
+W=`cd \`dirname $0\`/.. && /bin/pwd`
+cd $W || exit 1 # work in Master
+
+Date=`date +%Y/%m/%d`
+Who=`whoami`
+
+if test "x$1" = x-n; then
+ chicken=true
+else
+ chicken=false
+fi
+
+$chicken || rm -f texmf/lists/*
+
+echo "$0: doing packages from $W"
+for i in texmf-dist/tpm/*.tpm texmf/tpm/hyphen*tpm texmf/tpm/lib-*.tpm texmf/tpm/bin-*.tpm \
+ texmf-doc/tpm/* ; do
+ xsltproc --stringparam ROOT $W $M/tpm2list.xsl $i
+done
+
+echo "$0: doing collections..."
+for i in texmf/tpm/collection*.tpm; do
+ xsltproc --stringparam ROOT $W $M/collection2list.xsl $i
+done
+
+echo "$0: doing schemes..."
+for i in texmf/tpm/scheme*.tpm; do
+ xsltproc --stringparam ROOT $W $M/scheme2list.xsl $i
+done
+
+echo "$0: regenerated lists."
+$chicken && exit 0
+
+echo "$0: updating lists in repository."
+cd texmf/lists || exit 1
+svn commit -m'update-lists autoupdate'
+# xx must svn remove old lists somehow
diff --git a/Build/tools/update-lsr b/Build/tools/update-lsr
new file mode 100755
index 00000000000..de700f81cbd
--- /dev/null
+++ b/Build/tools/update-lsr
@@ -0,0 +1,22 @@
+#!/bin/sh
+# $Id$
+# Originally written 2004, Karl Berry. Public domain.
+#
+# Update ls-R files. Called from tlrebuild and also karl@tug's cron.
+
+mydir=`dirname $0`
+tools=`cd $mydir && pwd`
+PATH=$tools:$PATH; export PATH
+umask 0
+
+master=`cd $mydir/.. && pwd`
+cd $master || exit 1
+
+# generate new.
+./bin/i386-linux/mktexlsr
+
+# if texmf-var exists, it's not part of the distribution.
+test -f texmf-var/ls-R && svn revert texmf-var/ls-R
+
+# if we have changes, submit to repository (frightening but necessary).
+svn commit -m'update-lsr autoupdate' texmf*/ls-R
diff --git a/Build/tools/update-tpm b/Build/tools/update-tpm
new file mode 100755
index 00000000000..370553921a4
--- /dev/null
+++ b/Build/tools/update-tpm
@@ -0,0 +1,40 @@
+#!/bin/sh
+# $Id$
+# Public domain. Originally written 2004, Karl Berry.
+#
+# Regenerate the given set of tpm's using tpm-factory.
+
+mydir=`dirname $0`
+master=`cd $mydir/.. && pwd`
+tools=$master/Tools
+
+verbose=${OVERRIDE_VERBOSE-}
+
+if test "x$1" = x--debug; then
+ verbose=--debug
+ shift
+fi
+
+test $# -eq 0 && set - TLCore Package Documentation
+
+for type in "$@"; do
+ case $type in
+ TLCore) p=from; dir=texmf;;
+ Package) p=auto; dir=texmf-dist;;
+ Documentation) p=auto; dir=texmf-doc;;
+ *) echo "$0: unknown type $type, one of TLCore, Package, Documentation.">&2
+ exit 1;;
+ esac
+
+ cd $master/$dir/tpm || exit 1
+ chmod a+rw * >&/dev/null # all files must be writable for tpm-factory.
+
+ perl $tools/tpm-factory.pl $verbose \
+ --master_dir=$master --ftp_dir=/tmp \
+ --clean \
+ --arch=all \
+ --patterns=$p \
+ --type=$type \
+ | grep -v '^Writing '
+done
+exit 0
diff --git a/Build/tools/update-tpm.bat b/Build/tools/update-tpm.bat
new file mode 100644
index 00000000000..12e2b6feac1
--- /dev/null
+++ b/Build/tools/update-tpm.bat
@@ -0,0 +1,24 @@
+@echo off
+if "%1" == "src" (
+set MASTERDIR=c:/source/texlive/Master
+set ARCH=all
+) else if "%1" == "texlive" (
+set MASTERDIR=c:/Progra~1/TeXLive
+set ARCH=win32,win32-static
+) else if "%1" == "xemtex" (
+set MASTERDIR=c:/Progra~1/XeMTeX
+set ARCH=win32
+) else (
+echo Wrong target!
+goto done
+)
+perl c:/source/TeXLive/Master/Tools/tpm-factory.pl --master_dir=%MASTERDIR% --clean --patterns=from --arch=%ARCH% --type=TLCore
+perl c:/source/TeXLive/Master/Tools/tpm-factory.pl --master_dir=%MASTERDIR% --clean --patterns=auto --arch=%ARCH% --type=Package
+perl c:/source/TeXLive/Master/Tools/tpm-factory.pl --master_dir=%MASTERDIR% --clean --patterns=auto --arch=%ARCH% --type=Documentation
+rem
+perl c:/source/TeXLive/Master/Tools/tpm-factory.pl --master_dir=%MASTERDIR% --check=cov --arch=%ARCH% --type=all > \source\texlive\Master\Tools\cov-%1.log
+perl c:/source/TeXLive/Master/Tools/tpm-factory.pl --master_dir=%MASTERDIR% --check=dep --arch=%ARCH% --type=all > \source\texlive\Master\Tools\dep-%1.log
+perl c:/source/TeXLive/Master/Tools/tpm-factory.pl --master_dir=%MASTERDIR% --check=dup --arch=%ARCH% --type=all > \source\texlive\Master\Tools\dup-%1.log
+:done
+set MASTERDIR=
+set ARCH=
diff --git a/Build/tools/updatetpm.xsl b/Build/tools/updatetpm.xsl
new file mode 100644
index 00000000000..0afad1990a1
--- /dev/null
+++ b/Build/tools/updatetpm.xsl
@@ -0,0 +1,102 @@
+<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
+ xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+ xmlns:TPM="http://texlive.dante.de/"
+ version="1.0">
+
+<xsl:param name="TMP"/>
+<xsl:param name="binaries"/>
+<xsl:param name="files"/>
+<xsl:param name="Who"/>
+<xsl:param name="When"/>
+<xsl:output indent="yes"
+ method="xml"
+ omit-xml-declaration="yes"
+ doctype-system="tpm.dtd"/>
+<xsl:template match="*|@*|processing-instruction()">
+ <xsl:copy>
+ <xsl:apply-templates select="*|@*|processing-instruction()|comment()|text()"/>
+ </xsl:copy>
+</xsl:template>
+
+<xsl:template match="TPM:Size"/>
+<xsl:template match="TPM:Title">
+ <xsl:copy-of select="."/>
+ <TPM:Size><xsl:value-of select="sum(//TPM:*/@size)"/></TPM:Size>
+</xsl:template>
+
+<xsl:template match="TPM:Date">
+ <TPM:Date><xsl:value-of select="$When"/></TPM:Date>
+</xsl:template>
+
+<xsl:template match="TPM:Creator">
+ <TPM:Creator><xsl:value-of select="$Who"/></TPM:Creator>
+</xsl:template>
+
+<xsl:template match="text()">
+ <xsl:value-of select="."/> <!-- could normalize() here -->
+</xsl:template>
+
+<xsl:template match="TPM:BinFiles">
+<xsl:choose>
+<xsl:when test="$binaries">
+<xsl:if test="not(preceding-sibling::TPM:BinFiles)">
+ <xsl:message>add binaries for <xsl:value-of select="../TPM:Name"/></xsl:message>
+ <xsl:for-each
+ select="document(concat('/texlive/Build/cdbuild/list.',../TPM:Name))/bin/*">
+ <xsl:copy-of select="."/>
+ </xsl:for-each>
+</xsl:if>
+</xsl:when>
+<xsl:otherwise>
+ <xsl:copy-of select="."/>
+</xsl:otherwise>
+</xsl:choose>
+</xsl:template>
+
+
+<xsl:template match="TPM:DocFiles">
+<xsl:choose>
+<xsl:when test="$files">
+ <xsl:for-each
+ select="document(concat($TMP,'.doc'))/*">
+ <xsl:copy-of select="."/>
+ </xsl:for-each>
+</xsl:when>
+<xsl:otherwise>
+ <xsl:copy-of select="."/>
+</xsl:otherwise>
+</xsl:choose>
+</xsl:template>
+
+<xsl:template match="TPM:RunFiles">
+<xsl:choose>
+<xsl:when test="$files">
+ <xsl:for-each
+ select="document(concat($TMP,'.run'))/*">
+ <xsl:copy-of select="."/>
+ </xsl:for-each>
+</xsl:when>
+<xsl:otherwise>
+ <xsl:copy-of select="."/>
+</xsl:otherwise>
+</xsl:choose>
+</xsl:template>
+
+<xsl:template match="TPM:SourceFiles">
+<xsl:choose>
+<xsl:when test="$files">
+ <xsl:for-each
+ select="document(concat($TMP,'.src'))/*">
+ <xsl:copy-of select="."/>
+ </xsl:for-each>
+</xsl:when>
+<xsl:otherwise>
+ <xsl:copy-of select="."/>
+</xsl:otherwise>
+</xsl:choose>
+</xsl:template>
+
+
+
+</xsl:stylesheet>
+