diff options
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 + © + &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 + ®expify + &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 { + ©($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 { + ©($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 { + ©($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; + + ©("$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) { + © ($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) { + © ($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, '', \®expify_recursive_node); + &FileUtils::walk_tree($node, '', \®expify_cleanup); + } + else { + &FileUtils::walk_tree($node, '', \®expify_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 = +( + '"' => """, + ">" => ">", + "<" => "<", + "'" => "'", + "&" => "&" +); + +$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/]]>/]]>/go; + $str; +} + +# +# PI may not contain "?>" +# +sub encodeProcessingInstruction +{ + my ($str) = shift; + $str =~ s/\?>/?>/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/--/--/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 "&" and "<" resp.) +# +sub encodeText +{ + my ($str, $default) = @_; + return undef unless defined $str; + + if ($] >= 5.006) { + $str =~ s/([$default])|(]]>)/ + defined ($1) ? $DecodeDefaultEntity{$1} : "]]>" /egs; + } + else { + $str =~ s/([\xC0-\xDF].|[\xE0-\xEF]..|[\xF0-\xFF]...)|([$default])|(]]>)/ + defined($1) ? XmlUtf8Decode ($1) : + defined ($2) ? $DecodeDefaultEntity{$2} : "]]>" /egs; + } + +#?? could there be references that should not be expanded? +# e.g. should not replace &#nn; ¯ and &abc; +# $str =~ s/&(?!($ReName|#[0-9]+|#x[0-9a-fA-F]+);)/&/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. { or Ͽ 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. "&" + } + } + $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 ">". +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> </xsl:text> +<xsl:text>*Size: </xsl:text> + <xsl:call-template name="findSize"/> + <xsl:text> </xsl:text> + <xsl:apply-templates select=".//TPM:Requires"/> + <xsl:apply-templates select=".//TPM:DocFiles"/><xsl:text> </xsl:text> + <xsl:apply-templates select=".//TPM:SourceFiles"/><xsl:text> </xsl:text> + <xsl:apply-templates select=".//TPM:RunFiles"/><xsl:text> </xsl:text> + <xsl:text> </xsl:text> + <xsl:value-of select="$LISTS"/> + <xsl:value-of select=".//TPM:Name"/> + <xsl:text> </xsl:text> + </exsl:document> +</xsl:template> + +<xsl:template match="TPM:DocFiles|TPM:SourceFiles|TPM:RunFiles"> + <xsl:value-of select="translate(normalize-space(.),' ',' ')"/> +</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),' ',' ')"/> +<xsl:text> </xsl:text> +</xsl:for-each> +<xsl:for-each select="TPM:Collection"> +<xsl:text>-</xsl:text> +<xsl:value-of select="translate(normalize-space(@name),' ',' ')"/> +<xsl:text> </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> </xsl:text> +<xsl:text>*Size: </xsl:text> +<xsl:value-of select=".//TPM:Size"/> + <xsl:text> </xsl:text> + <xsl:apply-templates select=".//TPM:Requires"/> + <xsl:apply-templates select=".//TPM:DocFiles"/><xsl:text> </xsl:text> + <xsl:apply-templates select=".//TPM:SourceFiles"/><xsl:text> </xsl:text> + <xsl:apply-templates select=".//TPM:RunFiles"/><xsl:text> </xsl:text> + <xsl:apply-templates select=".//TPM:BinFiles"/> + <xsl:text> </xsl:text> + <xsl:value-of select="$LISTS"/> + <xsl:value-of select=".//TPM:Name"/> + <xsl:text>.scheme </xsl:text> + </exsl:document> +</xsl:template> + +<xsl:template match="TPM:DocFiles|TPM:SourceFiles|TPM:RunFiles"> + <xsl:value-of select="translate(normalize-space(.),' ',' ')"/> +</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(.),' ',' ')"/> +<xsl:text> </xsl:text> +<xsl:value-of select="concat($LISTS,//TPM:Name)"/> + <xsl:text>.vlist.</xsl:text> + <xsl:value-of select="@arch"/> +<xsl:text> </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),' ',' ')"/> +<xsl:text> </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),' ',' ')"/> +<xsl:text> </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> </xsl:text> + </exsl:document> + </xsl:for-each> + </xsl:if> + <xsl:if test=".//TPM:DocFiles/text()"> + <xsl:apply-templates select=".//TPM:DocFiles"/> + <xsl:text> </xsl:text> + </xsl:if> + <xsl:if test=".//TPM:SourceFiles/text()"> + <xsl:apply-templates select=".//TPM:SourceFiles"/> + <xsl:text> </xsl:text> + </xsl:if> + <xsl:if test=".//TPM:RunFiles/text()"> + <xsl:apply-templates select=".//TPM:RunFiles"/> + <xsl:text> </xsl:text> + </xsl:if> +</exsl:document> +</xsl:template> + +<xsl:template match="TPM:BinFiles/text()"> + <xsl:value-of select="translate(normalize-space(.),' ',' ')"/> +</xsl:template> + +<xsl:template match="TPM:DocFiles"> + <xsl:value-of select="translate(normalize-space(.),' ',' ')"/> +</xsl:template> + +<xsl:template match="TPM:RunFiles"> + <xsl:value-of select="translate(normalize-space(.),' ',' ')"/> +</xsl:template> + +<xsl:template match="TPM:SourceFiles"> + <xsl:value-of select="translate(normalize-space(.),' ',' ')"/> +</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> </xsl:text> + <xsl:apply-templates select="TPM:SourceFiles"/><xsl:text> </xsl:text> + <xsl:apply-templates select="TPM:RunFiles"/><xsl:text> </xsl:text> + <xsl:apply-templates select="TPM:Installation"/> +<xsl:text> texmf</xsl:text> + <xsl:value-of select="substring-after($Master,'texmf')"/> + <xsl:value-of select="TPM:Name"/><xsl:text> </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(.),' ',' ')"/> +<xsl:text> </xsl:text> +<xsl:value-of + select="concat($LISTS,//TPM:Name)"/> + <xsl:text>.</xsl:text> + <xsl:value-of select="@arch"/> +<xsl:text> </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(.),' ',' ')"/> +</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> </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),' ',' ')"/> +<xsl:text> </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> </xsl:text> + </xsl:for-each> + </xsl:if> + <xsl:if test=".//TPM:DocFiles/text()"> + <xsl:apply-templates select=".//TPM:DocFiles"/> + <xsl:text> </xsl:text> + </xsl:if> + <xsl:if test=".//TPM:SourceFiles/text()"> + <xsl:apply-templates select=".//TPM:SourceFiles"/> + <xsl:text> </xsl:text> + </xsl:if> + <xsl:if test=".//TPM:RunFiles/text()"> + <xsl:apply-templates select=".//TPM:RunFiles"/> + <xsl:text> </xsl:text> + </xsl:if> +</exsl:document> +</xsl:template> + +<xsl:template match="TPM:BinFiles/text()"> + <xsl:value-of select="translate(normalize-space(.),' ',' ')"/> +</xsl:template> + +<xsl:template match="TPM:DocFiles"> + <xsl:value-of select="translate(normalize-space(.),' ',' ')"/> +</xsl:template> + +<xsl:template match="TPM:RunFiles"> + <xsl:value-of select="translate(normalize-space(.),' ',' ')"/> +</xsl:template> + +<xsl:template match="TPM:SourceFiles"> + <xsl:value-of select="translate(normalize-space(.),' ',' ')"/> +</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> + |