@@ -34,3 +34,26 @@ Algorithm::Diff 1.15)
0.11 Sat May 1 15:50:47 CEST 2004
- fix for warning on reserved namespace without local name
- test fixes (and the requirement) for LibXML 1.58
+
+1.00 Sat Jul 1 13:49:34 2006
+ - reimplemented with XS; created by h2xs 1.23 with options
+ -A -v 1.00 -n XML::DifferenceMarkup
+
+1.01 Wed Jan 2 19:38:10 2008
+ - resolved name conflict between Perl and gcc headers
+ (reported by Brad Guillory)
+
+1.02 Sat Jan 5 12:10:37 2008
+ - stricter checks for required libraries
+
+1.03 Mon Dec 27 16:18:35 UTC 2010
+ - ignoring more whitespace
+
+1.04 Thu Nov 17 08:06:07 UTC 2011
+ - requiring newer XML::LibXML
+ - tests not loading external DTDs
+
+1.05 Sun Jun 15 06:51:36 UTC 2014
+ - upgraded LibXML adapter to files from XML-LibXML-2.0116
+ (lightly edited to compile as C++)
+
@@ -1,998 +0,0 @@
-=head1 NAME
-
-XML::DifferenceMarkup
-
-=head1 SYNOPSIS
-
- use XML::DifferenceMarkup qw(make_diff);
-
- $parser = XML::LibXML->new();
- $parser->keep_blanks(0);
- $d1 = $parser->parse_file($fname1);
- $d2 = $parser->parse_file($fname2);
-
- $dom = make_diff($d1, $d2);
- print $dom->toString(1);
-
-=head1 DESCRIPTION
-
-This module implements an XML diff producing XML output. Both input
-and output are DOM documents, as implemented by XML::LibXML.
-
-The diff format used by XML::DifferenceMarkup is meant to be
-human-readable (i.e. simple, as opposed to short) - basically the diff
-is a subset of the input trees, annotated with instruction element
-nodes specifying how to convert the source tree to the target by
-inserting and deleting nodes. To prevent name colisions with input
-trees, all added elements are in a namespace
-C<http://www.locus.cz/XML/DifferenceMarkup> (the diff will fail on
-input trees which already use that namespace).
-
-The top-level node of the diff is always <diff/> (or rather <dm:diff
-xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup"> ... </dm:diff> -
-this description omits the namespace specification from now on);
-under it are fragments of the input trees and instruction nodes:
-<insert/>, <delete/> and <copy/>. <copy/> is used in places where the
-input subtrees are the same - in the limit, the diff of 2 identical
-documents is
-
- <?xml version="1.0"?>
- <dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:copy count="1"/>
- </dm:diff>
-
-(copy always has the count attribute and no other content). <insert/>
-and <delete/> have the obvious meaning - in the limit a diff of 2
-documents which have nothing in common is something like
-
- <?xml version="1.0"?>
- <dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:delete>
- <old/>
- </dm:delete>
- <dm:insert>
- <new>
- <tree>with the whole subtree, of course</tree>
- </new>
- </dm:insert>
- </dm:diff>
-
-Actually, the above is a typical output even for documents which have
-plenty in common - if (for example) the names of top-level elements in
-the two input documents differ, XML::DifferenceMarkup will produce a
-maximal diff, even when their subtrees are exactly the same.
-
-Note that <delete/> contains just one level of nested nodes - their
-subtrees are not included in the diff (but the element nodes which are
-included always come with all their attributes). <insert/> and
-<delete/> don't have any attributes and always contain some subtree.
-
-Instruction nodes are never nested; all nodes above an instruction
-node (except the top-level <diff/>) come from the input trees. A node
-from the input tree is included in the output diff to provide context
-for instruction nodes when it satisfies the following conditions:
-
-=over
-
-=item * it's an element node
-
-=item * it has the same name in both input trees
-
-=item * it has the same attributes (names and values) in the same order
-
-=item * its subtree is not the same
-
-=back
-
-The last condition guarantees that the "contextual" nodes always
-contain at least one <insert/> or <delete/>.
-
-=head1 FUNCTIONS
-
-Note that XML::DifferenceMarkup functions must be explicitly imported
-(i.e. with C<use XML::DifferenceMarkup qw(make_diff merge_diff);>)
-before they can be called.
-
-=head2 make_diff
-
-C<make_diff> takes 2 parameters (the input documents) and produces
-their diff. Note that the diff is asymmetric - C<make_diff($a, $b)> is
-different from C<make_diff($b, $a)>.
-
-=head2 merge_diff
-
-C<merge_diff> takes the first document passed to C<make_diff> and its
-return value and produces the second document. (More-or-less - the
-document isn't canonicalized, so opinions on its "equality" may
-differ.)
-
-=head2 Error Handling
-
-Both C<make_diff> and C<merge_diff> throw exceptions on invalid input
-- their own exceptions as well as exceptions thrown by
-XML::LibXML. These exceptions can usually (not always, though - it
-I<is> possible to construct an input which will crash the calling
-process) be catched by calling the functions from an eval block.
-
-=head1 BUGS
-
-=over
-
-=item * attribute order is significant
-
-=item * diff needs just one namespace declaration but usually has more
-
-=item * information outside the document element is not processed
-
-=back
-
-=head1 AUTHOR
-
-Vaclav Barta <vbar@comp.cz>
-
-=head1 SEE ALSO
-
-L<XML::LibXML>
-
-=cut
-
-# ' stop the comment highlighting
-
-package XML::DifferenceMarkup;
-
-use 5.006;
-use strict;
-use warnings;
-
-use vars qw(@ISA @EXPORT_OK $VERSION);
-
-require Exporter;
-
-@ISA = qw(Exporter);
-
-@EXPORT_OK = qw(make_diff merge_diff);
-
-$VERSION = '0.11';
-
-our $NSURL = 'http://www.locus.cz/XML/DifferenceMarkup';
-
-sub _get_unique_prefix {
- my ($m, $n) = @_;
-
- # warn "_get_unique_prefix\n";
-
- my $prefix = 'dm';
-
- my $col = XML::DifferenceMarkup::NamespaceCollector->new(
- $prefix, $NSURL);
- my $top = $col->get_unused_number($m, $n);
-
- if ($top != -1) {
- $prefix .= $top;
- }
-
- # warn "unique prefix: $prefix\n";
- return $prefix;
-}
-
-sub make_diff {
- my ($d1, $d2) = @_;
-
- my $m = $d1->documentElement;
- my $n = $d2->documentElement;
-
- my $dm = XML::DifferenceMarkup::Diff->new(
- _get_unique_prefix($m, $n),
- $NSURL);
-
- return $dm->diff_nodes($m, $n);
-}
-
-sub merge_diff {
- my ($src_doc, $diff_doc) = @_;
-
- my $builder = XML::DifferenceMarkup::Merge->new($NSURL);
- return $builder->merge(
- $src_doc,
- $diff_doc->documentElement);
-}
-
-package XML::DifferenceMarkup::Merge;
-
-use strict;
-use warnings;
-
-use vars qw(@ISA);
-
-@ISA = qw(XML::DifferenceMarkup::Target);
-
-sub new {
- my ($class, $nsurl) = @_;
-
-# warn "new\n";
-
- my $self = XML::DifferenceMarkup::Target::new($class, $nsurl);
- $self->{die_head} = 'XML::DifferenceMarkup merge: invalid diff: ';
-
- return $self;
-}
-
-sub merge {
- my ($self, $src_tree, $diff_node) = @_;
-
- # warn "merge\n";
-
- $self->{src} = $src_tree;
- $self->{src_point} = $src_tree->documentElement;
- # warn "src_point := " . $self->{src_point}->nodeName;
-
- $self->{nsprefix} = $self->_get_nsprefix($diff_node);
- $self->_check_top_node_name($diff_node);
-
- $self->{dest} = XML::LibXML::Document->createDocument;
-
- my $ch = $diff_node->firstChild;
- unless ($ch) {
- die $self->{die_head} . "diff node has no children\n";
- }
-
- $self->_do_merge($ch);
- $ch = $ch->nextSibling;
-
- while ($ch) {
- $self->_do_merge($ch);
- $ch = $ch->nextSibling;
- }
-
- return $self->{dest};
-}
-
-sub _do_merge {
- my ($self, $tree) = @_;
-
- # warn "_do_merge\n";
-
- my $name = $tree->nodeName;
-
- if ($name eq $self->get_scoped_name('delete')) {
- $self->_handle_delete($tree);
- } elsif ($name eq $self->get_scoped_name('copy')) {
- $self->_handle_copy($tree);
- } elsif ($name eq $self->get_scoped_name('insert')) {
- $self->_handle_insert($tree);
- } else {
- # it can't be an instruction
- my $prefix = $tree->prefix;
- if (defined($prefix) &&
- $prefix eq $self->{nsprefix}) {
- die $self->{die_head} . "unknown instruction $name (this is version " . $XML::DifferenceMarkup::VERSION . " of XML::DifferenceMarkup)\n";
- }
-
- $self->_copy_shallow;
-
- my $ch = $tree->firstChild;
- while ($ch) {
- $self->_do_merge($ch);
- $ch = $ch->nextSibling;
- }
-
- $self->_elevate_dest_point;
- }
-}
-
-sub _handle_delete {
- my ($self, $delete_instruction) = @_;
-
- # warn "_handle_delete\n";
-
- my $ch = $delete_instruction->firstChild;
- unless ($ch) {
- die $self->{die_head} . "delete node has no children\n";
- }
-
- unless ($self->{src_point}) {
- die $self->{die_head} . "nothing to delete\n";
- }
-
- my $finished = 0;
- while ($ch) {
- # check that the deleted node name is the same in source &
- # diff (it could check the attributes as well, but the time
- # spent checking probably isn't worth it)
- unless ($ch->nodeName eq $self->{src_point}->nodeName) {
- die $self->{die_head} . $ch->nodeName . " isn't there to be deleted; source has " . $self->{src_point}->nodeName . " instead\n";
- }
-
- my $checked_sibling = $self->{src_point}->nextSibling;
- if ($checked_sibling) {
- $self->{src_point} = $checked_sibling;
- # my $src_point_str = $self->{src_point}->nodeName;
- # warn "src_point := $src_point_str";
- } else {
- if ($finished) {
- die $self->{die_head} . "too many nodes to delete\n";
- }
-
- $finished = 1;
- }
-
- $ch = $ch->nextSibling;
- }
-
- if ($finished) {
- $self->_elevate_src_point;
- }
-}
-
-sub _advance_src_point {
- my $self = shift;
-
- my $sibling = $self->{src_point}->nextSibling;
- if ($sibling) {
- $self->{src_point} = $sibling;
- # warn "src_point := " . $self->{src_point}->nodeName . "\n";
- } else {
- $self->_elevate_src_point;
- }
-}
-
-sub _elevate_src_point {
- my $self = shift;
-
- # warn "_elevate_src_point\n";
-
- my $top = $self->{src}->documentElement;
-
- return if $self->{src_point}->isSameNode($top);
-
- my $previous = $self->{src_point}->parentNode;
-
- while (!($previous->nextSibling)) {
- if ($previous->isSameNode($top)) {
- # warn "wrapping up...\n";
- return;
- }
-
- $previous = $previous->parentNode;
- # warn "source point going up to " . $previous->nodeName . "\n";
- }
-
- $self->{src_point} = $previous->nextSibling;
- # my $src_point_str = $self->{src_point} ? $self->{src_point}->nodeName : 'undef';
- # warn "src_point := $src_point_str";
-}
-
-# Moves dest_point one level up (unless it's already pointing to the top).
-sub _elevate_dest_point {
- my $self = shift;
-
- # warn "_elevate_dest_point\n";
-
- my $top = $self->{dest}->documentElement;
- if (!$self->{dest_point}->isSameNode($top)) {
- $self->{dest_point} = $self->{dest_point}->parentNode;
- # my $dest_point_str = $self->{dest_point} ? $self->{dest_point}->nodeName : 'undef';
- # warn "dest_point := $dest_point_str";
- }
-}
-
-sub _handle_insert {
- my ($self, $insert_instruction) = @_;
-
- # warn "_handle_insert\n";
-
- my $ch = $insert_instruction->firstChild;
- unless ($ch) {
- die $self->{die_head} . "insert node has no children\n";
- }
-
- while ($ch) {
- my $new = $self->{dest}->importNode($ch);
- $self->_append($new);
-
- $ch = $ch->nextSibling;
- }
-}
-
-sub _handle_copy {
- my ($self, $copy_instruction) = @_;
-
- # warn "_handle_copy\n";
-
- unless ($self->{src_point}) {
- die $self->{die_head} . "nothing to copy\n";
- }
-
- my $count = $copy_instruction->getAttribute('count');
- unless (defined($count)) {
- die $self->{die_head} . "no copy count\n";
- }
- unless ($count > 0) {
- die $self->{die_head} . "invalid copy count $count\n";
- }
-
- while ($count > 0) {
- $self->_copy_deep;
- --$count;
- }
-}
-
-# Copies $self->{src_point} (without its subtree) to the target
-# document.
-sub _copy_shallow {
- my $self = shift;
-
- # warn "_copy_shallow\n";
-
- unless ($self->{src_point}) {
- die $self->{die_head} . "nothing to shallow-copy\n";
- }
-
- my $new = $self->import_tip($self->{src_point});
- $self->_append($new);
-
- my $checked_child = $self->{src_point}->firstChild;
- if ($checked_child) {
- $self->{src_point} = $checked_child;
- # my $src_point_str = $self->{src_point}->nodeName;
- # warn "src_point := $src_point_str";
- } else {
- $self->_advance_src_point;
- }
-
- $self->{dest_point} = $new;
- # my $dest_point_str = $self->{dest_point} ? $self->{dest_point}->nodeName : 'undef';
- # warn "dest_point := $dest_point_str";
-}
-
-sub _copy_deep {
- my $self = shift;
-
- # warn "_copy_deep\n";
-
- unless ($self->{src_point}) {
- die $self->{die_head} . "nothing to deep-copy\n";
- }
-
- my $new = $self->{dest}->importNode($self->{src_point});
- $self->_append($new);
-
- $self->_advance_src_point;
-}
-
-sub _append {
- my ($self, $new) = @_;
-
- # warn "_append(" . $new->nodeName . ")\n";
-
- if (!exists($self->{dest_point})) {
- $self->{dest}->setDocumentElement($new);
- } else {
- $self->{dest_point}->appendChild($new);
- }
-}
-
-sub _check_top_node_name {
- my ($self, $diff_node) = @_;
-
- # warn "_check_top_node_name\n";
-
- my $nsprefix = $self->{nsprefix};
-
- unless ($diff_node->nodeName eq "$nsprefix:diff") {
- die $self->{die_head} . "invalid document node " . $diff_node->nodeName . "\n";
- }
-}
-
-sub _get_nsprefix {
- my ($self, $diff_node) = @_;
-
- # warn "_get_nsprefix\n";
-
- my @dm_ns = $diff_node->getNamespaces;
- if (!@dm_ns) {
- die $self->{die_head} . "document node has no namespace declarations\n";
- }
- if (@dm_ns > 1) {
- my $dm_ns_text = join ', ', map { '"' . $_->getData . '"'; } @dm_ns;
- die $self->{die_head} . "document node has too many namespace declarations: $dm_ns_text\n";
- }
-
- my $dm_ns = $dm_ns[0];
-
- my $dm_ns_url = $dm_ns->getData;
- if ($dm_ns_url ne $NSURL) {
- die $self->{die_head} . "document node namespace declaration must be $NSURL (not $dm_ns_url)\n";
- }
-
- if (!defined($dm_ns->name)) {
- die $self->{die_head} . "document node namespace declaration has no prefix\n";
- }
-
- return $dm_ns->name;
-}
-
-package XML::DifferenceMarkup::Diff;
-
-use XML::LibXML;
-use Algorithm::Diff qw(traverse_balanced);
-
-use strict;
-use warnings;
-
-use vars qw(@ISA);
-
-@ISA = qw(XML::DifferenceMarkup::Target);
-
-sub new {
- my ($class, $nsprefix, $nsurl) = @_;
-
- # warn "new\n";
- my $self = XML::DifferenceMarkup::Target::new($class, $nsurl);
- $self->{nsprefix} = $nsprefix;
- return $self;
-}
-
-sub diff_nodes {
- my ($self, $m, $n) = @_;
-
- $self->{dest} = XML::LibXML::Document->createDocument;
- $self->{dest_point} = $self->{dest}->createElementNS(
- $self->{nsurl},
- $self->get_scoped_name('diff'));
- $self->{dest}->setDocumentElement($self->{dest_point});
-
- if ($m->toString eq $n->toString) {
- $self->_append_copy;
- } else {
- if (!$self->_eq_shallow($m, $n)) {
- $self->_replace($m, $n);
- } else {
- $self->_descend($m, $n);
- }
- }
-
- return $self->{dest};
-}
-
-sub _eq_shallow {
- my ($self, $m, $n) = @_;
-
- # warn "_eq_shallow\n";
-
- # 10Sep2002: this isn't really equality as understood by DOM (the
- # same attributes in different order will be considered
- # different), but it's the same equality as used in other places
- # (most importantly traverse_balanced)
-
- my $p = $self->get_tip($m);
- my $q = $self->get_tip($n);
-
- return $p->toString eq $q->toString;
-}
-
-# insert a bottom pair
-sub _replace {
- my ($self, $m, $n) = @_;
-
- # warn "_replace\n";
-
- my $del = $self->{dest}->createElementNS(
- $self->{nsurl},
- $self->get_scoped_name('delete'));
- $self->{dest_point}->appendChild($del);
-
- $del->appendChild($self->import_tip($m));
- $self->_append_insert($n);
-}
-
-sub _append_insert {
- my ($self, $n) = @_;
-
- # warn "_append_insert(" . $self . ", " . $n->nodeName . ")\n";
-
- my $ins = $self->{dest}->createElementNS(
- $self->{nsurl},
- $self->get_scoped_name('insert'));
- $self->{dest_point}->appendChild($ins);
- $ins->appendChild($self->{dest}->importNode($n));
-}
-
-sub _append_delete {
- my ($self, $n) = @_;
-
- # warn "_append_delete(" . $self . ", " . $n->nodeName . ")\n";
-
- my $del = $self->{dest}->createElementNS(
- $self->{nsurl},
- $self->get_scoped_name('delete'));
- $self->{dest_point}->appendChild($del);
- $del->appendChild($self->{dest}->importNode($n));
-}
-
-sub _append_copy {
- my $self = shift;
-
- # warn "_append_copy($self)\n";
-
- my $copy = $self->{dest}->createElementNS(
- $self->{nsurl},
- $self->get_scoped_name('copy'));
- $self->{dest_point}->appendChild($copy);
- $copy->setAttribute('count', 1);
-}
-
-sub _descend {
- my ($self, $m, $n) = @_;
-
- # warn "_descend\n";
-
- my $seq = $self->import_tip($n);
-
- $self->{dest_point}->appendChild($seq);
- $self->{dest_point} = $seq;
-
- my $a = $self->_children($m);
- my $b = $self->_children($n);
-
- # 25Sep2002: From the Algorithm::Diff POD: "If both arrows point
- # to elements that are not part of the LCS, then
- # C<traverse_sequences> will advance one of them and call the
- # appropriate callback, but it is not specified which it will
- # call." That's a problem, because XML::DifferenceMarkup needs the
- # callbacks called in a very specific order, namely the order
- # minimizing the size of the resulting diff. Using
- # C<traverse_balanced> does not *guarantee* minimal diff, but
- # "jumping back and forth" between insertions & deletions seems
- # like a good heuristics...
-
- traverse_balanced($a, $b,
- {
- MATCH => sub {
- $self->_on_match;
- },
- DISCARD_A => sub {
- my $i = shift;
-
- $self->_on_delete($a->[$i]);
- },
- DISCARD_B => sub {
- my $i = shift;
- my $j = shift;
-
- $self->_on_insert($b->[$j]);
- }
- },
- sub {
- my $n = shift;
-
- return $n->toString;
- });
-
- my $last = $seq->lastChild;
- if ($last && $last->nodeName eq
- $self->get_scoped_name('delete')) {
- # the last <delete/> isn't going to be descended into (because
- # it's the last in the sequence); we can leave only the top
- # node from it & remove the subnodes
- $self->_prune($last);
- }
-
- # warn "_descend finished\n";
-}
-
-sub _children {
- my ($dummy_self, $n) = @_;
-
- # warn "_children\n";
-
- my $out = [];
-
- my $ch = $n->firstChild;
- while ($ch) {
- push @$out, $ch;
- $ch = $ch->nextSibling;
- }
-
- return $out;
-}
-
-sub _diff {
- my ($self, $m, $n) = @_;
-
- # warn "_diff\n";
-
- my $dm = XML::DifferenceMarkup::Diff->new($self->{nsprefix},
- $self->{nsurl});
- my $dom = $dm->diff_nodes($m, $n);
- return $dom->documentElement;
-}
-
-# returns 1 the subtree of the child has been merged, 0 no merge
-# possible
-sub _combine_first_child {
- my ($self, $first_child, $checked_name) = @_;
-
- my $last = $self->{dest_point}->lastChild;
- if (!$last) {
- return 0;
- }
-
- if (($last->nodeName ne $checked_name) ||
- ($first_child->nodeName ne $checked_name)) {
- return 0;
- }
-
- my $cnt = $first_child->firstChild;
- while ($cnt) {
- $last->appendChild($self->{dest}->importNode($cnt));
- $cnt = $cnt->nextSibling;
- }
-
- return 1;
-}
-
-# returns 1 OK (destination has been modified), 0 it isn't possible to
-# combine the pair (i.e. because one node of the pair is a text node)
-sub _combine_pair {
- my ($self, $n, $reverse) = @_;
-
- # warn "_combine_pair(" . $self . ", " . $n->nodeName . ", " . $reverse . ")\n";
-
- my $last = $self->{dest_point}->lastChild;
- if (!$last) {
- die "internal error: no last insert";
- }
-
- my $m = $last->lastChild;
- if (!$m) {
- die "internal error: " . $last->nodeName . " without children";
- }
-
- # 1 is XML_ELEMENT_NODE
- if (($m->nodeType != 1) ||
- ($n->nodeType != 1)) {
- return 0;
- }
-
- if ($reverse) {
- my $t = $m; $m = $n; $n = $t;
- }
-
- my $root = $self->_diff($m, $n);
- my $ch = $root->firstChild;
- if (!$ch) {
- die "internal error: empty " . $root->nodeName;
- }
-
- my $moved = $last->lastChild;
- # 14Sep2002: it is incorrect to check the equality of first & last
- # child using isSameNode - isSameNode checks structural (deep)
- # equivalence, *not* identity
- if (!$moved->previousSibling) {
- # the same node might be immediately created again, but that's
- # just inefficient, whereas leaving an empty insert/delete
- # node in the destination tree is downright incorrect
- $self->{dest_point}->removeChild($last);
- } else {
- $last->removeChild($moved);
- }
-
- if ($self->_combine_first_child($ch,
- $self->get_scoped_name('delete')) ||
- $self->_combine_first_child($ch,
- $self->get_scoped_name('insert'))) {
- $ch = $ch->nextSibling;
- }
-
- while ($ch) {
- $self->{dest_point}->appendChild($self->{dest}->importNode($ch));
- $ch = $ch->nextSibling;
- }
-
- return 1;
-}
-
-sub _on_insert {
- my ($self, $n) = @_;
-
- # warn "_on_insert(" . $self . ", " . $n->nodeName . ")\n";
-
- my $last = $self->{dest_point}->lastChild;
- if (!$last) {
- $self->_append_insert($n);
- } elsif ($last->nodeName eq $self->get_scoped_name('insert')) {
- $last->appendChild($self->{dest}->importNode($n));
- } elsif ($last->nodeName ne $self->get_scoped_name('delete')) {
- $self->_append_insert($n);
- } else {
- if (!$self->_combine_pair($n, 0)) {
- $self->_append_insert($n);
- }
- }
-
- # warn "_on_insert finished\n";
-}
-
-sub _on_delete {
- my ($self, $n) = @_;
-
- # warn "_on_delete(" . $self . ", " . $n->nodeName . ")\n";
-
- my $last = $self->{dest_point}->lastChild;
- if (!$last) {
- $self->_append_delete($n);
- } elsif ($last->nodeName eq $self->get_scoped_name('delete')) {
- # the last node under <delete/> isn't going to be descended
- # into (because it's going to be followed by another deleted
- # node); we can leave only the top node from it & remove the
- # subnodes
- $self->_prune($last);
- $last->appendChild($self->{dest}->importNode($n));
- } elsif ($last->nodeName ne $self->get_scoped_name('insert')) {
- $self->_append_delete($n);
- } else {
- if (!$self->_combine_pair($n, 1)) {
- $self->_append_delete($n);
- }
- }
-}
-
-# remove grandchildren of a node
-sub _prune {
- my ($self, $n) = @_;
-
- # warn "_prune\n";
-
- my $ch = $n->firstChild;
- while ($ch) {
- $self->remove_children($ch);
- $ch = $ch->nextSibling;
- }
-}
-
-sub _on_match {
- my $self = shift;
-
- # warn "_on_match\n";
-
- my $last = $self->{dest_point}->lastChild;
- if (!$last) {
- $self->_append_copy;
- } elsif ($last->nodeName ne $self->get_scoped_name('copy')) {
- if ($last->nodeName eq $self->get_scoped_name('delete')) {
- $self->_prune($last);
- }
- $self->_append_copy;
- } else {
- my $count = 1 + $last->getAttribute('count');
- $last->setAttribute('count', $count);
- }
-}
-
-package XML::DifferenceMarkup::Target;
-
-use strict;
-use warnings;
-
-sub new {
- my ($class, $nsurl) = @_;
-
- my $self = { nsurl => $nsurl };
- # also using nsprefix & dest, but those are initialized later
-
- return bless $self, $class;
-}
-
-# copy a node to the destination tree, removing its children in the
-# process
-sub import_tip {
- my ($self, $n) = @_;
-
- my $tip = $self->get_tip($n);
- return $self->{dest}->importNode($tip);
-}
-
-# get (a copy of) a node without its chidren (note that the result is
-# different than cloneNode(0) - the attributes are kept)
-sub get_tip {
- my ($self, $n) = @_;
-
- my $tip = $n->cloneNode(1);
- $self->remove_children($tip);
- return $tip;
-}
-
-sub remove_children {
- my ($dummy, $n) = @_;
-
- # warn "remove_children\n";
-
- my $ch = $n->firstChild;
- while ($ch) {
- my $next = $ch->nextSibling;
- $n->removeChild($ch);
- $ch = $next;
- }
-}
-
-sub get_scoped_name {
- my ($self, $tail) = @_;
-
- return $self->{nsprefix} . ":$tail";
-}
-
-package XML::DifferenceMarkup::NamespaceCollector;
-
-sub new {
- my ($class, $stem, $nsurl) = @_;
-
- # keys of the namespaces hashref have the form prefix\nurl
- my $self = { stem => $stem, nsurl => $nsurl, namespaces => { } };
-
- return bless $self, $class;
-}
-
-sub get_unused_number {
- my ($self, $m, $n) = @_;
-
- $self->_fill($m);
- $self->_fill($n);
-
- my $stem = $self->{stem};
- my $use_max = 0;
- my $max = 1;
- foreach my $pair (keys %{$self->{namespaces}}) {
- unless ($pair =~ /^(.+)\n(.+)$/) {
- die "internal error: invalid pair $pair";
- }
-
- my ($prefix, $url) = ($1, $2);
-
- if ($url eq $self->{nsurl}) {
- die "XML::DifferenceMarkup diff: input tree contains the reserved namespace " . $self->{nsurl} . "\n";
- }
-
- if ($prefix eq $stem) {
- $use_max = 1;
- } elsif ($prefix =~ /^$stem([0-9]+)$/) {
- if ($1 > $max) {
- $max = $1;
- }
- }
- }
-
- return $use_max ? ($max + 1) : -1;
-}
-
-sub _fill {
- my ($self, $n) = @_;
-
- foreach ($n->getNamespaces) {
- unless (defined $_->getData) {
- # 11Sep2002: LibXML apparently drops the prefix somewhere
- # during cloning - this case really is't worth
- # supporting...
- die "XML::DifferenceMarkup diff: invalid XML: no namespace declaration for prefix " .
- $_->name . "\n";
- }
-
- if (defined $_->name) {
- my $pair = $_->name . "\n" . $_->getData;
- $self->{namespaces}->{$pair} = 1;
- } else {
- if ($_->getData eq $self->{nsurl}) {
- die "XML::DifferenceMarkup diff: input tree contains the reserved namespace " . $self->{nsurl} . "\n";
- }
- }
-
- }
-
- my $ch = $n->firstChild;
- while ($ch) {
- $self->_fill($ch);
- $ch = $ch->nextSibling;
- }
-}
-
-1;
@@ -0,0 +1,92 @@
+extern "C" {
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "ppport.h"
+}
+
+//required because of namespace collision between perl's <embed.h>
+//a private macro in gcc's <iostream>
+#ifdef do_open
+ #undef do_open
+#endif
+#ifdef do_close
+ #undef do_close
+#endif
+
+#include "diff.hh"
+#include "merge.hh"
+#include "nspace.hh"
+#include "perl-libxml-mm.h"
+#include <string>
+
+MODULE = XML::DifferenceMarkup PACKAGE = XML::DifferenceMarkup
+
+PROTOTYPES: ENABLE
+
+SV *
+_make_diff(de1, de2)
+ SV *de1;
+ SV *de2;
+ CODE:
+ {
+
+ if (!de1 || !de2)
+ {
+ croak("XML::DifferenceMarkup diff: _make_diff called without arguments");
+ }
+
+ xmlDocPtr rv = 0;
+ try
+ {
+ xmlNodePtr m = PmmSvNode(de1);
+ xmlNodePtr n = PmmSvNode(de2);
+
+ Diff dm(diffmark::get_unique_prefix(m, n),
+ diffmark::nsurl);
+ rv = dm.diff_nodes(m, n);
+ }
+ catch (std::string &x)
+ {
+ std::string msg("XML::DifferenceMarkup diff: ");
+ msg += x;
+ croak("%s", msg.c_str());
+ }
+
+ RETVAL = PmmNodeToSv(reinterpret_cast<xmlNodePtr>(rv), 0);
+ }
+ OUTPUT:
+ RETVAL
+
+
+SV *
+_merge_diff(src_doc, diff_elem)
+ SV *src_doc;
+ SV *diff_elem;
+ CODE:
+ {
+
+ if (!src_doc || !diff_elem)
+ {
+ croak("XML::DifferenceMarkup merge: _merge_diff called without arguments");
+ }
+
+ xmlDocPtr rv = 0;
+ try
+ {
+ xmlDocPtr src = reinterpret_cast<xmlDocPtr>(
+ PmmSvNode(src_doc));
+ Merge builder(diffmark::nsurl, src);
+ rv = builder.merge(PmmSvNode(diff_elem));
+ }
+ catch (std::string &x)
+ {
+ std::string msg("XML::DifferenceMarkup merge: ");
+ msg += x;
+ croak("%s", msg.c_str());
+ }
+
+ RETVAL = PmmNodeToSv(reinterpret_cast<xmlNodePtr>(rv), 0);
+ }
+ OUTPUT:
+ RETVAL
@@ -1,11 +1,172 @@
Changes
-DifferenceMarkup.pm
-MANIFEST This list of files
+DifferenceMarkup.xs
Makefile.PL
+MANIFEST
+perl-libxml-mm.c
+perl-libxml-mm.h
+perl-libxml-sax.c
+perl-libxml-sax.h
+ppport.h
README
+lib/XML/DifferenceMarkup.pm
t/00load.t
t/01diff.t
t/02merge.t
t/03roundup.t
t/04faildiff.t
-t/05failmerge.t
+testdata/diff/00a.xml
+testdata/diff/00b.xml
+testdata/diff/00d.xml
+testdata/diff/01a.xml
+testdata/diff/01b.xml
+testdata/diff/01d.xml
+testdata/diff/02a.xml
+testdata/diff/02b.xml
+testdata/diff/02d.xml
+testdata/diff/03a.xml
+testdata/diff/03b.xml
+testdata/diff/03d.xml
+testdata/diff/04a.xml
+testdata/diff/04b.xml
+testdata/diff/04d.xml
+testdata/diff/05a.xml
+testdata/diff/05b.xml
+testdata/diff/05d.xml
+testdata/diff/06a.xml
+testdata/diff/06b.xml
+testdata/diff/06d.xml
+testdata/diff/07a.xml
+testdata/diff/07b.xml
+testdata/diff/07d.xml
+testdata/diff/08a.xml
+testdata/diff/08b.xml
+testdata/diff/08d.xml
+testdata/diff/09a.xml
+testdata/diff/09b.xml
+testdata/diff/09d.xml
+testdata/diff/10a.xml
+testdata/diff/10b.xml
+testdata/diff/10d.xml
+testdata/diff/11a.xml
+testdata/diff/11b.xml
+testdata/diff/11d.xml
+testdata/diff/12a.xml
+testdata/diff/12b.xml
+testdata/diff/12d.xml
+testdata/diff/13a.xml
+testdata/diff/13b.xml
+testdata/diff/13d.xml
+testdata/diff/14a.xml
+testdata/diff/14b.xml
+testdata/diff/14d.xml
+testdata/faildiff/00a.xml
+testdata/faildiff/00b.xml
+testdata/faildiff/01a.xml
+testdata/faildiff/01b.xml
+testdata/failmerge/00a.xml
+testdata/failmerge/00d.xml
+testdata/failmerge/01a.xml
+testdata/failmerge/01d.xml
+testdata/failmerge/02a.xml
+testdata/failmerge/02d.xml
+testdata/failmerge/03a.xml
+testdata/failmerge/03d.xml
+testdata/failmerge/04a.xml
+testdata/failmerge/04d.xml
+testdata/failmerge/05a.xml
+testdata/failmerge/05d.xml
+testdata/failmerge/06a.xml
+testdata/failmerge/06d.xml
+testdata/failmerge/07a.xml
+testdata/failmerge/07d.xml
+testdata/failmerge/08a.xml
+testdata/failmerge/08d.xml
+testdata/merge/00a.xml
+testdata/merge/00b.xml
+testdata/merge/00d.xml
+testdata/merge/01a.xml
+testdata/merge/01b.xml
+testdata/merge/01d.xml
+testdata/merge/02a.xml
+testdata/merge/02b.xml
+testdata/merge/02d.xml
+testdata/merge/03a.xml
+testdata/merge/03b.xml
+testdata/merge/03d.xml
+testdata/merge/04a.xml
+testdata/merge/04b.xml
+testdata/merge/04d.xml
+testdata/roundup/00a.xml
+testdata/roundup/00b.xml
+testdata/roundup/00d.xml
+testdata/roundup/01a.xml
+testdata/roundup/01b.xml
+testdata/roundup/01d.xml
+testdata/roundup/02a.xml
+testdata/roundup/02b.xml
+testdata/roundup/02d.xml
+testdata/roundup/03a.xml
+testdata/roundup/03b.xml
+testdata/roundup/03d.xml
+testdata/roundup/04a.xml
+testdata/roundup/04b.xml
+testdata/roundup/04d.xml
+testdata/roundup/05a.xml
+testdata/roundup/05b.xml
+testdata/roundup/05d.xml
+testdata/roundup/06a.xml
+testdata/roundup/06b.xml
+testdata/roundup/06d.xml
+testdata/roundup/07a.xml
+testdata/roundup/07b.xml
+testdata/roundup/07d.xml
+testdata/roundup/08a.xml
+testdata/roundup/08b.xml
+testdata/roundup/08d.xml
+testdata/roundup/09a.xml
+testdata/roundup/09b.xml
+testdata/roundup/09d.xml
+testdata/roundup/10a.xml
+testdata/roundup/10b.xml
+testdata/roundup/10d.xml
+testdata/roundup/11a.xml
+testdata/roundup/11b.xml
+testdata/roundup/11d.xml
+testdata/roundup/12a.xml
+testdata/roundup/12b.xml
+testdata/roundup/12d.xml
+testdata/roundup/13a.xml
+testdata/roundup/13b.xml
+testdata/roundup/13d.xml
+testdata/roundup/14a.xml
+testdata/roundup/14b.xml
+testdata/roundup/14d.xml
+testdata/roundup/15a.xml
+testdata/roundup/15b.xml
+testdata/roundup/15d.xml
+testdata/roundup/16a.xml
+testdata/roundup/16b.xml
+testdata/roundup/16d.xml
+testdata/roundup/17a.xml
+testdata/roundup/17b.xml
+testdata/roundup/17d.xml
+testdata/roundup/18a.xml
+testdata/roundup/18b.xml
+testdata/roundup/18d.xml
+testdata/roundup/19a.xml
+testdata/roundup/19b.xml
+testdata/roundup/19d.xml
+testdata/roundup/20a.xml
+testdata/roundup/20b.xml
+testdata/roundup/20d.xml
+testdata/roundup/21a.xml
+testdata/roundup/21b.xml
+testdata/roundup/21d.xml
+testdata/roundup/22a.xml
+testdata/roundup/22b.xml
+testdata/roundup/22d.xml
+testdata/roundup/23a.xml
+testdata/roundup/23b.xml
+testdata/roundup/23d.xml
+META.yml Module meta-data (added by MakeMaker)
+META.json Module JSON meta-data (added by MakeMaker)
@@ -0,0 +1,41 @@
+{
+ "abstract" : "XML diff and merge",
+ "author" : [
+ "Vaclav Barta <vbar@comp.cz>"
+ ],
+ "dynamic_config" : 1,
+ "generated_by" : "ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921",
+ "license" : [
+ "unknown"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "XML-DifferenceMarkup",
+ "no_index" : {
+ "directory" : [
+ "t",
+ "inc"
+ ]
+ },
+ "prereqs" : {
+ "build" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "0"
+ }
+ },
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "0"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "XML::LibXML" : "1.70"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "version" : "1.05"
+}
@@ -0,0 +1,22 @@
+---
+abstract: 'XML diff and merge'
+author:
+ - 'Vaclav Barta <vbar@comp.cz>'
+build_requires:
+ ExtUtils::MakeMaker: 0
+configure_requires:
+ ExtUtils::MakeMaker: 0
+dynamic_config: 1
+generated_by: 'ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921'
+license: unknown
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: XML-DifferenceMarkup
+no_index:
+ directory:
+ - t
+ - inc
+requires:
+ XML::LibXML: 1.70
+version: 1.05
@@ -1,13 +1,381 @@
+# mostly copied from Makefile.PL of XML::LibXML::Common
+
+use 5.008008;
use ExtUtils::MakeMaker;
-# See lib/ExtUtils/MakeMaker.pm for details of how to influence
-# the contents of the Makefile that is written.
+use Config;
+use Symbol;
+use File::Spec;
+
+$|=0;
+
+$CC = 'g++';
+
+my %cplusplus_opt = (
+ CC => $CC,
+ # default includes -Wdeclaration-after-statement, which
+ # isn't valid for C++
+ CCFLAGS => '-fno-strict-aliasing -pipe -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
+ LD => '$(CC)',
+ XSOPT => '-C++'
+);
+
+my %config;
+
+while($_ = shift) {
+ my ($key, $val) = split(/=/, $_, 2);
+ $config{$key} = $val;
+}
+
+my $DEBUG = delete $config{DEBUG};
+
+if ( $] >= 5.006 ) {
+ warn "enable native perl UTF8\n";
+ $config{DEFINE} .= " -DHAVE_UTF8";
+}
+
+# get libs and inc from xml2-config
+
+unless ( $is_Win32 ) {
+ eval {
+ my $xml2cfg = "xml2-config";
+ if ( defined $ENV{XMLPREFIX} ) {
+ $xml2cfg = $ENV{XMLPREFIX} . '/bin/' . $xml2cfg;
+ }
+
+ print "running xml2-config... ";
+ my $ver = backtick("$xml2cfg --version");
+ $config{LIBS} ||= backtick("$xml2cfg --libs");
+ $config{INC} ||= backtick("$xml2cfg --cflags");
+ print "ok\n";
+ };
+ if ($@) {
+ print "failed\n";
+ warn "*** ", $@ if $DEBUG;
+ warn "using fallback values for LIBS and INC\n";
+ $config{LIBS} = '-L/usr/local/lib -L/usr/lib -lxml2 -lz -lm';
+ $config{INC} = '-I/usr/local/include -I/usr/include';
+
+ print <<OPT;
+options:
+ LIBS='$config{LIBS}'
+ INC='$config{INC}'
+If this is wrong, Re-run as:
+ \$ $^X Makefile.PL LIBS='-L/path/to/lib' INC='-I/path/to/include'
+
+OPT
+ }
+}
+
+# libdiffmark, not expected to work on Windows
+
+$config{LIBS} = '-L/usr/local/lib ' . $config{LIBS};
+
+if ($config{LIBS} !~ /\-ldiffmark\b/) {
+ $config{LIBS} .= ' -ldiffmark';
+}
+
+if ($config{INC} !~ /\bdiffmark\b/) {
+ foreach (qw(/usr/include /usr/local/include)) {
+ if (-f "$_/diffmark/diff.hh") {
+ $config{INC} .= " -I$_/diffmark";
+ $have_diffmark_headers = 1;
+ last;
+ }
+ }
+
+ unless($have_diffmark_headers) {
+ error_exit(<<DEATH);
+diffmark headers not found
+Try setting LIBS and INC values on the command line,
+or get diffmark from
+ http://www.mangrove.cz/diffmark/
+DEATH
+ }
+}
+
+$config{INC} .= ' -I.';
+
+if ($config{LIBS} !~ /\-lxml2\b/) {
+ $config{LIBS} .= $is_Win32 ? ' -llibxml2' : ' -lxml2';
+}
+
+if ($config{LIBS} !~ /\-lz\b/) {
+ $config{LIBS} .= $is_Win32 ? ' -lzlib' :' -lz';
+}
+
+if ($config{LIBS} !~ /\-lm\b/) {
+ $config{LIBS} .= $is_Win32 ? '' :' -lm';
+}
+
+if ( $config{DEBUG} ) {
+ warn "win32 compile\n" if $is_Win32;
+}
+
+unless (have_library("xml2", "xmlCleanupParser") or
+ have_library("libxml2", "xmlCleanupParser")) {
+ error_exit(<<DEATH);
+libxml2 not found
+Try setting LIBS and INC values on the command line,
+or do whatever it took to install XML::LibXML
+DEATH
+}
+
+unless (have_library("diffmark", "xutil::remove_children")) {
+ error_exit(<<DEATH);
+libdiffmark not found
+Try setting LIBS and INC values on the command line,
+or get diffmark from
+ http://www.mangrove.cz/diffmark/
+DEATH
+}
+
WriteMakefile(
- 'NAME' => 'XML::DifferenceMarkup',
- 'VERSION_FROM' => 'DifferenceMarkup.pm', # finds $VERSION
- 'PREREQ_PM' => {
- 'XML::LibXML' => '1.58',
- 'Algorithm::Diff' => '1.15',
- },
- ($] >= 5.005 ? ## keyword supported since 5.005
- ( AUTHOR => 'Vaclav Barta <vbar@comp.cz>') : ()),
+ NAME => 'XML::DifferenceMarkup',
+ VERSION_FROM => 'lib/XML/DifferenceMarkup.pm', # finds $VERSION
+ PREREQ_PM => {
+ 'XML::LibXML' => '1.70',
+ },
+ ABSTRACT_FROM => 'lib/XML/DifferenceMarkup.pm', # retrieve abstract from module
+ AUTHOR => 'Vaclav Barta <vbar@comp.cz>',
+ OBJECT => 'DifferenceMarkup.o perl-libxml-mm.o perl-libxml-sax.o',
+ depend => {
+ 'perl-libxml-mm.o' => 'perl-libxml-mm.c perl-libxml-mm.h',
+ 'perl-libxml-sax.o' => 'perl-libxml-sax.c perl-libxml-sax.h',
+ },
+ %cplusplus_opt,
+ %config
);
+
+use Config;
+use Cwd;
+use Symbol;
+use File::Spec;
+
+use vars qw/$DEVNULL $is_Win32/;
+
+BEGIN {
+ $is_Win32 = ($^O =~ /Win32/);
+ if ($is_Win32) {
+ $DEVNULL = 'DEVNULL';
+ }
+ else {
+ $DEVNULL = eval { File::Spec->devnull };
+ if ($@) { $DEVNULL = '/dev/null' }
+ }
+}
+
+# In case of missing dependencies,
+# http://cpantest.grango.org/wiki/CPANAuthorNotes recommends to "just
+# exit from the Makefile.PL or Build.PL normally (with an exit code of
+# 0)".
+sub error_exit {
+ my $msg = shift;
+ print $msg;
+ exit 0;
+}
+
+sub rm_f {
+ my @files = @_;
+ my @realfiles;
+ foreach (@files) {
+ push @realfiles, glob($_);
+ }
+ if (@realfiles) {
+ chmod(0777, @realfiles);
+ unlink(@realfiles);
+ }
+}
+
+sub rm_fr {
+ my @files = @_;
+ my @realfiles;
+ foreach (@files) {
+ push @realfiles, glob($_);
+ }
+ foreach my $file (@realfiles) {
+ if (-d $file) {
+ # warn("$file is a directory\n");
+ rm_fr("$file/*");
+ rm_fr("$file/.exists");
+ rmdir($file) || die "Couldn't remove $file: $!";
+ }
+ else {
+ # warn("removing $file\n");
+ chmod(0777, $file);
+ unlink($file);
+ }
+ }
+}
+
+sub xsystem {
+ my $command = shift;
+ if ($DEBUG) {
+ print $command, "\n";
+ if (system($command) != 0) {
+ die "system call to '$command' failed";
+ }
+ return 1;
+ }
+ open(OLDOUT, ">&STDOUT");
+ open(OLDERR, ">&STDERR");
+ open(STDOUT, ">$DEVNULL");
+ open(STDERR, ">$DEVNULL");
+ my $retval = system($command);
+ open(STDOUT, ">&OLDOUT");
+ open(STDERR, ">&OLDERR");
+ if ($retval != 0) {
+ die "system call to '$command' failed";
+ }
+ return 1;
+}
+
+sub backtick {
+ my $command = shift;
+ if ($DEBUG) {
+ print $command, "\n";
+ my $results = `$command`;
+ chomp $results;
+ if ($? != 0) {
+ die "backticks call to '$command' failed";
+ }
+ return $results;
+ }
+ open(OLDOUT, ">&STDOUT");
+ open(OLDERR, ">&STDERR");
+ open(STDOUT, ">$DEVNULL");
+ open(STDERR, ">$DEVNULL");
+ my $results = `$command`;
+ my $retval = $?;
+ open(STDOUT, ">&OLDOUT");
+ open(STDERR, ">&OLDERR");
+ if ($retval != 0) {
+ die "backticks call to '$command' failed";
+ }
+ chomp $results;
+ return $results;
+}
+
+sub try_link0 {
+ my ($src, %opt) = @_;
+ my $cfile = gensym();
+ unless (mkdir(".testlink", 0777)) {
+ rm_fr(".testlink");
+ mkdir(".testlink", 0777) || die "Cannot create .testlink dir: $!";
+ }
+ chdir(".testlink");
+ open($cfile, ">Conftest.xs") || die "Cannot write to file Conftest.xs: $!";
+print $cfile <<EOT;
+#ifdef __cplusplus
+extern "C" {
+#endif
+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+#ifdef __cplusplus
+}
+#endif
+
+EOT
+ print $cfile $src;
+ print $cfile <<EOT;
+
+MODULE = Conftest PACKAGE = Conftest
+
+PROTOTYPES: DISABLE
+
+EOT
+ close($cfile);
+ open($cfile, ">Conftest.pm") || die "Cannot write to file Conftest.pm: $!";
+ print $cfile <<'EOT';
+package Conftest;
+$VERSION = 1.0;
+require DynaLoader;
+@ISA = ('DynaLoader');
+bootstrap Conftest $VERSION;
+1;
+EOT
+ close($cfile);
+ open($cfile, ">Makefile.PL") || die "Cannot write to file Makefile.PL: $!";
+ print $cfile <<'EOT';
+use ExtUtils::MakeMaker;
+my %config;
+while($_ = shift @ARGV) {
+ my ($k, $v) = split /=/, $_, 2;
+ warn("$k = $v\n");
+ $config{$k} = $v;
+}
+WriteMakefile(NAME => "Conftest", VERSION_FROM => "Conftest.pm",
+EOT
+ foreach (keys %opt) {
+ print $cfile $_ . ' => \'' . $opt{$_} . "',\n",
+ }
+
+ print $cfile '%config);', "\n";
+ close($cfile);
+ open($cfile, ">test.pl") || die "Cannot write to file test.pl: $!";
+ print $cfile <<EOT;
+use Test; BEGIN { plan tests => 1; } END { ok(\$loaded) }
+use Conftest; \$loaded++;
+EOT
+ close($cfile);
+ my $quote = $is_Win32 ? '"' : "'";
+ xsystem("$^X Makefile.PL " . join(' ', map { "${quote}$_=$config{$_}${quote}" } keys %config));
+ xsystem("$Config{make} test ${quote}OTHERLDFLAGS=${quote}");
+} # end try_link0
+
+sub try_link {
+ my $start_dir = cwd();
+ my $result = eval {
+ try_link0(@_);
+ };
+ warn $@ if $DEBUG && $@;
+ chdir($start_dir);
+ rm_fr(".testlink");
+ return $result;
+}
+
+sub have_library {
+ my ($lib, $func) = (@_, "blank");
+ printf("checking for %s() in -l%s... ", $func, $lib) if $func ne "blank";
+ printf("looking for -l%s... ", $lib) if $func eq "blank";
+
+ my $result;
+ if ($lib ne 'diffmark') {
+ my $libs = $is_Win32 ? " $lib.lib " : "-l$lib";
+ if ($is_Win32) {
+ $result = try_link(<<"SRC");
+#include <windows.h>
+#include <winsock.h>
+blank() { return 0; }
+int t() { ${func}(); return 0; }
+SRC
+ unless ($result) {
+ $result = try_link(<<"SRC");
+#include <windows.h>
+#include <winsock.h>
+blank() { return 0; }
+int t() { void ((*p)()); p = (void ((*)()))${func}; return 0; }
+SRC
+ }
+ }
+ else {
+ $result = try_link(<<"SRC");
+blank() { return 0; }
+int t() { ${func}(); return 0; }
+SRC
+ }
+ } else {
+ $result = try_link(<<"SRC", %cplusplus_opt);
+#include "xutil.hh"
+int t() { xutil::remove_children(0); return 0; }
+SRC
+ }
+
+ unless ($result) {
+ print "no\n";
+ return 0;
+ }
+
+ print "yes\n";
+ return 1;
+}
@@ -1,5 +1,5 @@
-XML/DifferenceMarkup version 0.01
-=================================
+XML-DifferenceMarkup version 1.x
+================================
This module implements an XML diff producing XML output. Both input
and output are DOM documents, as implemented by XML::LibXML. The
@@ -19,14 +19,18 @@ To install this module type the following:
DEPENDENCIES
-This module requires these other modules and libraries:
-
- XML::LibXML
- Algorithm::Diff
+This module requires XML::LibXML and its dependencies (see the
+documentation of XML::LibXML for the full list) and also the
+libdiffmark library, available as part of the diffmark package from
+http://www.mangrove.cz/diffmark/ . Consequently, it's an XS module,
+whose compilation requires a C++ compiler. It's tested only with gcc
+on Linux; it might work on other unix-like platforms, but probably not
+on Windows.
COPYRIGHT AND LICENCE
-Copyright (C) 2004 Vaclav Barta. All rights reserved. This program is
-free software; you can redistribute it and/or modify it under the same
-terms as Perl itself.
+Copyright (C) 2006-2014 by Vaclav Barta
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.7 or,
+at your option, any later version of Perl 5 you may have available.
@@ -0,0 +1,185 @@
+package XML::DifferenceMarkup;
+
+use 5.008008;
+use strict;
+use warnings;
+
+require Exporter;
+
+our @ISA = qw(Exporter);
+
+# This allows declaration use XML::DifferenceMarkup ':all';
+# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
+# will save memory.
+our %EXPORT_TAGS = ( 'all' => [ qw(
+ make_diff
+ merge_diff
+) ] );
+
+our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+our $VERSION = '1.05';
+
+require XSLoader;
+XSLoader::load('XML::DifferenceMarkup', $VERSION);
+
+sub make_diff {
+ my ($d1, $d2) = @_;
+
+ my $m = $d1->documentElement;
+ my $n = $d2->documentElement;
+ return XML::DifferenceMarkup::_make_diff($m, $n);
+}
+
+sub merge_diff {
+ my ($src_doc, $diff_doc) = @_;
+
+ my $n = $diff_doc->documentElement;
+ return XML::DifferenceMarkup::_merge_diff($src_doc, $n);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+XML::DifferenceMarkup - XML diff and merge
+
+=head1 SYNOPSIS
+
+ use XML::DifferenceMarkup qw(make_diff);
+ use XML::LibXML;
+
+ $parser = XML::LibXML->new(keep_blanks => 0, load_ext_dtd => 0);
+ $d1 = $parser->parse_file($fname1);
+ $d2 = $parser->parse_file($fname2);
+
+ $dom = make_diff($d1, $d2);
+ print $dom->toString(1);
+
+=head1 DESCRIPTION
+
+This module implements an XML diff producing XML output. Both input
+and output are DOM documents, as implemented by XML::LibXML.
+
+The diff format used by XML::DifferenceMarkup is meant to be
+human-readable (i.e. simple, as opposed to short) - basically the diff
+is a subset of the input trees, annotated with instruction element
+nodes specifying how to convert the source tree to the target by
+inserting and deleting nodes. To prevent name colisions with input
+trees, all added elements are in a namespace
+C<http://www.locus.cz/diffmark> (the diff will fail on
+input trees which already use that namespace).
+
+The top-level node of the diff is always <diff/> (or rather <dm:diff
+xmlns:dm="http://www.locus.cz/diffmark"> ... </dm:diff> -
+this description omits the namespace specification from now on);
+under it are fragments of the input trees and instruction nodes:
+<insert/>, <delete/> and <copy/>. <copy/> is used in places where the
+input subtrees are the same - in the limit, the diff of 2 identical
+documents is
+
+ <?xml version="1.0"?>
+ <dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:copy count="1"/>
+ </dm:diff>
+
+(copy always has the count attribute and no other content). <insert/>
+and <delete/> have the obvious meaning - in the limit a diff of 2
+documents which have nothing in common is something like
+
+ <?xml version="1.0"?>
+ <dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:delete>
+ <old/>
+ </dm:delete>
+ <dm:insert>
+ <new>
+ <tree>with the whole subtree, of course</tree>
+ </new>
+ </dm:insert>
+ </dm:diff>
+
+A combination of <insert/>, <delete/> and <copy/> can capture any
+difference, but it's sub-optimal for the case where (for example) the
+top-level elements in the two input documents differ while their
+subtrees are exactly the same. This case is handled by putting the
+element from the second document into the diff, adding to it a special
+attribute dm:update (whose value is the element name from the first
+document) marking the element change:
+
+ <?xml version="1.0"?>
+ <dm:diff xmlns:dm="http://www.locus.cz/XML/diffmark">
+ <top-of-second dm:update="top-of-first">
+ <dm:copy count="42"/>
+ </top-of-second>
+ </dm:diff>
+
+<delete/> contains just one level of nested nodes - their subtrees are
+not included in the diff (but the element nodes which are included
+always come with all their attributes). <insert/> and <delete/> don't
+have any attributes and always contain some subtree.
+
+Instruction nodes are never nested; all nodes above an instruction
+node (except the top-level <diff/>) come from the input trees. A node
+from the second input tree might be included in the output diff to
+provide context for instruction nodes when it's an element node whose
+subtree is not the same in the two input documents. When such an
+element has the same name, attributes (names and values) and namespace
+declarations in both input documents, it's always included in the diff
+(its different output trees guarantee that it will have some chindren
+there). If the corresponding elements are different, the one from the
+second document might still be included, with an added dm:update
+attribute, provided that both corresponding elements have non-empty
+subtrees, and these subtrees are so similar that deleting the first
+corresponding element and inserting the second would lead to a larger
+diff. And if this paragraph seems too complicated, don't despair -
+just ignore it and look at some examples.
+
+=head1 FUNCTIONS
+
+Note that XML::DifferenceMarkup functions must be explicitly imported
+(i.e. with C<use XML::DifferenceMarkup qw(make_diff merge_diff);>)
+before they can be called.
+
+=head2 make_diff
+
+C<make_diff> takes 2 parameters (the input documents) and produces
+their diff. Note that the diff is asymmetric - C<make_diff($a, $b)> is
+different from C<make_diff($b, $a)>.
+
+=head2 merge_diff
+
+C<merge_diff> takes the first document passed to C<make_diff> and its
+return value and produces the second document. (More-or-less - the
+document isn't canonicalized, so opinions on its "equality" may
+differ.)
+
+=head2 Error Handling
+
+Both C<make_diff> and C<merge_diff> throw exceptions on invalid input
+- their own exceptions as well as exceptions thrown by
+XML::LibXML. These exceptions can usually (probably not always, though
+- it used to be possible to construct an input which would crash the
+calling process) be catched by calling the functions from an eval
+block.
+
+=head1 BUGS
+
+=over
+
+=item * information outside the document element is not processed
+
+=back
+
+=head1 AUTHOR
+
+Vaclav Barta <vbar@comp.cz>
+
+=head1 SEE ALSO
+
+L<XML::LibXML>
+
+=cut
+
@@ -0,0 +1,1306 @@
+/**
+ * perl-libxml-mm.c
+ * $Id$
+ *
+ * This is free software, you may use it and distribute it under the same terms as
+ * Perl itself.
+ *
+ * Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+*/
+
+/*
+ *
+ * Basic concept:
+ * perl varies in the implementation of UTF8 handling. this header (together
+ * with the c source) implements a few functions, that can be used from within
+ * the core module inorder to avoid cascades of c pragmas
+ */
+
+#include <stdarg.h>
+#include <stdlib.h>
+
+#include "perl-libxml-mm.h"
+
+#include "XSUB.h"
+#include "ppport.h"
+#include <libxml/tree.h>
+
+#ifdef XML_LIBXML_GDOME_SUPPORT
+
+#include <libgdome/gdome.h>
+#include <libgdome/gdome-libxml-util.h>
+
+#endif
+
+#include "perl-libxml-sax.h"
+
+/**
+ * this is a wrapper function that does the type evaluation for the
+ * node. this makes the code a little more readable in the .XS
+ *
+ * the code is not really portable, but i think we'll avoid some
+ * memory leak problems that way.
+ **/
+const char*
+PmmNodeTypeName( xmlNodePtr elem ){
+ const char *name = "XML::LibXML::Node";
+
+ if ( elem != NULL ) {
+ switch ( elem->type ) {
+ case XML_ELEMENT_NODE:
+ name = "XML::LibXML::Element";
+ break;
+ case XML_TEXT_NODE:
+ name = "XML::LibXML::Text";
+ break;
+ case XML_COMMENT_NODE:
+ name = "XML::LibXML::Comment";
+ break;
+ case XML_CDATA_SECTION_NODE:
+ name = "XML::LibXML::CDATASection";
+ break;
+ case XML_ATTRIBUTE_NODE:
+ name = "XML::LibXML::Attr";
+ break;
+ case XML_DOCUMENT_NODE:
+ case XML_HTML_DOCUMENT_NODE:
+ name = "XML::LibXML::Document";
+ break;
+ case XML_DOCUMENT_FRAG_NODE:
+ name = "XML::LibXML::DocumentFragment";
+ break;
+ case XML_NAMESPACE_DECL:
+ name = "XML::LibXML::Namespace";
+ break;
+ case XML_DTD_NODE:
+ name = "XML::LibXML::Dtd";
+ break;
+ case XML_PI_NODE:
+ name = "XML::LibXML::PI";
+ break;
+ default:
+ name = "XML::LibXML::Node";
+ break;
+ };
+ return name;
+ }
+ return "";
+}
+
+/*
+ * free a hash table
+ */
+void
+PmmFreeHashTable(xmlHashTablePtr table)
+{
+ if( xmlHashSize(table) > 0 ) {
+ warn("PmmFreeHashTable: not empty\n");
+ /* PmmDumpRegistry(table); */
+ }
+ /* warn("Freeing table %p with %d elements in\n", table, xmlHashSize(table)); */
+ xmlHashFree(table, NULL);
+}
+
+#ifdef XML_LIBXML_THREADS
+
+/*
+ * registry of all current proxy nodes
+ *
+ * other classes like XML::LibXSLT must get a pointer
+ * to this registry via XML::LibXML::__proxy_registry
+ *
+ */
+extern SV* PROXY_NODE_REGISTRY_MUTEX;
+
+/* Utility method used by PmmDumpRegistry */
+void PmmRegistryDumpHashScanner(void * payload, void * data, xmlChar * name)
+{
+ LocalProxyNodePtr lp = (LocalProxyNodePtr) payload;
+ ProxyNodePtr node = (ProxyNodePtr) lp->proxy;
+ const char * CLASS = PmmNodeTypeName( PmmNODE(node) );
+ warn("%s=%p with %d references (%d perl)\n",CLASS,node,PmmREFCNT(node),lp->count);
+}
+
+/*
+ * dump the current thread's node registry to STDERR
+ */
+void
+PmmDumpRegistry(xmlHashTablePtr r)
+{
+ if( r )
+ {
+ SvLOCK(PROXY_NODE_REGISTRY_MUTEX);
+ warn("%d total nodes\n", xmlHashSize(r));
+ xmlHashScan(r, PmmRegistryDumpHashScanner, NULL);
+ SvUNLOCK(PROXY_NODE_REGISTRY_MUTEX);
+ }
+}
+
+/*
+ * returns the address of the proxy registry
+ */
+xmlHashTablePtr*
+PmmProxyNodeRegistryPtr(ProxyNodePtr proxy)
+{
+ croak("PmmProxyNodeRegistryPtr: TODO!\n");
+ return NULL;
+ /* return &PmmREGISTRY; */
+}
+
+/*
+ * efficiently generate a string representation of the given pointer
+ */
+#define _PMM_HASH_NAME_SIZE(n) n+(n>>3)+(n%8>0 ? 1 : 0)
+xmlChar *
+PmmRegistryName(void * ptr)
+{
+ unsigned long int v = (unsigned long int) ptr;
+ int HASH_NAME_SIZE = _PMM_HASH_NAME_SIZE(sizeof(void*));
+ xmlChar * name;
+ int i;
+
+ name = (xmlChar *) safemalloc(HASH_NAME_SIZE+1);
+
+ for(i = 0; i < HASH_NAME_SIZE; ++i)
+ {
+ name[i] = (xmlChar) (128 | v);
+ v >>= 7;
+ }
+ name[HASH_NAME_SIZE] = '\0';
+
+ return name;
+}
+
+/*
+ * allocate and return a new LocalProxyNode structure
+ */
+LocalProxyNodePtr
+PmmNewLocalProxyNode(ProxyNodePtr proxy)
+{
+ LocalProxyNodePtr lp;
+ Newc(0, lp, 1, LocalProxyNode, LocalProxyNode);
+ lp->proxy = proxy;
+ lp->count = 0;
+ return lp;
+}
+
+/*
+ * @proxy: proxy node to register
+ *
+ * adds a proxy node to the proxy node registry
+ */
+LocalProxyNodePtr
+PmmRegisterProxyNode(ProxyNodePtr proxy)
+{
+ xmlChar * name = PmmRegistryName( proxy );
+ LocalProxyNodePtr lp = PmmNewLocalProxyNode( proxy );
+ /* warn("LibXML registers proxy node with %p\n",PmmREGISTRY); */
+ SvLOCK(PROXY_NODE_REGISTRY_MUTEX);
+ if( xmlHashAddEntry(PmmREGISTRY, name, lp) )
+ croak("PmmRegisterProxyNode: error adding node to hash, hash size is %d\n",xmlHashSize(PmmREGISTRY));
+ SvUNLOCK(PROXY_NODE_REGISTRY_MUTEX);
+ Safefree(name);
+ return lp;
+}
+
+/* utility method for PmmUnregisterProxyNode */
+/* PP: originally this was static inline void, but on AIX the compiler
+ did not chew it, so I'm removing the inline */
+static void
+PmmRegistryHashDeallocator(void *payload, xmlChar *name)
+{
+ Safefree((LocalProxyNodePtr) payload);
+}
+
+/*
+ * @proxy: proxy node to remove
+ *
+ * removes a proxy node from the proxy node registry
+ */
+void
+PmmUnregisterProxyNode(ProxyNodePtr proxy)
+{
+ xmlChar * name = PmmRegistryName( proxy );
+ /* warn("LibXML unregistering proxy node with %p\n",PmmREGISTRY); */
+ SvLOCK(PROXY_NODE_REGISTRY_MUTEX);
+ if( xmlHashRemoveEntry(PmmREGISTRY, name, PmmRegistryHashDeallocator) )
+ croak("PmmUnregisterProxyNode: error removing node from hash\n");
+ Safefree(name);
+ SvUNLOCK(PROXY_NODE_REGISTRY_MUTEX);
+}
+
+/*
+ * lookup a LocalProxyNode in the registry
+ */
+LocalProxyNodePtr
+PmmRegistryLookup(ProxyNodePtr proxy)
+{
+ xmlChar * name = PmmRegistryName( proxy );
+ LocalProxyNodePtr lp = xmlHashLookup(PmmREGISTRY, name);
+ Safefree(name);
+ return lp;
+}
+
+/*
+ * increment the local refcount for proxy
+ */
+void
+PmmRegistryREFCNT_inc(ProxyNodePtr proxy)
+{
+ /* warn("Registry inc\n"); */
+ LocalProxyNodePtr lp = PmmRegistryLookup( proxy );
+ if( lp )
+ lp->count++;
+ else
+ PmmRegisterProxyNode( proxy )->count++;
+}
+
+/*
+ * decrement the local refcount for proxy and remove the local pointer if zero
+ */
+void
+PmmRegistryREFCNT_dec(ProxyNodePtr proxy)
+{
+ /* warn("Registry dec\n"); */
+ LocalProxyNodePtr lp = PmmRegistryLookup(proxy);
+ if( lp && --(lp->count) == 0 )
+ PmmUnregisterProxyNode(proxy);
+}
+
+/*
+ * internal, used by PmmCloneProxyNodes
+ */
+void *
+PmmRegistryHashCopier(void *payload, xmlChar *name)
+{
+ ProxyNodePtr proxy = ((LocalProxyNodePtr) payload)->proxy;
+ LocalProxyNodePtr lp;
+ Newc(0, lp, 1, LocalProxyNode, LocalProxyNode);
+ memcpy(lp, payload, sizeof(LocalProxyNode));
+ PmmREFCNT_inc(proxy);
+ return lp;
+}
+
+/*
+ * increments all proxy node counters by one (called on thread spawn)
+ */
+void
+PmmCloneProxyNodes()
+{
+ SV *sv_reg = get_sv("XML::LibXML::__PROXY_NODE_REGISTRY",0);
+ xmlHashTablePtr reg_copy;
+ SvLOCK(PROXY_NODE_REGISTRY_MUTEX);
+ reg_copy = xmlHashCopy(PmmREGISTRY, PmmRegistryHashCopier);
+ SvIV_set(SvRV(sv_reg), PTR2IV(reg_copy));
+ SvUNLOCK(PROXY_NODE_REGISTRY_MUTEX);
+}
+
+/*
+ * returns the current number of proxy nodes in the registry
+ */
+int
+PmmProxyNodeRegistrySize()
+{
+ return xmlHashSize(PmmREGISTRY);
+}
+
+#endif /* end of XML_LIBXML_THREADS */
+
+/* creates a new proxy node from a given node. this function is aware
+ * about the fact that a node may already has a proxy structure.
+ */
+ProxyNodePtr
+PmmNewNode(xmlNodePtr node)
+{
+ ProxyNodePtr proxy = NULL;
+
+ if ( node == NULL ) {
+ xs_warn( "PmmNewNode: no node found\n" );
+ return NULL;
+ }
+
+ if ( node->_private == NULL ) {
+ switch ( node->type ) {
+ case XML_DOCUMENT_NODE:
+ case XML_HTML_DOCUMENT_NODE:
+ case XML_DOCB_DOCUMENT_NODE:
+ proxy = (ProxyNodePtr)xmlMalloc(sizeof(struct _DocProxyNode));
+ if (proxy != NULL) {
+ ((DocProxyNodePtr)proxy)->psvi_status = Pmm_NO_PSVI;
+ SetPmmENCODING(proxy, XML_CHAR_ENCODING_NONE);
+ }
+ break;
+ default:
+ proxy = (ProxyNodePtr)xmlMalloc(sizeof(struct _ProxyNode));
+ break;
+ }
+ if (proxy != NULL) {
+ proxy->node = node;
+ proxy->owner = NULL;
+ proxy->count = 0;
+ node->_private = (void*) proxy;
+ }
+ }
+ else {
+ proxy = (ProxyNodePtr)node->_private;
+ }
+
+ return proxy;
+}
+
+ProxyNodePtr
+PmmNewFragment(xmlDocPtr doc)
+{
+ ProxyNodePtr retval = NULL;
+ xmlNodePtr frag = NULL;
+
+ xs_warn("PmmNewFragment: new frag\n");
+ frag = xmlNewDocFragment( doc );
+ retval = PmmNewNode(frag);
+ /* fprintf(stderr, "REFCNT NOT incremented on frag: 0x%08.8X\n", retval); */
+
+ if ( doc != NULL ) {
+ xs_warn("PmmNewFragment: inc document\n");
+ /* under rare circumstances _private is not set correctly? */
+ if ( doc->_private != NULL ) {
+ xs_warn("PmmNewFragment: doc->_private being incremented!\n");
+ PmmREFCNT_inc(((ProxyNodePtr)doc->_private));
+ /* fprintf(stderr, "REFCNT incremented on doc: 0x%08.8X\n", doc->_private); */
+ }
+ retval->owner = (xmlNodePtr)doc;
+ }
+
+ return retval;
+}
+
+/* frees the node if necessary. this method is aware that libxml2
+ * has several different nodetypes.
+ */
+void
+PmmFreeNode( xmlNodePtr node )
+{
+ switch( node->type ) {
+ case XML_DOCUMENT_NODE:
+ case XML_HTML_DOCUMENT_NODE:
+ xs_warn("PmmFreeNode: XML_DOCUMENT_NODE\n");
+ xmlFreeDoc( (xmlDocPtr) node );
+ break;
+ case XML_ATTRIBUTE_NODE:
+ xs_warn("PmmFreeNode: XML_ATTRIBUTE_NODE\n");
+ if ( node->parent == NULL ) {
+ xs_warn( "PmmFreeNode: free node!\n");
+ node->ns = NULL;
+ xmlFreeProp( (xmlAttrPtr) node );
+ }
+ break;
+ case XML_DTD_NODE:
+ if ( node->doc != NULL ) {
+ if ( node->doc->extSubset != (xmlDtdPtr)node
+ && node->doc->intSubset != (xmlDtdPtr)node ) {
+ xs_warn( "PmmFreeNode: XML_DTD_NODE\n");
+ node->doc = NULL;
+ xmlFreeDtd( (xmlDtdPtr)node );
+ }
+ } else {
+ xs_warn( "PmmFreeNode: XML_DTD_NODE (no doc)\n");
+ xmlFreeDtd( (xmlDtdPtr)node );
+ }
+ break;
+ case XML_DOCUMENT_FRAG_NODE:
+ xs_warn("PmmFreeNode: XML_DOCUMENT_FRAG_NODE\n");
+ default:
+ xs_warn( "PmmFreeNode: normal node\n" );
+ xmlFreeNode( node);
+ break;
+ }
+}
+
+/* decrements the proxy counter. if the counter becomes zero or less,
+ this method will free the proxy node. If the node is part of a
+ subtree, PmmREFCNT_dec will fix the reference counts and delete
+ the subtree if it is not required any more.
+ */
+int
+PmmREFCNT_dec( ProxyNodePtr node )
+{
+ xmlNodePtr libnode = NULL;
+ ProxyNodePtr owner = NULL;
+ int retval = 0;
+
+ if ( node != NULL ) {
+ retval = PmmREFCNT(node)--;
+ /* fprintf(stderr, "REFCNT on 0x%08.8X decremented to %d\n", node, PmmREFCNT(node)); */
+ if ( PmmREFCNT(node) < 0 )
+ warn( "PmmREFCNT_dec: REFCNT decremented below 0 for %p!", node );
+ if ( PmmREFCNT(node) <= 0 ) {
+ xs_warn( "PmmREFCNT_dec: NODE DELETION\n" );
+
+ libnode = PmmNODE( node );
+ if ( libnode != NULL ) {
+ if ( libnode->_private != node ) {
+ xs_warn( "PmmREFCNT_dec: lost node\n" );
+ libnode = NULL;
+ }
+ else {
+ libnode->_private = NULL;
+ }
+ }
+
+ PmmNODE( node ) = NULL;
+ if ( PmmOWNER(node) && PmmOWNERPO(node) ) {
+ xs_warn( "PmmREFCNT_dec: DOC NODE!\n" );
+ owner = PmmOWNERPO(node);
+ PmmOWNER( node ) = NULL;
+ if( libnode != NULL && libnode->parent == NULL ) {
+ /* this is required if the node does not directly
+ * belong to the document tree
+ */
+ xs_warn( "PmmREFCNT_dec: REAL DELETE\n" );
+ PmmFreeNode( libnode );
+ }
+ xs_warn( "PmmREFCNT_dec: decrease owner\n" );
+ PmmREFCNT_dec( owner );
+ }
+ else if ( libnode != NULL ) {
+ xs_warn( "PmmREFCNT_dec: STANDALONE REAL DELETE\n" );
+
+ PmmFreeNode( libnode );
+ }
+ else {
+ xs_warn( "PmmREFCNT_dec: NO OWNER\n" );
+ }
+ xmlFree( node );
+ }
+ }
+ else {
+ xs_warn("PmmREFCNT_dec: lost node\n" );
+ }
+ return retval;
+}
+
+/* @node: the node that should be wrapped into a SV
+ * @owner: perl instance of the owner node (may be NULL)
+ *
+ * This function will create a real perl instance of a given node.
+ * the function is called directly by the XS layer, to generate a perl
+ * instance of the node. All node reference counts are updated within
+ * this function. Therefore this function returns a node that can
+ * directly be used as output.
+ *
+ * if @ower is NULL or undefined, the node is ment to be the root node
+ * of the tree. this node will later be used as an owner of other
+ * nodes.
+ */
+SV*
+PmmNodeToSv( xmlNodePtr node, ProxyNodePtr owner )
+{
+ ProxyNodePtr dfProxy= NULL;
+ SV * retval = &PL_sv_undef;
+ const char * CLASS = "XML::LibXML::Node";
+
+ if ( node != NULL ) {
+#ifdef XML_LIBXML_THREADS
+ if( PmmUSEREGISTRY )
+ SvLOCK(PROXY_NODE_REGISTRY_MUTEX);
+#endif
+ /* find out about the class */
+ CLASS = PmmNodeTypeName( node );
+ xs_warn("PmmNodeToSv: return new perl node of class:\n");
+ xs_warn( CLASS );
+
+ if ( node->_private != NULL ) {
+ dfProxy = PmmNewNode(node);
+ /* fprintf(stderr, " at 0x%08.8X\n", dfProxy); */
+ }
+ else {
+ dfProxy = PmmNewNode(node);
+ /* fprintf(stderr, " at 0x%08.8X\n", dfProxy); */
+ if ( dfProxy != NULL ) {
+ if ( owner != NULL ) {
+ dfProxy->owner = PmmNODE( owner );
+ PmmREFCNT_inc( owner );
+ /* fprintf(stderr, "REFCNT incremented on owner: 0x%08.8X\n", owner); */
+ }
+ else {
+ xs_warn("PmmNodeToSv: node contains itself (owner==NULL)\n");
+ }
+ }
+ else {
+ croak("XML::LibXML: failed to create a proxy node (out of memory?)\n");
+ }
+ }
+
+ retval = NEWSV(0,0);
+ sv_setref_pv( retval, CLASS, (void*)dfProxy );
+#ifdef XML_LIBXML_THREADS
+ if( PmmUSEREGISTRY )
+ PmmRegistryREFCNT_inc(dfProxy);
+#endif
+ PmmREFCNT_inc(dfProxy);
+ /* fprintf(stderr, "REFCNT incremented on node: 0x%08.8X\n", dfProxy); */
+
+ switch ( node->type ) {
+ case XML_DOCUMENT_NODE:
+ case XML_HTML_DOCUMENT_NODE:
+ case XML_DOCB_DOCUMENT_NODE:
+ if ( ((xmlDocPtr)node)->encoding != NULL ) {
+ SetPmmENCODING(dfProxy, (int)xmlParseCharEncoding( (const char*)((xmlDocPtr)node)->encoding ));
+ }
+ break;
+ default:
+ break;
+ }
+#ifdef XML_LIBXML_THREADS
+ if( PmmUSEREGISTRY )
+ SvUNLOCK(PROXY_NODE_REGISTRY_MUTEX);
+#endif
+ }
+ else {
+ xs_warn( "PmmNodeToSv: no node found!\n" );
+ }
+
+ return retval;
+}
+
+
+xmlNodePtr
+PmmCloneNode( xmlNodePtr node, int recursive )
+{
+ xmlNodePtr retval = NULL;
+
+ if ( node != NULL ) {
+ switch ( node->type ) {
+ case XML_ELEMENT_NODE:
+ case XML_TEXT_NODE:
+ case XML_CDATA_SECTION_NODE:
+ case XML_ENTITY_REF_NODE:
+ case XML_PI_NODE:
+ case XML_COMMENT_NODE:
+ case XML_DOCUMENT_FRAG_NODE:
+ case XML_ENTITY_DECL:
+ retval = xmlCopyNode( node, recursive ? 1 : 2 );
+ break;
+ case XML_ATTRIBUTE_NODE:
+ retval = (xmlNodePtr) xmlCopyProp( NULL, (xmlAttrPtr) node );
+ break;
+ case XML_DOCUMENT_NODE:
+ case XML_HTML_DOCUMENT_NODE:
+ retval = (xmlNodePtr) xmlCopyDoc( (xmlDocPtr)node, recursive );
+ break;
+ case XML_DOCUMENT_TYPE_NODE:
+ case XML_DTD_NODE:
+ retval = (xmlNodePtr) xmlCopyDtd( (xmlDtdPtr)node );
+ break;
+ case XML_NAMESPACE_DECL:
+ retval = ( xmlNodePtr ) xmlCopyNamespace( (xmlNsPtr) node );
+ break;
+ default:
+ break;
+ }
+ }
+
+ return retval;
+}
+
+/* extracts the libxml2 node from a perl reference
+ */
+
+xmlNodePtr
+PmmSvNodeExt( SV* perlnode, int copy )
+{
+ xmlNodePtr retval = NULL;
+ ProxyNodePtr proxy = NULL;
+
+ if ( perlnode != NULL && perlnode != &PL_sv_undef ) {
+/* if ( sv_derived_from(perlnode, "XML::LibXML::Node") */
+/* && SvPROXYNODE(perlnode) != NULL ) { */
+/* retval = PmmNODE( SvPROXYNODE(perlnode) ) ; */
+/* } */
+ xs_warn("PmmSvNodeExt: perlnode found\n" );
+ if ( sv_derived_from(perlnode, "XML::LibXML::Node") ) {
+ proxy = SvPROXYNODE(perlnode);
+ if ( proxy != NULL ) {
+ xs_warn( "PmmSvNodeExt: is a xmlNodePtr structure\n" );
+ retval = PmmNODE( proxy ) ;
+ }
+
+ if ( retval != NULL
+ && ((ProxyNodePtr)retval->_private) != proxy ) {
+ xs_warn( "PmmSvNodeExt: no node in proxy node\n" );
+ PmmNODE( proxy ) = NULL;
+ retval = NULL;
+ }
+ }
+#ifdef XML_LIBXML_GDOME_SUPPORT
+ else if ( sv_derived_from( perlnode, "XML::GDOME::Node" ) ) {
+ GdomeNode* gnode = (GdomeNode*)SvIV((SV*)SvRV( perlnode ));
+ if ( gnode == NULL ) {
+ warn( "no XML::GDOME data found (datastructure empty)" );
+ }
+ else {
+ retval = gdome_xml_n_get_xmlNode( gnode );
+ if ( retval == NULL ) {
+ xs_warn( "PmmSvNodeExt: no XML::LibXML node found in GDOME object\n" );
+ }
+ else if ( copy == 1 ) {
+ retval = PmmCloneNode( retval, 1 );
+ }
+ }
+ }
+#endif
+ }
+
+ return retval;
+}
+
+/* extracts the libxml2 owner node from a perl reference
+ */
+xmlNodePtr
+PmmSvOwner( SV* perlnode )
+{
+ xmlNodePtr retval = NULL;
+ if ( perlnode != NULL
+ && perlnode != &PL_sv_undef
+ && SvPROXYNODE(perlnode) != NULL ) {
+ retval = PmmOWNER( SvPROXYNODE(perlnode) );
+ }
+ return retval;
+}
+
+/* reverse to PmmSvOwner(). sets the owner of the current node. this
+ * will increase the proxy count of the owner.
+ */
+SV*
+PmmSetSvOwner( SV* perlnode, SV* extra )
+{
+ if ( perlnode != NULL && perlnode != &PL_sv_undef ) {
+ PmmOWNER( SvPROXYNODE(perlnode)) = PmmNODE( SvPROXYNODE(extra) );
+ PmmREFCNT_inc( SvPROXYNODE(extra) );
+ /* fprintf(stderr, "REFCNT incremented on new owner: 0x%08.8X\n", SvPROXYNODE(extra)); */
+ }
+ return perlnode;
+}
+
+void PmmFixOwnerList( xmlNodePtr list, ProxyNodePtr parent );
+
+/**
+ * this functions fixes the reference counts for an entire subtree.
+ * it is very important to fix an entire subtree after node operations
+ * where the documents or the owner node may get changed. this method is
+ * aware about nodes that already belong to a certain owner node.
+ *
+ * the method uses the internal methods PmmFixNode and PmmChildNodes to
+ * do the real updates.
+ *
+ * in the worst case this traverses the subtree twice during a node
+ * operation. this case is only given when the node has to be
+ * adopted by the document. Since the ownerdocument and the effective
+ * owner may differ this double traversing makes sense.
+ */
+int
+PmmFixOwner( ProxyNodePtr nodetofix, ProxyNodePtr parent )
+{
+ ProxyNodePtr oldParent = NULL;
+
+ if ( nodetofix != NULL ) {
+ switch ( PmmNODE(nodetofix)->type ) {
+ case XML_ENTITY_DECL:
+ case XML_ATTRIBUTE_DECL:
+ case XML_NAMESPACE_DECL:
+ case XML_ELEMENT_DECL:
+ case XML_DOCUMENT_NODE:
+ xs_warn( "PmmFixOwner: don't need to fix this type of node\n" );
+ return(0);
+ default:
+ break;
+ }
+
+ if ( PmmOWNER(nodetofix) != NULL ) {
+ oldParent = PmmOWNERPO(nodetofix);
+ }
+
+ /* The owner data is only fixed if the node is neither a
+ * fragment nor a document. Also no update will happen if
+ * the node is already his owner or the owner has not
+ * changed during previous operations.
+ */
+ if( oldParent != parent ) {
+ xs_warn( "PmmFixOwner: re-parenting node\n" );
+ /* fprintf(stderr, " 0x%08.8X (%s)\n", nodetofix, PmmNODE(nodetofix)->name); */
+ if ( parent && parent != nodetofix ){
+ PmmOWNER(nodetofix) = PmmNODE(parent);
+ PmmREFCNT_inc( parent );
+ /* fprintf(stderr, "REFCNT incremented on new parent: 0x%08.8X\n", parent); */
+ }
+ else {
+ PmmOWNER(nodetofix) = NULL;
+ }
+
+ if ( oldParent != NULL && oldParent != nodetofix )
+ PmmREFCNT_dec(oldParent);
+
+ if ( PmmNODE(nodetofix)->type != XML_ATTRIBUTE_NODE
+ && PmmNODE(nodetofix)->type != XML_DTD_NODE
+ && PmmNODE(nodetofix)->properties != NULL ) {
+ PmmFixOwnerList( (xmlNodePtr)PmmNODE(nodetofix)->properties,
+ parent );
+ }
+
+ if ( parent == NULL || PmmNODE(nodetofix)->parent == NULL ) {
+ /* fix to self */
+ parent = nodetofix;
+ }
+
+ PmmFixOwnerList(PmmNODE(nodetofix)->children, parent);
+ }
+ else {
+ xs_warn( "PmmFixOwner: node doesn't need to get fixed\n" );
+ }
+ return(1);
+ }
+ return(0);
+}
+
+void
+PmmFixOwnerList( xmlNodePtr list, ProxyNodePtr parent )
+{
+ if ( list != NULL ) {
+ xmlNodePtr iterator = list;
+ while ( iterator != NULL ) {
+ switch ( iterator->type ) {
+ case XML_ENTITY_DECL:
+ case XML_ATTRIBUTE_DECL:
+ case XML_NAMESPACE_DECL:
+ case XML_ELEMENT_DECL:
+ xs_warn( "PmmFixOwnerList: don't need to fix this type of node\n" );
+ iterator = iterator->next;
+ continue;
+ break;
+ default:
+ break;
+ }
+
+ if ( iterator->_private != NULL ) {
+ PmmFixOwner( (ProxyNodePtr)iterator->_private, parent );
+ }
+ else {
+ if ( iterator->type != XML_ATTRIBUTE_NODE
+ && iterator->properties != NULL ){
+ PmmFixOwnerList( (xmlNodePtr)iterator->properties, parent );
+ }
+ PmmFixOwnerList(iterator->children, parent);
+ }
+ iterator = iterator->next;
+ }
+ }
+}
+
+void
+PmmFixOwnerNode( xmlNodePtr node, ProxyNodePtr parent )
+{
+ if ( node != NULL && parent != NULL ) {
+ if ( node->_private != NULL ) {
+ xs_warn( "PmmFixOwnerNode: calling PmmFixOwner\n" );
+ PmmFixOwner( (ProxyNodePtr)(node->_private), parent );
+ }
+ else {
+ xs_warn( "PmmFixOwnerNode: calling PmmFixOwnerList\n" );
+ PmmFixOwnerList(node->children, parent );
+ }
+ }
+}
+
+ProxyNodePtr
+PmmNewContext(xmlParserCtxtPtr node)
+{
+ ProxyNodePtr proxy = NULL;
+
+ proxy = (ProxyNodePtr)xmlMalloc(sizeof(ProxyNode));
+ if (proxy != NULL) {
+ proxy->node = (xmlNodePtr)node;
+ proxy->owner = NULL;
+ proxy->count = 0;
+ }
+ else {
+ warn( "empty context" );
+ }
+ return proxy;
+}
+
+int
+PmmContextREFCNT_dec( ProxyNodePtr node )
+{
+ xmlParserCtxtPtr libnode = NULL;
+ int retval = 0;
+ if ( node != NULL ) {
+ retval = PmmREFCNT(node)--;
+ /* fprintf(stderr, "REFCNT on context %p decremented to %d\n", node, PmmREFCNT(node)); */
+ if ( PmmREFCNT(node) <= 0 ) {
+ xs_warn( "PmmContextREFCNT_dec: NODE DELETION\n" );
+ libnode = (xmlParserCtxtPtr)PmmNODE( node );
+ if ( libnode != NULL ) {
+ if (libnode->_private != NULL ) {
+ if ( libnode->_private != (void*)node ) {
+ PmmSAXCloseContext( libnode );
+ }
+ else {
+ xmlFree( libnode->_private );
+ }
+ libnode->_private = NULL;
+ }
+ PmmNODE( node ) = NULL;
+ xmlFreeParserCtxt(libnode);
+ }
+ }
+ xmlFree( node );
+ }
+ return retval;
+}
+
+SV*
+PmmContextSv( xmlParserCtxtPtr ctxt )
+{
+ ProxyNodePtr dfProxy= NULL;
+ SV * retval = &PL_sv_undef;
+ const char * CLASS = "XML::LibXML::ParserContext";
+
+ if ( ctxt != NULL ) {
+ dfProxy = PmmNewContext(ctxt);
+
+ retval = NEWSV(0,0);
+ sv_setref_pv( retval, CLASS, (void*)dfProxy );
+ PmmREFCNT_inc(dfProxy);
+ /* fprintf(stderr, "REFCNT incremented on new context: 0x%08.8X\n", dfProxy); */
+ }
+ else {
+ xs_warn( "PmmContextSv: no node found!\n" );
+ }
+
+ return retval;
+}
+
+xmlParserCtxtPtr
+PmmSvContext( SV * scalar )
+{
+ xmlParserCtxtPtr retval = NULL;
+
+ if ( scalar != NULL
+ && scalar != &PL_sv_undef
+ && sv_isa( scalar, "XML::LibXML::ParserContext" )
+ && SvPROXYNODE(scalar) != NULL ) {
+ retval = (xmlParserCtxtPtr)PmmNODE( SvPROXYNODE(scalar) );
+ }
+ else {
+ if ( scalar == NULL
+ && scalar == &PL_sv_undef ) {
+ xs_warn( "PmmSvContext: no scalar!\n" );
+ }
+ else if ( ! sv_isa( scalar, "XML::LibXML::ParserContext" ) ) {
+ xs_warn( "PmmSvContext: bad object\n" );
+ }
+ else if (SvPROXYNODE(scalar) == NULL) {
+ xs_warn( "PmmSvContext: empty object\n" );
+ }
+ else {
+ xs_warn( "PmmSvContext: nothing was wrong!\n");
+ }
+ }
+ return retval;
+}
+
+xmlChar*
+PmmFastEncodeString( int charset,
+ const xmlChar *string,
+ const xmlChar *encoding,
+ STRLEN len )
+{
+ xmlCharEncodingHandlerPtr coder = NULL;
+ xmlChar *retval = NULL;
+ xmlBufferPtr in = NULL, out = NULL;
+
+ int i;
+ /* first check that the input is not ascii */
+ /* since we do not want to recode ascii as, say, UTF-16 */
+ if (len == 0)
+ len=xmlStrlen(string);
+ for (i=0; i<len; i++) {
+ if(!string[i] || string[i] & 0x80) {
+ break;
+ }
+ }
+ if (i>=len) return xmlStrdup( string );
+ xs_warn("PmmFastEncodeString: string is non-ascii\n");
+
+ if ( charset == XML_CHAR_ENCODING_ERROR){
+ if (xmlStrcmp(encoding,(const xmlChar*)"UTF-16LE")==0) {
+ charset = XML_CHAR_ENCODING_UTF16LE;
+ } else if (xmlStrcmp(encoding,(const xmlChar*) "UTF-16BE")==0) {
+ charset = XML_CHAR_ENCODING_UTF16BE;
+ }
+ }
+ if ( charset == XML_CHAR_ENCODING_UTF8 ) {
+ /* warn("use UTF8 for encoding ... %s ", string); */
+ return xmlStrdup( string );
+ }
+ else if ( charset == XML_CHAR_ENCODING_UTF16LE || charset == XML_CHAR_ENCODING_UTF16BE ){
+ /* detect and strip BOM, if any */
+ if (len>=2 && (char)string[0]=='\xFE' && (char)string[1]=='\xFF') {
+ xs_warn("detected BE BOM\n");
+ string += 2;
+ len -= 2;
+ coder = xmlGetCharEncodingHandler( XML_CHAR_ENCODING_UTF16BE );
+ } else if (len>=2 && (char)string[0]=='\xFF' && (char)string[1]=='\xFE') {
+ xs_warn("detected LE BOM\n");
+ string += 2;
+ len -= 2;
+ coder = xmlGetCharEncodingHandler( XML_CHAR_ENCODING_UTF16LE );
+ } else {
+ coder= xmlGetCharEncodingHandler( (xmlCharEncoding)charset );
+ }
+ }
+ else if ( charset == XML_CHAR_ENCODING_ERROR ){
+ /* warn("no standard encoding %s\n", encoding); */
+ coder =xmlFindCharEncodingHandler( (const char *)encoding );
+ }
+ else if ( charset == XML_CHAR_ENCODING_NONE ){
+ xs_warn("PmmFastEncodeString: no encoding found\n");
+ }
+ else {
+ /* warn( "use document encoding %s (%d)", encoding, charset ); */
+ coder= xmlGetCharEncodingHandler( (xmlCharEncoding)charset );
+ }
+
+ if ( coder != NULL ) {
+ xs_warn("PmmFastEncodeString: coding machine found \n");
+ in = xmlBufferCreateStatic((void*)string, len);
+ out = xmlBufferCreate();
+ if ( xmlCharEncInFunc( coder, out, in ) >= 0 ) {
+ retval = xmlStrdup( out->content );
+ /* warn( "encoded string is %s" , retval); */
+ }
+ else {
+ /* warn( "b0rked encoiding!\n"); */
+ }
+
+ xmlBufferFree( in );
+ xmlBufferFree( out );
+ xmlCharEncCloseFunc( coder );
+ }
+ return retval;
+}
+
+xmlChar*
+PmmFastDecodeString( int charset,
+ const xmlChar *string,
+ const xmlChar *encoding,
+ STRLEN* len )
+{
+ xmlCharEncodingHandlerPtr coder = NULL;
+ xmlChar *retval = NULL;
+ xmlBufferPtr in = NULL, out = NULL;
+ if (len==NULL) return NULL;
+ *len = 0;
+ if ( charset == XML_CHAR_ENCODING_ERROR){
+ if (xmlStrcmp(encoding,(const xmlChar*)"UTF-16LE")==0) {
+ charset = XML_CHAR_ENCODING_UTF16LE;
+ } else if (xmlStrcmp(encoding,(const xmlChar*) "UTF-16BE")==0) {
+ charset = XML_CHAR_ENCODING_UTF16BE;
+ }
+ }
+
+ if ( charset == XML_CHAR_ENCODING_UTF8 ) {
+ retval = xmlStrdup( string );
+ *len = xmlStrlen(retval);
+ }
+ else if ( charset == XML_CHAR_ENCODING_ERROR ){
+ coder = xmlFindCharEncodingHandler( (const char *) encoding );
+ }
+ else if ( charset == XML_CHAR_ENCODING_NONE ){
+ warn("PmmFastDecodeString: no encoding found\n");
+ }
+ else {
+ coder= xmlGetCharEncodingHandler( (xmlCharEncoding)charset );
+ }
+
+ if ( coder != NULL ) {
+ /* warn( "do encoding %s", string ); */
+ in = xmlBufferCreateStatic((void*)string,xmlStrlen(string));
+ out = xmlBufferCreate();
+ if ( xmlCharEncOutFunc( coder, out, in ) >= 0 ) {
+ *len = xmlBufferLength(out);
+ retval = xmlStrndup(xmlBufferContent(out), *len);
+ }
+ else {
+ /* xs_warn("PmmFastEncodeString: decoding error\n"); */
+ }
+
+ xmlBufferFree( in );
+ xmlBufferFree( out );
+ xmlCharEncCloseFunc( coder );
+ }
+ return retval;
+}
+
+/**
+ * encodeString returns an UTF-8 encoded String
+ * while the encodig has the name of the encoding of string
+ **/
+xmlChar*
+PmmEncodeString( const char *encoding, const xmlChar *string, STRLEN len ){
+ xmlCharEncoding enc;
+ xmlChar *ret = NULL;
+
+ if ( string != NULL ) {
+ if( encoding != NULL ) {
+ xs_warn("PmmEncodeString: encoding to UTF-8 from:\n");
+ xs_warn( encoding );
+ enc = xmlParseCharEncoding( encoding );
+ ret = PmmFastEncodeString( enc, string, (const xmlChar *)encoding,len);
+ }
+ else {
+ /* if utf-8 is requested we do nothing */
+ ret = xmlStrdup( string );
+ }
+ }
+ return ret;
+}
+
+SV*
+C2Sv( const xmlChar *string, const xmlChar *encoding )
+{
+ SV *retval = &PL_sv_undef;
+ xmlCharEncoding enc;
+
+ if ( string != NULL ) {
+ if ( encoding != NULL ) {
+ enc = xmlParseCharEncoding( (const char*)encoding );
+ }
+ else {
+ enc = (xmlCharEncoding)0;
+ }
+ if ( enc == 0 ) {
+ /* this happens if the encoding is "" or NULL */
+ enc = XML_CHAR_ENCODING_UTF8;
+ }
+
+ retval = newSVpvn( (const char *)string, (STRLEN) xmlStrlen(string) );
+
+ if ( enc == XML_CHAR_ENCODING_UTF8 ) {
+ /* create an UTF8 string. */
+#ifdef HAVE_UTF8
+ xs_warn("C2Sv: set UTF8-SV-flag\n");
+ SvUTF8_on(retval);
+#endif
+ }
+ }
+
+ return retval;
+}
+
+xmlChar *
+Sv2C( SV* scalar, const xmlChar *encoding )
+{
+ xmlChar *retval = NULL;
+
+ xs_warn("SV2C: start!\n");
+ if ( scalar != NULL && scalar != &PL_sv_undef ) {
+ STRLEN len = 0;
+ char * t_pv =SvPV(scalar, len);
+ xmlChar* ts = NULL;
+ xmlChar* string = xmlStrdup((xmlChar*)t_pv);
+ if ( xmlStrlen(string) > 0 ) {
+ xs_warn( "SV2C: no undefs\n" );
+#ifdef HAVE_UTF8
+ xs_warn( "SV2C: use UTF8\n" );
+ if( !DO_UTF8(scalar) && encoding != NULL ) {
+#else
+ if ( encoding != NULL ) {
+#endif
+ xs_warn( "SV2C: domEncodeString!\n" );
+ ts= PmmEncodeString( (const char *)encoding, string, len );
+ xs_warn( "SV2C: done encoding!\n" );
+ if ( string != NULL ) {
+ xmlFree(string);
+ }
+ string=ts;
+ }
+ }
+
+ retval = xmlStrdup(string);
+ if (string != NULL ) {
+ xmlFree(string);
+ }
+ }
+ xs_warn("SV2C: end!\n");
+ return retval;
+}
+
+SV*
+nodeC2Sv( const xmlChar * string, xmlNodePtr refnode )
+{
+ /* this is a little helper function to avoid to much redundand
+ code in LibXML.xs */
+ SV* retval = &PL_sv_undef;
+ STRLEN len = 0;
+ xmlChar * decoded = NULL;
+
+ if ( refnode != NULL ) {
+ xmlDocPtr real_doc = refnode->doc;
+ if ( real_doc != NULL && real_doc->encoding != NULL ) {
+ xs_warn( " encode node !!" );
+ /* The following statement is to handle bad
+ values set by XML::LibXSLT */
+
+ if ( PmmNodeEncoding(real_doc) == XML_CHAR_ENCODING_NONE ) {
+ SetPmmNodeEncoding(real_doc, XML_CHAR_ENCODING_UTF8);
+ }
+
+ decoded = PmmFastDecodeString( PmmNodeEncoding(real_doc),
+ (const xmlChar *)string,
+ (const xmlChar *)real_doc->encoding,
+ &len );
+
+ xs_warn( "push decoded string into SV" );
+ retval = newSVpvn( (const char *)decoded, len );
+ xmlFree( decoded );
+
+ if ( PmmNodeEncoding( real_doc ) == XML_CHAR_ENCODING_UTF8 ) {
+#ifdef HAVE_UTF8
+ xs_warn("nodeC2Sv: set UTF8-SV-flag\n");
+ SvUTF8_on(retval);
+#endif
+ }
+
+ return retval;
+ }
+ }
+
+ return C2Sv(string, NULL );
+}
+
+xmlChar *
+nodeSv2C( SV * scalar, xmlNodePtr refnode )
+{
+ /* this function requires conditionized compiling, because we
+ request a function, that does not exists in earlier versions of
+ perl. in this cases the library assumes, all strings are in
+ UTF8. if a programmer likes to have the intelligent code, he
+ needs to upgrade perl */
+
+ if ( refnode != NULL ) {
+ xmlDocPtr real_dom = refnode->doc;
+ xs_warn("nodeSv2C: have node!\n");
+ if (real_dom != NULL && real_dom->encoding != NULL ) {
+ xs_warn("nodeSv2C: encode string!\n");
+ /* speed things a bit up.... */
+ if ( scalar != NULL && scalar != &PL_sv_undef ) {
+ STRLEN len = 0;
+ char * t_pv =SvPV(scalar, len);
+ xmlChar* string = NULL;
+ if ( t_pv && len > 0 ) {
+ xs_warn( "nodeSv2C: no undefs\n" );
+#ifdef HAVE_UTF8
+ xs_warn( "nodeSv2C: use UTF8\n" );
+ if( !DO_UTF8(scalar) ) {
+#endif
+ xs_warn( "nodeSv2C: domEncodeString!\n" );
+ /* The following statement is to handle bad
+ values set by XML::LibXSLT */
+ if ( PmmNodeEncoding(real_dom) == XML_CHAR_ENCODING_NONE ) {
+ SetPmmNodeEncoding(real_dom, XML_CHAR_ENCODING_UTF8);
+ }
+ /* the following allocates a new string (by xmlStrdup if no conversion is done) */
+ string= PmmFastEncodeString( PmmNodeEncoding(real_dom),
+ (xmlChar*) t_pv,
+ (const xmlChar*)real_dom->encoding,
+ len);
+ xs_warn( "nodeSv2C: done!\n" );
+#ifdef HAVE_UTF8
+ } else {
+ xs_warn( "nodeSv2C: no encoding set, use UTF8!\n" );
+ }
+#endif
+ }
+ if (string==NULL) {
+ return xmlStrndup((xmlChar*)t_pv,len);
+ } else {
+ return string;
+ }
+ /* if ( string == NULL ) warn( "nodeSv2C: string is NULL\n" ); */
+ }
+ else {
+ xs_warn( "nodeSv2C: return NULL\n" );
+ return NULL;
+ }
+ }
+ else {
+ xs_warn( "nodeSv2C: document has no encoding defined! use simple SV extraction\n" );
+ }
+ }
+ xs_warn("nodeSv2C: no encoding !!\n");
+
+ return Sv2C( scalar, NULL );
+}
+
+SV *
+PmmNodeToGdomeSv( xmlNodePtr node )
+{
+ SV * retval = &PL_sv_undef;
+
+#ifdef XML_LIBXML_GDOME_SUPPORT
+ GdomeNode * gnode = NULL;
+ GdomeException exc;
+ const char * CLASS = "";
+
+ if ( node != NULL ) {
+ gnode = gdome_xml_n_mkref( node );
+ if ( gnode != NULL ) {
+ switch (gdome_n_nodeType(gnode, &exc)) {
+ case GDOME_ELEMENT_NODE:
+ CLASS = "XML::GDOME::Element";
+ break;
+ case GDOME_ATTRIBUTE_NODE:
+ CLASS = "XML::GDOME::Attr";
+ break;
+ case GDOME_TEXT_NODE:
+ CLASS = "XML::GDOME::Text";
+ break;
+ case GDOME_CDATA_SECTION_NODE:
+ CLASS = "XML::GDOME::CDATASection";
+ break;
+ case GDOME_ENTITY_REFERENCE_NODE:
+ CLASS = "XML::GDOME::EntityReference";
+ break;
+ case GDOME_ENTITY_NODE:
+ CLASS = "XML::GDOME::Entity";
+ break;
+ case GDOME_PROCESSING_INSTRUCTION_NODE:
+ CLASS = "XML::GDOME::ProcessingInstruction";
+ break;
+ case GDOME_COMMENT_NODE:
+ CLASS = "XML::GDOME::Comment";
+ break;
+ case GDOME_DOCUMENT_TYPE_NODE:
+ CLASS = "XML::GDOME::DocumentType";
+ break;
+ case GDOME_DOCUMENT_FRAGMENT_NODE:
+ CLASS = "XML::GDOME::DocumentFragment";
+ break;
+ case GDOME_NOTATION_NODE:
+ CLASS = "XML::GDOME::Notation";
+ break;
+ case GDOME_DOCUMENT_NODE:
+ CLASS = "XML::GDOME::Document";
+ break;
+ default:
+ break;
+ }
+
+ retval = NEWSV(0,0);
+ sv_setref_pv( retval, CLASS, gnode);
+ }
+ }
+#endif
+
+ return retval;
+}
@@ -0,0 +1,367 @@
+/**
+ * perl-libxml-mm.h
+ * $Id$
+ *
+ * Basic concept:
+ * perl varies in the implementation of UTF8 handling. this header (together
+ * with the c source) implements a few functions, that can be used from within
+ * the core module in order to avoid cascades of c pragmas
+ */
+
+#ifndef __PERL_LIBXML_MM_H__
+#define __PERL_LIBXML_MM_H__
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#include <libxml/parser.h>
+
+/*
+ * NAME xs_warn
+ * TYPE MACRO
+ *
+ * this makro is for XML::LibXML development and debugging.
+ *
+ * SYNOPSIS
+ * xs_warn("my warning")
+ *
+ * this makro takes only a single string(!) and passes it to perls
+ * warn function if the XS_WARNRINGS pragma is used at compile time
+ * otherwise any xs_warn call is ignored.
+ *
+ * pay attention, that xs_warn does not implement a complete wrapper
+ * for warn!!
+ */
+#ifdef XS_WARNINGS
+#define xs_warn(string) warn("%s",string)
+#else
+#define xs_warn(string)
+#endif
+
+/*
+ * @node: Reference to the node the structure proxies
+ * @owner: libxml defines only the document, but not the node owner
+ * (in case of document fragments, they are not the same!)
+ * @count: this is the internal reference count!
+ * @encoding: this value is missing in libxml2's doc structure
+ *
+ * Since XML::LibXML will not know, is a certain node is already
+ * defined in the perl layer, it can't surely tell when a node can be
+ * safely be removed from the memory. This structure helps to keep
+ * track how intense the nodes of a document are used and will not
+ * delete the nodes unless they are not referred from somewhere else.
+ */
+struct _ProxyNode {
+ xmlNodePtr node;
+ xmlNodePtr owner;
+ int count;
+};
+
+struct _DocProxyNode {
+ xmlNodePtr node;
+ xmlNodePtr owner;
+ int count;
+ int encoding; /* only used for proxies of xmlDocPtr */
+ int psvi_status; /* see below ... */
+};
+
+/* the psvi_status flag requires some explanation:
+
+ each time libxml2 validates a document (using DTD, Schema or
+ RelaxNG) it stores a pointer to a last successfully applied grammar
+ rule in node->psvi. Upon next validation, if libxml2 wants to check
+ that node matches some grammar rule, it first compares the rule
+ pointer and node->psvi. If these are equal, the validation of the
+ node's subtree is skipped and the node is assumed to match the
+ rule.
+
+ This causes problems when the tree is modified and then
+ re-validated or when the schema is freed and the document is
+ revalidated using a different schema and by bad chance a rule
+ tested against some node got allocated to the exact same location
+ as the rule from the schema used for the prior validation, already
+ freed, but still pointed to by node->psvi).
+
+ Thus, the node->psvi values can't be trusted at all and we want to
+ make sure all psvi slots are NULL before each validation. To aviod
+ traversing the tree in the most common case, when each document is
+ validated just once, we maintain the psvi_status flag.
+
+ Validating a document triggers this flag (sets it to 1). The
+ document with psvi_status==1 is traversed and psvi slots are nulled
+ prior to any validation. When the flag is triggered, it remains
+ triggered for the rest of the document's life, there is no way to
+ null it (even nulling up the psvi's does not null the flag, because
+ there may be unlinked parts of the document floating around which
+ we don't know about and thus cannot null their psvi pointers; these
+ unlinked document parts would cause inconsistency when re-attached
+ to the document tree).
+
+ Also, importing a node from a document with psvi_status==1 to a
+ document with psvi_status==0 automatically triggers psvi_status on
+ the target document.
+
+ NOTE: We could alternatively just null psvis from any imported
+ subtrees, but that would add an O(n) cleanup operation (n the size
+ of the imported subtree) on every importNode (possibly needlessly
+ since the target document may not ever be revalidated) whereas
+ triggering the flag is O(1) and possibly adds one O(N) cleanup
+ operation (N the size of the document) to the first validation of
+ the target document (any subsequent re-validation of the document
+ would have to perform the operation anyway). The sum of all n's may
+ be less then N, but OTH, there is a great chance that the O(N)
+ cleanup will never be performed. (BTW, validation is at least
+ O(N), probably O(Nlog N) anyway, so the cleanup has little impact;
+ similarly, importNode does xmlSetTreeDoc which is also O(n). So in
+ fact, neither solution should have significant performance impact
+ overall....).
+
+*/
+
+#define Pmm_NO_PSVI 0
+#define Pmm_PSVI_TAINTED 1
+
+/* helper type for the proxy structure */
+typedef struct _DocProxyNode DocProxyNode;
+typedef struct _ProxyNode ProxyNode;
+
+/* pointer to the proxy structure */
+typedef ProxyNode* ProxyNodePtr;
+typedef DocProxyNode* DocProxyNodePtr;
+
+/* this my go only into the header used by the xs */
+#define SvPROXYNODE(x) (INT2PTR(ProxyNodePtr,SvIV(SvRV(x))))
+#define PmmPROXYNODE(x) (INT2PTR(ProxyNodePtr,x->_private))
+#define SvNAMESPACE(x) (INT2PTR(xmlNsPtr,SvIV(SvRV(x))))
+
+#define PmmREFCNT(node) node->count
+#define PmmREFCNT_inc(node) node->count++
+#define PmmNODE(xnode) xnode->node
+#define PmmOWNER(node) node->owner
+#define PmmOWNERPO(node) ((node && PmmOWNER(node)) ? (ProxyNodePtr)PmmOWNER(node)->_private : node)
+
+#define PmmENCODING(node) ((DocProxyNodePtr)(node))->encoding
+#define PmmNodeEncoding(node) ((DocProxyNodePtr)(node->_private))->encoding
+
+#define SetPmmENCODING(node,code) PmmENCODING(node)=(code)
+#define SetPmmNodeEncoding(node,code) PmmNodeEncoding(node)=(code)
+
+#define PmmInvalidatePSVI(doc) if (doc && doc->_private) ((DocProxyNodePtr)(doc->_private))->psvi_status = Pmm_PSVI_TAINTED;
+#define PmmIsPSVITainted(doc) (doc && doc->_private && (((DocProxyNodePtr)(doc->_private))->psvi_status == Pmm_PSVI_TAINTED))
+
+#define PmmClearPSVI(node) if (node && node->doc && node->doc->_private && \
+ ((DocProxyNodePtr)(node->doc->_private))->psvi_status == Pmm_PSVI_TAINTED) \
+ domClearPSVI((xmlNodePtr) node)
+
+#define NO_XML_LIBXML_THREADS 1
+
+#ifndef NO_XML_LIBXML_THREADS
+#ifdef USE_ITHREADS
+#define XML_LIBXML_THREADS
+#endif
+#endif
+
+#ifdef XML_LIBXML_THREADS
+
+/* structure for storing thread-local refcount */
+struct _LocalProxyNode {
+ ProxyNodePtr proxy;
+ int count;
+};
+typedef struct _LocalProxyNode LocalProxyNode;
+typedef LocalProxyNode* LocalProxyNodePtr;
+
+#define PmmUSEREGISTRY (PROXY_NODE_REGISTRY_MUTEX != NULL)
+#define PmmREGISTRY (INT2PTR(xmlHashTablePtr,SvIV(SvRV(get_sv("XML::LibXML::__PROXY_NODE_REGISTRY",0)))))
+/* #define PmmREGISTRY (INT2PTR(xmlHashTablePtr,SvIV(SvRV(PROXY_NODE_REGISTRY)))) */
+
+void
+PmmCloneProxyNodes();
+int
+PmmProxyNodeRegistrySize();
+void
+PmmDumpRegistry(xmlHashTablePtr r);
+void
+PmmRegistryREFCNT_dec(ProxyNodePtr proxy);
+
+#endif
+
+void
+PmmFreeHashTable(xmlHashTablePtr table);
+
+ProxyNodePtr
+PmmNewNode(xmlNodePtr node);
+
+ProxyNodePtr
+PmmNewFragment(xmlDocPtr document);
+
+SV*
+PmmCreateDocNode( unsigned int type, ProxyNodePtr pdoc, ...);
+
+int
+PmmREFCNT_dec( ProxyNodePtr node );
+
+SV*
+PmmNodeToSv( xmlNodePtr node, ProxyNodePtr owner );
+
+/* PmmFixProxyEncoding
+ * TYPE
+ * Method
+ * PARAMETER
+ * @dfProxy: The proxystructure to fix.
+ *
+ * DESCRIPTION
+ *
+ * This little helper allows to fix the proxied encoding information
+ * after a not standard operation was done. This is required for
+ * XML::LibXSLT
+ */
+void
+PmmFixProxyEncoding( ProxyNodePtr dfProxy );
+
+/* PmmSvNodeExt
+ * TYPE
+ * Function
+ * PARAMETER
+ * @perlnode: the perl reference that holds the scalar.
+ * @copy : copy flag
+ *
+ * DESCRIPTION
+ *
+ * The function recognizes XML::LibXML and XML::GDOME
+ * nodes as valid input data. The second parameter 'copy'
+ * indicates if in case of GDOME nodes the libxml2 node
+ * should be copied. In some cases, where the node is
+ * cloned anyways, this flag has to be set to '0', while
+ * the default value should be allways '1'.
+ */
+xmlNodePtr
+PmmSvNodeExt( SV * perlnode, int copy );
+
+/* PmmSvNode
+ * TYPE
+ * Macro
+ * PARAMETER
+ * @perlnode: a perl reference that holds a libxml node
+ *
+ * DESCRIPTION
+ *
+ * PmmSvNode fetches the libxml node such as PmmSvNodeExt does. It is
+ * a wrapper, that sets the copy always to 1, which is good for all
+ * cases XML::LibXML uses.
+ */
+#define PmmSvNode(n) PmmSvNodeExt(n,1)
+
+
+xmlNodePtr
+PmmSvOwner( SV * perlnode );
+
+SV*
+PmmSetSvOwner(SV * perlnode, SV * owner );
+
+int
+PmmFixOwner(ProxyNodePtr node, ProxyNodePtr newOwner );
+
+void
+PmmFixOwnerNode(xmlNodePtr node, ProxyNodePtr newOwner );
+
+int
+PmmContextREFCNT_dec( ProxyNodePtr node );
+
+SV*
+PmmContextSv( xmlParserCtxtPtr ctxt );
+
+xmlParserCtxtPtr
+PmmSvContext( SV * perlctxt );
+
+/**
+ * NAME PmmCopyNode
+ * TYPE function
+ *
+ * returns libxml2 node
+ *
+ * DESCRIPTION
+ * This function implements a nodetype independent node cloning.
+ *
+ * Note that this function has to stay in this module, since
+ * XML::LibXSLT reuses it.
+ */
+xmlNodePtr
+PmmCloneNode( xmlNodePtr node , int deep );
+
+/**
+ * NAME PmmNodeToGdomeSv
+ * TYPE function
+ *
+ * returns XML::GDOME node
+ *
+ * DESCRIPTION
+ * creates an Gdome node from our XML::LibXML node.
+ * this function is very useful for the parser.
+ *
+ * the function will only work, if XML::LibXML is compiled with
+ * XML::GDOME support.
+ *
+ */
+SV *
+PmmNodeToGdomeSv( xmlNodePtr node );
+
+/**
+ * NAME PmmNodeTypeName
+ * TYPE function
+ *
+ * returns the perl class name for the given node
+ *
+ * SYNOPSIS
+ * CLASS = PmmNodeTypeName( node );
+ */
+const char*
+PmmNodeTypeName( xmlNodePtr elem );
+
+xmlChar*
+PmmEncodeString( const char *encoding, const xmlChar *string, STRLEN len );
+
+char*
+PmmDecodeString( const char *encoding, const xmlChar *string, STRLEN* len);
+
+/* string manipulation will go elsewhere! */
+
+/*
+ * NAME c_string_to_sv
+ * TYPE function
+ * SYNOPSIS
+ * SV *my_sv = c_string_to_sv( "my string", encoding );
+ *
+ * this function converts a libxml2 string to a SV*. although the
+ * string is copied, the func does not free the c-string for you!
+ *
+ * encoding is either NULL or a encoding string such as provided by
+ * the documents encoding. if encoding is NULL UTF8 is assumed.
+ *
+ */
+SV*
+C2Sv( const xmlChar *string, const xmlChar *encoding );
+
+/*
+ * NAME sv_to_c_string
+ * TYPE function
+ * SYNOPSIS
+ * SV *my_sv = sv_to_c_string( my_sv, encoding );
+ *
+ * this function converts a SV* to a libxml string. the SV-value will
+ * be copied into a *newly* allocated string. (don't forget to free it!)
+ *
+ * encoding is either NULL or a encoding string such as provided by
+ * the documents encoding. if encoding is NULL UTF8 is assumed.
+ *
+ */
+xmlChar *
+Sv2C( SV* scalar, const xmlChar *encoding );
+
+SV*
+nodeC2Sv( const xmlChar * string, xmlNodePtr refnode );
+
+xmlChar *
+nodeSv2C( SV * scalar, xmlNodePtr refnode );
+
+#endif
@@ -0,0 +1,1555 @@
+/**
+ * perl-libxml-sax.c
+ * $Id$
+ *
+ * This is free software, you may use it and distribute it under the same terms as
+ * Perl itself.
+ *
+ * Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
+*/
+
+#define PERL_NO_GET_CONTEXT /* we want efficiency */
+
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "ppport.h"
+
+#include <stdlib.h>
+#include <libxml/xmlmemory.h>
+#include <libxml/parser.h>
+#include <libxml/parserInternals.h>
+#include <libxml/tree.h>
+#include <libxml/entities.h>
+#include <libxml/xmlerror.h>
+
+#include "perl-libxml-sax.h"
+
+/*
+ we must call CLEAR_SERROR_HANDLER upon each excurse from
+ perl
+*/
+#define WITH_SERRORS
+
+#ifdef WITH_SERRORS
+#define CLEAR_SERROR_HANDLER /*xmlSetStructuredErrorFunc(NULL,NULL);*/
+#else
+#define CLEAR_SERROR_HANDLER
+#endif
+
+#define NSDELIM ':'
+/* #define NSDEFAULTURI "http://www.w3.org/XML/1998/namespace" */
+#define NSDEFAULTURI "http://www.w3.org/2000/xmlns/"
+typedef struct {
+ SV * parser;
+ xmlNodePtr ns_stack;
+ xmlSAXLocator * locator;
+ xmlDocPtr ns_stack_root;
+ SV * handler;
+ SV * saved_error;
+ struct CBuffer *charbuf;
+ int joinchars;
+} PmmSAXVector;
+
+typedef PmmSAXVector* PmmSAXVectorPtr;
+
+struct CBufferChunk {
+ struct CBufferChunk *next;
+ xmlChar *data;
+ int len;
+};
+
+struct CBuffer {
+ struct CBufferChunk *head;
+ struct CBufferChunk *tail;
+};
+
+static U32 PrefixHash; /* pre-computed */
+static U32 NsURIHash;
+static U32 NameHash;
+static U32 LocalNameHash;
+static U32 AttributesHash;
+static U32 ValueHash;
+static U32 DataHash;
+static U32 TargetHash;
+static U32 VersionHash;
+static U32 EncodingHash;
+static U32 PublicIdHash;
+static U32 SystemIdHash;
+
+/* helper function C2Sv is ment to work faster than the perl-libxml-mm
+ version. this shortcut is useful, because SAX handles only UTF8
+ strings, so there is no conversion logic required.
+*/
+SV*
+_C2Sv( const xmlChar *string, const xmlChar *dummy )
+{
+
+ dTHX;
+ SV *retval = &PL_sv_undef;
+ STRLEN len;
+
+ if ( string != NULL ) {
+ len = xmlStrlen( string );
+ retval = NEWSV(0, len+1);
+ sv_setpvn(retval, (const char *)string, len );
+#ifdef HAVE_UTF8
+ SvUTF8_on( retval );
+#endif
+ }
+
+ return retval;
+}
+
+SV*
+_C2Sv_len( const xmlChar *string, int len )
+{
+
+ dTHX;
+ SV *retval = &PL_sv_undef;
+
+ if ( string != NULL ) {
+ retval = NEWSV(0, len+1);
+ sv_setpvn(retval, (const char *)string, (STRLEN) len );
+#ifdef HAVE_UTF8
+ SvUTF8_on( retval );
+#endif
+ }
+
+ return retval;
+}
+
+void
+PmmSAXInitialize(pTHX)
+{
+ PERL_HASH(PrefixHash, "Prefix", 6);
+ PERL_HASH(NsURIHash, "NamespaceURI", 12);
+ PERL_HASH(NameHash, "Name", 4);
+ PERL_HASH(LocalNameHash, "LocalName", 9);
+ PERL_HASH(AttributesHash, "Attributes", 10);
+ PERL_HASH(ValueHash, "Value", 5);
+ PERL_HASH(DataHash, "Data", 4);
+ PERL_HASH(TargetHash, "Target", 6);
+ PERL_HASH(VersionHash, "Version", 7);
+ PERL_HASH(EncodingHash, "Encoding", 8);
+ PERL_HASH(PublicIdHash, "PublicId", 8);
+ PERL_HASH(SystemIdHash, "SystemId", 8);
+}
+
+xmlSAXHandlerPtr PSaxGetHandler();
+int PSaxCharactersFlush(void *, struct CBuffer *);
+
+
+/* Character buffering functions */
+
+struct CBufferChunk * CBufferChunkNew(void) {
+ struct CBufferChunk *newchunk = (CBufferChunk *)xmlMalloc(sizeof(struct CBufferChunk));
+ memset(newchunk, 0, sizeof(struct CBufferChunk));
+ return newchunk;
+}
+
+struct CBuffer * CBufferNew(void) {
+ struct CBuffer *new_ = (CBuffer *)xmlMalloc(sizeof(struct CBuffer));
+ struct CBufferChunk *newchunk = CBufferChunkNew();
+
+ memset(new_, 0, sizeof(struct CBuffer));
+
+ new_->head = newchunk;
+ new_->tail = newchunk;
+
+ return new_;
+}
+
+void CBufferPurge(struct CBuffer *buffer) {
+ struct CBufferChunk *p1;
+ struct CBufferChunk *p2;
+
+ if (buffer == NULL || buffer->head->data == NULL) {
+ return;
+ }
+
+ if ((p1 = buffer->head)) {
+
+ while(p1) {
+ p2 = p1->next;
+
+ if (p1->data) {
+ xmlFree(p1->data);
+ }
+
+ xmlFree(p1);
+
+ p1 = p2;
+ }
+ }
+
+ buffer->head = CBufferChunkNew();
+ buffer->tail = buffer->head;
+}
+
+void CBufferFree(struct CBuffer *buffer) {
+ struct CBufferChunk *p1;
+ struct CBufferChunk *p2;
+
+ if (buffer == NULL) {
+ return;
+ }
+
+ if ((p1 = buffer->head)) {
+
+ while(p1) {
+ p2 = p1->next;
+
+ if (p1->data) {
+ xmlFree(p1->data);
+ }
+
+ xmlFree(p1);
+
+ p1 = p2;
+ }
+ }
+
+ xmlFree(buffer);
+
+ return;
+}
+
+int CBufferLength(struct CBuffer *buffer) {
+ int length = 0;
+ struct CBufferChunk *cur;
+
+ for(cur = buffer->head; cur; cur = cur->next) {
+ length += cur->len;
+ }
+
+ return length;
+}
+
+void CBufferAppend(struct CBuffer *buffer, const xmlChar *newstring, int len) {
+ xmlChar *copy = (xmlChar *)xmlMalloc(len);
+
+ memcpy(copy, newstring, len);
+
+ buffer->tail->data = copy;
+ buffer->tail->len = len;
+ buffer->tail->next = CBufferChunkNew();
+ buffer->tail = buffer->tail->next;
+}
+
+xmlChar * CBufferCharacters(struct CBuffer *buffer) {
+ int length = CBufferLength(buffer);
+ xmlChar *new_ = (xmlChar *)xmlMalloc(length + 1);
+ xmlChar *p = new_;
+ int copied = 0;
+ struct CBufferChunk *cur;
+
+ /* We need this because stderr on some perls requires
+ * my_perl. See:
+ *
+ * https://rt.cpan.org/Public/Bug/Display.html?id=69082
+ *
+ * */
+ dTHX;
+
+ if (buffer->head->data == NULL) {
+ return NULL;
+ }
+
+ for(cur = buffer->head;cur;cur = cur->next) {
+ if (! cur->data) {
+ continue;
+ }
+
+ if ((copied = copied + cur->len) > length) {
+ fprintf(stderr, "string overflow\n");
+ abort();
+ }
+
+ memcpy(p, cur->data, cur->len);
+ p += cur->len;
+ }
+
+ new_[length] = '\0';
+
+ return new_;
+}
+
+/* end character buffering functions */
+
+
+void
+PmmSAXInitContext( xmlParserCtxtPtr ctxt, SV * parser, SV * saved_error )
+{
+ PmmSAXVectorPtr vec = NULL;
+ SV ** th;
+ SV ** joinchars;
+
+ dTHX;
+
+ CLEAR_SERROR_HANDLER
+ vec = (PmmSAXVector*) xmlMalloc( sizeof(PmmSAXVector) );
+
+ vec->ns_stack_root = xmlNewDoc(NULL);
+ vec->ns_stack = xmlNewDocNode(vec->ns_stack_root,
+ NULL,
+ (const xmlChar*)"stack",
+ NULL );
+
+ xmlAddChild((xmlNodePtr)vec->ns_stack_root, vec->ns_stack);
+
+ vec->locator = NULL;
+
+ vec->saved_error = saved_error;
+
+ vec->parser = SvREFCNT_inc( parser );
+ th = hv_fetch( (HV*)SvRV(parser), "HANDLER", 7, 0 );
+ if ( th != NULL && SvTRUE(*th) ) {
+ vec->handler = SvREFCNT_inc(*th) ;
+ }
+ else {
+ vec->handler = NULL;
+ }
+
+ joinchars = hv_fetch((HV*)SvRV(parser), "JOIN_CHARACTERS", 15, 0);
+
+ if (joinchars != NULL) {
+ vec->joinchars = (SvIV(*joinchars));
+ } else {
+ vec->joinchars = 0;
+ }
+
+ if (vec->joinchars) {
+ vec->charbuf = CBufferNew();
+ } else {
+ vec->charbuf = NULL;
+ }
+
+ if ( ctxt->sax ) {
+ xmlFree( ctxt->sax );
+ }
+ ctxt->sax = PSaxGetHandler();
+
+ ctxt->_private = (void*)vec;
+}
+
+void
+PmmSAXCloseContext( xmlParserCtxtPtr ctxt )
+{
+ PmmSAXVector * vec = (PmmSAXVectorPtr) ctxt->_private;
+ dTHX;
+
+ if ( vec->handler != NULL ) {
+ SvREFCNT_dec( vec->handler );
+ vec->handler = NULL;
+ }
+
+ CBufferFree(vec->charbuf);
+ vec->charbuf = NULL;
+
+ xmlFree( ctxt->sax );
+ ctxt->sax = NULL;
+
+ SvREFCNT_dec( vec->parser );
+ vec->parser = NULL;
+
+ xmlFreeDoc( vec->ns_stack_root );
+ vec->ns_stack_root = NULL;
+ xmlFree( vec );
+ ctxt->_private = NULL;
+}
+
+
+xmlNsPtr
+PmmGetNsMapping( xmlNodePtr ns_stack, const xmlChar * prefix )
+{
+ if ( ns_stack != NULL ) {
+ return xmlSearchNs( ns_stack->doc, ns_stack, prefix );
+ }
+
+ return NULL;
+}
+
+
+void
+PSaxStartPrefix( PmmSAXVectorPtr sax, const xmlChar * prefix,
+ const xmlChar * uri, SV * handler )
+{
+ dTHX;
+ HV * param;
+ SV * rv;
+
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+
+ param = newHV();
+
+ (void) hv_store(param, "NamespaceURI", 12,
+ _C2Sv(uri, NULL), NsURIHash);
+
+ if ( prefix != NULL ) {
+ (void) hv_store(param, "Prefix", 6,
+ _C2Sv(prefix, NULL), PrefixHash);
+ }
+ else {
+ (void) hv_store(param, "Prefix", 6,
+ _C2Sv((const xmlChar*)"", NULL), PrefixHash);
+ }
+
+ PUSHMARK(SP) ;
+ XPUSHs(handler);
+
+ rv = newRV_noinc((SV*)param);
+
+ XPUSHs(rv);
+ PUTBACK;
+
+ call_method( "start_prefix_mapping", G_SCALAR | G_EVAL | G_DISCARD );
+ sv_2mortal(rv);
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+ FREETMPS ;
+ LEAVE ;
+ CLEAR_SERROR_HANDLER
+}
+
+void
+PSaxEndPrefix( PmmSAXVectorPtr sax, const xmlChar * prefix,
+ const xmlChar * uri, SV * handler )
+{
+ dTHX;
+ HV * param;
+ SV * rv;
+
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+ param = newHV();
+ (void) hv_store(param, "NamespaceURI", 12,
+ _C2Sv(uri, NULL), NsURIHash);
+
+ if ( prefix != NULL ) {
+ (void) hv_store(param, "Prefix", 6,
+ _C2Sv(prefix, NULL), PrefixHash);
+ }
+ else {
+ (void) hv_store(param, "Prefix", 6,
+ _C2Sv((const xmlChar *)"", NULL), PrefixHash);
+ }
+
+ PUSHMARK(SP) ;
+ XPUSHs(handler);
+
+
+ rv = newRV_noinc((SV*)param);
+
+ XPUSHs(rv);
+ PUTBACK;
+
+ call_method( "end_prefix_mapping", G_SCALAR | G_EVAL | G_DISCARD );
+ sv_2mortal(rv);
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ FREETMPS ;
+ LEAVE ;
+ CLEAR_SERROR_HANDLER
+}
+
+void
+PmmExtendNsStack( PmmSAXVectorPtr sax , const xmlChar * name) {
+ xmlNodePtr newNS = NULL;
+ xmlChar * localname = NULL;
+ xmlChar * prefix = NULL;
+
+ localname = xmlSplitQName( NULL, name, &prefix );
+ if ( prefix != NULL ) {
+ /* check if we can find a namespace with that prefix... */
+ xmlNsPtr ns = xmlSearchNs( sax->ns_stack->doc, sax->ns_stack, prefix );
+
+ if ( ns != NULL ) {
+ newNS = xmlNewDocNode( sax->ns_stack_root, ns, localname, NULL );
+ }
+ else {
+ newNS = xmlNewDocNode( sax->ns_stack_root, NULL, name, NULL );
+ }
+ }
+ else {
+ newNS = xmlNewDocNode( sax->ns_stack_root, NULL, name, NULL );
+ }
+
+ if ( newNS != NULL ) {
+ xmlAddChild(sax->ns_stack, newNS);
+ sax->ns_stack = newNS;
+ }
+
+ if ( localname != NULL ) {
+ xmlFree( localname ) ;
+ }
+ if ( prefix != NULL ) {
+ xmlFree( prefix );
+ }
+}
+
+void
+PmmNarrowNsStack( PmmSAXVectorPtr sax, SV *handler )
+{
+ xmlNodePtr parent = sax->ns_stack->parent;
+ xmlNsPtr list = sax->ns_stack->nsDef;
+
+ while ( list ) {
+ if ( !xmlStrEqual(list->prefix, (const xmlChar*)"xml") ) {
+ PSaxEndPrefix( sax, list->prefix, list->href, handler );
+ }
+ list = list->next;
+ }
+ xmlUnlinkNode(sax->ns_stack);
+ xmlFreeNode(sax->ns_stack);
+ sax->ns_stack = parent;
+}
+
+void
+PmmAddNamespace( PmmSAXVectorPtr sax, const xmlChar * name,
+ const xmlChar * href, SV *handler)
+{
+ xmlNsPtr ns = NULL;
+ xmlChar * prefix = NULL;
+ xmlChar * localname = NULL;
+
+
+ if ( sax->ns_stack == NULL ) {
+ return;
+ }
+
+ ns = xmlNewNs( sax->ns_stack, href, name );
+
+ if ( sax->ns_stack->ns == NULL ) {
+ localname = xmlSplitQName( NULL, sax->ns_stack->name, &prefix );
+
+ if ( name != NULL ) {
+ if ( xmlStrEqual( prefix , name ) ) {
+ xmlChar * oname = (xmlChar*)(sax->ns_stack->name);
+ sax->ns_stack->ns = ns;
+ xmlFree( oname );
+ sax->ns_stack->name = (const xmlChar*) xmlStrdup( localname );
+ }
+ }
+ else if ( prefix == NULL ) {
+ sax->ns_stack->ns = ns;
+ }
+ }
+
+ if ( prefix ) {
+ xmlFree( prefix );
+ }
+ if ( localname ) {
+ xmlFree( localname );
+ }
+
+ PSaxStartPrefix( sax, name, href, handler );
+}
+
+HV *
+PmmGenElementSV( pTHX_ PmmSAXVectorPtr sax, const xmlChar * name )
+{
+ HV * retval = newHV();
+ xmlChar * localname = NULL;
+ xmlChar * prefix = NULL;
+
+ xmlNsPtr ns = NULL;
+
+ if ( name != NULL && xmlStrlen( name ) ) {
+ (void) hv_store(retval, "Name", 4,
+ _C2Sv(name, NULL), NameHash);
+
+ localname = xmlSplitQName(NULL, name, &prefix);
+ if (localname != NULL) xmlFree(localname);
+ ns = PmmGetNsMapping( sax->ns_stack, prefix );
+ if (prefix != NULL) xmlFree(prefix);
+
+ if ( ns != NULL ) {
+ (void) hv_store(retval, "NamespaceURI", 12,
+ _C2Sv(ns->href, NULL), NsURIHash);
+ if ( ns->prefix ) {
+ (void) hv_store(retval, "Prefix", 6,
+ _C2Sv(ns->prefix, NULL), PrefixHash);
+ }
+ else {
+ (void) hv_store(retval, "Prefix", 6,
+ _C2Sv((const xmlChar *)"",NULL), PrefixHash);
+ }
+
+ (void) hv_store(retval, "LocalName", 9,
+ _C2Sv(sax->ns_stack->name, NULL), LocalNameHash);
+ }
+ else {
+ (void) hv_store(retval, "NamespaceURI", 12,
+ _C2Sv((const xmlChar *)"",NULL), NsURIHash);
+ (void) hv_store(retval, "Prefix", 6,
+ _C2Sv((const xmlChar *)"",NULL), PrefixHash);
+ (void) hv_store(retval, "LocalName", 9,
+ _C2Sv(name, NULL), LocalNameHash);
+ }
+ }
+
+ return retval;
+}
+
+xmlChar *
+PmmGenNsName( const xmlChar * name, const xmlChar * nsURI )
+{
+ int namelen = 0;
+ int urilen = 0;
+ xmlChar * retval = NULL;
+
+ if ( name == NULL ) {
+ return NULL;
+ }
+ namelen = xmlStrlen( name );
+
+ retval =xmlStrncat( retval, (const xmlChar *)"{", 1 );
+ if ( nsURI != NULL ) {
+ urilen = xmlStrlen( nsURI );
+ retval =xmlStrncat( retval, nsURI, urilen );
+ }
+ retval = xmlStrncat( retval, (const xmlChar *)"}", 1 );
+ retval = xmlStrncat( retval, name, namelen );
+ return retval;
+}
+
+HV *
+PmmGenAttributeHashSV( pTHX_ PmmSAXVectorPtr sax,
+ const xmlChar **attr, SV * handler )
+{
+ HV * retval = NULL;
+ HV * atV = NULL;
+ xmlNsPtr ns = NULL;
+
+ U32 atnameHash = 0;
+ int len = 0;
+
+ const xmlChar * nsURI = NULL;
+ const xmlChar **ta = attr;
+ const xmlChar * name = NULL;
+ const xmlChar * value = NULL;
+
+ xmlChar * keyname = NULL;
+ xmlChar * localname = NULL;
+ xmlChar * prefix = NULL;
+
+ retval = newHV();
+
+ if ( ta != NULL ) {
+ while ( *ta != NULL ) {
+ atV = newHV();
+ name = *ta; ta++;
+ value = *ta; ta++;
+
+ if ( name != NULL && xmlStrlen( name ) ) {
+ localname = xmlSplitQName(NULL, name, &prefix);
+
+ (void) hv_store(atV, "Name", 4,
+ _C2Sv(name, NULL), NameHash);
+ if ( value != NULL ) {
+ (void) hv_store(atV, "Value", 5,
+ _C2Sv(value, NULL), ValueHash);
+ }
+
+ if ( xmlStrEqual( (const xmlChar *)"xmlns", name ) ) {
+ /* a default namespace */
+ PmmAddNamespace( sax, NULL, value, handler);
+ /* nsURI = (const xmlChar*)NSDEFAULTURI; */
+ nsURI = NULL;
+ (void) hv_store(atV, "Name", 4,
+ _C2Sv(name, NULL), NameHash);
+
+ (void) hv_store(atV, "Prefix", 6,
+ _C2Sv((const xmlChar *)"", NULL), PrefixHash);
+ (void) hv_store(atV, "LocalName", 9,
+ _C2Sv(name,NULL), LocalNameHash);
+ (void) hv_store(atV, "NamespaceURI", 12,
+ _C2Sv((const xmlChar *)"", NULL), NsURIHash);
+
+ }
+ else if (xmlStrncmp((const xmlChar *)"xmlns:", name, 6 ) == 0 ) {
+ PmmAddNamespace( sax,
+ localname,
+ value,
+ handler);
+
+ nsURI = (const xmlChar*)NSDEFAULTURI;
+
+ (void) hv_store(atV, "Prefix", 6,
+ _C2Sv(prefix, NULL), PrefixHash);
+ (void) hv_store(atV, "LocalName", 9,
+ _C2Sv(localname, NULL), LocalNameHash);
+ (void) hv_store(atV, "NamespaceURI", 12,
+ _C2Sv((const xmlChar *)NSDEFAULTURI,NULL),
+ NsURIHash);
+ }
+ else if ( prefix != NULL
+ && (ns = PmmGetNsMapping( sax->ns_stack, prefix ) ) ) {
+ nsURI = ns->href;
+
+ (void) hv_store(atV, "NamespaceURI", 12,
+ _C2Sv(ns->href, NULL), NsURIHash);
+ (void) hv_store(atV, "Prefix", 6,
+ _C2Sv(ns->prefix, NULL), PrefixHash);
+ (void) hv_store(atV, "LocalName", 9,
+ _C2Sv(localname, NULL), LocalNameHash);
+ }
+ else {
+ nsURI = NULL;
+ (void) hv_store(atV, "NamespaceURI", 12,
+ _C2Sv((const xmlChar *)"", NULL), NsURIHash);
+ (void) hv_store(atV, "Prefix", 6,
+ _C2Sv((const xmlChar *)"", NULL), PrefixHash);
+ (void) hv_store(atV, "LocalName", 9,
+ _C2Sv(name, NULL), LocalNameHash);
+ }
+
+ keyname = PmmGenNsName( localname != NULL ? localname : name,
+ nsURI );
+
+ len = xmlStrlen( keyname );
+ PERL_HASH( atnameHash, (const char *)keyname, len );
+ (void) hv_store(retval,
+ (const char *)keyname,
+ len,
+ newRV_noinc((SV*)atV),
+ atnameHash );
+
+ if ( keyname != NULL ) {
+ xmlFree( keyname );
+ }
+ if ( localname != NULL ) {
+ xmlFree(localname);
+ }
+ localname = NULL;
+ if ( prefix != NULL ) {
+ xmlFree( prefix );
+ }
+ prefix = NULL;
+
+ }
+ }
+ }
+
+ return retval;
+}
+
+HV *
+PmmGenCharDataSV( pTHX_ PmmSAXVectorPtr sax, const xmlChar * data, int len )
+{
+ HV * retval = newHV();
+
+ if ( data != NULL && xmlStrlen( data ) ) {
+ (void) hv_store(retval, "Data", 4,
+ _C2Sv_len(data, len), DataHash);
+ }
+
+ return retval;
+}
+
+HV *
+PmmGenPISV( pTHX_ PmmSAXVectorPtr sax,
+ const xmlChar * target,
+ const xmlChar * data )
+{
+ HV * retval = newHV();
+
+ if ( target != NULL && xmlStrlen( target ) ) {
+ (void) hv_store(retval, "Target", 6,
+ _C2Sv(target, NULL), TargetHash);
+
+ if ( data != NULL && xmlStrlen( data ) ) {
+ (void) hv_store(retval, "Data", 4,
+ _C2Sv(data, NULL), DataHash);
+ }
+ else {
+ (void) hv_store(retval, "Data", 4,
+ _C2Sv((const xmlChar *)"", NULL), DataHash);
+ }
+ }
+
+ return retval;
+}
+
+HV *
+PmmGenDTDSV( pTHX_ PmmSAXVectorPtr sax,
+ const xmlChar * name,
+ const xmlChar * publicId,
+ const xmlChar * systemId )
+{
+ HV * retval = newHV();
+ if ( name != NULL && xmlStrlen( name ) ) {
+ (void) hv_store(retval, "Name", 4,
+ _C2Sv(name, NULL), NameHash);
+ }
+ if ( publicId != NULL && xmlStrlen( publicId ) ) {
+ (void) hv_store(retval, "PublicId", 8,
+ _C2Sv(publicId, NULL), PublicIdHash);
+ }
+ if ( systemId != NULL && xmlStrlen( systemId ) ) {
+ (void) hv_store(retval, "SystemId", 8,
+ _C2Sv(systemId, NULL), SystemIdHash);
+ }
+ return retval;
+}
+
+int
+PSaxStartDocument(void * ctx)
+{
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+ dTHX;
+ HV* empty;
+ SV * handler = sax->handler;
+
+ SV * rv;
+ if ( handler != NULL ) {
+
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+
+ empty = newHV();
+ PUSHMARK(SP) ;
+ XPUSHs(handler);
+ XPUSHs(sv_2mortal(newRV_noinc((SV*)empty)));
+ PUTBACK;
+
+ call_method( "start_document", G_SCALAR | G_EVAL | G_DISCARD );
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ SPAGAIN;
+
+ PUSHMARK(SP) ;
+
+
+ XPUSHs(handler);
+
+ empty = newHV();
+ if ( ctxt->version != NULL ) {
+ (void) hv_store(empty, "Version", 7,
+ _C2Sv(ctxt->version, NULL), VersionHash);
+ }
+ else {
+ (void) hv_store(empty, "Version", 7,
+ _C2Sv((const xmlChar *)"1.0", NULL), VersionHash);
+ }
+
+ if ( ctxt->input->encoding != NULL ) {
+ (void) hv_store(empty, "Encoding", 8,
+ _C2Sv(ctxt->input->encoding, NULL), EncodingHash);
+ }
+
+ rv = newRV_noinc((SV*)empty);
+ XPUSHs( rv);
+
+ PUTBACK;
+
+ call_method( "xml_decl", G_SCALAR | G_EVAL | G_DISCARD );
+ CLEAR_SERROR_HANDLER
+ sv_2mortal(rv);
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ FREETMPS ;
+ LEAVE ;
+ }
+ CLEAR_SERROR_HANDLER
+ return 1;
+}
+
+int
+PSaxEndDocument(void * ctx)
+{
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+
+ dTHX;
+ dSP;
+
+ if (sax->joinchars)
+ {
+ PSaxCharactersFlush(ctxt, sax->charbuf);
+ }
+
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(sax->parser);
+ PUTBACK;
+
+ call_pv( "XML::LibXML::_SAXParser::end_document", G_SCALAR | G_EVAL | G_DISCARD );
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ FREETMPS ;
+ LEAVE ;
+ CLEAR_SERROR_HANDLER
+ return 1;
+}
+
+int
+PSaxStartElement(void *ctx, const xmlChar * name, const xmlChar** attr)
+{
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+ dTHX;
+ HV * attrhash = NULL;
+ HV * element = NULL;
+ SV * handler = sax->handler;
+ SV * rv;
+ SV * arv;
+
+ dSP;
+
+ if (sax->joinchars)
+ {
+ PSaxCharactersFlush(ctxt, sax->charbuf);
+ }
+
+ ENTER;
+ SAVETMPS;
+
+ PmmExtendNsStack(sax, name);
+
+ attrhash = PmmGenAttributeHashSV(aTHX_ sax, attr, handler );
+ element = PmmGenElementSV(aTHX_ sax, name);
+
+ arv = newRV_noinc((SV*)attrhash);
+ (void) hv_store( element,
+ "Attributes",
+ 10,
+ arv,
+ AttributesHash );
+
+ PUSHMARK(SP) ;
+
+ XPUSHs(handler);
+ rv = newRV_noinc((SV*)element);
+ XPUSHs(rv);
+ PUTBACK;
+
+ call_method( "start_element", G_SCALAR | G_EVAL | G_DISCARD );
+ sv_2mortal(rv) ;
+
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ FREETMPS ;
+ LEAVE ;
+ CLEAR_SERROR_HANDLER
+ return 1;
+}
+
+int
+PSaxEndElement(void *ctx, const xmlChar * name) {
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+ dTHX;
+ SV * handler = sax->handler;
+ SV * rv;
+ HV * element;
+
+ dSP;
+
+ if (sax->joinchars)
+ {
+ PSaxCharactersFlush(ctxt, sax->charbuf);
+ }
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(handler);
+
+ element = PmmGenElementSV(aTHX_ sax, name);
+ rv = newRV_noinc((SV*)element);
+
+ XPUSHs(rv);
+ PUTBACK;
+
+ call_method( "end_element", G_SCALAR | G_EVAL | G_DISCARD );
+ sv_2mortal(rv);
+
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ FREETMPS ;
+ LEAVE ;
+
+ PmmNarrowNsStack(sax, handler);
+ CLEAR_SERROR_HANDLER
+ return 1;
+}
+
+int
+PSaxCharactersDispatch(void *ctx, const xmlChar * ch, int len) {
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+ dTHX;
+ HV* element;
+ SV * handler;
+ SV * rv = NULL;
+
+ if ( sax == NULL ) {
+/* warn( "lost my sax context!? ( %s, %d )\n", ch, len ); */
+ return 0;
+ }
+
+ handler = sax->handler;
+
+ if ( ch != NULL && handler != NULL ) {
+
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+
+ XPUSHs(handler);
+ element = PmmGenCharDataSV(aTHX_ sax, ch, len );
+
+ rv = newRV_noinc((SV*)element);
+ XPUSHs(rv);
+ sv_2mortal(rv);
+
+ PUTBACK;
+
+ call_method( "characters", G_SCALAR | G_EVAL | G_DISCARD );
+
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+ FREETMPS ;
+ LEAVE ;
+
+ }
+ CLEAR_SERROR_HANDLER;
+ return 1;
+}
+
+int PSaxCharactersFlush (void *ctx, struct CBuffer *buffer) {
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+ xmlChar *ch;
+ int len;
+
+ if (buffer->head->data == NULL) {
+ return 1;
+ }
+
+ ch = CBufferCharacters(sax->charbuf);
+ len = CBufferLength(sax->charbuf);
+
+ CBufferPurge(buffer);
+
+ return PSaxCharactersDispatch(ctx, ch, len);
+}
+
+int PSaxCharacters (void *ctx, const xmlChar * ch, int len) {
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+
+ if (sax->joinchars) {
+ struct CBuffer *buffer = sax->charbuf;
+ CBufferAppend(buffer, ch, len);
+ return 1;
+ }
+
+ return PSaxCharactersDispatch(ctx, ch, len);
+}
+
+int
+PSaxComment(void *ctx, const xmlChar * ch) {
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+ dTHX;
+ HV* element;
+ SV * handler = sax->handler;
+
+ SV * rv = NULL;
+
+ if ( ch != NULL && handler != NULL ) {
+ dSP;
+
+ int len = xmlStrlen( ch );
+
+ if (sax->joinchars)
+ {
+ PSaxCharactersFlush(ctxt, sax->charbuf);
+ }
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(handler);
+ element = PmmGenCharDataSV(aTHX_ sax, ch, len);
+
+ rv = newRV_noinc((SV*)element);
+ XPUSHs(rv);
+ PUTBACK;
+
+ call_method( "comment", G_SCALAR | G_EVAL | G_DISCARD );
+ sv_2mortal(rv);
+
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ FREETMPS ;
+ LEAVE ;
+ }
+ CLEAR_SERROR_HANDLER
+ return 1;
+}
+
+int
+PSaxCDATABlock(void *ctx, const xmlChar * ch, int len) {
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+ dTHX;
+
+ HV* element;
+ SV * handler = sax->handler;
+
+ SV * rv = NULL;
+
+ if ( ch != NULL && handler != NULL ) {
+ dSP;
+
+ if (sax->joinchars)
+ {
+ PSaxCharactersFlush(ctxt, sax->charbuf);
+ }
+
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(handler);
+ PUTBACK;
+ call_method( "start_cdata", G_SCALAR | G_EVAL | G_DISCARD );
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ SPAGAIN;
+ PUSHMARK(SP) ;
+
+ XPUSHs(handler);
+ element = PmmGenCharDataSV(aTHX_ sax, ch, len);
+
+ rv = newRV_noinc((SV*)element);
+ XPUSHs(rv);
+ PUTBACK;
+
+ call_method( "characters", G_SCALAR | G_EVAL | G_DISCARD);
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ SPAGAIN;
+ PUSHMARK(SP) ;
+
+ XPUSHs(handler);
+ PUTBACK;
+
+ call_method( "end_cdata", G_SCALAR | G_EVAL | G_DISCARD );
+ sv_2mortal(rv);
+
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ FREETMPS ;
+ LEAVE ;
+
+ }
+ CLEAR_SERROR_HANDLER
+ return 1;
+
+}
+
+int
+PSaxProcessingInstruction( void * ctx, const xmlChar * target, const xmlChar * data )
+{
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+ dTHX;
+ SV * handler = sax->handler;
+
+ SV * element;
+ SV * rv = NULL;
+
+ if ( handler != NULL ) {
+ dSP;
+
+ if (sax->joinchars)
+ {
+ PSaxCharactersFlush(ctxt, sax->charbuf);
+ }
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(handler);
+ element = (SV*)PmmGenPISV(aTHX_ sax, (const xmlChar *)target, data);
+ rv = newRV_noinc((SV*)element);
+ XPUSHs(rv);
+
+ PUTBACK;
+
+ call_method( "processing_instruction", G_SCALAR | G_EVAL | G_DISCARD );
+
+ sv_2mortal(rv);
+
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ FREETMPS ;
+ LEAVE ;
+ }
+ CLEAR_SERROR_HANDLER
+ return 1;
+}
+
+void PSaxExternalSubset (void * ctx,
+ const xmlChar * name,
+ const xmlChar * ExternalID,
+ const xmlChar * SystemID)
+{
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+ dTHX;
+ SV * handler = sax->handler;
+
+ SV * element;
+ SV * rv = NULL;
+
+ if ( handler != NULL ) {
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(handler);
+ element = (SV*)PmmGenDTDSV(aTHX_ sax,
+ name,
+ ExternalID,
+ SystemID);
+ rv = newRV_noinc((SV*)element);
+ XPUSHs(rv);
+
+ PUTBACK;
+
+ call_method( "start_dtd", G_SCALAR | G_EVAL | G_DISCARD );
+ sv_2mortal(rv);
+
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ PUSHMARK(SP) ;
+ XPUSHs(handler);
+ rv = newRV_noinc((SV*)newHV()); /* empty */
+ XPUSHs(rv);
+
+ PUTBACK;
+
+ call_method( "end_dtd", G_SCALAR | G_EVAL | G_DISCARD );
+
+ FREETMPS ;
+ LEAVE ;
+ }
+ CLEAR_SERROR_HANDLER
+ return;
+}
+
+
+/*
+
+void PSaxInternalSubset (void * ctx,
+ const xmlChar * name,
+ const xmlChar * ExternalID,
+ const xmlChar * SystemID)
+{
+ // called before ExternalSubset
+ // if used, how do we generate the correct start_dtd ?
+}
+
+void PSaxElementDecl (void *ctx, const xmlChar *name,
+ int type,
+ xmlElementContentPtr content) {
+ // this one is not easy to implement
+ // since libxml2 has no (reliable) public method
+ // for dumping xmlElementContent :-(
+}
+
+void
+PSaxAttributeDecl (void * ctx,
+ const xmlChar * elem,
+ const xmlChar * fullname,
+ int type,
+ int def,
+ const xmlChar * defaultValue,
+ xmlEnumerationPtr tree)
+{
+}
+
+void
+PSaxEntityDecl (void * ctx,
+ const xmlChar * name,
+ int type,
+ const xmlChar * publicId,
+ const xmlChar * systemId,
+ xmlChar * content)
+{
+}
+
+void
+PSaxNotationDecl (void * ctx,
+ const xmlChar * name,
+ const xmlChar * publicId,
+ const xmlChar * systemId)
+{
+}
+
+void
+PSaxUnparsedEntityDecl (void * ctx,
+ const xmlChar * name,
+ const xmlChar * publicId,
+ const xmlChar * systemId,
+ const xmlChar * notationName)
+{
+}
+*/
+
+int
+PmmSaxWarning(void * ctx, const char * msg, ...)
+{
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+
+ va_list args;
+ SV * svMessage;
+
+ dTHX;
+ dSP;
+ svMessage = NEWSV(0,512);
+
+ va_start(args, msg);
+ sv_vsetpvfn(svMessage,
+ msg,
+ xmlStrlen((const xmlChar *)msg),
+ &args,
+ NULL,
+ 0,
+ NULL);
+ va_end(args);
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(sax->parser);
+
+ XPUSHs(sv_2mortal(svMessage));
+ XPUSHs(sv_2mortal(newSViv(ctxt->input->line)));
+ XPUSHs(sv_2mortal(newSViv(ctxt->input->col)));
+
+ PUTBACK;
+
+ call_pv( "XML::LibXML::_SAXParser::warning", G_SCALAR | G_EVAL | G_DISCARD );
+
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ FREETMPS ;
+ LEAVE ;
+ CLEAR_SERROR_HANDLER
+ return 1;
+}
+
+
+int
+PmmSaxError(void * ctx, const char * msg, ...)
+{
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+
+ va_list args;
+ SV * svMessage;
+
+#if LIBXML_VERSION > 20600
+ xmlErrorPtr last_err = xmlCtxtGetLastError( ctxt );
+#endif
+ dTHX;
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+
+ XPUSHs(sax->parser);
+
+ svMessage = NEWSV(0,512);
+
+ va_start(args, msg);
+ sv_vsetpvfn(svMessage, msg, xmlStrlen((const xmlChar *)msg), &args, NULL, 0, NULL);
+ va_end(args);
+ if (SvOK(sax->saved_error)) {
+ sv_catsv( sax->saved_error, svMessage );
+ } else {
+ sv_setsv( sax->saved_error, svMessage );
+ }
+ XPUSHs(sv_2mortal(svMessage));
+ XPUSHs(sv_2mortal(newSViv(ctxt->input->line)));
+ XPUSHs(sv_2mortal(newSViv(ctxt->input->col)));
+
+ PUTBACK;
+#if LIBXML_VERSION > 20600
+ /*
+ this is a workaround: at least some versions of libxml2 didn't not call
+ the fatalError callback at all
+ */
+ if (last_err && last_err->level == XML_ERR_FATAL) {
+ call_pv( "XML::LibXML::_SAXParser::fatal_error", G_SCALAR | G_EVAL | G_DISCARD );
+ } else {
+ call_pv( "XML::LibXML::_SAXParser::error", G_SCALAR | G_EVAL | G_DISCARD );
+ }
+#else
+ /* actually, we do not know if it is a fatal error or not */
+ call_pv( "XML::LibXML::_SAXParser::fatal_error", G_SCALAR | G_EVAL | G_DISCARD );
+#endif
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ FREETMPS ;
+ LEAVE ;
+ CLEAR_SERROR_HANDLER
+ return 1;
+}
+
+
+int
+PmmSaxFatalError(void * ctx, const char * msg, ...)
+{
+ xmlParserCtxtPtr ctxt = (xmlParserCtxtPtr)ctx;
+ PmmSAXVectorPtr sax = (PmmSAXVectorPtr)ctxt->_private;
+
+ va_list args;
+ SV * svMessage;
+
+ dTHX;
+ dSP;
+
+ svMessage = NEWSV(0,512);
+
+ va_start(args, msg);
+ sv_vsetpvfn(svMessage, msg, xmlStrlen((const xmlChar *)msg), &args, NULL, 0, NULL);
+ va_end(args);
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP) ;
+ XPUSHs(sax->parser);
+
+ if (SvOK(sax->saved_error)) {
+ sv_catsv( sax->saved_error, svMessage );
+ } else {
+ sv_setsv( sax->saved_error, svMessage );
+ }
+
+ XPUSHs(sv_2mortal(svMessage));
+ XPUSHs(sv_2mortal(newSViv(ctxt->input->line)));
+ XPUSHs(sv_2mortal(newSViv(ctxt->input->col)));
+
+ PUTBACK;
+ call_pv( "XML::LibXML::_SAXParser::fatal_error", G_SCALAR | G_EVAL | G_DISCARD );
+ if (SvTRUE(ERRSV)) {
+ croak_obj;
+ }
+
+ FREETMPS ;
+ LEAVE ;
+ CLEAR_SERROR_HANDLER
+ return 1;
+}
+
+/* NOTE:
+ * end document is not handled by the parser itself! use
+ * XML::LibXML::SAX instead!
+ */
+xmlSAXHandlerPtr
+PSaxGetHandler()
+{
+ xmlSAXHandlerPtr retval = (xmlSAXHandlerPtr)xmlMalloc(sizeof(xmlSAXHandler));
+ memset(retval, 0, sizeof(xmlSAXHandler));
+
+ retval->startDocument = (startDocumentSAXFunc)&PSaxStartDocument;
+
+ /* libxml2 will not handle perls returnvalue correctly, so we have
+ * to end the document ourselfes
+ */
+ retval->endDocument = NULL; /* (endDocumentSAXFunc)&PSaxEndDocument; */
+
+ retval->startElement = (startElementSAXFunc)&PSaxStartElement;
+ retval->endElement = (endElementSAXFunc)&PSaxEndElement;
+
+ retval->characters = (charactersSAXFunc)&PSaxCharacters;
+ retval->ignorableWhitespace = (ignorableWhitespaceSAXFunc)&PSaxCharacters;
+
+ retval->comment = (commentSAXFunc)&PSaxComment;
+ retval->cdataBlock = (cdataBlockSAXFunc)&PSaxCDATABlock;
+
+ retval->processingInstruction = (processingInstructionSAXFunc)&PSaxProcessingInstruction;
+
+ /* warning functions should be internal */
+ retval->warning = (warningSAXFunc)&PmmSaxWarning;
+ retval->error = (errorSAXFunc)&PmmSaxError;
+ retval->fatalError = (fatalErrorSAXFunc)&PmmSaxFatalError;
+
+ retval->externalSubset = (externalSubsetSAXFunc)&PSaxExternalSubset;
+
+ /*
+ retval->internalSubset = (internalSubsetSAXFunc)&PSaxInternalSubset;
+ retval->elementDecl = (elementDeclSAXFunc)&PSaxElementDecl;
+ retval->entityDecl = (entityDeclSAXFunc)&PSaxEntityDecl;
+ retval->notationDecl = (notationDeclSAXFunc)&PSaxNotationDecl;
+ retval->attributeDecl = (attributeDeclSAXFunc)&PSaxAttributeDecl;
+ retval->unparsedEntityDecl = (unparsedEntityDeclSAXFunc)&PSaxUnparsedEntityDecl;
+ */
+
+ return retval;
+}
+
@@ -0,0 +1,43 @@
+/**
+ * perl-libxml-sax.h
+ * $Id$
+ */
+
+#ifndef __PERL_LIBXML_SAX_H__
+#define __PERL_LIBXML_SAX_H__
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include <libxml/tree.h>
+
+#ifdef __cplusplus
+}
+#endif
+
+
+/*
+ * auxiliary macro to serve as an croak(NULL)
+ * unlike croak(NULL), this version does not produce
+ * a warning (see the perlapi for the meaning of croak(NULL))
+ *
+ */
+
+#define croak_obj Perl_croak(aTHX_ NULL)
+
+
+/* has to be called in BOOT sequence */
+void
+PmmSAXInitialize(pTHX);
+
+void
+PmmSAXInitContext( xmlParserCtxtPtr ctxt, SV * parser, SV * saved_error );
+
+void
+PmmSAXCloseContext( xmlParserCtxtPtr ctxt );
+
+xmlSAXHandlerPtr
+PSaxGetHandler();
+
+#endif
@@ -0,0 +1,4954 @@
+#if 0
+<<'SKIP';
+#endif
+/*
+----------------------------------------------------------------------
+
+ ppport.h -- Perl/Pollution/Portability Version 3.06_01
+
+ Automatically created by Devel::PPPort running under
+ perl 5.008008 on Sat Jul 1 13:49:34 2006.
+
+ Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
+ includes in parts/inc/ instead.
+
+ Use 'perldoc ppport.h' to view the documentation below.
+
+----------------------------------------------------------------------
+
+SKIP
+
+=pod
+
+=head1 NAME
+
+ppport.h - Perl/Pollution/Portability version 3.06_01
+
+=head1 SYNOPSIS
+
+ perl ppport.h [options] [source files]
+
+ Searches current directory for files if no [source files] are given
+
+ --help show short help
+
+ --patch=file write one patch file with changes
+ --copy=suffix write changed copies with suffix
+ --diff=program use diff program and options
+
+ --compat-version=version provide compatibility with Perl version
+ --cplusplus accept C++ comments
+
+ --quiet don't output anything except fatal errors
+ --nodiag don't show diagnostics
+ --nohints don't show hints
+ --nochanges don't suggest changes
+ --nofilter don't filter input files
+
+ --list-provided list provided API
+ --list-unsupported list unsupported API
+ --api-info=name show Perl API portability information
+
+=head1 COMPATIBILITY
+
+This version of F<ppport.h> is designed to support operation with Perl
+installations back to 5.003, and has been tested up to 5.9.3.
+
+=head1 OPTIONS
+
+=head2 --help
+
+Display a brief usage summary.
+
+=head2 --patch=I<file>
+
+If this option is given, a single patch file will be created if
+any changes are suggested. This requires a working diff program
+to be installed on your system.
+
+=head2 --copy=I<suffix>
+
+If this option is given, a copy of each file will be saved with
+the given suffix that contains the suggested changes. This does
+not require any external programs.
+
+If neither C<--patch> or C<--copy> are given, the default is to
+simply print the diffs for each file. This requires either
+C<Text::Diff> or a C<diff> program to be installed.
+
+=head2 --diff=I<program>
+
+Manually set the diff program and options to use. The default
+is to use C<Text::Diff>, when installed, and output unified
+context diffs.
+
+=head2 --compat-version=I<version>
+
+Tell F<ppport.h> to check for compatibility with the given
+Perl version. The default is to check for compatibility with Perl
+version 5.003. You can use this option to reduce the output
+of F<ppport.h> if you intend to be backward compatible only
+up to a certain Perl version.
+
+=head2 --cplusplus
+
+Usually, F<ppport.h> will detect C++ style comments and
+replace them with C style comments for portability reasons.
+Using this option instructs F<ppport.h> to leave C++
+comments untouched.
+
+=head2 --quiet
+
+Be quiet. Don't print anything except fatal errors.
+
+=head2 --nodiag
+
+Don't output any diagnostic messages. Only portability
+alerts will be printed.
+
+=head2 --nohints
+
+Don't output any hints. Hints often contain useful portability
+notes.
+
+=head2 --nochanges
+
+Don't suggest any changes. Only give diagnostic output and hints
+unless these are also deactivated.
+
+=head2 --nofilter
+
+Don't filter the list of input files. By default, files not looking
+like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped.
+
+=head2 --list-provided
+
+Lists the API elements for which compatibility is provided by
+F<ppport.h>. Also lists if it must be explicitly requested,
+if it has dependencies, and if there are hints for it.
+
+=head2 --list-unsupported
+
+Lists the API elements that are known not to be supported by
+F<ppport.h> and below which version of Perl they probably
+won't be available or work.
+
+=head2 --api-info=I<name>
+
+Show portability information for API elements matching I<name>.
+If I<name> is surrounded by slashes, it is interpreted as a regular
+expression.
+
+=head1 DESCRIPTION
+
+In order for a Perl extension (XS) module to be as portable as possible
+across differing versions of Perl itself, certain steps need to be taken.
+
+=over 4
+
+=item *
+
+Including this header is the first major one. This alone will give you
+access to a large part of the Perl API that hasn't been available in
+earlier Perl releases. Use
+
+ perl ppport.h --list-provided
+
+to see which API elements are provided by ppport.h.
+
+=item *
+
+You should avoid using deprecated parts of the API. For example, using
+global Perl variables without the C<PL_> prefix is deprecated. Also,
+some API functions used to have a C<perl_> prefix. Using this form is
+also deprecated. You can safely use the supported API, as F<ppport.h>
+will provide wrappers for older Perl versions.
+
+=item *
+
+If you use one of a few functions that were not present in earlier
+versions of Perl, and that can't be provided using a macro, you have
+to explicitly request support for these functions by adding one or
+more C<#define>s in your source code before the inclusion of F<ppport.h>.
+
+These functions will be marked C<explicit> in the list shown by
+C<--list-provided>.
+
+Depending on whether you module has a single or multiple files that
+use such functions, you want either C<static> or global variants.
+
+For a C<static> function, use:
+
+ #define NEED_function
+
+For a global function, use:
+
+ #define NEED_function_GLOBAL
+
+Note that you mustn't have more than one global request for one
+function in your project.
+
+ Function Static Request Global Request
+ -----------------------------------------------------------------------------------------
+ eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
+ grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
+ grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
+ grok_number() NEED_grok_number NEED_grok_number_GLOBAL
+ grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
+ grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
+ newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
+ newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
+ sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL
+ sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL
+ sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL
+ sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL
+ sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL
+ sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL
+ vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL
+
+To avoid namespace conflicts, you can change the namespace of the
+explicitly exported functions using the C<DPPP_NAMESPACE> macro.
+Just C<#define> the macro before including C<ppport.h>:
+
+ #define DPPP_NAMESPACE MyOwnNamespace_
+ #include "ppport.h"
+
+The default namespace is C<DPPP_>.
+
+=back
+
+The good thing is that most of the above can be checked by running
+F<ppport.h> on your source code. See the next section for
+details.
+
+=head1 EXAMPLES
+
+To verify whether F<ppport.h> is needed for your module, whether you
+should make any changes to your code, and whether any special defines
+should be used, F<ppport.h> can be run as a Perl script to check your
+source code. Simply say:
+
+ perl ppport.h
+
+The result will usually be a list of patches suggesting changes
+that should at least be acceptable, if not necessarily the most
+efficient solution, or a fix for all possible problems.
+
+If you know that your XS module uses features only available in
+newer Perl releases, if you're aware that it uses C++ comments,
+and if you want all suggestions as a single patch file, you could
+use something like this:
+
+ perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
+
+If you only want your code to be scanned without any suggestions
+for changes, use:
+
+ perl ppport.h --nochanges
+
+You can specify a different C<diff> program or options, using
+the C<--diff> option:
+
+ perl ppport.h --diff='diff -C 10'
+
+This would output context diffs with 10 lines of context.
+
+To display portability information for the C<newSVpvn> function,
+use:
+
+ perl ppport.h --api-info=newSVpvn
+
+Since the argument to C<--api-info> can be a regular expression,
+you can use
+
+ perl ppport.h --api-info=/_nomg$/
+
+to display portability information for all C<_nomg> functions or
+
+ perl ppport.h --api-info=/./
+
+to display information for all known API elements.
+
+=head1 BUGS
+
+If this version of F<ppport.h> is causing failure during
+the compilation of this module, please check if newer versions
+of either this module or C<Devel::PPPort> are available on CPAN
+before sending a bug report.
+
+If F<ppport.h> was generated using the latest version of
+C<Devel::PPPort> and is causing failure of this module, please
+file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
+
+Please include the following information:
+
+=over 4
+
+=item 1.
+
+The complete output from running "perl -V"
+
+=item 2.
+
+This file.
+
+=item 3.
+
+The name and version of the module you were trying to build.
+
+=item 4.
+
+A full log of the build that failed.
+
+=item 5.
+
+Any other information that you think could be relevant.
+
+=back
+
+For the latest version of this code, please get the C<Devel::PPPort>
+module from CPAN.
+
+=head1 COPYRIGHT
+
+Version 3.x, Copyright (c) 2004-2005, Marcus Holland-Moritz.
+
+Version 2.x, Copyright (C) 2001, Paul Marquess.
+
+Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+See L<Devel::PPPort>.
+
+=cut
+
+use strict;
+
+my %opt = (
+ quiet => 0,
+ diag => 1,
+ hints => 1,
+ changes => 1,
+ cplusplus => 0,
+ filter => 1,
+);
+
+my($ppport) = $0 =~ /([\w.]+)$/;
+my $LF = '(?:\r\n|[\r\n])'; # line feed
+my $HS = "[ \t]"; # horizontal whitespace
+
+eval {
+ require Getopt::Long;
+ Getopt::Long::GetOptions(\%opt, qw(
+ help quiet diag! filter! hints! changes! cplusplus
+ patch=s copy=s diff=s compat-version=s
+ list-provided list-unsupported api-info=s
+ )) or usage();
+};
+
+if ($@ and grep /^-/, @ARGV) {
+ usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
+ die "Getopt::Long not found. Please don't use any options.\n";
+}
+
+usage() if $opt{help};
+
+if (exists $opt{'compat-version'}) {
+ my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
+ if ($@) {
+ die "Invalid version number format: '$opt{'compat-version'}'\n";
+ }
+ die "Only Perl 5 is supported\n" if $r != 5;
+ die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
+ $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
+}
+else {
+ $opt{'compat-version'} = 5;
+}
+
+# Never use C comments in this file!!!!!
+my $ccs = '/'.'*';
+my $cce = '*'.'/';
+my $rccs = quotemeta $ccs;
+my $rcce = quotemeta $cce;
+
+my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
+ ? ( $1 => {
+ ($2 ? ( base => $2 ) : ()),
+ ($3 ? ( todo => $3 ) : ()),
+ (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
+ (index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
+ (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
+ } )
+ : die "invalid spec: $_" } qw(
+AvFILLp|5.004050||p
+AvFILL|||
+CLASS|||n
+CX_CURPAD_SAVE|||
+CX_CURPAD_SV|||
+CopFILEAV|5.006000||p
+CopFILEGV_set|5.006000||p
+CopFILEGV|5.006000||p
+CopFILESV|5.006000||p
+CopFILE_set|5.006000||p
+CopFILE|5.006000||p
+CopSTASHPV_set|5.006000||p
+CopSTASHPV|5.006000||p
+CopSTASH_eq|5.006000||p
+CopSTASH_set|5.006000||p
+CopSTASH|5.006000||p
+CopyD|5.009002||p
+Copy|||
+CvPADLIST|||
+CvSTASH|||
+CvWEAKOUTSIDE|||
+DEFSV|5.004050||p
+END_EXTERN_C|5.005000||p
+ENTER|||
+ERRSV|5.004050||p
+EXTEND|||
+EXTERN_C|5.005000||p
+FREETMPS|||
+GIMME_V||5.004000|n
+GIMME|||n
+GROK_NUMERIC_RADIX|5.007002||p
+G_ARRAY|||
+G_DISCARD|||
+G_EVAL|||
+G_NOARGS|||
+G_SCALAR|||
+G_VOID||5.004000|
+GetVars|||
+GvSV|||
+Gv_AMupdate|||
+HEf_SVKEY||5.004000|
+HeHASH||5.004000|
+HeKEY||5.004000|
+HeKLEN||5.004000|
+HePV||5.004000|
+HeSVKEY_force||5.004000|
+HeSVKEY_set||5.004000|
+HeSVKEY||5.004000|
+HeVAL||5.004000|
+HvNAME|||
+INT2PTR|5.006000||p
+IN_LOCALE_COMPILETIME|5.007002||p
+IN_LOCALE_RUNTIME|5.007002||p
+IN_LOCALE|5.007002||p
+IN_PERL_COMPILETIME|5.008001||p
+IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p
+IS_NUMBER_INFINITY|5.007002||p
+IS_NUMBER_IN_UV|5.007002||p
+IS_NUMBER_NAN|5.007003||p
+IS_NUMBER_NEG|5.007002||p
+IS_NUMBER_NOT_INT|5.007002||p
+IVSIZE|5.006000||p
+IVTYPE|5.006000||p
+IVdf|5.006000||p
+LEAVE|||
+LVRET|||
+MARK|||
+MY_CXT_CLONE|5.009002||p
+MY_CXT_INIT|5.007003||p
+MY_CXT|5.007003||p
+MoveD|5.009002||p
+Move|||
+NEWSV|||
+NOOP|5.005000||p
+NUM2PTR|5.006000||p
+NVTYPE|5.006000||p
+NVef|5.006001||p
+NVff|5.006001||p
+NVgf|5.006001||p
+Newc|||
+Newz|||
+New|||
+Nullav|||
+Nullch|||
+Nullcv|||
+Nullhv|||
+Nullsv|||
+ORIGMARK|||
+PAD_BASE_SV|||
+PAD_CLONE_VARS|||
+PAD_COMPNAME_FLAGS|||
+PAD_COMPNAME_GEN_set|||
+PAD_COMPNAME_GEN|||
+PAD_COMPNAME_OURSTASH|||
+PAD_COMPNAME_PV|||
+PAD_COMPNAME_TYPE|||
+PAD_RESTORE_LOCAL|||
+PAD_SAVE_LOCAL|||
+PAD_SAVE_SETNULLPAD|||
+PAD_SETSV|||
+PAD_SET_CUR_NOSAVE|||
+PAD_SET_CUR|||
+PAD_SVl|||
+PAD_SV|||
+PERL_BCDVERSION|5.009003||p
+PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
+PERL_INT_MAX|5.004000||p
+PERL_INT_MIN|5.004000||p
+PERL_LONG_MAX|5.004000||p
+PERL_LONG_MIN|5.004000||p
+PERL_MAGIC_arylen|5.007002||p
+PERL_MAGIC_backref|5.007002||p
+PERL_MAGIC_bm|5.007002||p
+PERL_MAGIC_collxfrm|5.007002||p
+PERL_MAGIC_dbfile|5.007002||p
+PERL_MAGIC_dbline|5.007002||p
+PERL_MAGIC_defelem|5.007002||p
+PERL_MAGIC_envelem|5.007002||p
+PERL_MAGIC_env|5.007002||p
+PERL_MAGIC_ext|5.007002||p
+PERL_MAGIC_fm|5.007002||p
+PERL_MAGIC_glob|5.007002||p
+PERL_MAGIC_isaelem|5.007002||p
+PERL_MAGIC_isa|5.007002||p
+PERL_MAGIC_mutex|5.007002||p
+PERL_MAGIC_nkeys|5.007002||p
+PERL_MAGIC_overload_elem|5.007002||p
+PERL_MAGIC_overload_table|5.007002||p
+PERL_MAGIC_overload|5.007002||p
+PERL_MAGIC_pos|5.007002||p
+PERL_MAGIC_qr|5.007002||p
+PERL_MAGIC_regdata|5.007002||p
+PERL_MAGIC_regdatum|5.007002||p
+PERL_MAGIC_regex_global|5.007002||p
+PERL_MAGIC_shared_scalar|5.007003||p
+PERL_MAGIC_shared|5.007003||p
+PERL_MAGIC_sigelem|5.007002||p
+PERL_MAGIC_sig|5.007002||p
+PERL_MAGIC_substr|5.007002||p
+PERL_MAGIC_sv|5.007002||p
+PERL_MAGIC_taint|5.007002||p
+PERL_MAGIC_tiedelem|5.007002||p
+PERL_MAGIC_tiedscalar|5.007002||p
+PERL_MAGIC_tied|5.007002||p
+PERL_MAGIC_utf8|5.008001||p
+PERL_MAGIC_uvar_elem|5.007003||p
+PERL_MAGIC_uvar|5.007002||p
+PERL_MAGIC_vec|5.007002||p
+PERL_MAGIC_vstring|5.008001||p
+PERL_QUAD_MAX|5.004000||p
+PERL_QUAD_MIN|5.004000||p
+PERL_REVISION|5.006000||p
+PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p
+PERL_SCAN_DISALLOW_PREFIX|5.007003||p
+PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p
+PERL_SCAN_SILENT_ILLDIGIT|5.008001||p
+PERL_SHORT_MAX|5.004000||p
+PERL_SHORT_MIN|5.004000||p
+PERL_SUBVERSION|5.006000||p
+PERL_UCHAR_MAX|5.004000||p
+PERL_UCHAR_MIN|5.004000||p
+PERL_UINT_MAX|5.004000||p
+PERL_UINT_MIN|5.004000||p
+PERL_ULONG_MAX|5.004000||p
+PERL_ULONG_MIN|5.004000||p
+PERL_UNUSED_DECL|5.007002||p
+PERL_UQUAD_MAX|5.004000||p
+PERL_UQUAD_MIN|5.004000||p
+PERL_USHORT_MAX|5.004000||p
+PERL_USHORT_MIN|5.004000||p
+PERL_VERSION|5.006000||p
+PL_DBsingle|||pn
+PL_DBsub|||pn
+PL_DBtrace|||n
+PL_Sv|5.005000||p
+PL_compiling|5.004050||p
+PL_copline|5.005000||p
+PL_curcop|5.004050||p
+PL_curstash|5.004050||p
+PL_debstash|5.004050||p
+PL_defgv|5.004050||p
+PL_diehook|5.004050||p
+PL_dirty|5.004050||p
+PL_dowarn|||pn
+PL_errgv|5.004050||p
+PL_hexdigit|5.005000||p
+PL_hints|5.005000||p
+PL_last_in_gv|||n
+PL_modglobal||5.005000|n
+PL_na|5.004050||pn
+PL_no_modify|5.006000||p
+PL_ofs_sv|||n
+PL_perl_destruct_level|5.004050||p
+PL_perldb|5.004050||p
+PL_ppaddr|5.006000||p
+PL_rsfp_filters|5.004050||p
+PL_rsfp|5.004050||p
+PL_rs|||n
+PL_stack_base|5.004050||p
+PL_stack_sp|5.004050||p
+PL_stdingv|5.004050||p
+PL_sv_arenaroot|5.004050||p
+PL_sv_no|5.004050||pn
+PL_sv_undef|5.004050||pn
+PL_sv_yes|5.004050||pn
+PL_tainted|5.004050||p
+PL_tainting|5.004050||p
+POPi|||n
+POPl|||n
+POPn|||n
+POPpbytex||5.007001|n
+POPpx||5.005030|n
+POPp|||n
+POPs|||n
+PTR2IV|5.006000||p
+PTR2NV|5.006000||p
+PTR2UV|5.006000||p
+PTR2ul|5.007001||p
+PTRV|5.006000||p
+PUSHMARK|||
+PUSHi|||
+PUSHmortal|5.009002||p
+PUSHn|||
+PUSHp|||
+PUSHs|||
+PUSHu|5.004000||p
+PUTBACK|||
+PerlIO_clearerr||5.007003|
+PerlIO_close||5.007003|
+PerlIO_eof||5.007003|
+PerlIO_error||5.007003|
+PerlIO_fileno||5.007003|
+PerlIO_fill||5.007003|
+PerlIO_flush||5.007003|
+PerlIO_get_base||5.007003|
+PerlIO_get_bufsiz||5.007003|
+PerlIO_get_cnt||5.007003|
+PerlIO_get_ptr||5.007003|
+PerlIO_read||5.007003|
+PerlIO_seek||5.007003|
+PerlIO_set_cnt||5.007003|
+PerlIO_set_ptrcnt||5.007003|
+PerlIO_setlinebuf||5.007003|
+PerlIO_stderr||5.007003|
+PerlIO_stdin||5.007003|
+PerlIO_stdout||5.007003|
+PerlIO_tell||5.007003|
+PerlIO_unread||5.007003|
+PerlIO_write||5.007003|
+Poison|5.008000||p
+RETVAL|||n
+Renewc|||
+Renew|||
+SAVECLEARSV|||
+SAVECOMPPAD|||
+SAVEPADSV|||
+SAVETMPS|||
+SAVE_DEFSV|5.004050||p
+SPAGAIN|||
+SP|||
+START_EXTERN_C|5.005000||p
+START_MY_CXT|5.007003||p
+STMT_END|||p
+STMT_START|||p
+ST|||
+SVt_IV|||
+SVt_NV|||
+SVt_PVAV|||
+SVt_PVCV|||
+SVt_PVHV|||
+SVt_PVMG|||
+SVt_PV|||
+Safefree|||
+Slab_Alloc|||
+Slab_Free|||
+StructCopy|||
+SvCUR_set|||
+SvCUR|||
+SvEND|||
+SvGETMAGIC|5.004050||p
+SvGROW|||
+SvIOK_UV||5.006000|
+SvIOK_notUV||5.006000|
+SvIOK_off|||
+SvIOK_only_UV||5.006000|
+SvIOK_only|||
+SvIOK_on|||
+SvIOKp|||
+SvIOK|||
+SvIVX|||
+SvIV_nomg|5.009001||p
+SvIV_set|||
+SvIVx|||
+SvIV|||
+SvIsCOW_shared_hash||5.008003|
+SvIsCOW||5.008003|
+SvLEN_set|||
+SvLEN|||
+SvLOCK||5.007003|
+SvMAGIC_set||5.009003|
+SvNIOK_off|||
+SvNIOKp|||
+SvNIOK|||
+SvNOK_off|||
+SvNOK_only|||
+SvNOK_on|||
+SvNOKp|||
+SvNOK|||
+SvNVX|||
+SvNV_set|||
+SvNVx|||
+SvNV|||
+SvOK|||
+SvOOK|||
+SvPOK_off|||
+SvPOK_only_UTF8||5.006000|
+SvPOK_only|||
+SvPOK_on|||
+SvPOKp|||
+SvPOK|||
+SvPVX|||
+SvPV_force_nomg|5.007002||p
+SvPV_force|||
+SvPV_nolen|5.006000||p
+SvPV_nomg|5.007002||p
+SvPV_set|||
+SvPVbyte_force||5.009002|
+SvPVbyte_nolen||5.006000|
+SvPVbytex_force||5.006000|
+SvPVbytex||5.006000|
+SvPVbyte|5.006000||p
+SvPVutf8_force||5.006000|
+SvPVutf8_nolen||5.006000|
+SvPVutf8x_force||5.006000|
+SvPVutf8x||5.006000|
+SvPVutf8||5.006000|
+SvPVx|||
+SvPV|||
+SvREFCNT_dec|||
+SvREFCNT_inc|||
+SvREFCNT|||
+SvROK_off|||
+SvROK_on|||
+SvROK|||
+SvRV_set||5.009003|
+SvRV|||
+SvSETMAGIC|||
+SvSHARE||5.007003|
+SvSTASH_set||5.009003|
+SvSTASH|||
+SvSetMagicSV_nosteal||5.004000|
+SvSetMagicSV||5.004000|
+SvSetSV_nosteal||5.004000|
+SvSetSV|||
+SvTAINTED_off||5.004000|
+SvTAINTED_on||5.004000|
+SvTAINTED||5.004000|
+SvTAINT|||
+SvTRUE|||
+SvTYPE|||
+SvUNLOCK||5.007003|
+SvUOK||5.007001|
+SvUPGRADE|||
+SvUTF8_off||5.006000|
+SvUTF8_on||5.006000|
+SvUTF8||5.006000|
+SvUVXx|5.004000||p
+SvUVX|5.004000||p
+SvUV_nomg|5.009001||p
+SvUV_set||5.009003|
+SvUVx|5.004000||p
+SvUV|5.004000||p
+SvVOK||5.008001|
+THIS|||n
+UNDERBAR|5.009002||p
+UVSIZE|5.006000||p
+UVTYPE|5.006000||p
+UVXf|5.007001||p
+UVof|5.006000||p
+UVuf|5.006000||p
+UVxf|5.006000||p
+XCPT_CATCH|5.009002||p
+XCPT_RETHROW|5.009002||p
+XCPT_TRY_END|5.009002||p
+XCPT_TRY_START|5.009002||p
+XPUSHi|||
+XPUSHmortal|5.009002||p
+XPUSHn|||
+XPUSHp|||
+XPUSHs|||
+XPUSHu|5.004000||p
+XSRETURN_EMPTY|||
+XSRETURN_IV|||
+XSRETURN_NO|||
+XSRETURN_NV|||
+XSRETURN_PV|||
+XSRETURN_UNDEF|||
+XSRETURN_UV|5.008001||p
+XSRETURN_YES|||
+XSRETURN|||
+XST_mIV|||
+XST_mNO|||
+XST_mNV|||
+XST_mPV|||
+XST_mUNDEF|||
+XST_mUV|5.008001||p
+XST_mYES|||
+XS_VERSION_BOOTCHECK|||
+XS_VERSION|||
+XS|||
+ZeroD|5.009002||p
+Zero|||
+_aMY_CXT|5.007003||p
+_pMY_CXT|5.007003||p
+aMY_CXT_|5.007003||p
+aMY_CXT|5.007003||p
+aTHX_|5.006000||p
+aTHX|5.006000||p
+add_data|||
+allocmy|||
+amagic_call|||
+any_dup|||
+ao|||
+append_elem|||
+append_list|||
+apply_attrs_my|||
+apply_attrs_string||5.006001|
+apply_attrs|||
+apply|||
+asIV|||
+asUV|||
+atfork_lock||5.007003|n
+atfork_unlock||5.007003|n
+av_arylen_p||5.009003|
+av_clear|||
+av_delete||5.006000|
+av_exists||5.006000|
+av_extend|||
+av_fake|||
+av_fetch|||
+av_fill|||
+av_len|||
+av_make|||
+av_pop|||
+av_push|||
+av_reify|||
+av_shift|||
+av_store|||
+av_undef|||
+av_unshift|||
+ax|||n
+bad_type|||
+bind_match|||
+block_end|||
+block_gimme||5.004000|
+block_start|||
+boolSV|5.004000||p
+boot_core_PerlIO|||
+boot_core_UNIVERSAL|||
+boot_core_xsutils|||
+bytes_from_utf8||5.007001|
+bytes_to_utf8||5.006001|
+cache_re|||
+call_argv|5.006000||p
+call_atexit||5.006000|
+call_body|||
+call_list_body|||
+call_list||5.004000|
+call_method|5.006000||p
+call_pv|5.006000||p
+call_sv|5.006000||p
+calloc||5.007002|n
+cando|||
+cast_i32||5.006000|
+cast_iv||5.006000|
+cast_ulong||5.006000|
+cast_uv||5.006000|
+check_uni|||
+checkcomma|||
+checkposixcc|||
+ck_anoncode|||
+ck_bitop|||
+ck_concat|||
+ck_defined|||
+ck_delete|||
+ck_die|||
+ck_eof|||
+ck_eval|||
+ck_exec|||
+ck_exists|||
+ck_exit|||
+ck_ftst|||
+ck_fun|||
+ck_glob|||
+ck_grep|||
+ck_index|||
+ck_join|||
+ck_lengthconst|||
+ck_lfun|||
+ck_listiob|||
+ck_match|||
+ck_method|||
+ck_null|||
+ck_open|||
+ck_repeat|||
+ck_require|||
+ck_retarget|||
+ck_return|||
+ck_rfun|||
+ck_rvconst|||
+ck_sassign|||
+ck_select|||
+ck_shift|||
+ck_sort|||
+ck_spair|||
+ck_split|||
+ck_subr|||
+ck_substr|||
+ck_svconst|||
+ck_trunc|||
+ck_unpack|||
+cl_and|||
+cl_anything|||
+cl_init_zero|||
+cl_init|||
+cl_is_anything|||
+cl_or|||
+closest_cop|||
+convert|||
+cop_free|||
+cr_textfilter|||
+croak_nocontext|||vn
+croak|||v
+csighandler||5.007001|n
+custom_op_desc||5.007003|
+custom_op_name||5.007003|
+cv_ckproto|||
+cv_clone|||
+cv_const_sv||5.004000|
+cv_dump|||
+cv_undef|||
+cx_dump||5.005000|
+cx_dup|||
+cxinc|||
+dAXMARK||5.009003|
+dAX|5.007002||p
+dITEMS|5.007002||p
+dMARK|||
+dMY_CXT_SV|5.007003||p
+dMY_CXT|5.007003||p
+dNOOP|5.006000||p
+dORIGMARK|||
+dSP|||
+dTHR|5.004050||p
+dTHXa|5.006000||p
+dTHXoa|5.006000||p
+dTHX|5.006000||p
+dUNDERBAR|5.009002||p
+dXCPT|5.009002||p
+dXSARGS|||
+dXSI32|||
+dXSTARG|5.006000||p
+deb_curcv|||
+deb_nocontext|||vn
+deb_stack_all|||
+deb_stack_n|||
+debop||5.005000|
+debprofdump||5.005000|
+debprof|||
+debstackptrs||5.007003|
+debstack||5.007003|
+deb||5.007003|v
+del_he|||
+del_sv|||
+delimcpy||5.004000|
+depcom|||
+deprecate_old|||
+deprecate|||
+despatch_signals||5.007001|
+die_nocontext|||vn
+die_where|||
+die|||v
+dirp_dup|||
+div128|||
+djSP|||
+do_aexec5|||
+do_aexec|||
+do_aspawn|||
+do_binmode||5.004050|
+do_chomp|||
+do_chop|||
+do_close|||
+do_dump_pad|||
+do_eof|||
+do_exec3|||
+do_execfree|||
+do_exec|||
+do_gv_dump||5.006000|
+do_gvgv_dump||5.006000|
+do_hv_dump||5.006000|
+do_ipcctl|||
+do_ipcget|||
+do_join|||
+do_kv|||
+do_magic_dump||5.006000|
+do_msgrcv|||
+do_msgsnd|||
+do_oddball|||
+do_op_dump||5.006000|
+do_open9||5.006000|
+do_openn||5.007001|
+do_open||5.004000|
+do_pipe|||
+do_pmop_dump||5.006000|
+do_print|||
+do_readline|||
+do_seek|||
+do_semop|||
+do_shmio|||
+do_spawn_nowait|||
+do_spawn|||
+do_sprintf|||
+do_sv_dump||5.006000|
+do_sysseek|||
+do_tell|||
+do_trans_complex_utf8|||
+do_trans_complex|||
+do_trans_count_utf8|||
+do_trans_count|||
+do_trans_simple_utf8|||
+do_trans_simple|||
+do_trans|||
+do_vecget|||
+do_vecset|||
+do_vop|||
+docatch_body|||
+docatch|||
+doeval|||
+dofile|||
+dofindlabel|||
+doform|||
+doing_taint||5.008001|n
+dooneliner|||
+doopen_pm|||
+doparseform|||
+dopoptoeval|||
+dopoptolabel|||
+dopoptoloop|||
+dopoptosub_at|||
+dopoptosub|||
+dounwind|||
+dowantarray|||
+dump_all||5.006000|
+dump_eval||5.006000|
+dump_fds|||
+dump_form||5.006000|
+dump_indent||5.006000|v
+dump_mstats|||
+dump_packsubs||5.006000|
+dump_sub||5.006000|
+dump_vindent||5.006000|
+dumpuntil|||
+dup_attrlist|||
+emulate_eaccess|||
+eval_pv|5.006000||p
+eval_sv|5.006000||p
+expect_number|||
+fbm_compile||5.005000|
+fbm_instr||5.005000|
+fd_on_nosuid_fs|||
+filter_add|||
+filter_del|||
+filter_gets|||
+filter_read|||
+find_beginning|||
+find_byclass|||
+find_in_my_stash|||
+find_runcv|||
+find_rundefsvoffset||5.009002|
+find_script|||
+find_uninit_var|||
+fold_constants|||
+forbid_setid|||
+force_ident|||
+force_list|||
+force_next|||
+force_version|||
+force_word|||
+form_nocontext|||vn
+form||5.004000|v
+fp_dup|||
+fprintf_nocontext|||vn
+free_global_struct|||
+free_tied_hv_pool|||
+free_tmps|||
+gen_constant_list|||
+get_av|5.006000||p
+get_context||5.006000|n
+get_cv|5.006000||p
+get_db_sub|||
+get_debug_opts|||
+get_hash_seed|||
+get_hv|5.006000||p
+get_mstats|||
+get_no_modify|||
+get_num|||
+get_op_descs||5.005000|
+get_op_names||5.005000|
+get_opargs|||
+get_ppaddr||5.006000|
+get_sv|5.006000||p
+get_vtbl||5.005030|
+getcwd_sv||5.007002|
+getenv_len|||
+gp_dup|||
+gp_free|||
+gp_ref|||
+grok_bin|5.007003||p
+grok_hex|5.007003||p
+grok_number|5.007002||p
+grok_numeric_radix|5.007002||p
+grok_oct|5.007003||p
+group_end|||
+gv_AVadd|||
+gv_HVadd|||
+gv_IOadd|||
+gv_autoload4||5.004000|
+gv_check|||
+gv_dump||5.006000|
+gv_efullname3||5.004000|
+gv_efullname4||5.006001|
+gv_efullname|||
+gv_ename|||
+gv_fetchfile|||
+gv_fetchmeth_autoload||5.007003|
+gv_fetchmethod_autoload||5.004000|
+gv_fetchmethod|||
+gv_fetchmeth|||
+gv_fetchpvn_flags||5.009002|
+gv_fetchpv|||
+gv_fetchsv||5.009002|
+gv_fullname3||5.004000|
+gv_fullname4||5.006001|
+gv_fullname|||
+gv_handler||5.007001|
+gv_init_sv|||
+gv_init|||
+gv_share|||
+gv_stashpvn|5.006000||p
+gv_stashpv|||
+gv_stashsv|||
+he_dup|||
+hek_dup|||
+hfreeentries|||
+hsplit|||
+hv_assert||5.009001|
+hv_auxinit|||
+hv_clear_placeholders||5.009001|
+hv_clear|||
+hv_delayfree_ent||5.004000|
+hv_delete_common|||
+hv_delete_ent||5.004000|
+hv_delete|||
+hv_eiter_p||5.009003|
+hv_eiter_set||5.009003|
+hv_exists_ent||5.004000|
+hv_exists|||
+hv_fetch_common|||
+hv_fetch_ent||5.004000|
+hv_fetch|||
+hv_free_ent||5.004000|
+hv_iterinit|||
+hv_iterkeysv||5.004000|
+hv_iterkey|||
+hv_iternext_flags||5.008000|
+hv_iternextsv|||
+hv_iternext|||
+hv_iterval|||
+hv_ksplit||5.004000|
+hv_magic_check|||
+hv_magic|||
+hv_name_set||5.009003|
+hv_notallowed|||
+hv_placeholders_get||5.009003|
+hv_placeholders_p||5.009003|
+hv_placeholders_set||5.009003|
+hv_riter_p||5.009003|
+hv_riter_set||5.009003|
+hv_scalar||5.009001|
+hv_store_ent||5.004000|
+hv_store_flags||5.008000|
+hv_store|||
+hv_undef|||
+ibcmp_locale||5.004000|
+ibcmp_utf8||5.007003|
+ibcmp|||
+incl_perldb|||
+incline|||
+incpush|||
+ingroup|||
+init_argv_symbols|||
+init_debugger|||
+init_global_struct|||
+init_i18nl10n||5.006000|
+init_i18nl14n||5.006000|
+init_ids|||
+init_interp|||
+init_lexer|||
+init_main_stash|||
+init_perllib|||
+init_postdump_symbols|||
+init_predump_symbols|||
+init_stacks||5.005000|
+init_tm||5.007002|
+instr|||
+intro_my|||
+intuit_method|||
+intuit_more|||
+invert|||
+io_close|||
+isALNUM|||
+isALPHA|||
+isDIGIT|||
+isLOWER|||
+isSPACE|||
+isUPPER|||
+is_an_int|||
+is_gv_magical_sv|||
+is_gv_magical|||
+is_handle_constructor|||
+is_list_assignment|||
+is_lvalue_sub||5.007001|
+is_uni_alnum_lc||5.006000|
+is_uni_alnumc_lc||5.006000|
+is_uni_alnumc||5.006000|
+is_uni_alnum||5.006000|
+is_uni_alpha_lc||5.006000|
+is_uni_alpha||5.006000|
+is_uni_ascii_lc||5.006000|
+is_uni_ascii||5.006000|
+is_uni_cntrl_lc||5.006000|
+is_uni_cntrl||5.006000|
+is_uni_digit_lc||5.006000|
+is_uni_digit||5.006000|
+is_uni_graph_lc||5.006000|
+is_uni_graph||5.006000|
+is_uni_idfirst_lc||5.006000|
+is_uni_idfirst||5.006000|
+is_uni_lower_lc||5.006000|
+is_uni_lower||5.006000|
+is_uni_print_lc||5.006000|
+is_uni_print||5.006000|
+is_uni_punct_lc||5.006000|
+is_uni_punct||5.006000|
+is_uni_space_lc||5.006000|
+is_uni_space||5.006000|
+is_uni_upper_lc||5.006000|
+is_uni_upper||5.006000|
+is_uni_xdigit_lc||5.006000|
+is_uni_xdigit||5.006000|
+is_utf8_alnumc||5.006000|
+is_utf8_alnum||5.006000|
+is_utf8_alpha||5.006000|
+is_utf8_ascii||5.006000|
+is_utf8_char_slow|||
+is_utf8_char||5.006000|
+is_utf8_cntrl||5.006000|
+is_utf8_digit||5.006000|
+is_utf8_graph||5.006000|
+is_utf8_idcont||5.008000|
+is_utf8_idfirst||5.006000|
+is_utf8_lower||5.006000|
+is_utf8_mark||5.006000|
+is_utf8_print||5.006000|
+is_utf8_punct||5.006000|
+is_utf8_space||5.006000|
+is_utf8_string_loclen||5.009003|
+is_utf8_string_loc||5.008001|
+is_utf8_string||5.006001|
+is_utf8_upper||5.006000|
+is_utf8_xdigit||5.006000|
+isa_lookup|||
+items|||n
+ix|||n
+jmaybe|||
+keyword|||
+leave_scope|||
+lex_end|||
+lex_start|||
+linklist|||
+listkids|||
+list|||
+load_module_nocontext|||vn
+load_module||5.006000|v
+localize|||
+looks_like_number|||
+lop|||
+mPUSHi|5.009002||p
+mPUSHn|5.009002||p
+mPUSHp|5.009002||p
+mPUSHu|5.009002||p
+mXPUSHi|5.009002||p
+mXPUSHn|5.009002||p
+mXPUSHp|5.009002||p
+mXPUSHu|5.009002||p
+magic_clear_all_env|||
+magic_clearenv|||
+magic_clearpack|||
+magic_clearsig|||
+magic_dump||5.006000|
+magic_existspack|||
+magic_freearylen_p|||
+magic_freeovrld|||
+magic_freeregexp|||
+magic_getarylen|||
+magic_getdefelem|||
+magic_getglob|||
+magic_getnkeys|||
+magic_getpack|||
+magic_getpos|||
+magic_getsig|||
+magic_getsubstr|||
+magic_gettaint|||
+magic_getuvar|||
+magic_getvec|||
+magic_get|||
+magic_killbackrefs|||
+magic_len|||
+magic_methcall|||
+magic_methpack|||
+magic_nextpack|||
+magic_regdata_cnt|||
+magic_regdatum_get|||
+magic_regdatum_set|||
+magic_scalarpack|||
+magic_set_all_env|||
+magic_setamagic|||
+magic_setarylen|||
+magic_setbm|||
+magic_setcollxfrm|||
+magic_setdbline|||
+magic_setdefelem|||
+magic_setenv|||
+magic_setfm|||
+magic_setglob|||
+magic_setisa|||
+magic_setmglob|||
+magic_setnkeys|||
+magic_setpack|||
+magic_setpos|||
+magic_setregexp|||
+magic_setsig|||
+magic_setsubstr|||
+magic_settaint|||
+magic_setutf8|||
+magic_setuvar|||
+magic_setvec|||
+magic_set|||
+magic_sizepack|||
+magic_wipepack|||
+magicname|||
+make_trie|||
+malloced_size|||n
+malloc||5.007002|n
+markstack_grow|||
+measure_struct|||
+memEQ|5.004000||p
+memNE|5.004000||p
+mem_collxfrm|||
+mess_alloc|||
+mess_nocontext|||vn
+mess||5.006000|v
+method_common|||
+mfree||5.007002|n
+mg_clear|||
+mg_copy|||
+mg_dup|||
+mg_find|||
+mg_free|||
+mg_get|||
+mg_length||5.005000|
+mg_localize|||
+mg_magical|||
+mg_set|||
+mg_size||5.005000|
+mini_mktime||5.007002|
+missingterm|||
+mode_from_discipline|||
+modkids|||
+mod|||
+moreswitches|||
+mul128|||
+mulexp10|||n
+my_atof2||5.007002|
+my_atof||5.006000|
+my_attrs|||
+my_bcopy|||n
+my_betoh16|||n
+my_betoh32|||n
+my_betoh64|||n
+my_betohi|||n
+my_betohl|||n
+my_betohs|||n
+my_bzero|||n
+my_chsize|||
+my_exit_jump|||
+my_exit|||
+my_failure_exit||5.004000|
+my_fflush_all||5.006000|
+my_fork||5.007003|n
+my_htobe16|||n
+my_htobe32|||n
+my_htobe64|||n
+my_htobei|||n
+my_htobel|||n
+my_htobes|||n
+my_htole16|||n
+my_htole32|||n
+my_htole64|||n
+my_htolei|||n
+my_htolel|||n
+my_htoles|||n
+my_htonl|||
+my_kid|||
+my_letoh16|||n
+my_letoh32|||n
+my_letoh64|||n
+my_letohi|||n
+my_letohl|||n
+my_letohs|||n
+my_lstat|||
+my_memcmp||5.004000|n
+my_memset|||n
+my_ntohl|||
+my_pclose||5.004000|
+my_popen_list||5.007001|
+my_popen||5.004000|
+my_setenv|||
+my_socketpair||5.007003|n
+my_stat|||
+my_strftime||5.007002|
+my_swabn|||n
+my_swap|||
+my_unexec|||
+my|||
+newANONATTRSUB||5.006000|
+newANONHASH|||
+newANONLIST|||
+newANONSUB|||
+newASSIGNOP|||
+newATTRSUB||5.006000|
+newAVREF|||
+newAV|||
+newBINOP|||
+newCONDOP|||
+newCONSTSUB|5.006000||p
+newCVREF|||
+newDEFSVOP|||
+newFORM|||
+newFOROP|||
+newGVOP|||
+newGVREF|||
+newGVgen|||
+newHVREF|||
+newHVhv||5.005000|
+newHV|||
+newIO|||
+newLISTOP|||
+newLOGOP|||
+newLOOPEX|||
+newLOOPOP|||
+newMYSUB||5.006000|
+newNULLLIST|||
+newOP|||
+newPADOP||5.006000|
+newPMOP|||
+newPROG|||
+newPVOP|||
+newRANGE|||
+newRV_inc|5.004000||p
+newRV_noinc|5.006000||p
+newRV|||
+newSLICEOP|||
+newSTATEOP|||
+newSUB|||
+newSVOP|||
+newSVREF|||
+newSVhek||5.009003|
+newSViv|||
+newSVnv|||
+newSVpvf_nocontext|||vn
+newSVpvf||5.004000|v
+newSVpvn_share||5.007001|
+newSVpvn|5.006000||p
+newSVpv|||
+newSVrv|||
+newSVsv|||
+newSVuv|5.006000||p
+newSV|||
+newUNOP|||
+newWHILEOP||5.009003|
+newXSproto||5.006000|
+newXS||5.006000|
+new_collate||5.006000|
+new_constant|||
+new_ctype||5.006000|
+new_he|||
+new_logop|||
+new_numeric||5.006000|
+new_stackinfo||5.005000|
+new_version||5.009000|
+next_symbol|||
+nextargv|||
+nextchar|||
+ninstr|||
+no_bareword_allowed|||
+no_fh_allowed|||
+no_op|||
+not_a_number|||
+nothreadhook||5.008000|
+nuke_stacks|||
+num_overflow|||n
+oopsAV|||
+oopsCV|||
+oopsHV|||
+op_clear|||
+op_const_sv|||
+op_dump||5.006000|
+op_free|||
+op_null||5.007002|
+op_refcnt_lock||5.009002|
+op_refcnt_unlock||5.009002|
+open_script|||
+pMY_CXT_|5.007003||p
+pMY_CXT|5.007003||p
+pTHX_|5.006000||p
+pTHX|5.006000||p
+pack_cat||5.007003|
+pack_rec|||
+package|||
+packlist||5.008001|
+pad_add_anon|||
+pad_add_name|||
+pad_alloc|||
+pad_block_start|||
+pad_check_dup|||
+pad_compname_type|||
+pad_findlex|||
+pad_findmy|||
+pad_fixup_inner_anons|||
+pad_free|||
+pad_leavemy|||
+pad_new|||
+pad_push|||
+pad_reset|||
+pad_setsv|||
+pad_sv|||
+pad_swipe|||
+pad_tidy|||
+pad_undef|||
+parse_body|||
+parse_unicode_opts|||
+path_is_absolute|||
+peep|||
+pending_ident|||
+perl_alloc_using|||n
+perl_alloc|||n
+perl_clone_using|||n
+perl_clone|||n
+perl_construct|||n
+perl_destruct||5.007003|n
+perl_free|||n
+perl_parse||5.006000|n
+perl_run|||n
+pidgone|||
+pmflag|||
+pmop_dump||5.006000|
+pmruntime|||
+pmtrans|||
+pop_scope|||
+pregcomp|||
+pregexec|||
+pregfree|||
+prepend_elem|||
+printf_nocontext|||vn
+ptr_table_clear|||
+ptr_table_fetch|||
+ptr_table_free|||
+ptr_table_new|||
+ptr_table_split|||
+ptr_table_store|||
+push_scope|||
+put_byte|||
+pv_display||5.006000|
+pv_uni_display||5.007003|
+qerror|||
+re_croak2|||
+re_dup|||
+re_intuit_start||5.006000|
+re_intuit_string||5.006000|
+realloc||5.007002|n
+reentrant_free|||
+reentrant_init|||
+reentrant_retry|||vn
+reentrant_size|||
+refkids|||
+refto|||
+ref|||
+reg_node|||
+reganode|||
+regatom|||
+regbranch|||
+regclass_swash||5.007003|
+regclass|||
+regcp_set_to|||
+regcppop|||
+regcppush|||
+regcurly|||
+regdump||5.005000|
+regexec_flags||5.005000|
+reghop3|||
+reghopmaybe3|||
+reghopmaybe|||
+reghop|||
+reginclass|||
+reginitcolors||5.006000|
+reginsert|||
+regmatch|||
+regnext||5.005000|
+regoptail|||
+regpiece|||
+regpposixcc|||
+regprop|||
+regrepeat_hard|||
+regrepeat|||
+regtail|||
+regtry|||
+reguni|||
+regwhite|||
+reg|||
+repeatcpy|||
+report_evil_fh|||
+report_uninit|||
+require_errno|||
+require_pv||5.006000|
+rninstr|||
+rsignal_restore|||
+rsignal_save|||
+rsignal_state||5.004000|
+rsignal||5.004000|
+run_body|||
+runops_debug||5.005000|
+runops_standard||5.005000|
+rvpv_dup|||
+rxres_free|||
+rxres_restore|||
+rxres_save|||
+safesyscalloc||5.006000|n
+safesysfree||5.006000|n
+safesysmalloc||5.006000|n
+safesysrealloc||5.006000|n
+same_dirent|||
+save_I16||5.004000|
+save_I32|||
+save_I8||5.006000|
+save_aelem||5.004050|
+save_alloc||5.006000|
+save_aptr|||
+save_ary|||
+save_bool||5.008001|
+save_clearsv|||
+save_delete|||
+save_destructor_x||5.006000|
+save_destructor||5.006000|
+save_freeop|||
+save_freepv|||
+save_freesv|||
+save_generic_pvref||5.006001|
+save_generic_svref||5.005030|
+save_gp||5.004000|
+save_hash|||
+save_hek_flags|||
+save_helem||5.004050|
+save_hints||5.005000|
+save_hptr|||
+save_int|||
+save_item|||
+save_iv||5.005000|
+save_lines|||
+save_list|||
+save_long|||
+save_magic|||
+save_mortalizesv||5.007001|
+save_nogv|||
+save_op|||
+save_padsv||5.007001|
+save_pptr|||
+save_re_context||5.006000|
+save_scalar_at|||
+save_scalar|||
+save_set_svflags||5.009000|
+save_shared_pvref||5.007003|
+save_sptr|||
+save_svref|||
+save_threadsv||5.005000|
+save_vptr||5.006000|
+savepvn|||
+savepv|||
+savesharedpv||5.007003|
+savestack_grow_cnt||5.008001|
+savestack_grow|||
+savesvpv||5.009002|
+sawparens|||
+scalar_mod_type|||
+scalarboolean|||
+scalarkids|||
+scalarseq|||
+scalarvoid|||
+scalar|||
+scan_bin||5.006000|
+scan_commit|||
+scan_const|||
+scan_formline|||
+scan_heredoc|||
+scan_hex|||
+scan_ident|||
+scan_inputsymbol|||
+scan_num||5.007001|
+scan_oct|||
+scan_pat|||
+scan_str|||
+scan_subst|||
+scan_trans|||
+scan_version||5.009001|
+scan_vstring||5.008001|
+scan_word|||
+scope|||
+screaminstr||5.005000|
+seed|||
+set_context||5.006000|n
+set_csh|||
+set_numeric_local||5.006000|
+set_numeric_radix||5.006000|
+set_numeric_standard||5.006000|
+setdefout|||
+setenv_getix|||
+share_hek_flags|||
+share_hek|||
+si_dup|||
+sighandler|||n
+simplify_sort|||
+skipspace|||
+sortsv||5.007003|
+ss_dup|||
+stack_grow|||
+start_glob|||
+start_subparse||5.004000|
+stashpv_hvname_match||5.009003|
+stdize_locale|||
+strEQ|||
+strGE|||
+strGT|||
+strLE|||
+strLT|||
+strNE|||
+str_to_version||5.006000|
+strnEQ|||
+strnNE|||
+study_chunk|||
+sub_crush_depth|||
+sublex_done|||
+sublex_push|||
+sublex_start|||
+sv_2bool|||
+sv_2cv|||
+sv_2io|||
+sv_2iuv_non_preserve|||
+sv_2iv_flags||5.009001|
+sv_2iv|||
+sv_2mortal|||
+sv_2nv|||
+sv_2pv_flags||5.007002|
+sv_2pv_nolen|5.006000||p
+sv_2pvbyte_nolen|||
+sv_2pvbyte|5.006000||p
+sv_2pvutf8_nolen||5.006000|
+sv_2pvutf8||5.006000|
+sv_2pv|||
+sv_2uv_flags||5.009001|
+sv_2uv|5.004000||p
+sv_add_arena|||
+sv_add_backref|||
+sv_backoff|||
+sv_bless|||
+sv_cat_decode||5.008001|
+sv_catpv_mg|5.006000||p
+sv_catpvf_mg_nocontext|||pvn
+sv_catpvf_mg|5.006000|5.004000|pv
+sv_catpvf_nocontext|||vn
+sv_catpvf||5.004000|v
+sv_catpvn_flags||5.007002|
+sv_catpvn_mg|5.006000||p
+sv_catpvn_nomg|5.007002||p
+sv_catpvn|||
+sv_catpv|||
+sv_catsv_flags||5.007002|
+sv_catsv_mg|5.006000||p
+sv_catsv_nomg|5.007002||p
+sv_catsv|||
+sv_chop|||
+sv_clean_all|||
+sv_clean_objs|||
+sv_clear|||
+sv_cmp_locale||5.004000|
+sv_cmp|||
+sv_collxfrm|||
+sv_compile_2op||5.008001|
+sv_copypv||5.007003|
+sv_dec|||
+sv_del_backref|||
+sv_derived_from||5.004000|
+sv_dump|||
+sv_dup|||
+sv_eq|||
+sv_force_normal_flags||5.007001|
+sv_force_normal||5.006000|
+sv_free2|||
+sv_free_arenas|||
+sv_free|||
+sv_gets||5.004000|
+sv_grow|||
+sv_inc|||
+sv_insert|||
+sv_isa|||
+sv_isobject|||
+sv_iv||5.005000|
+sv_len_utf8||5.006000|
+sv_len|||
+sv_magicext||5.007003|
+sv_magic|||
+sv_mortalcopy|||
+sv_newmortal|||
+sv_newref|||
+sv_nolocking||5.007003|
+sv_nosharing||5.007003|
+sv_nounlocking||5.007003|
+sv_nv||5.005000|
+sv_peek||5.005000|
+sv_pos_b2u||5.006000|
+sv_pos_u2b||5.006000|
+sv_pvbyten_force||5.006000|
+sv_pvbyten||5.006000|
+sv_pvbyte||5.006000|
+sv_pvn_force_flags||5.007002|
+sv_pvn_force|||p
+sv_pvn_nomg|5.007003||p
+sv_pvn|5.006000||p
+sv_pvutf8n_force||5.006000|
+sv_pvutf8n||5.006000|
+sv_pvutf8||5.006000|
+sv_pv||5.006000|
+sv_recode_to_utf8||5.007003|
+sv_reftype|||
+sv_release_COW|||
+sv_release_IVX|||
+sv_replace|||
+sv_report_used|||
+sv_reset|||
+sv_rvweaken||5.006000|
+sv_setiv_mg|5.006000||p
+sv_setiv|||
+sv_setnv_mg|5.006000||p
+sv_setnv|||
+sv_setpv_mg|5.006000||p
+sv_setpvf_mg_nocontext|||pvn
+sv_setpvf_mg|5.006000|5.004000|pv
+sv_setpvf_nocontext|||vn
+sv_setpvf||5.004000|v
+sv_setpviv_mg||5.008001|
+sv_setpviv||5.008001|
+sv_setpvn_mg|5.006000||p
+sv_setpvn|||
+sv_setpv|||
+sv_setref_iv|||
+sv_setref_nv|||
+sv_setref_pvn|||
+sv_setref_pv|||
+sv_setref_uv||5.007001|
+sv_setsv_cow|||
+sv_setsv_flags||5.007002|
+sv_setsv_mg|5.006000||p
+sv_setsv_nomg|5.007002||p
+sv_setsv|||
+sv_setuv_mg|5.006000||p
+sv_setuv|5.006000||p
+sv_tainted||5.004000|
+sv_taint||5.004000|
+sv_true||5.005000|
+sv_unglob|||
+sv_uni_display||5.007003|
+sv_unmagic|||
+sv_unref_flags||5.007001|
+sv_unref|||
+sv_untaint||5.004000|
+sv_upgrade|||
+sv_usepvn_mg|5.006000||p
+sv_usepvn|||
+sv_utf8_decode||5.006000|
+sv_utf8_downgrade||5.006000|
+sv_utf8_encode||5.006000|
+sv_utf8_upgrade_flags||5.007002|
+sv_utf8_upgrade||5.007001|
+sv_uv|5.006000||p
+sv_vcatpvf_mg|5.006000|5.004000|p
+sv_vcatpvfn||5.004000|
+sv_vcatpvf|5.006000|5.004000|p
+sv_vsetpvf_mg|5.006000|5.004000|p
+sv_vsetpvfn||5.004000|
+sv_vsetpvf|5.006000|5.004000|p
+svtype|||
+swallow_bom|||
+swash_fetch||5.007002|
+swash_init||5.006000|
+sys_intern_clear|||
+sys_intern_dup|||
+sys_intern_init|||
+taint_env|||
+taint_proper|||
+tmps_grow||5.006000|
+toLOWER|||
+toUPPER|||
+to_byte_substr|||
+to_uni_fold||5.007003|
+to_uni_lower_lc||5.006000|
+to_uni_lower||5.007003|
+to_uni_title_lc||5.006000|
+to_uni_title||5.007003|
+to_uni_upper_lc||5.006000|
+to_uni_upper||5.007003|
+to_utf8_case||5.007003|
+to_utf8_fold||5.007003|
+to_utf8_lower||5.007003|
+to_utf8_substr|||
+to_utf8_title||5.007003|
+to_utf8_upper||5.007003|
+tokeq|||
+tokereport|||
+too_few_arguments|||
+too_many_arguments|||
+unlnk|||
+unpack_rec|||
+unpack_str||5.007003|
+unpackstring||5.008001|
+unshare_hek_or_pvn|||
+unshare_hek|||
+unsharepvn||5.004000|
+upg_version||5.009000|
+usage|||
+utf16_textfilter|||
+utf16_to_utf8_reversed||5.006001|
+utf16_to_utf8||5.006001|
+utf16rev_textfilter|||
+utf8_distance||5.006000|
+utf8_hop||5.006000|
+utf8_length||5.007001|
+utf8_mg_pos_init|||
+utf8_mg_pos|||
+utf8_to_bytes||5.006001|
+utf8_to_uvchr||5.007001|
+utf8_to_uvuni||5.007001|
+utf8n_to_uvchr||5.007001|
+utf8n_to_uvuni||5.007001|
+utilize|||
+uvchr_to_utf8_flags||5.007003|
+uvchr_to_utf8||5.007001|
+uvuni_to_utf8_flags||5.007003|
+uvuni_to_utf8||5.007001|
+validate_suid|||
+varname|||
+vcmp||5.009000|
+vcroak||5.006000|
+vdeb||5.007003|
+vdie|||
+vform||5.006000|
+visit|||
+vivify_defelem|||
+vivify_ref|||
+vload_module||5.006000|
+vmess||5.006000|
+vnewSVpvf|5.006000|5.004000|p
+vnormal||5.009002|
+vnumify||5.009000|
+vstringify||5.009000|
+vwarner||5.006000|
+vwarn||5.006000|
+wait4pid|||
+warn_nocontext|||vn
+warner_nocontext|||vn
+warner||5.006000|v
+warn|||v
+watch|||
+whichsig|||
+write_to_stderr|||
+yyerror|||
+yylex|||
+yyparse|||
+yywarn|||
+);
+
+if (exists $opt{'list-unsupported'}) {
+ my $f;
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $API{$f}{todo};
+ print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
+ }
+ exit 0;
+}
+
+# Scan for possible replacement candidates
+
+my(%replace, %need, %hints, %depends);
+my $replace = 0;
+my $hint = '';
+
+while (<DATA>) {
+ if ($hint) {
+ if (m{^\s*\*\s(.*?)\s*$}) {
+ $hints{$hint} ||= ''; # suppress warning with older perls
+ $hints{$hint} .= "$1\n";
+ }
+ else {
+ $hint = '';
+ }
+ }
+ $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$};
+
+ $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
+ $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
+ $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
+ $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
+
+ if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
+ push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2;
+ }
+
+ $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
+}
+
+if (exists $opt{'api-info'}) {
+ my $f;
+ my $count = 0;
+ my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $f =~ /$match/;
+ print "\n=== $f ===\n\n";
+ my $info = 0;
+ if ($API{$f}{base} || $API{$f}{todo}) {
+ my $base = format_version($API{$f}{base} || $API{$f}{todo});
+ print "Supported at least starting from perl-$base.\n";
+ $info++;
+ }
+ if ($API{$f}{provided}) {
+ my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
+ print "Support by $ppport provided back to perl-$todo.\n";
+ print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
+ print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
+ print "$hints{$f}" if exists $hints{$f};
+ $info++;
+ }
+ unless ($info) {
+ print "No portability information available.\n";
+ }
+ $count++;
+ }
+ if ($count > 0) {
+ print "\n";
+ }
+ else {
+ print "Found no API matching '$opt{'api-info'}'.\n";
+ }
+ exit 0;
+}
+
+if (exists $opt{'list-provided'}) {
+ my $f;
+ for $f (sort { lc $a cmp lc $b } keys %API) {
+ next unless $API{$f}{provided};
+ my @flags;
+ push @flags, 'explicit' if exists $need{$f};
+ push @flags, 'depend' if exists $depends{$f};
+ push @flags, 'hint' if exists $hints{$f};
+ my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
+ print "$f$flags\n";
+ }
+ exit 0;
+}
+
+my @files;
+my @srcext = qw( xs c h cc cpp );
+my $srcext = join '|', @srcext;
+
+if (@ARGV) {
+ my %seen;
+ @files = grep { -f && !exists $seen{$_} } map { glob $_ } @ARGV;
+}
+else {
+ eval {
+ require File::Find;
+ File::Find::find(sub {
+ $File::Find::name =~ /\.($srcext)$/i
+ and push @files, $File::Find::name;
+ }, '.');
+ };
+ if ($@) {
+ @files = map { glob "*.$_" } @srcext;
+ }
+}
+
+if (!@ARGV || $opt{filter}) {
+ my(@in, @out);
+ my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
+ for (@files) {
+ my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/\.($srcext)$/i;
+ push @{ $out ? \@out : \@in }, $_;
+ }
+ if (@ARGV && @out) {
+ warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
+ }
+ @files = @in;
+}
+
+unless (@files) {
+ die "No input files given!\n";
+}
+
+my(%files, %global, %revreplace);
+%revreplace = reverse %replace;
+my $filename;
+my $patch_opened = 0;
+
+for $filename (@files) {
+ unless (open IN, "<$filename") {
+ warn "Unable to read from $filename: $!\n";
+ next;
+ }
+
+ info("Scanning $filename ...");
+
+ my $c = do { local $/; <IN> };
+ close IN;
+
+ my %file = (orig => $c, changes => 0);
+
+ # temporarily remove C comments from the code
+ my @ccom;
+ $c =~ s{
+ (
+ [^"'/]+
+ |
+ (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+
+ |
+ (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+
+ )
+ |
+ (/ (?:
+ \*[^*]*\*+(?:[^$ccs][^*]*\*+)* /
+ |
+ /[^\r\n]*
+ ))
+ }{
+ defined $2 and push @ccom, $2;
+ defined $1 ? $1 : "$ccs$#ccom$cce";
+ }egsx;
+
+ $file{ccom} = \@ccom;
+ $file{code} = $c;
+ $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/);
+
+ my $func;
+
+ for $func (keys %API) {
+ my $match = $func;
+ $match .= "|$revreplace{$func}" if exists $revreplace{$func};
+ if ($c =~ /\b(?:Perl_)?($match)\b/) {
+ $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
+ $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
+ if (exists $API{$func}{provided}) {
+ if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
+ $file{uses}{$func}++;
+ my @deps = rec_depend($func);
+ if (@deps) {
+ $file{uses_deps}{$func} = \@deps;
+ for (@deps) {
+ $file{uses}{$_} = 0 unless exists $file{uses}{$_};
+ }
+ }
+ for ($func, @deps) {
+ if (exists $need{$_}) {
+ $file{needs}{$_} = 'static';
+ }
+ }
+ }
+ }
+ if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
+ if ($c =~ /\b$func\b/) {
+ $file{uses_todo}{$func}++;
+ }
+ }
+ }
+ }
+
+ while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
+ if (exists $need{$2}) {
+ $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
+ }
+ else {
+ warning("Possibly wrong #define $1 in $filename");
+ }
+ }
+
+ for (qw(uses needs uses_todo needed_global needed_static)) {
+ for $func (keys %{$file{$_}}) {
+ push @{$global{$_}{$func}}, $filename;
+ }
+ }
+
+ $files{$filename} = \%file;
+}
+
+# Globally resolve NEED_'s
+my $need;
+for $need (keys %{$global{needs}}) {
+ if (@{$global{needs}{$need}} > 1) {
+ my @targets = @{$global{needs}{$need}};
+ my @t = grep $files{$_}{needed_global}{$need}, @targets;
+ @targets = @t if @t;
+ @t = grep /\.xs$/i, @targets;
+ @targets = @t if @t;
+ my $target = shift @targets;
+ $files{$target}{needs}{$need} = 'global';
+ for (@{$global{needs}{$need}}) {
+ $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
+ }
+ }
+}
+
+for $filename (@files) {
+ exists $files{$filename} or next;
+
+ info("=== Analyzing $filename ===");
+
+ my %file = %{$files{$filename}};
+ my $func;
+ my $c = $file{code};
+
+ for $func (sort keys %{$file{uses_Perl}}) {
+ if ($API{$func}{varargs}) {
+ my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
+ { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
+ if ($changes) {
+ warning("Doesn't pass interpreter argument aTHX to Perl_$func");
+ $file{changes} += $changes;
+ }
+ }
+ else {
+ warning("Uses Perl_$func instead of $func");
+ $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
+ {$func$1(}g);
+ }
+ }
+
+ for $func (sort keys %{$file{uses_replace}}) {
+ warning("Uses $func instead of $replace{$func}");
+ $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
+ }
+
+ for $func (sort keys %{$file{uses}}) {
+ next unless $file{uses}{$func}; # if it's only a dependency
+ if (exists $file{uses_deps}{$func}) {
+ diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
+ }
+ elsif (exists $replace{$func}) {
+ warning("Uses $func instead of $replace{$func}");
+ $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
+ }
+ else {
+ diag("Uses $func");
+ }
+ hint($func);
+ }
+
+ for $func (sort keys %{$file{uses_todo}}) {
+ warning("Uses $func, which may not be portable below perl ",
+ format_version($API{$func}{todo}));
+ }
+
+ for $func (sort keys %{$file{needed_static}}) {
+ my $message = '';
+ if (not exists $file{uses}{$func}) {
+ $message = "No need to define NEED_$func if $func is never used";
+ }
+ elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
+ $message = "No need to define NEED_$func when already needed globally";
+ }
+ if ($message) {
+ diag($message);
+ $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
+ }
+ }
+
+ for $func (sort keys %{$file{needed_global}}) {
+ my $message = '';
+ if (not exists $global{uses}{$func}) {
+ $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
+ }
+ elsif (exists $file{needs}{$func}) {
+ if ($file{needs}{$func} eq 'extern') {
+ $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
+ }
+ elsif ($file{needs}{$func} eq 'static') {
+ $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
+ }
+ }
+ if ($message) {
+ diag($message);
+ $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
+ }
+ }
+
+ $file{needs_inc_ppport} = keys %{$file{uses}};
+
+ if ($file{needs_inc_ppport}) {
+ my $pp = '';
+
+ for $func (sort keys %{$file{needs}}) {
+ my $type = $file{needs}{$func};
+ next if $type eq 'extern';
+ my $suffix = $type eq 'global' ? '_GLOBAL' : '';
+ unless (exists $file{"needed_$type"}{$func}) {
+ if ($type eq 'global') {
+ diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
+ }
+ else {
+ diag("File needs $func, adding static request");
+ }
+ $pp .= "#define NEED_$func$suffix\n";
+ }
+ }
+
+ if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
+ $pp = '';
+ $file{changes}++;
+ }
+
+ unless ($file{has_inc_ppport}) {
+ diag("Needs to include '$ppport'");
+ $pp .= qq(#include "$ppport"\n)
+ }
+
+ if ($pp) {
+ $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
+ || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
+ || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
+ || ($c =~ s/^/$pp/);
+ }
+ }
+ else {
+ if ($file{has_inc_ppport}) {
+ diag("No need to include '$ppport'");
+ $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
+ }
+ }
+
+ # put back in our C comments
+ my $ix;
+ my $cppc = 0;
+ my @ccom = @{$file{ccom}};
+ for $ix (0 .. $#ccom) {
+ if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
+ $cppc++;
+ $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
+ }
+ else {
+ $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
+ }
+ }
+
+ if ($cppc) {
+ my $s = $cppc != 1 ? 's' : '';
+ warning("Uses $cppc C++ style comment$s, which is not portable");
+ }
+
+ if ($file{changes}) {
+ if (exists $opt{copy}) {
+ my $newfile = "$filename$opt{copy}";
+ if (-e $newfile) {
+ error("'$newfile' already exists, refusing to write copy of '$filename'");
+ }
+ else {
+ local *F;
+ if (open F, ">$newfile") {
+ info("Writing copy of '$filename' with changes to '$newfile'");
+ print F $c;
+ close F;
+ }
+ else {
+ error("Cannot open '$newfile' for writing: $!");
+ }
+ }
+ }
+ elsif (exists $opt{patch} || $opt{changes}) {
+ if (exists $opt{patch}) {
+ unless ($patch_opened) {
+ if (open PATCH, ">$opt{patch}") {
+ $patch_opened = 1;
+ }
+ else {
+ error("Cannot open '$opt{patch}' for writing: $!");
+ delete $opt{patch};
+ $opt{changes} = 1;
+ goto fallback;
+ }
+ }
+ mydiff(\*PATCH, $filename, $c);
+ }
+ else {
+fallback:
+ info("Suggested changes:");
+ mydiff(\*STDOUT, $filename, $c);
+ }
+ }
+ else {
+ my $s = $file{changes} == 1 ? '' : 's';
+ info("$file{changes} potentially required change$s detected");
+ }
+ }
+ else {
+ info("Looks good");
+ }
+}
+
+close PATCH if $patch_opened;
+
+exit 0;
+
+
+sub mydiff
+{
+ local *F = shift;
+ my($file, $str) = @_;
+ my $diff;
+
+ if (exists $opt{diff}) {
+ $diff = run_diff($opt{diff}, $file, $str);
+ }
+
+ if (!defined $diff and can_use('Text::Diff')) {
+ $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
+ $diff = <<HEADER . $diff;
+--- $file
++++ $file.patched
+HEADER
+ }
+
+ if (!defined $diff) {
+ $diff = run_diff('diff -u', $file, $str);
+ }
+
+ if (!defined $diff) {
+ $diff = run_diff('diff', $file, $str);
+ }
+
+ if (!defined $diff) {
+ error("Cannot generate a diff. Please install Text::Diff or use --copy.");
+ return;
+ }
+
+ print F $diff;
+
+}
+
+sub run_diff
+{
+ my($prog, $file, $str) = @_;
+ my $tmp = 'dppptemp';
+ my $suf = 'aaa';
+ my $diff = '';
+ local *F;
+
+ while (-e "$tmp.$suf") { $suf++ }
+ $tmp = "$tmp.$suf";
+
+ if (open F, ">$tmp") {
+ print F $str;
+ close F;
+
+ if (open F, "$prog $file $tmp |") {
+ while (<F>) {
+ s/\Q$tmp\E/$file.patched/;
+ $diff .= $_;
+ }
+ close F;
+ unlink $tmp;
+ return $diff;
+ }
+
+ unlink $tmp;
+ }
+ else {
+ error("Cannot open '$tmp' for writing: $!");
+ }
+
+ return undef;
+}
+
+sub can_use
+{
+ eval "use @_;";
+ return $@ eq '';
+}
+
+sub rec_depend
+{
+ my $func = shift;
+ my %seen;
+ return () unless exists $depends{$func};
+ grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}};
+}
+
+sub parse_version
+{
+ my $ver = shift;
+
+ if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
+ return ($1, $2, $3);
+ }
+ elsif ($ver !~ /^\d+\.[\d_]+$/) {
+ die "cannot parse version '$ver'\n";
+ }
+
+ $ver =~ s/_//g;
+ $ver =~ s/$/000000/;
+
+ my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
+
+ $v = int $v;
+ $s = int $s;
+
+ if ($r < 5 || ($r == 5 && $v < 6)) {
+ if ($s % 10) {
+ die "cannot parse version '$ver'\n";
+ }
+ }
+
+ return ($r, $v, $s);
+}
+
+sub format_version
+{
+ my $ver = shift;
+
+ $ver =~ s/$/000000/;
+ my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
+
+ $v = int $v;
+ $s = int $s;
+
+ if ($r < 5 || ($r == 5 && $v < 6)) {
+ if ($s % 10) {
+ die "invalid version '$ver'\n";
+ }
+ $s /= 10;
+
+ $ver = sprintf "%d.%03d", $r, $v;
+ $s > 0 and $ver .= sprintf "_%02d", $s;
+
+ return $ver;
+ }
+
+ return sprintf "%d.%d.%d", $r, $v, $s;
+}
+
+sub info
+{
+ $opt{quiet} and return;
+ print @_, "\n";
+}
+
+sub diag
+{
+ $opt{quiet} and return;
+ $opt{diag} and print @_, "\n";
+}
+
+sub warning
+{
+ $opt{quiet} and return;
+ print "*** ", @_, "\n";
+}
+
+sub error
+{
+ print "*** ERROR: ", @_, "\n";
+}
+
+my %given_hints;
+sub hint
+{
+ $opt{quiet} and return;
+ $opt{hints} or return;
+ my $func = shift;
+ exists $hints{$func} or return;
+ $given_hints{$func}++ and return;
+ my $hint = $hints{$func};
+ $hint =~ s/^/ /mg;
+ print " --- hint for $func ---\n", $hint;
+}
+
+sub usage
+{
+ my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
+ my %M = ( 'I' => '*' );
+ $usage =~ s/^\s*perl\s+\S+/$^X $0/;
+ $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
+
+ print <<ENDUSAGE;
+
+Usage: $usage
+
+See perldoc $0 for details.
+
+ENDUSAGE
+
+ exit 2;
+}
+
+__DATA__
+*/
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+#ifndef DPPP_NAMESPACE
+# define DPPP_NAMESPACE DPPP_
+#endif
+
+#define DPPP_CAT2(x,y) CAT2(x,y)
+#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
+
+#ifndef PERL_REVISION
+# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
+# define PERL_PATCHLEVEL_H_IMPLICIT
+# include <patchlevel.h>
+# endif
+# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
+# include <could_not_find_Perl_patchlevel.h>
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
+
+/* It is very unlikely that anyone will try to use this with Perl 6
+ (or greater), but who knows.
+ */
+#if PERL_REVISION != 5
+# error ppport.h only works with Perl version 5
+#endif /* PERL_REVISION != 5 */
+
+#ifdef I_LIMITS
+# include <limits.h>
+#endif
+
+#ifndef PERL_UCHAR_MIN
+# define PERL_UCHAR_MIN ((unsigned char)0)
+#endif
+
+#ifndef PERL_UCHAR_MAX
+# ifdef UCHAR_MAX
+# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
+# else
+# ifdef MAXUCHAR
+# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
+# else
+# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_USHORT_MIN
+# define PERL_USHORT_MIN ((unsigned short)0)
+#endif
+
+#ifndef PERL_USHORT_MAX
+# ifdef USHORT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
+# else
+# ifdef MAXUSHORT
+# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
+# else
+# ifdef USHRT_MAX
+# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
+# else
+# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_SHORT_MAX
+# ifdef SHORT_MAX
+# define PERL_SHORT_MAX ((short)SHORT_MAX)
+# else
+# ifdef MAXSHORT /* Often used in <values.h> */
+# define PERL_SHORT_MAX ((short)MAXSHORT)
+# else
+# ifdef SHRT_MAX
+# define PERL_SHORT_MAX ((short)SHRT_MAX)
+# else
+# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_SHORT_MIN
+# ifdef SHORT_MIN
+# define PERL_SHORT_MIN ((short)SHORT_MIN)
+# else
+# ifdef MINSHORT
+# define PERL_SHORT_MIN ((short)MINSHORT)
+# else
+# ifdef SHRT_MIN
+# define PERL_SHORT_MIN ((short)SHRT_MIN)
+# else
+# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
+# endif
+# endif
+# endif
+#endif
+
+#ifndef PERL_UINT_MAX
+# ifdef UINT_MAX
+# define PERL_UINT_MAX ((unsigned int)UINT_MAX)
+# else
+# ifdef MAXUINT
+# define PERL_UINT_MAX ((unsigned int)MAXUINT)
+# else
+# define PERL_UINT_MAX (~(unsigned int)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_UINT_MIN
+# define PERL_UINT_MIN ((unsigned int)0)
+#endif
+
+#ifndef PERL_INT_MAX
+# ifdef INT_MAX
+# define PERL_INT_MAX ((int)INT_MAX)
+# else
+# ifdef MAXINT /* Often used in <values.h> */
+# define PERL_INT_MAX ((int)MAXINT)
+# else
+# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
+# endif
+# endif
+#endif
+
+#ifndef PERL_INT_MIN
+# ifdef INT_MIN
+# define PERL_INT_MIN ((int)INT_MIN)
+# else
+# ifdef MININT
+# define PERL_INT_MIN ((int)MININT)
+# else
+# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
+# endif
+# endif
+#endif
+
+#ifndef PERL_ULONG_MAX
+# ifdef ULONG_MAX
+# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
+# else
+# ifdef MAXULONG
+# define PERL_ULONG_MAX ((unsigned long)MAXULONG)
+# else
+# define PERL_ULONG_MAX (~(unsigned long)0)
+# endif
+# endif
+#endif
+
+#ifndef PERL_ULONG_MIN
+# define PERL_ULONG_MIN ((unsigned long)0L)
+#endif
+
+#ifndef PERL_LONG_MAX
+# ifdef LONG_MAX
+# define PERL_LONG_MAX ((long)LONG_MAX)
+# else
+# ifdef MAXLONG
+# define PERL_LONG_MAX ((long)MAXLONG)
+# else
+# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
+# endif
+# endif
+#endif
+
+#ifndef PERL_LONG_MIN
+# ifdef LONG_MIN
+# define PERL_LONG_MIN ((long)LONG_MIN)
+# else
+# ifdef MINLONG
+# define PERL_LONG_MIN ((long)MINLONG)
+# else
+# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
+# endif
+# endif
+#endif
+
+#if defined(HAS_QUAD) && (defined(convex) || defined(uts))
+# ifndef PERL_UQUAD_MAX
+# ifdef ULONGLONG_MAX
+# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
+# else
+# ifdef MAXULONGLONG
+# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
+# else
+# define PERL_UQUAD_MAX (~(unsigned long long)0)
+# endif
+# endif
+# endif
+
+# ifndef PERL_UQUAD_MIN
+# define PERL_UQUAD_MIN ((unsigned long long)0L)
+# endif
+
+# ifndef PERL_QUAD_MAX
+# ifdef LONGLONG_MAX
+# define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
+# else
+# ifdef MAXLONGLONG
+# define PERL_QUAD_MAX ((long long)MAXLONGLONG)
+# else
+# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
+# endif
+# endif
+# endif
+
+# ifndef PERL_QUAD_MIN
+# ifdef LONGLONG_MIN
+# define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
+# else
+# ifdef MINLONGLONG
+# define PERL_QUAD_MIN ((long long)MINLONGLONG)
+# else
+# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
+# endif
+# endif
+# endif
+#endif
+
+/* This is based on code from 5.003 perl.h */
+#ifdef HAS_QUAD
+# ifdef cray
+#ifndef IVTYPE
+# define IVTYPE int
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_INT_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_INT_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_UINT_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_UINT_MAX
+#endif
+
+# ifdef INTSIZE
+#ifndef IVSIZE
+# define IVSIZE INTSIZE
+#endif
+
+# endif
+# else
+# if defined(convex) || defined(uts)
+#ifndef IVTYPE
+# define IVTYPE long long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_QUAD_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_QUAD_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_UQUAD_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_UQUAD_MAX
+#endif
+
+# ifdef LONGLONGSIZE
+#ifndef IVSIZE
+# define IVSIZE LONGLONGSIZE
+#endif
+
+# endif
+# else
+#ifndef IVTYPE
+# define IVTYPE long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_LONG_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_LONG_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_ULONG_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_ULONG_MAX
+#endif
+
+# ifdef LONGSIZE
+#ifndef IVSIZE
+# define IVSIZE LONGSIZE
+#endif
+
+# endif
+# endif
+# endif
+#ifndef IVSIZE
+# define IVSIZE 8
+#endif
+
+#ifndef PERL_QUAD_MIN
+# define PERL_QUAD_MIN IV_MIN
+#endif
+
+#ifndef PERL_QUAD_MAX
+# define PERL_QUAD_MAX IV_MAX
+#endif
+
+#ifndef PERL_UQUAD_MIN
+# define PERL_UQUAD_MIN UV_MIN
+#endif
+
+#ifndef PERL_UQUAD_MAX
+# define PERL_UQUAD_MAX UV_MAX
+#endif
+
+#else
+#ifndef IVTYPE
+# define IVTYPE long
+#endif
+
+#ifndef IV_MIN
+# define IV_MIN PERL_LONG_MIN
+#endif
+
+#ifndef IV_MAX
+# define IV_MAX PERL_LONG_MAX
+#endif
+
+#ifndef UV_MIN
+# define UV_MIN PERL_ULONG_MIN
+#endif
+
+#ifndef UV_MAX
+# define UV_MAX PERL_ULONG_MAX
+#endif
+
+#endif
+
+#ifndef IVSIZE
+# ifdef LONGSIZE
+# define IVSIZE LONGSIZE
+# else
+# define IVSIZE 4 /* A bold guess, but the best we can make. */
+# endif
+#endif
+#ifndef UVTYPE
+# define UVTYPE unsigned IVTYPE
+#endif
+
+#ifndef UVSIZE
+# define UVSIZE IVSIZE
+#endif
+
+#ifndef sv_setuv
+# define sv_setuv(sv, uv) \
+ STMT_START { \
+ UV TeMpUv = uv; \
+ if (TeMpUv <= IV_MAX) \
+ sv_setiv(sv, TeMpUv); \
+ else \
+ sv_setnv(sv, (double)TeMpUv); \
+ } STMT_END
+#endif
+
+#ifndef newSVuv
+# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
+#endif
+#ifndef sv_2uv
+# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
+#endif
+
+#ifndef SvUVX
+# define SvUVX(sv) ((UV)SvIVX(sv))
+#endif
+
+#ifndef SvUVXx
+# define SvUVXx(sv) SvUVX(sv)
+#endif
+
+#ifndef SvUV
+# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
+#endif
+
+#ifndef SvUVx
+# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
+#endif
+
+/* Hint: sv_uv
+ * Always use the SvUVx() macro instead of sv_uv().
+ */
+#ifndef sv_uv
+# define sv_uv(sv) SvUVx(sv)
+#endif
+#ifndef XST_mUV
+# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
+#endif
+
+#ifndef XSRETURN_UV
+# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
+#endif
+#ifndef PUSHu
+# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
+#endif
+
+#ifndef XPUSHu
+# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
+#endif
+
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
+/* Replace: 1 */
+# define PL_DBsingle DBsingle
+# define PL_DBsub DBsub
+# define PL_Sv Sv
+# define PL_compiling compiling
+# define PL_copline copline
+# define PL_curcop curcop
+# define PL_curstash curstash
+# define PL_debstash debstash
+# define PL_defgv defgv
+# define PL_diehook diehook
+# define PL_dirty dirty
+# define PL_dowarn dowarn
+# define PL_errgv errgv
+# define PL_hexdigit hexdigit
+# define PL_hints hints
+# define PL_na na
+# define PL_no_modify no_modify
+# define PL_perl_destruct_level perl_destruct_level
+# define PL_perldb perldb
+# define PL_ppaddr ppaddr
+# define PL_rsfp_filters rsfp_filters
+# define PL_rsfp rsfp
+# define PL_stack_base stack_base
+# define PL_stack_sp stack_sp
+# define PL_stdingv stdingv
+# define PL_sv_arenaroot sv_arenaroot
+# define PL_sv_no sv_no
+# define PL_sv_undef sv_undef
+# define PL_sv_yes sv_yes
+# define PL_tainted tainted
+# define PL_tainting tainting
+/* Replace: 0 */
+#endif
+
+#ifndef PERL_UNUSED_DECL
+# ifdef HASATTRIBUTE
+# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
+# define PERL_UNUSED_DECL
+# else
+# define PERL_UNUSED_DECL __attribute__((unused))
+# endif
+# else
+# define PERL_UNUSED_DECL
+# endif
+#endif
+#ifndef NOOP
+# define NOOP (void)0
+#endif
+
+#ifndef dNOOP
+# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
+
+#ifndef NVTYPE
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
+# define NVTYPE long double
+# else
+# define NVTYPE double
+# endif
+typedef NVTYPE NV;
+#endif
+
+#ifndef INT2PTR
+
+# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
+# define PTRV UV
+# define INT2PTR(any,d) (any)(d)
+# else
+# if PTRSIZE == LONGSIZE
+# define PTRV unsigned long
+# else
+# define PTRV unsigned
+# endif
+# define INT2PTR(any,d) (any)(PTRV)(d)
+# endif
+
+# define NUM2PTR(any,d) (any)(PTRV)(d)
+# define PTR2IV(p) INT2PTR(IV,p)
+# define PTR2UV(p) INT2PTR(UV,p)
+# define PTR2NV(p) NUM2PTR(NV,p)
+
+# if PTRSIZE == LONGSIZE
+# define PTR2ul(p) (unsigned long)(p)
+# else
+# define PTR2ul(p) INT2PTR(unsigned long,p)
+# endif
+
+#endif /* !INT2PTR */
+
+#undef START_EXTERN_C
+#undef END_EXTERN_C
+#undef EXTERN_C
+#ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# define END_EXTERN_C }
+# define EXTERN_C extern "C"
+#else
+# define START_EXTERN_C
+# define END_EXTERN_C
+# define EXTERN_C extern
+#endif
+
+#ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC)
+# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
+# endif
+#endif
+
+#undef STMT_START
+#undef STMT_END
+#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
+# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
+# define STMT_END )
+#else
+# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
+# define STMT_START if (1)
+# define STMT_END else (void)0
+# else
+# define STMT_START do
+# define STMT_END while (0)
+# endif
+#endif
+#ifndef boolSV
+# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+#endif
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(PL_defgv)
+#endif
+
+#ifndef SAVE_DEFSV
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif
+
+/* Older perls (<=5.003) lack AvFILLp */
+#ifndef AvFILLp
+# define AvFILLp AvFILL
+#endif
+#ifndef ERRSV
+# define ERRSV get_sv("@",FALSE)
+#endif
+#ifndef newSVpvn
+# define newSVpvn(data,len) ((data) \
+ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
+ : newSV(0))
+#endif
+
+/* Hint: gv_stashpvn
+ * This function's backport doesn't support the length parameter, but
+ * rather ignores it. Portability can only be ensured if the length
+ * parameter is used for speed reasons, but the length can always be
+ * correctly computed from the string argument.
+ */
+#ifndef gv_stashpvn
+# define gv_stashpvn(str,len,create) gv_stashpv(str,create)
+#endif
+
+/* Replace: 1 */
+#ifndef get_cv
+# define get_cv perl_get_cv
+#endif
+
+#ifndef get_sv
+# define get_sv perl_get_sv
+#endif
+
+#ifndef get_av
+# define get_av perl_get_av
+#endif
+
+#ifndef get_hv
+# define get_hv perl_get_hv
+#endif
+
+/* Replace: 0 */
+
+#ifdef HAS_MEMCMP
+#ifndef memNE
+# define memNE(s1,s2,l) (memcmp(s1,s2,l))
+#endif
+
+#ifndef memEQ
+# define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
+#endif
+
+#else
+#ifndef memNE
+# define memNE(s1,s2,l) (bcmp(s1,s2,l))
+#endif
+
+#ifndef memEQ
+# define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
+#endif
+
+#endif
+#ifndef MoveD
+# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
+#endif
+
+#ifndef CopyD
+# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
+#endif
+
+#ifdef HAS_MEMSET
+#ifndef ZeroD
+# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
+#endif
+
+#else
+#ifndef ZeroD
+# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d)
+#endif
+
+#endif
+#ifndef Poison
+# define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
+#endif
+#ifndef dUNDERBAR
+# define dUNDERBAR dNOOP
+#endif
+
+#ifndef UNDERBAR
+# define UNDERBAR DEFSV
+#endif
+#ifndef dAX
+# define dAX I32 ax = MARK - PL_stack_base + 1
+#endif
+
+#ifndef dITEMS
+# define dITEMS I32 items = SP - MARK
+#endif
+#ifndef dXSTARG
+# define dXSTARG SV * targ = sv_newmortal()
+#endif
+#ifndef dTHR
+# define dTHR dNOOP
+#endif
+#ifndef dTHX
+# define dTHX dNOOP
+#endif
+
+#ifndef dTHXa
+# define dTHXa(x) dNOOP
+#endif
+#ifndef pTHX
+# define pTHX void
+#endif
+
+#ifndef pTHX_
+# define pTHX_
+#endif
+
+#ifndef aTHX
+# define aTHX
+#endif
+
+#ifndef aTHX_
+# define aTHX_
+#endif
+#ifndef dTHXoa
+# define dTHXoa(x) dTHXa(x)
+#endif
+#ifndef PUSHmortal
+# define PUSHmortal PUSHs(sv_newmortal())
+#endif
+
+#ifndef mPUSHp
+# define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l))
+#endif
+
+#ifndef mPUSHn
+# define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n))
+#endif
+
+#ifndef mPUSHi
+# define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i))
+#endif
+
+#ifndef mPUSHu
+# define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u))
+#endif
+#ifndef XPUSHmortal
+# define XPUSHmortal XPUSHs(sv_newmortal())
+#endif
+
+#ifndef mXPUSHp
+# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END
+#endif
+
+#ifndef mXPUSHn
+# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END
+#endif
+
+#ifndef mXPUSHi
+# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END
+#endif
+
+#ifndef mXPUSHu
+# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END
+#endif
+
+/* Replace: 1 */
+#ifndef call_sv
+# define call_sv perl_call_sv
+#endif
+
+#ifndef call_pv
+# define call_pv perl_call_pv
+#endif
+
+#ifndef call_argv
+# define call_argv perl_call_argv
+#endif
+
+#ifndef call_method
+# define call_method perl_call_method
+#endif
+#ifndef eval_sv
+# define eval_sv perl_eval_sv
+#endif
+
+/* Replace: 0 */
+
+/* Replace perl_eval_pv with eval_pv */
+/* eval_pv depends on eval_sv */
+
+#ifndef eval_pv
+#if defined(NEED_eval_pv)
+static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
+static
+#else
+extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
+#endif
+
+#ifdef eval_pv
+# undef eval_pv
+#endif
+#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
+#define Perl_eval_pv DPPP_(my_eval_pv)
+
+#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
+
+SV*
+DPPP_(my_eval_pv)(char *p, I32 croak_on_error)
+{
+ dSP;
+ SV* sv = newSVpv(p, 0);
+
+ PUSHMARK(sp);
+ eval_sv(sv, G_SCALAR);
+ SvREFCNT_dec(sv);
+
+ SPAGAIN;
+ sv = POPs;
+ PUTBACK;
+
+ if (croak_on_error && SvTRUE(GvSV(errgv)))
+ croak(SvPVx(GvSV(errgv), na));
+
+ return sv;
+}
+
+#endif
+#endif
+#ifndef newRV_inc
+# define newRV_inc(sv) newRV(sv) /* Replace */
+#endif
+
+#ifndef newRV_noinc
+#if defined(NEED_newRV_noinc)
+static SV * DPPP_(my_newRV_noinc)(SV *sv);
+static
+#else
+extern SV * DPPP_(my_newRV_noinc)(SV *sv);
+#endif
+
+#ifdef newRV_noinc
+# undef newRV_noinc
+#endif
+#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a)
+#define Perl_newRV_noinc DPPP_(my_newRV_noinc)
+
+#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL)
+SV *
+DPPP_(my_newRV_noinc)(SV *sv)
+{
+ SV *rv = (SV *)newRV(sv);
+ SvREFCNT_dec(sv);
+ return rv;
+}
+#endif
+#endif
+
+/* Hint: newCONSTSUB
+ * Returns a CV* as of perl-5.7.1. This return value is not supported
+ * by Devel::PPPort.
+ */
+
+/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
+#if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5))
+#if defined(NEED_newCONSTSUB)
+static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
+static
+#else
+extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
+#endif
+
+#ifdef newCONSTSUB
+# undef newCONSTSUB
+#endif
+#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c)
+#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB)
+
+#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
+
+void
+DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv)
+{
+ U32 oldhints = PL_hints;
+ HV *old_cop_stash = PL_curcop->cop_stash;
+ HV *old_curstash = PL_curstash;
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ if (stash)
+ PL_curstash = PL_curcop->cop_stash = stash;
+
+ newSUB(
+
+#if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)))
+ start_subparse(),
+#elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22))
+ start_subparse(0),
+#else /* 5.003_23 onwards */
+ start_subparse(FALSE, 0),
+#endif
+
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ PL_hints = oldhints;
+ PL_curcop->cop_stash = old_cop_stash;
+ PL_curstash = old_curstash;
+ PL_curcop->cop_line = oldline;
+}
+#endif
+#endif
+
+/*
+ * Boilerplate macros for initializing and accessing interpreter-local
+ * data from C. All statics in extensions should be reworked to use
+ * this, if you want to make the extension thread-safe. See ext/re/re.xs
+ * for an example of the use of these macros.
+ *
+ * Code that uses these macros is responsible for the following:
+ * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
+ * 2. Declare a typedef named my_cxt_t that is a structure that contains
+ * all the data that needs to be interpreter-local.
+ * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
+ * 4. Use the MY_CXT_INIT macro such that it is called exactly once
+ * (typically put in the BOOT: section).
+ * 5. Use the members of the my_cxt_t structure everywhere as
+ * MY_CXT.member.
+ * 6. Use the dMY_CXT macro (a declaration) in all the functions that
+ * access MY_CXT.
+ */
+
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
+ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
+
+#ifndef START_MY_CXT
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT
+
+#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
+/* Fetches the SV that keeps the per-interpreter data. */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
+#else /* >= perl5.004_68 */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
+ sizeof(MY_CXT_KEY)-1, TRUE)
+#endif /* < perl5.004_68 */
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ dMY_CXT_SV; \
+ /* newSV() allocates one more than needed */ \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Zero(my_cxtp, 1, my_cxt_t); \
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+
+/* This macro must be used to access members of the my_cxt_t structure.
+ * e.g. MYCXT.some_data */
+#define MY_CXT (*my_cxtp)
+
+/* Judicious use of these macros can reduce the number of times dMY_CXT
+ * is used. Use is similar to pTHX, aTHX etc. */
+#define pMY_CXT my_cxt_t *my_cxtp
+#define pMY_CXT_ pMY_CXT,
+#define _pMY_CXT ,pMY_CXT
+#define aMY_CXT my_cxtp
+#define aMY_CXT_ aMY_CXT,
+#define _aMY_CXT ,aMY_CXT
+
+#endif /* START_MY_CXT */
+
+#ifndef MY_CXT_CLONE
+/* Clones the per-interpreter data. */
+#define MY_CXT_CLONE \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+#endif
+
+#else /* single interpreter */
+
+#ifndef START_MY_CXT
+
+#define START_MY_CXT static my_cxt_t my_cxt;
+#define dMY_CXT_SV dNOOP
+#define dMY_CXT dNOOP
+#define MY_CXT_INIT NOOP
+#define MY_CXT my_cxt
+
+#define pMY_CXT void
+#define pMY_CXT_
+#define _pMY_CXT
+#define aMY_CXT
+#define aMY_CXT_
+#define _aMY_CXT
+
+#endif /* START_MY_CXT */
+
+#ifndef MY_CXT_CLONE
+#define MY_CXT_CLONE NOOP
+#endif
+
+#endif
+
+#ifndef IVdf
+# if IVSIZE == LONGSIZE
+# define IVdf "ld"
+# define UVuf "lu"
+# define UVof "lo"
+# define UVxf "lx"
+# define UVXf "lX"
+# else
+# if IVSIZE == INTSIZE
+# define IVdf "d"
+# define UVuf "u"
+# define UVof "o"
+# define UVxf "x"
+# define UVXf "X"
+# endif
+# endif
+#endif
+
+#ifndef NVef
+# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
+ defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
+# define NVef PERL_PRIeldbl
+# define NVff PERL_PRIfldbl
+# define NVgf PERL_PRIgldbl
+# else
+# define NVef "e"
+# define NVff "f"
+# define NVgf "g"
+# endif
+#endif
+
+#ifndef SvPV_nolen
+
+#if defined(NEED_sv_2pv_nolen)
+static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
+static
+#else
+extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
+#endif
+
+#ifdef sv_2pv_nolen
+# undef sv_2pv_nolen
+#endif
+#define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a)
+#define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen)
+
+#if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL)
+
+char *
+DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv)
+{
+ STRLEN n_a;
+ return sv_2pv(sv, &n_a);
+}
+
+#endif
+
+/* Hint: sv_2pv_nolen
+ * Use the SvPV_nolen() macro instead of sv_2pv_nolen().
+ */
+
+/* SvPV_nolen depends on sv_2pv_nolen */
+#define SvPV_nolen(sv) \
+ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ ? SvPVX(sv) : sv_2pv_nolen(sv))
+
+#endif
+
+#ifdef SvPVbyte
+
+/* Hint: SvPVbyte
+ * Does not work in perl-5.6.1, ppport.h implements a version
+ * borrowed from perl-5.7.3.
+ */
+
+#if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0)))
+
+#if defined(NEED_sv_2pvbyte)
+static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
+static
+#else
+extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
+#endif
+
+#ifdef sv_2pvbyte
+# undef sv_2pvbyte
+#endif
+#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b)
+#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte)
+
+#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL)
+
+char *
+DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp)
+{
+ sv_utf8_downgrade(sv,0);
+ return SvPV(sv,*lp);
+}
+
+#endif
+
+/* Hint: sv_2pvbyte
+ * Use the SvPVbyte() macro instead of sv_2pvbyte().
+ */
+
+#undef SvPVbyte
+
+/* SvPVbyte depends on sv_2pvbyte */
+#define SvPVbyte(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
+
+#endif
+
+#else
+
+# define SvPVbyte SvPV
+# define sv_2pvbyte sv_2pv
+
+#endif
+
+/* sv_2pvbyte_nolen depends on sv_2pv_nolen */
+#ifndef sv_2pvbyte_nolen
+# define sv_2pvbyte_nolen sv_2pv_nolen
+#endif
+
+/* Hint: sv_pvn
+ * Always use the SvPV() macro instead of sv_pvn().
+ */
+#ifndef sv_pvn
+# define sv_pvn(sv, len) SvPV(sv, len)
+#endif
+
+/* Hint: sv_pvn_force
+ * Always use the SvPV_force() macro instead of sv_pvn_force().
+ */
+#ifndef sv_pvn_force
+# define sv_pvn_force(sv, len) SvPV_force(sv, len)
+#endif
+
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf)
+#if defined(NEED_vnewSVpvf)
+static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
+static
+#else
+extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
+#endif
+
+#ifdef vnewSVpvf
+# undef vnewSVpvf
+#endif
+#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b)
+#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf)
+
+#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL)
+
+SV *
+DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args)
+{
+ register SV *sv = newSV(0);
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ return sv;
+}
+
+#endif
+#endif
+
+/* sv_vcatpvf depends on sv_vcatpvfn */
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf)
+# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
+#endif
+
+/* sv_vsetpvf depends on sv_vsetpvfn */
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf)
+# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
+#endif
+
+/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg)
+#if defined(NEED_sv_catpvf_mg)
+static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
+static
+#else
+extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
+#endif
+
+#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
+
+#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
+
+void
+DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ SvSETMAGIC(sv);
+ va_end(args);
+}
+
+#endif
+#endif
+
+/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */
+#ifdef PERL_IMPLICIT_CONTEXT
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext)
+#if defined(NEED_sv_catpvf_mg_nocontext)
+static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
+static
+#else
+extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
+#endif
+
+#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
+#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
+
+#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
+
+void
+DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...)
+{
+ dTHX;
+ va_list args;
+ va_start(args, pat);
+ sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ SvSETMAGIC(sv);
+ va_end(args);
+}
+
+#endif
+#endif
+#endif
+
+#ifndef sv_catpvf_mg
+# ifdef PERL_IMPLICIT_CONTEXT
+# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
+# else
+# define sv_catpvf_mg Perl_sv_catpvf_mg
+# endif
+#endif
+
+/* sv_vcatpvf_mg depends on sv_vcatpvfn */
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg)
+# define sv_vcatpvf_mg(sv, pat, args) \
+ STMT_START { \
+ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
+ SvSETMAGIC(sv); \
+ } STMT_END
+#endif
+
+/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg)
+#if defined(NEED_sv_setpvf_mg)
+static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
+static
+#else
+extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
+#endif
+
+#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
+
+#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
+
+void
+DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
+{
+ va_list args;
+ va_start(args, pat);
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ SvSETMAGIC(sv);
+ va_end(args);
+}
+
+#endif
+#endif
+
+/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */
+#ifdef PERL_IMPLICIT_CONTEXT
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext)
+#if defined(NEED_sv_setpvf_mg_nocontext)
+static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
+static
+#else
+extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
+#endif
+
+#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
+#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
+
+#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
+
+void
+DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...)
+{
+ dTHX;
+ va_list args;
+ va_start(args, pat);
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ SvSETMAGIC(sv);
+ va_end(args);
+}
+
+#endif
+#endif
+#endif
+
+#ifndef sv_setpvf_mg
+# ifdef PERL_IMPLICIT_CONTEXT
+# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
+# else
+# define sv_setpvf_mg Perl_sv_setpvf_mg
+# endif
+#endif
+
+/* sv_vsetpvf_mg depends on sv_vsetpvfn */
+#if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg)
+# define sv_vsetpvf_mg(sv, pat, args) \
+ STMT_START { \
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
+ SvSETMAGIC(sv); \
+ } STMT_END
+#endif
+#ifndef SvGETMAGIC
+# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
+#endif
+#ifndef PERL_MAGIC_sv
+# define PERL_MAGIC_sv '\0'
+#endif
+
+#ifndef PERL_MAGIC_overload
+# define PERL_MAGIC_overload 'A'
+#endif
+
+#ifndef PERL_MAGIC_overload_elem
+# define PERL_MAGIC_overload_elem 'a'
+#endif
+
+#ifndef PERL_MAGIC_overload_table
+# define PERL_MAGIC_overload_table 'c'
+#endif
+
+#ifndef PERL_MAGIC_bm
+# define PERL_MAGIC_bm 'B'
+#endif
+
+#ifndef PERL_MAGIC_regdata
+# define PERL_MAGIC_regdata 'D'
+#endif
+
+#ifndef PERL_MAGIC_regdatum
+# define PERL_MAGIC_regdatum 'd'
+#endif
+
+#ifndef PERL_MAGIC_env
+# define PERL_MAGIC_env 'E'
+#endif
+
+#ifndef PERL_MAGIC_envelem
+# define PERL_MAGIC_envelem 'e'
+#endif
+
+#ifndef PERL_MAGIC_fm
+# define PERL_MAGIC_fm 'f'
+#endif
+
+#ifndef PERL_MAGIC_regex_global
+# define PERL_MAGIC_regex_global 'g'
+#endif
+
+#ifndef PERL_MAGIC_isa
+# define PERL_MAGIC_isa 'I'
+#endif
+
+#ifndef PERL_MAGIC_isaelem
+# define PERL_MAGIC_isaelem 'i'
+#endif
+
+#ifndef PERL_MAGIC_nkeys
+# define PERL_MAGIC_nkeys 'k'
+#endif
+
+#ifndef PERL_MAGIC_dbfile
+# define PERL_MAGIC_dbfile 'L'
+#endif
+
+#ifndef PERL_MAGIC_dbline
+# define PERL_MAGIC_dbline 'l'
+#endif
+
+#ifndef PERL_MAGIC_mutex
+# define PERL_MAGIC_mutex 'm'
+#endif
+
+#ifndef PERL_MAGIC_shared
+# define PERL_MAGIC_shared 'N'
+#endif
+
+#ifndef PERL_MAGIC_shared_scalar
+# define PERL_MAGIC_shared_scalar 'n'
+#endif
+
+#ifndef PERL_MAGIC_collxfrm
+# define PERL_MAGIC_collxfrm 'o'
+#endif
+
+#ifndef PERL_MAGIC_tied
+# define PERL_MAGIC_tied 'P'
+#endif
+
+#ifndef PERL_MAGIC_tiedelem
+# define PERL_MAGIC_tiedelem 'p'
+#endif
+
+#ifndef PERL_MAGIC_tiedscalar
+# define PERL_MAGIC_tiedscalar 'q'
+#endif
+
+#ifndef PERL_MAGIC_qr
+# define PERL_MAGIC_qr 'r'
+#endif
+
+#ifndef PERL_MAGIC_sig
+# define PERL_MAGIC_sig 'S'
+#endif
+
+#ifndef PERL_MAGIC_sigelem
+# define PERL_MAGIC_sigelem 's'
+#endif
+
+#ifndef PERL_MAGIC_taint
+# define PERL_MAGIC_taint 't'
+#endif
+
+#ifndef PERL_MAGIC_uvar
+# define PERL_MAGIC_uvar 'U'
+#endif
+
+#ifndef PERL_MAGIC_uvar_elem
+# define PERL_MAGIC_uvar_elem 'u'
+#endif
+
+#ifndef PERL_MAGIC_vstring
+# define PERL_MAGIC_vstring 'V'
+#endif
+
+#ifndef PERL_MAGIC_vec
+# define PERL_MAGIC_vec 'v'
+#endif
+
+#ifndef PERL_MAGIC_utf8
+# define PERL_MAGIC_utf8 'w'
+#endif
+
+#ifndef PERL_MAGIC_substr
+# define PERL_MAGIC_substr 'x'
+#endif
+
+#ifndef PERL_MAGIC_defelem
+# define PERL_MAGIC_defelem 'y'
+#endif
+
+#ifndef PERL_MAGIC_glob
+# define PERL_MAGIC_glob '*'
+#endif
+
+#ifndef PERL_MAGIC_arylen
+# define PERL_MAGIC_arylen '#'
+#endif
+
+#ifndef PERL_MAGIC_pos
+# define PERL_MAGIC_pos '.'
+#endif
+
+#ifndef PERL_MAGIC_backref
+# define PERL_MAGIC_backref '<'
+#endif
+
+#ifndef PERL_MAGIC_ext
+# define PERL_MAGIC_ext '~'
+#endif
+
+/* That's the best we can do... */
+#ifndef SvPV_force_nomg
+# define SvPV_force_nomg SvPV_force
+#endif
+
+#ifndef SvPV_nomg
+# define SvPV_nomg SvPV
+#endif
+
+#ifndef sv_catpvn_nomg
+# define sv_catpvn_nomg sv_catpvn
+#endif
+
+#ifndef sv_catsv_nomg
+# define sv_catsv_nomg sv_catsv
+#endif
+
+#ifndef sv_setsv_nomg
+# define sv_setsv_nomg sv_setsv
+#endif
+
+#ifndef sv_pvn_nomg
+# define sv_pvn_nomg sv_pvn
+#endif
+
+#ifndef SvIV_nomg
+# define SvIV_nomg SvIV
+#endif
+
+#ifndef SvUV_nomg
+# define SvUV_nomg SvUV
+#endif
+
+#ifndef sv_catpv_mg
+# define sv_catpv_mg(sv, ptr) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_catpv(TeMpSv,ptr); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_catpvn_mg
+# define sv_catpvn_mg(sv, ptr, len) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_catpvn(TeMpSv,ptr,len); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_catsv_mg
+# define sv_catsv_mg(dsv, ssv) \
+ STMT_START { \
+ SV *TeMpSv = dsv; \
+ sv_catsv(TeMpSv,ssv); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setiv_mg
+# define sv_setiv_mg(sv, i) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setiv(TeMpSv,i); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setnv_mg
+# define sv_setnv_mg(sv, num) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setnv(TeMpSv,num); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setpv_mg
+# define sv_setpv_mg(sv, ptr) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setpv(TeMpSv,ptr); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setpvn_mg
+# define sv_setpvn_mg(sv, ptr, len) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setpvn(TeMpSv,ptr,len); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setsv_mg
+# define sv_setsv_mg(dsv, ssv) \
+ STMT_START { \
+ SV *TeMpSv = dsv; \
+ sv_setsv(TeMpSv,ssv); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_setuv_mg
+# define sv_setuv_mg(sv, i) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_setuv(TeMpSv,i); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifndef sv_usepvn_mg
+# define sv_usepvn_mg(sv, ptr, len) \
+ STMT_START { \
+ SV *TeMpSv = sv; \
+ sv_usepvn(TeMpSv,ptr,len); \
+ SvSETMAGIC(TeMpSv); \
+ } STMT_END
+#endif
+
+#ifdef USE_ITHREADS
+#ifndef CopFILE
+# define CopFILE(c) ((c)->cop_file)
+#endif
+
+#ifndef CopFILEGV
+# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
+#endif
+
+#ifndef CopFILE_set
+# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
+#endif
+
+#ifndef CopFILESV
+# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
+#endif
+
+#ifndef CopFILEAV
+# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
+#endif
+
+#ifndef CopSTASHPV
+# define CopSTASHPV(c) ((c)->cop_stashpv)
+#endif
+
+#ifndef CopSTASHPV_set
+# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
+#endif
+
+#ifndef CopSTASH
+# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
+#endif
+
+#ifndef CopSTASH_set
+# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
+#endif
+
+#ifndef CopSTASH_eq
+# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
+ || (CopSTASHPV(c) && HvNAME(hv) \
+ && strEQ(CopSTASHPV(c), HvNAME(hv)))))
+#endif
+
+#else
+#ifndef CopFILEGV
+# define CopFILEGV(c) ((c)->cop_filegv)
+#endif
+
+#ifndef CopFILEGV_set
+# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
+#endif
+
+#ifndef CopFILE_set
+# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
+#endif
+
+#ifndef CopFILESV
+# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
+#endif
+
+#ifndef CopFILEAV
+# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
+#endif
+
+#ifndef CopFILE
+# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
+#endif
+
+#ifndef CopSTASH
+# define CopSTASH(c) ((c)->cop_stash)
+#endif
+
+#ifndef CopSTASH_set
+# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
+#endif
+
+#ifndef CopSTASHPV
+# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
+#endif
+
+#ifndef CopSTASHPV_set
+# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
+#endif
+
+#ifndef CopSTASH_eq
+# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
+#endif
+
+#endif /* USE_ITHREADS */
+#ifndef IN_PERL_COMPILETIME
+# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
+#endif
+
+#ifndef IN_LOCALE_RUNTIME
+# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
+#endif
+
+#ifndef IN_LOCALE_COMPILETIME
+# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
+#endif
+
+#ifndef IN_LOCALE
+# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
+#endif
+#ifndef IS_NUMBER_IN_UV
+# define IS_NUMBER_IN_UV 0x01
+#endif
+
+#ifndef IS_NUMBER_GREATER_THAN_UV_MAX
+# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
+#endif
+
+#ifndef IS_NUMBER_NOT_INT
+# define IS_NUMBER_NOT_INT 0x04
+#endif
+
+#ifndef IS_NUMBER_NEG
+# define IS_NUMBER_NEG 0x08
+#endif
+
+#ifndef IS_NUMBER_INFINITY
+# define IS_NUMBER_INFINITY 0x10
+#endif
+
+#ifndef IS_NUMBER_NAN
+# define IS_NUMBER_NAN 0x20
+#endif
+
+/* GROK_NUMERIC_RADIX depends on grok_numeric_radix */
+#ifndef GROK_NUMERIC_RADIX
+# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
+#endif
+#ifndef PERL_SCAN_GREATER_THAN_UV_MAX
+# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
+#endif
+
+#ifndef PERL_SCAN_SILENT_ILLDIGIT
+# define PERL_SCAN_SILENT_ILLDIGIT 0x04
+#endif
+
+#ifndef PERL_SCAN_ALLOW_UNDERSCORES
+# define PERL_SCAN_ALLOW_UNDERSCORES 0x01
+#endif
+
+#ifndef PERL_SCAN_DISALLOW_PREFIX
+# define PERL_SCAN_DISALLOW_PREFIX 0x02
+#endif
+
+#ifndef grok_numeric_radix
+#if defined(NEED_grok_numeric_radix)
+static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
+static
+#else
+extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
+#endif
+
+#ifdef grok_numeric_radix
+# undef grok_numeric_radix
+#endif
+#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
+#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
+
+#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
+bool
+DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
+{
+#ifdef USE_LOCALE_NUMERIC
+#ifdef PL_numeric_radix_sv
+ if (PL_numeric_radix_sv && IN_LOCALE) {
+ STRLEN len;
+ char* radix = SvPV(PL_numeric_radix_sv, len);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+#else
+ /* older perls don't have PL_numeric_radix_sv so the radix
+ * must manually be requested from locale.h
+ */
+#include <locale.h>
+ dTHR; /* needed for older threaded perls */
+ struct lconv *lc = localeconv();
+ char *radix = lc->decimal_point;
+ if (radix && IN_LOCALE) {
+ STRLEN len = strlen(radix);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+#endif /* PERL_VERSION */
+#endif /* USE_LOCALE_NUMERIC */
+ /* always try "." if numeric radix didn't match because
+ * we may have data from different locales mixed */
+ if (*sp < send && **sp == '.') {
+ ++*sp;
+ return TRUE;
+ }
+ return FALSE;
+}
+#endif
+#endif
+
+/* grok_number depends on grok_numeric_radix */
+
+#ifndef grok_number
+#if defined(NEED_grok_number)
+static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
+static
+#else
+extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
+#endif
+
+#ifdef grok_number
+# undef grok_number
+#endif
+#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
+#define Perl_grok_number DPPP_(my_grok_number)
+
+#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
+int
+DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
+{
+ const char *s = pv;
+ const char *send = pv + len;
+ const UV max_div_10 = UV_MAX / 10;
+ const char max_mod_10 = UV_MAX % 10;
+ int numtype = 0;
+ int sawinf = 0;
+ int sawnan = 0;
+
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s == send) {
+ return 0;
+ } else if (*s == '-') {
+ s++;
+ numtype = IS_NUMBER_NEG;
+ }
+ else if (*s == '+')
+ s++;
+
+ if (s == send)
+ return 0;
+
+ /* next must be digit or the radix separator or beginning of infinity */
+ if (isDIGIT(*s)) {
+ /* UVs are at least 32 bits, so the first 9 decimal digits cannot
+ overflow. */
+ UV value = *s - '0';
+ /* This construction seems to be more optimiser friendly.
+ (without it gcc does the isDIGIT test and the *s - '0' separately)
+ With it gcc on arm is managing 6 instructions (6 cycles) per digit.
+ In theory the optimiser could deduce how far to unroll the loop
+ before checking for overflow. */
+ if (++s < send) {
+ int digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ digit = *s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ if (++s < send) {
+ /* Now got 9 digits, so need to check
+ each time for overflow. */
+ digit = *s - '0';
+ while (digit >= 0 && digit <= 9
+ && (value < max_div_10
+ || (value == max_div_10
+ && digit <= max_mod_10))) {
+ value = value * 10 + digit;
+ if (++s < send)
+ digit = *s - '0';
+ else
+ break;
+ }
+ if (digit >= 0 && digit <= 9
+ && (s < send)) {
+ /* value overflowed.
+ skip the remaining digits, don't
+ worry about setting *valuep. */
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ numtype |=
+ IS_NUMBER_GREATER_THAN_UV_MAX;
+ goto skip_value;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ numtype |= IS_NUMBER_IN_UV;
+ if (valuep)
+ *valuep = value;
+
+ skip_value:
+ if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT;
+ while (s < send && isDIGIT(*s)) /* optional digits after the radix */
+ s++;
+ }
+ }
+ else if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
+ /* no digits before the radix means we need digits after it */
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ if (valuep) {
+ /* integer approximation is valid - it's 0. */
+ *valuep = 0;
+ }
+ }
+ else
+ return 0;
+ } else if (*s == 'I' || *s == 'i') {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
+ s++; if (s < send && (*s == 'I' || *s == 'i')) {
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
+ s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
+ s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
+ s++;
+ }
+ sawinf = 1;
+ } else if (*s == 'N' || *s == 'n') {
+ /* XXX TODO: There are signaling NaNs and quiet NaNs. */
+ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
+ s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
+ s++;
+ sawnan = 1;
+ } else
+ return 0;
+
+ if (sawinf) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
+ } else if (sawnan) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
+ } else if (s < send) {
+ /* we can have an optional exponent part */
+ if (*s == 'e' || *s == 'E') {
+ /* The only flag we keep is sign. Blow away any "it's UV" */
+ numtype &= IS_NUMBER_NEG;
+ numtype |= IS_NUMBER_NOT_INT;
+ s++;
+ if (s < send && (*s == '-' || *s == '+'))
+ s++;
+ if (s < send && isDIGIT(*s)) {
+ do {
+ s++;
+ } while (s < send && isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
+ }
+ while (s < send && isSPACE(*s))
+ s++;
+ if (s >= send)
+ return numtype;
+ if (len == 10 && memEQ(pv, "0 but true", 10)) {
+ if (valuep)
+ *valuep = 0;
+ return IS_NUMBER_IN_UV;
+ }
+ return 0;
+}
+#endif
+#endif
+
+/*
+ * The grok_* routines have been modified to use warn() instead of
+ * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
+ * which is why the stack variable has been renamed to 'xdigit'.
+ */
+
+#ifndef grok_bin
+#if defined(NEED_grok_bin)
+static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
+static
+#else
+extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
+#endif
+
+#ifdef grok_bin
+# undef grok_bin
+#endif
+#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
+#define Perl_grok_bin DPPP_(my_grok_bin)
+
+#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
+UV
+DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
+{
+ const char *s = start;
+ STRLEN len = *len_p;
+ UV value = 0;
+ NV value_nv = 0;
+
+ const UV max_div_2 = UV_MAX / 2;
+ bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
+ bool overflowed = FALSE;
+
+ if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
+ /* strip off leading b or 0b.
+ for compatibility silently suffer "b" and "0b" as valid binary
+ numbers. */
+ if (len >= 1) {
+ if (s[0] == 'b') {
+ s++;
+ len--;
+ }
+ else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
+ s+=2;
+ len-=2;
+ }
+ }
+ }
+
+ for (; len-- && *s; s++) {
+ char bit = *s;
+ if (bit == '0' || bit == '1') {
+ /* Write it in this wonky order with a goto to attempt to get the
+ compiler to make the common case integer-only loop pretty tight.
+ With gcc seems to be much straighter code than old scan_bin. */
+ redo:
+ if (!overflowed) {
+ if (value <= max_div_2) {
+ value = (value << 1) | (bit - '0');
+ continue;
+ }
+ /* Bah. We're just overflowed. */
+ warn("Integer overflow in binary number");
+ overflowed = TRUE;
+ value_nv = (NV) value;
+ }
+ value_nv *= 2.0;
+ /* If an NV has not enough bits in its mantissa to
+ * represent a UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply value_nv by the
+ * right amount. */
+ value_nv += (NV)(bit - '0');
+ continue;
+ }
+ if (bit == '_' && len && allow_underscores && (bit = s[1])
+ && (bit == '0' || bit == '1'))
+ {
+ --len;
+ ++s;
+ goto redo;
+ }
+ if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
+ warn("Illegal binary digit '%c' ignored", *s);
+ break;
+ }
+
+ if ( ( overflowed && value_nv > 4294967295.0)
+#if UVSIZE > 4
+ || (!overflowed && value > 0xffffffff )
+#endif
+ ) {
+ warn("Binary number > 0b11111111111111111111111111111111 non-portable");
+ }
+ *len_p = s - start;
+ if (!overflowed) {
+ *flags = 0;
+ return value;
+ }
+ *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result)
+ *result = value_nv;
+ return UV_MAX;
+}
+#endif
+#endif
+
+#ifndef grok_hex
+#if defined(NEED_grok_hex)
+static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
+static
+#else
+extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
+#endif
+
+#ifdef grok_hex
+# undef grok_hex
+#endif
+#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
+#define Perl_grok_hex DPPP_(my_grok_hex)
+
+#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
+UV
+DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
+{
+ const char *s = start;
+ STRLEN len = *len_p;
+ UV value = 0;
+ NV value_nv = 0;
+
+ const UV max_div_16 = UV_MAX / 16;
+ bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
+ bool overflowed = FALSE;
+ const char *xdigit;
+
+ if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
+ /* strip off leading x or 0x.
+ for compatibility silently suffer "x" and "0x" as valid hex numbers.
+ */
+ if (len >= 1) {
+ if (s[0] == 'x') {
+ s++;
+ len--;
+ }
+ else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
+ s+=2;
+ len-=2;
+ }
+ }
+ }
+
+ for (; len-- && *s; s++) {
+ xdigit = strchr((char *) PL_hexdigit, *s);
+ if (xdigit) {
+ /* Write it in this wonky order with a goto to attempt to get the
+ compiler to make the common case integer-only loop pretty tight.
+ With gcc seems to be much straighter code than old scan_hex. */
+ redo:
+ if (!overflowed) {
+ if (value <= max_div_16) {
+ value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
+ continue;
+ }
+ warn("Integer overflow in hexadecimal number");
+ overflowed = TRUE;
+ value_nv = (NV) value;
+ }
+ value_nv *= 16.0;
+ /* If an NV has not enough bits in its mantissa to
+ * represent a UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply value_nv by the
+ * right amount of 16-tuples. */
+ value_nv += (NV)((xdigit - PL_hexdigit) & 15);
+ continue;
+ }
+ if (*s == '_' && len && allow_underscores && s[1]
+ && (xdigit = strchr((char *) PL_hexdigit, s[1])))
+ {
+ --len;
+ ++s;
+ goto redo;
+ }
+ if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
+ warn("Illegal hexadecimal digit '%c' ignored", *s);
+ break;
+ }
+
+ if ( ( overflowed && value_nv > 4294967295.0)
+#if UVSIZE > 4
+ || (!overflowed && value > 0xffffffff )
+#endif
+ ) {
+ warn("Hexadecimal number > 0xffffffff non-portable");
+ }
+ *len_p = s - start;
+ if (!overflowed) {
+ *flags = 0;
+ return value;
+ }
+ *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result)
+ *result = value_nv;
+ return UV_MAX;
+}
+#endif
+#endif
+
+#ifndef grok_oct
+#if defined(NEED_grok_oct)
+static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
+static
+#else
+extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
+#endif
+
+#ifdef grok_oct
+# undef grok_oct
+#endif
+#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
+#define Perl_grok_oct DPPP_(my_grok_oct)
+
+#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
+UV
+DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
+{
+ const char *s = start;
+ STRLEN len = *len_p;
+ UV value = 0;
+ NV value_nv = 0;
+
+ const UV max_div_8 = UV_MAX / 8;
+ bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
+ bool overflowed = FALSE;
+
+ for (; len-- && *s; s++) {
+ /* gcc 2.95 optimiser not smart enough to figure that this subtraction
+ out front allows slicker code. */
+ int digit = *s - '0';
+ if (digit >= 0 && digit <= 7) {
+ /* Write it in this wonky order with a goto to attempt to get the
+ compiler to make the common case integer-only loop pretty tight.
+ */
+ redo:
+ if (!overflowed) {
+ if (value <= max_div_8) {
+ value = (value << 3) | digit;
+ continue;
+ }
+ /* Bah. We're just overflowed. */
+ warn("Integer overflow in octal number");
+ overflowed = TRUE;
+ value_nv = (NV) value;
+ }
+ value_nv *= 8.0;
+ /* If an NV has not enough bits in its mantissa to
+ * represent a UV this summing of small low-order numbers
+ * is a waste of time (because the NV cannot preserve
+ * the low-order bits anyway): we could just remember when
+ * did we overflow and in the end just multiply value_nv by the
+ * right amount of 8-tuples. */
+ value_nv += (NV)digit;
+ continue;
+ }
+ if (digit == ('_' - '0') && len && allow_underscores
+ && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
+ {
+ --len;
+ ++s;
+ goto redo;
+ }
+ /* Allow \octal to work the DWIM way (that is, stop scanning
+ * as soon as non-octal characters are seen, complain only iff
+ * someone seems to want to use the digits eight and nine). */
+ if (digit == 8 || digit == 9) {
+ if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
+ warn("Illegal octal digit '%c' ignored", *s);
+ }
+ break;
+ }
+
+ if ( ( overflowed && value_nv > 4294967295.0)
+#if UVSIZE > 4
+ || (!overflowed && value > 0xffffffff )
+#endif
+ ) {
+ warn("Octal number > 037777777777 non-portable");
+ }
+ *len_p = s - start;
+ if (!overflowed) {
+ *flags = 0;
+ return value;
+ }
+ *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
+ if (result)
+ *result = value_nv;
+ return UV_MAX;
+}
+#endif
+#endif
+
+#ifdef NO_XSLOCKS
+# ifdef dJMPENV
+# define dXCPT dJMPENV; int rEtV = 0
+# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
+# define XCPT_TRY_END JMPENV_POP;
+# define XCPT_CATCH if (rEtV != 0)
+# define XCPT_RETHROW JMPENV_JUMP(rEtV)
+# else
+# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0
+# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
+# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf);
+# define XCPT_CATCH if (rEtV != 0)
+# define XCPT_RETHROW Siglongjmp(top_env, rEtV)
+# endif
+#endif
+
+#endif /* _P_P_PORTABILITY_H_ */
+
+/* End of File ppport.h */
@@ -1,283 +1,51 @@
-
use XML::DifferenceMarkup qw(make_diff);
+use XML::LibXML;
use strict;
+use vars qw(*D);
+
+our ($path, @files, $testcount);
-our $testdata;
+sub reform
+{
+ my $out = '';
+ foreach (split /\n/, shift) {
+ $_ =~ s/^\s+//;
+ $out .= $_;
+ $out .= "\n";
+ }
-BEGIN {
- $testdata = [
- {
- name => 'same docs',
- a => <<A_SAME_DOCS,
-<?xml version="1.0"?>
-<some>
- <tree/>
-</some>
-A_SAME_DOCS
- b => <<B_SAME_DOCS,
-<?xml version="1.0"?>
-<some>
- <tree/>
-</some>
-B_SAME_DOCS
- diff => <<DIFF_SAME_DOCS
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:copy count="1"/>
-</dm:diff>
-DIFF_SAME_DOCS
- },
- {
- name => 'different attributes',
- a => <<A_DIFFERENT_ATTRIBUTES,
-<?xml version="1.0"?>
-<node with="attr"/>
-A_DIFFERENT_ATTRIBUTES
- b => <<B_DIFFERENT_ATTRIBUTES,
-<?xml version="1.0"?>
-<node with="other value"/>
-B_DIFFERENT_ATTRIBUTES
- diff => <<DIFF_DIFFERENT_ATTRIBUTES
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:delete>
- <node with="attr"/>
- </dm:delete>
- <dm:insert>
- <node with="other value"/>
- </dm:insert>
-</dm:diff>
-DIFF_DIFFERENT_ATTRIBUTES
- },
- {
- name => 'no version',
- a => <<A_NO_VERSION,
-<some><tree/></some>
-A_NO_VERSION
- b => <<B_NO_VERSION,
-<some>
- <tree/>
-</some>
-B_NO_VERSION
- diff => <<DIFF_NO_VERSION
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:copy count="1"/>
-</dm:diff>
-DIFF_NO_VERSION
- },
- {
- name => 'whitespace between attributes',
- a => <<A_WHITESPACE_BETWEEN_ATTRIBUTES,
-<?xml version="1.0"?>
-<node a="a" b="b"/>
-A_WHITESPACE_BETWEEN_ATTRIBUTES
- b => <<B_WHITESPACE_BETWEEN_ATTRIBUTES,
-<?xml version="1.0"?>
-<node a="a" b="b"/>
-B_WHITESPACE_BETWEEN_ATTRIBUTES
- diff => <<DIFF_WHITESPACE_BETWEEN_ATTRIBUTES
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:copy count="1"/>
-</dm:diff>
-DIFF_WHITESPACE_BETWEEN_ATTRIBUTES
- },
- {
- name => 'attribute quotes',
- a => <<A_ATTRIBUTE_QUOTES,
-<?xml version="1.0"?>
-<node a="a" b='b'/>
-A_ATTRIBUTE_QUOTES
- b => <<B_ATTRIBUTE_QUOTES,
-<?xml version="1.0"?>
-<node a='a' b="b"/>
-B_ATTRIBUTE_QUOTES
- diff => <<DIFF_ATTRIBUTE_QUOTES
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:copy count="1"/>
-</dm:diff>
-DIFF_ATTRIBUTE_QUOTES
- },
- {
- name => 'different docs',
- a => <<A_DIFFERENT_DOCS,
-<?xml version="1.0"?>
- <w:old xmlns:w="http://random.old.com/a/">
- <tree>
- <with>
- <some>
- <subtree/>
- </some>
- </with>
- </tree>
- </w:old>
-A_DIFFERENT_DOCS
- b => <<B_DIFFERENT_DOCS,
-<?xml version="1.0"?>
-<new xmlns:e="http://random.new.com/b/">
- <e:tree>with the whole subtree, of course</e:tree>
-</new>
-B_DIFFERENT_DOCS
- diff => <<DIFF_DIFFERENT_DOCS
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:delete>
- <w:old xmlns:w="http://random.old.com/a/"/>
- </dm:delete>
- <dm:insert>
- <new xmlns:e="http://random.new.com/b/">
- <e:tree>with the whole subtree, of course</e:tree>
- </new>
- </dm:insert>
-</dm:diff>
-DIFF_DIFFERENT_DOCS
- },
- {
- name => 'extra ns node',
- a => <<A_EXTRA_NS_NODE,
-<?xml version="1.0"?>
- <old xmlns:w="http://random.old.com/a/">
- <w:tree/>
- </old>
-A_EXTRA_NS_NODE
- b => <<B_EXTRA_NS_NODE,
-<?xml version="1.0"?>
-<new/>
-B_EXTRA_NS_NODE
-# 8Sep2002: note that the 'w' namespace isn't needed any more; the
-# diff keeps it even if there are no nodes using it
- diff => <<DIFF_EXTRA_NS_NODE
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:delete>
- <old xmlns:w="http://random.old.com/a/"/>
- </dm:delete>
- <dm:insert>
- <new/>
- </dm:insert>
-</dm:diff>
-DIFF_EXTRA_NS_NODE
- },
- {
- name => 'namespace without prefix',
- a => <<A_NAMESPACE_WITHOUT_PREFIX,
-<root>
-</root>
-A_NAMESPACE_WITHOUT_PREFIX
- b => <<B_NAMESPACE_WITHOUT_PREFIX,
-<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="cs" lang="cs">
-</html>
-B_NAMESPACE_WITHOUT_PREFIX
- diff => <<DIFF_NAMESPACE_WITHOUT_PREFIX
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:delete>
- <root/>
- </dm:delete>
- <dm:insert>
- <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="cs" lang="cs">
-</html>
- </dm:insert>
-</dm:diff>
-DIFF_NAMESPACE_WITHOUT_PREFIX
- },
- {
- name => 'different DTD',
- a => <<A_DIFFERENT_DTD,
-<root>
-</root>
-A_DIFFERENT_DTD
- b => <<B_DIFFERENT_DTD,
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-<html>
-</html>
-B_DIFFERENT_DTD
- diff => <<DIFF_DIFFERENT_DTD
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:delete>
- <root/>
- </dm:delete>
- <dm:insert>
- <html xmlns="http://www.w3.org/1999/xhtml"/>
- </dm:insert>
-</dm:diff>
-DIFF_DIFFERENT_DTD
- },
- {
- name => 'taken prefix unused',
- a => <<A_TAKEN_PREFIX_UNUSED,
-<?xml version="1.0"?>
-<dm:node xmlns:dm="http://www.deadmouse.com/"/>
-A_TAKEN_PREFIX_UNUSED
- b => <<B_TAKEN_PREFIX_UNUSED,
-<?xml version="1.0"?>
-<dm:node xmlns:dm="http://www.deadmouse.com/"/>
-B_TAKEN_PREFIX_UNUSED
- diff => <<DIFF_TAKEN_PREFIX_UNUSED
-<?xml version="1.0"?>
-<dm2:diff xmlns:dm2="http://www.locus.cz/XML/DifferenceMarkup">
- <dm2:copy count="1"/>
-</dm2:diff>
-DIFF_TAKEN_PREFIX_UNUSED
- },
- {
- name => 'taken prefix used',
- a => <<A_TAKEN_PREFIX_USED,
-<?xml version="1.0"?>
-<dm:old xmlns:dm="http://www.deadmouse.com/"/>
-A_TAKEN_PREFIX_USED
- b => <<B_TAKEN_PREFIX_USED,
-<?xml version="1.0"?>
-<dm:new xmlns:dm="http://www.deadmouse.com/"/>
-B_TAKEN_PREFIX_USED
- diff => <<DIFF_TAKEN_PREFIX_USED
-<?xml version="1.0"?>
-<dm2:diff xmlns:dm2="http://www.locus.cz/XML/DifferenceMarkup">
- <dm2:delete>
- <dm:old xmlns:dm="http://www.deadmouse.com/"/>
- </dm2:delete>
- <dm2:insert>
- <dm:new xmlns:dm="http://www.deadmouse.com/"/>
- </dm2:insert>
-</dm2:diff>
-DIFF_TAKEN_PREFIX_USED
- }
- ];
+ return $out;
}
-use Test::More tests => scalar @$testdata;
+BEGIN
+{
+ $path = "testdata/diff";
+ @files = glob "$path/*.xml";
+ $testcount = scalar(@files) / 3;
+}
-# 21Sep2002: It would be better to compare canonicalized docs, but
-# since there's no support for XML canonicalization in LibXML... Using
-# isSameNode on the document element is also possible, but the
-# document element isn't the whole document, and we *want* to test the
-# serialized version...
+use Test::More tests => $testcount;
-sub scrub_elem {
- my ($elem, $doc) = @_;
+my $parser = XML::LibXML->new(keep_blanks => 0, load_ext_dtd => 0);
- $doc =~ s~<(dm[0-9]*):$elem\s+xmlns:\1="http://www.locus.cz/XML/DifferenceMarkup"~<$1:$elem~g;
- return $doc;
-}
+my $i = 0;
+while ($i < $testcount) {
-sub scrub {
- my $doc = shift;
+ my $n = sprintf("%02d", $i);
- return scrub_elem('copy',
- scrub_elem('delete', scrub_elem('insert', $doc)));
-}
+ my $a = $parser->parse_file("$path/$n" . "a.xml");
+ my $b = $parser->parse_file("$path/$n" . "b.xml");
+
+ open(D, "$path/$n" . "d.xml");
+ my $expected = reform(join '', <D>);
-my $parser = XML::LibXML->new();
-$parser->keep_blanks(0);
+ my $diff = make_diff($a, $b);
+ my $actual = reform($diff->toString(1));
-foreach my $data (@$testdata) {
- my $dom = make_diff($parser->parse_string($data->{a}),
- $parser->parse_string($data->{b}));
- is(scrub($dom->toString(1)), $data->{diff}, $data->{name});
+ is($actual, $expected, "$path/$n?.xml");
+
+ ++$i;
}
+
@@ -1,190 +1,39 @@
-
use XML::DifferenceMarkup qw(merge_diff);
+use XML::LibXML;
use strict;
+use vars qw(*B);
-our $testdata;
+our ($path, @files, $testcount);
-BEGIN {
- $testdata = [
- {
- name => 'same docs',
- a => <<A_SAME_DOCS,
-<?xml version="1.0"?>
-<some>
- <tree/>
-</some>
-A_SAME_DOCS
- b => <<B_SAME_DOCS,
-<?xml version="1.0"?>
-<some>
- <tree/>
-</some>
-B_SAME_DOCS
- diff => <<DIFF_SAME_DOCS
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:copy count="1"/>
-</dm:diff>
-DIFF_SAME_DOCS
- },
- {
- name => 'different attributes',
- a => <<A_DIFFERENT_ATTRIBUTES,
-<?xml version="1.0"?>
-<node with="attr"/>
-A_DIFFERENT_ATTRIBUTES
- b => <<B_DIFFERENT_ATTRIBUTES,
-<?xml version="1.0"?>
-<node with="other value"/>
-B_DIFFERENT_ATTRIBUTES
- diff => <<DIFF_DIFFERENT_ATTRIBUTES
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:delete>
- <node with="attr"/>
- </dm:delete>
- <dm:insert>
- <node with="other value"/>
- </dm:insert>
-</dm:diff>
-DIFF_DIFFERENT_ATTRIBUTES
- },
- # 28Sep2002: not in the roundup tests because LibXML
- # doesn't format the reconstructed b-document
- # properly
- {
- name => 'two inserts',
- a => <<A_TWO_INSERTS,
-<?xml version="1.0"?>
-<framework>
-<structure/>
-</framework>
-A_TWO_INSERTS
- b => <<B_TWO_INSERTS,
-<?xml version="1.0"?>
-<framework><structure>
-with some
-</structure>
-inserted content...
-</framework>
-B_TWO_INSERTS
- diff => <<DIFF_TWO_INSERTS
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <framework>
- <structure>
- <dm:insert xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
-with some
-</dm:insert>
- </structure>
- <dm:insert xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
-inserted content...
-</dm:insert>
- </framework>
-</dm:diff>
-DIFF_TWO_INSERTS
- },
- {
- name => 'deep inserts',
- a => <<A_DEEP_INSERTS,
-<?xml version="1.0"?>
-<framework>
-<with>
-<a>
-<structure/>
-</a>
-</with>
-</framework>
-A_DEEP_INSERTS
- b => <<B_DEEP_INSERTS,
-<?xml version="1.0"?>
-<framework><with><a><structure>
-with some
-</structure></a></with>
-inserted content...
-</framework>
-B_DEEP_INSERTS
- diff => <<DIFF_DEEP_INSERTS,
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <framework>
- <with>
- <a>
- <structure>
- <dm:insert>
-with some
-</dm:insert>
- </structure>
- </a>
- </with>
- <dm:insert>
-inserted content...
-</dm:insert>
- </framework>
-</dm:diff>
-DIFF_DEEP_INSERTS
- },
- {
- name => 'spaced inserts',
- a => <<A_SPACED_INSERTS,
-<?xml version="1.0"?>
-<framework>
-<x1/>
-<x2/>
-<x3/>
-<with>
-<a>
-<structure/>
-</a>
-</with>
-<x4/>
-<x5/>
-</framework>
-A_SPACED_INSERTS
- b => <<B_SPACED_INSERTS,
-<?xml version="1.0"?>
-<framework><x1/><x2/><x3/><with><a><structure>
-with some
-</structure></a></with><x4/>
-inserted content...
-<x5/></framework>
-B_SPACED_INSERTS
- diff => <<DIFF_SPACED_INSERTS,
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <framework>
- <dm:copy count="3"/>
- <with>
- <a>
- <structure>
- <dm:insert>
-with some
-</dm:insert>
- </structure>
- </a>
- </with>
- <dm:copy count="1"/>
- <dm:insert>
-inserted content...
-</dm:insert>
- <dm:copy count="1"/>
- </framework>
-</dm:diff>
-DIFF_SPACED_INSERTS
- }
- ];
+BEGIN
+{
+ $path = "testdata/merge";
+ @files = glob "$path/*.xml";
+ $testcount = scalar(@files) / 3;
}
-use Test::More tests => scalar @$testdata;
+use Test::More tests => $testcount;
+
+my $parser = XML::LibXML->new(keep_blanks => 0, load_ext_dtd => 0);
+
+my $i = 0;
+while ($i < $testcount) {
+
+ my $n = sprintf("%02d", $i);
-my $parser = XML::LibXML->new();
-$parser->keep_blanks(0);
+ my $a = $parser->parse_file("$path/$n" . "a.xml");
+ my $d = $parser->parse_file("$path/$n" . "d.xml");
-foreach my $data (@$testdata) {
- my $a = $parser->parse_string($data->{a});
- my $diff = $parser->parse_string($data->{diff});
- my $merge = merge_diff($a, $diff);
- is($merge->toString(1), $data->{b}, $data->{name});
+ open(B, "$path/$n" . "b.xml");
+ my $expected = join '', <B>;
+
+ my $merged = merge_diff($a, $d);
+ my $actual = $merged->toString(1);
+
+ is($actual, $expected, "$path/$n?.xml");
+
+ ++$i;
}
+
@@ -1,750 +1,60 @@
-
use XML::DifferenceMarkup qw(make_diff merge_diff);
+use XML::LibXML;
use strict;
+use vars qw(*F);
+
+our ($path, @files, $testcount);
+
+sub reform
+{
+ my $raw = shift;
+ if ($raw =~ /<![[]CDATA/) {
+ return $raw;
+ }
+
+ my $out = '';
+ foreach (split /\n/, $raw) {
+ $_ =~ s/^\s+//;
+ $out .= $_;
+ $out .= "\n";
+ }
-our $testdata;
+ return $out;
+}
-BEGIN {
- $testdata = [
- {
- name => 'different docs',
- a => <<A_DIFFERENT_DOCS,
-<?xml version="1.0"?>
- <old>
- <tree>
- <with>
- <some>
- <subtree/>
- </some>
- </with>
- </tree>
- </old>
-A_DIFFERENT_DOCS
- b => <<B_DIFFERENT_DOCS,
-<?xml version="1.0"?>
-<new>
- <tree>with the whole subtree, of course</tree>
-</new>
-B_DIFFERENT_DOCS
- diff => <<DIFF_DIFFERENT_DOCS
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:delete>
- <old/>
- </dm:delete>
- <dm:insert>
- <new>
- <tree>with the whole subtree, of course</tree>
- </new>
- </dm:insert>
-</dm:diff>
-DIFF_DIFFERENT_DOCS
- },
-# 18Jul2003: this is the case where it would be useful to have a
-# "dm:update" attribute
- {
- name => 'almost same docs',
- a => <<A_ALMOST_SAME_DOCS,
-<?xml version="1.0"?>
-<deep>
- <tree>
- <with>
- <some>
- <subtree/>
- </some>
- </with>
- </tree>
-</deep>
-A_ALMOST_SAME_DOCS
- b => <<B_ALMOST_SAME_DOCS,
-<?xml version="1.0"?>
-<different>
- <tree>
- <with>
- <some>
- <subtree/>
- </some>
- </with>
- </tree>
-</different>
-B_ALMOST_SAME_DOCS
- diff => <<DIFF_ALMOST_SAME_DOCS
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:delete>
- <deep/>
- </dm:delete>
- <dm:insert>
- <different>
- <tree>
- <with>
- <some>
- <subtree/>
- </some>
- </with>
- </tree>
- </different>
- </dm:insert>
-</dm:diff>
-DIFF_ALMOST_SAME_DOCS
- },
- {
- name => 'unordered attributes',
- a => <<A_UNORDERED_ATTRIBUTES,
-<?xml version="1.0"?>
-<top a="1" c="3" b="2"/>
-A_UNORDERED_ATTRIBUTES
- b => <<B_UNORDERED_ATTRIBUTES,
-<?xml version="1.0"?>
-<top b="2" a="1" c="3"/>
-B_UNORDERED_ATTRIBUTES
- diff => <<DIFF_UNORDERED_ATTRIBUTES
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:delete>
- <top a="1" c="3" b="2"/>
- </dm:delete>
- <dm:insert>
- <top b="2" a="1" c="3"/>
- </dm:insert>
-</dm:diff>
-DIFF_UNORDERED_ATTRIBUTES
- },
- {
- name => 'text node',
- a => <<A_TEXT_NODE,
-<?xml version="1.0"?>
-<top>
-Some text.
-</top>
-A_TEXT_NODE
- b => <<B_TEXT_NODE,
-<?xml version="1.0"?>
-<top>
-A changed text.
-</top>
-B_TEXT_NODE
- diff => <<DIFF_TEXT_NODE
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <top>
- <dm:delete>
-Some text.
-</dm:delete>
- <dm:insert>
-A changed text.
-</dm:insert>
- </top>
-</dm:diff>
-DIFF_TEXT_NODE
- },
- {
- name => 'comment node',
- a => <<A_COMMENT_NODE,
-<?xml version="1.0"?>
-<textnode>
-<!-- with just a comment -->
-</textnode>
-<!-- note that the comment outside the top node is not preserved -->
-A_COMMENT_NODE
- b => <<B_COMMENT_NODE,
-<?xml version="1.0"?>
-<textnode>
-<!-- with a different comment -->
-</textnode>
-B_COMMENT_NODE
- diff => <<DIFF_COMMENT_NODE
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <textnode>
- <dm:delete>
-<!-- with just a comment -->
- </dm:delete>
- <dm:insert>
-<!-- with a different comment -->
- </dm:insert>
- </textnode>
-</dm:diff>
-DIFF_COMMENT_NODE
- },
- {
- name => 'processing instruction node',
- a => <<A_PI_NODE,
-<?xml version="1.0"?>
-<textnode>
-<?do something?>
-</textnode>
-<!-- note that the comment outside the top node is not preserved -->
-A_PI_NODE
- b => <<B_PI_NODE,
-<?xml version="1.0"?>
-<textnode>
-<?dont do it yet?>
-</textnode>
-B_PI_NODE
- diff => <<DIFF_PI_NODE
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <textnode>
- <dm:delete>
-<?do something?>
- </dm:delete>
- <dm:insert>
-<?dont do it yet?>
- </dm:insert>
- </textnode>
-</dm:diff>
-DIFF_PI_NODE
- },
- {
- name => 'pruned delete',
- a => <<A_PRUNED_DELETE,
-<?xml version="1.0"?>
-<a>
- <little>
- <bit>
- <deeper>
- <tree>
- <with>
- <additional>
- <nodes/>
- </additional>
- </with>
- </tree>
- </deeper>
- </bit>
- </little>
-</a>
-A_PRUNED_DELETE
- b => <<B_PRUNED_DELETE,
-<?xml version="1.0"?>
-<a>
- <little>
- <bit>
- <deeper>
- <tree/>
- </deeper>
- </bit>
- </little>
-</a>
-B_PRUNED_DELETE
-# 5Sep2002: the extra namespace declaration is ugly...
- diff => <<DIFF_PRUNED_DELETE
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <a>
- <little>
- <bit>
- <deeper>
- <tree>
- <dm:delete>
- <with/>
- </dm:delete>
- </tree>
- </deeper>
- </bit>
- </little>
- </a>
-</dm:diff>
-DIFF_PRUNED_DELETE
- },
- {
- name => 'delete before copy',
- a => <<A_DELETE_BEFORE_COPY,
-<?xml version="1.0"?>
-<delta>
- <uri value="first">
- <word value="1."/>
- </uri>
- <uri value="second">
- <word value="2."/>
- </uri>
- <uri value="third">
- <word value="3."/>
- </uri>
- <uri value="fourth">
- <word value="4."/>
- </uri>
-</delta>
-A_DELETE_BEFORE_COPY
- b => <<B_DELETE_BEFORE_COPY,
-<?xml version="1.0"?>
-<delta>
- <uri value="first">
- <word value="1."/>
- </uri>
- <uri value="second">
- <word value="2."/>
- </uri>
- <uri value="fourth">
- <word value="4."/>
- </uri>
-</delta>
-B_DELETE_BEFORE_COPY
- diff => <<DIFF_DELETE_BEFORE_COPY,
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <delta>
- <dm:copy count="2"/>
- <dm:delete>
- <uri value="third"/>
- </dm:delete>
- <dm:copy count="1"/>
- </delta>
-</dm:diff>
-DIFF_DELETE_BEFORE_COPY
- },
- {
- name => 'repeated delete',
- a => <<A_REPEATED_DELETE,
-<?xml version="1.0"?>
-<top>
- <a/>
- <b/>
- <c/>
- <d/>
- <e/>
- <f/>
-</top>
-A_REPEATED_DELETE
- b => <<B_REPEATED_DELETE,
-<?xml version="1.0"?>
-<top>
- <d/>
- <e/>
- <f/>
-</top>
-B_REPEATED_DELETE
- diff => <<DIFF_REPEATED_DELETE
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <top>
- <dm:delete>
- <a/>
- <b/>
- <c/>
- </dm:delete>
- <dm:copy count="3"/>
- </top>
-</dm:diff>
-DIFF_REPEATED_DELETE
- },
- {
- name => 'reorder',
- a => <<A_REORDER,
-<?xml version="1.0"?>
-<some>text<!-- and comment --></some>
-A_REORDER
- b => <<B_REORDER,
-<?xml version="1.0"?>
-<some><!-- and comment -->text</some>
-B_REORDER
- diff => <<DIFF_REORDER
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <some>
- <dm:delete>text</dm:delete>
- <dm:copy count="1"/>
- <dm:insert>text</dm:insert>
- </some>
-</dm:diff>
-DIFF_REORDER
- },
- {
- name => 'repetitive',
- a => <<A_REPETITIVE,
-<?xml version="1.0"?>
-<repetitive>
- <a/>
- <a/>
- <a/>
- <a/>
- <a/>
- <a/>
-</repetitive>
-A_REPETITIVE
- b => <<B_REPETITIVE,
-<?xml version="1.0"?>
-<repetitive>
- <a/>
- <a/>
-</repetitive>
-B_REPETITIVE
- diff => <<DIFF_REPETITIVE
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <repetitive>
- <dm:copy count="2"/>
- <dm:delete>
- <a/>
- <a/>
- <a/>
- <a/>
- </dm:delete>
- </repetitive>
-</dm:diff>
-DIFF_REPETITIVE
- },
- {
- name => 'asymmetric replace',
- a => <<A_ASYMMETRIC_REPLACE,
-<?xml version="1.0"?>
-<top>
- <a/>
- <b/>
-</top>
-A_ASYMMETRIC_REPLACE
- b => <<B_ASYMMETRIC_REPLACE,
-<?xml version="1.0"?>
-<top>
- <x/>
-</top>
-B_ASYMMETRIC_REPLACE
-# 5Sep2002: the extra namespace declaration is ugly...
- diff => <<DIFF_ASYMMETRIC_REPLACE
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <top>
- <dm:delete>
- <a/>
- <b/>
- </dm:delete>
- <dm:insert>
- <x/>
- </dm:insert>
- </top>
-</dm:diff>
-DIFF_ASYMMETRIC_REPLACE
- },
- { # 5Sep2002: added to expose an incorect use of _prune
- name => 'deep asymmetric replace',
- a => <<A_DEEP_ASYMMETRIC_REPLACE,
-<?xml version="1.0"?>
-<top>
- <a/>
- <b>
- <with/> a subtree
- </b>
-</top>
-A_DEEP_ASYMMETRIC_REPLACE
- b => <<B_DEEP_ASYMMETRIC_REPLACE,
-<?xml version="1.0"?>
-<top>
- <x/>
-</top>
-B_DEEP_ASYMMETRIC_REPLACE
-# 5Sep2002: the extra namespace declaration is ugly...
- diff => <<DIFF_DEEP_ASYMMETRIC_REPLACE
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <top>
- <dm:delete>
- <a/>
- <b/>
- </dm:delete>
- <dm:insert>
- <x/>
- </dm:insert>
- </top>
-</dm:diff>
-DIFF_DEEP_ASYMMETRIC_REPLACE
- },
- {
- name => 'insert below delete',
- a => <<A_INSERT_BELOW_DELETE,
-<?xml version="1.0"?>
-<page attr="1">
- <word value="Arbeiter"/>
- <word value="Kopf"/>
-</page>
-A_INSERT_BELOW_DELETE
- b => <<B_INSERT_BELOW_DELETE,
-<?xml version="1.0"?>
-<page attr="1">
- <word value="Kopf">
- <trans value="hlava"/>
- </word>
-</page>
-B_INSERT_BELOW_DELETE
-# 14Sep2002: the extra namespace declaration is ugly...
- diff => <<DIFF_INSERT_BELOW_DELETE,
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <page attr="1">
- <dm:delete>
- <word value="Arbeiter"/>
- </dm:delete>
- <word value="Kopf">
- <dm:insert>
- <trans value="hlava"/>
- </dm:insert>
- </word>
- </page>
-</dm:diff>
-DIFF_INSERT_BELOW_DELETE
- },
- {
- name => 'two changes',
- a => <<A_TWO_CHANGES,
-<?xml version="1.0"?>
-<a>
- <a2>
- <tree/>
- </a2>
- <a3>another</a3>
-</a>
-A_TWO_CHANGES
- b => <<B_TWO_CHANGES,
-<?xml version="1.0"?>
-<a>
- <a2/>
- <a3>difference</a3>
-</a>
-B_TWO_CHANGES
- diff => <<DIFF_TWO_CHANGES
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <a>
- <a2>
- <dm:delete>
- <tree/>
- </dm:delete>
- </a2>
- <a3>
- <dm:delete>another</dm:delete>
- <dm:insert>difference</dm:insert>
- </a3>
- </a>
-</dm:diff>
-DIFF_TWO_CHANGES
- },
- {
- name => 'balanced traversal',
- a => <<A_BALANCED_TRAVERSAL,
-<?xml version="1.0"?>
-<a>
- <a2>
- <mostly>
- <but>
- <not>
- <entirely>
- <same>
- <tree/>
- </same>
- </entirely>
- </not>
- </but>
- </mostly>
- </a2>
- <a3>another</a3>
-</a>
-A_BALANCED_TRAVERSAL
- b => <<B_BALANCED_TRAVERSAL,
-<?xml version="1.0"?>
-<a>
- <a2>
- <mostly>
- <but>
- <not>
- <entirely>
- <same/>
- </entirely>
- </not>
- </but>
- </mostly>
- </a2>
- <a3>difference</a3>
-</a>
-B_BALANCED_TRAVERSAL
- diff => <<DIFF_BALANCED_TRAVERSAL
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <a>
- <a2>
- <mostly>
- <but>
- <not>
- <entirely>
- <same>
- <dm:delete>
- <tree/>
- </dm:delete>
- </same>
- </entirely>
- </not>
- </but>
- </mostly>
- </a2>
- <a3>
- <dm:delete>another</dm:delete>
- <dm:insert>difference</dm:insert>
- </a3>
- </a>
-</dm:diff>
-DIFF_BALANCED_TRAVERSAL
- },
-# 18Jul2003: this case shows why it's problematic to treat the DOM
-# tree as a sequence
- {
- name => 'nesting change',
- a => <<A_NESTING,
-<?xml version="1.0"?>
-<top>
- <a/>
- <b/>
- <c/>
-</top>
-A_NESTING
- b => <<B_NESTING,
-<?xml version="1.0"?>
-<top>
- <a>
- <b>
- <c/>
- </b>
- </a>
-</top>
-B_NESTING
- diff => <<DIFF_NESTING
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <top>
- <a>
- <dm:insert>
- <b>
- <c/>
- </b>
- </dm:insert>
- </a>
- <dm:delete>
- <b/>
- <c/>
- </dm:delete>
- </top>
-</dm:diff>
-DIFF_NESTING
- },
- {
- name => 'extracted db dump',
- a => <<A_EXTRACTED_DB_DUMP,
-<?xml version="1.0"?>
-<table>
-<word value="reordered">
-<trans value="a"/>
-<trans value="b"/>
-<trans value="c"/>
-</word>
-<word value="leidenschaftlich"/>
-<word value="leider"/>
-</table>
-A_EXTRACTED_DB_DUMP
- b => <<B_EXTRACTED_DB_DUMP,
-<?xml version="1.0"?>
-<table>
- <word value="reordered">
- <trans value="b"/>
- <trans value="c"/>
- <trans value="a"/>
- </word>
- <word value="leidenschaftlich"/>
- <word value="leider"/>
-</table>
-B_EXTRACTED_DB_DUMP
- diff => <<DIFF_EXTRACTED_DB_DUMP
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <table>
- <word value="reordered">
- <dm:delete>
- <trans value="a"/>
- </dm:delete>
- <dm:copy count="2"/>
- <dm:insert>
- <trans value="a"/>
- </dm:insert>
- </word>
- <dm:copy count="2"/>
- </table>
-</dm:diff>
-DIFF_EXTRACTED_DB_DUMP
- },
- {
- name => 'suboptimal',
- a => <<A_SUBOPTIMAL,
-<?xml version="1.0"?>
-<top>
- <a>
- <with>
-a tree it would be nice to keep in the common subset
-</with>
- </a>
- <a/>
- <x/>
- <x/>
-</top>
-A_SUBOPTIMAL
- b => <<B_SUBOPTIMAL,
-<?xml version="1.0"?>
-<top>
- <x/>
- <x/>
- <a>
- <with>
-a tree it would be nice to keep in the common subset
-</with>
- </a>
- <a/>
-</top>
-B_SUBOPTIMAL
- diff => <<DIFF_SUBOPTIMAL,
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <top>
- <dm:delete>
- <a/>
- <a/>
- </dm:delete>
- <dm:copy count="2"/>
- <dm:insert>
- <a>
- <with>
-a tree it would be nice to keep in the common subset
-</with>
- </a>
- <a/>
- </dm:insert>
- </top>
-</dm:diff>
-DIFF_SUBOPTIMAL
- }
- ];
+BEGIN
+{
+ $path = "testdata/roundup";
+ @files = glob "$path/*.xml";
+ $testcount = scalar(@files) / 3;
}
-use Test::More tests => 2 * scalar @$testdata;
+use Test::More tests => 2 * $testcount;
-sub scrub {
- my $doc = shift;
+my $parser = XML::LibXML->new(keep_blanks => 0, load_ext_dtd => 0);
- $doc =~ s~<(dm[0-9]*):(?!diff)([a-z0-9]+)\s+xmlns:\1="http://www.locus.cz/XML/DifferenceMarkup"~<$1:$2~g;
+my $i = 0;
+while ($i < $testcount) {
- $doc =~ s~<([a-z0-9]+)\s+xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup"~<$1~g;
+ my $n = sprintf("%02d", $i);
- return $doc;
-}
+ my $a = $parser->parse_file("$path/$n" . "a.xml");
-my $parser = XML::LibXML->new();
-$parser->keep_blanks(0);
+ open(F, "$path/$n" . "b.xml");
+ my $serb = reform(join '', <F>);
+ my $b = $parser->parse_string($serb);
-foreach my $data (@$testdata) {
- my $a = $parser->parse_string($data->{a});
- my $b = $parser->parse_string($data->{b});
+ open(F, "$path/$n" . "d.xml");
+ my $serd = reform(join '', <F>);
my $diff = make_diff($a, $b);
- is(scrub($diff->toString(1)), $data->{diff},
- $data->{name} . ' (diff)');
+ is(reform($diff->toString(1)), $serd, "diff $n?.xml");
my $merge = merge_diff($a, $diff);
- is($merge->toString(1), $data->{b}, $data->{name} . ' (merge)');
+ is(reform($merge->toString(1)), $serb, "merge $n?.xml");
+
+ ++$i;
}
+
@@ -1,53 +1,44 @@
-
use XML::DifferenceMarkup qw(make_diff);
+use XML::LibXML;
use strict;
-our $testdata;
-
-BEGIN {
- $testdata = [
- {
- name => 'reserved namespace',
- a => <<A_SAME_DOCS,
-<?xml version="1.0"?>
-<some>
- <tree/>
-</some>
-A_SAME_DOCS
- b => <<B_SAME_DOCS,
-<?xml version="1.0"?>
-<some>
- <x:tree xmlns:x="http://www.locus.cz/XML/DifferenceMarkup"/>
-</some>
-B_SAME_DOCS
- },
- {
- name => 'unnamed reserved namespace',
- a => <<A_UNNAMED_RESERVED_NAMESPACE,
-<?xml version="1.0"?>
-<tree/>
-A_UNNAMED_RESERVED_NAMESPACE
- b => <<B_UNNAMED_RESERVED_NAMESPACE,
-<?xml version="1.0"?>
-<tree xmlns="http://www.locus.cz/XML/DifferenceMarkup"/>
-B_UNNAMED_RESERVED_NAMESPACE
- }
- ];
+our ($path, @files, $testcount);
+
+BEGIN
+{
+ $path = "testdata/faildiff";
+ @files = glob "$path/*.xml";
+ $testcount = scalar(@files) / 2;
}
-use Test::More tests => scalar @$testdata;
+use Test::More tests => 1 + $testcount;
+
+eval {
+ make_diff;
+};
+like($@,
+ qr/undefined value/,
+ "missing arguments");
+
+my $parser = XML::LibXML->new(keep_blanks => 0, load_ext_dtd => 0);
-my $parser = XML::LibXML->new();
-$parser->keep_blanks(0);
+my $i = 0;
+while ($i < $testcount) {
+
+ my $n = sprintf("%02d", $i);
+
+ my $a = $parser->parse_file("$path/$n" . "a.xml");
+ my $b = $parser->parse_file("$path/$n" . "b.xml");
-foreach my $data (@$testdata) {
eval {
- make_diff($parser->parse_string($data->{a}),
- $parser->parse_string($data->{b}));
+ make_diff($a, $b);
};
like($@,
qr/^XML::DifferenceMarkup diff: /,
- $data->{name});
+ "$path/$n?.xml");
+
+ ++$i;
}
+
@@ -1,171 +0,0 @@
-
-use XML::DifferenceMarkup qw(merge_diff);
-
-use strict;
-
-our $testdata;
-
-BEGIN {
- $testdata = [
- {
- name => 'not a diff',
- a => <<A_NOT_A_DIFF,
-<?xml version="1.0"?>
-<some>
- <tree/>
-</some>
-A_NOT_A_DIFF
- diff => <<DIFF_NOT_A_DIFF
-<?xml version="1.0"?>
-<some>
- <tree/>
-</some>
-DIFF_NOT_A_DIFF
- },
- {
- name => 'empty diff',
- a => <<A_EMPTY_DIFF,
-<?xml version="1.0"?>
-<some>
- <tree/>
-</some>
-A_EMPTY_DIFF
- diff => <<DIFF_EMPTY_DIFF
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup"/>
-DIFF_EMPTY_DIFF
- },
- {
- name => 'too many namespaces',
- a => <<A_TOO_MANY_NAMESPACES,
-<?xml version="1.0"?>
-<some>
- <tree/>
-</some>
-A_TOO_MANY_NAMESPACES
- diff => <<DIFF_TOO_MANY_NAMESPACES,
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup"
- xmlns:x="http://www.locus.cz/XML/DifferenceMarkup">
- <x:copy count="1"/>
-</dm:diff>
-DIFF_TOO_MANY_NAMESPACES
- },
- {
- name => 'no prefix',
- a => <<A_NO_PREFIX,
-<a>
- <b/>
- <b/>
- <c>
- <d/>
- <e/>
- <f/>
- </c>
-</a>
-A_NO_PREFIX
- diff => <<DIFF_NO_PREFIX
-<?xml version="1.0"?>
-<diff xmlns="http://www.locus.cz/XML/DifferenceMarkup">
- <a>
- <dm:copy xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup" count="2"/>
- <dm:delete xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <c/>
- </dm:delete>
- <dm:insert xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <c2>
- <d/>
- <e/>
- <f/>
- </c2>
- </dm:insert>
- </a>
-</diff>
-DIFF_NO_PREFIX
- },
- {
- name => 'unknown instruction',
- a => <<A_UNKNOWN_INSTRUCTION,
-<?xml version="1.0"?>
-<some>
- <tree/>
-</some>
-A_UNKNOWN_INSTRUCTION
- diff => <<DIFF_UNKNOWN_INSTRUCTION
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:changename from="some" to="other"/>
-</dm:diff>
-DIFF_UNKNOWN_INSTRUCTION
- },
- {
- name => 'copy without count',
- a => <<A_COPY_WITHOUT_COUNT,
-<?xml version="1.0"?>
-<some>
- <tree/>
-</some>
-A_COPY_WITHOUT_COUNT
- diff => <<DIFF_COPY_WITHOUT_COUNT
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <dm:copy/>
-</dm:diff>
-DIFF_COPY_WITHOUT_COUNT
- },
- {
- name => 'wrong name to delete',
- a => <<A_WRONG_NAME_TO_DELETE,
-<top>
-<real/>
-</top>
-A_WRONG_NAME_TO_DELETE
- diff => <<DIFF_WRONG_NAME_TO_DELETE
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <top>
- <dm:delete>
- <fake/>
- </dm:delete>
- </top>
-</dm:diff>
-DIFF_WRONG_NAME_TO_DELETE
- },
- {
- name => 'extra name to delete',
- a => <<A_EXTRA_NAME_TO_DELETE,
-<top>
-<real/>
-</top>
-A_EXTRA_NAME_TO_DELETE
- diff => <<DIFF_EXTRA_NAME_TO_DELETE
-<?xml version="1.0"?>
-<dm:diff xmlns:dm="http://www.locus.cz/XML/DifferenceMarkup">
- <top>
- <dm:delete>
- <real/>
- <real/>
- <real/>
- </dm:delete>
- </top>
-</dm:diff>
-DIFF_EXTRA_NAME_TO_DELETE
- }
- ];
-}
-
-use Test::More tests => scalar @$testdata;
-
-my $parser = XML::LibXML->new();
-$parser->keep_blanks(0);
-
-foreach my $data (@$testdata) {
- eval {
- merge_diff($parser->parse_string($data->{a}),
- $parser->parse_string($data->{diff}));
- };
- like($@,
- qr/^XML::DifferenceMarkup merge: invalid diff: /,
- $data->{name});
-}
-
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<some>
+ <tree/>
+</some>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<some>
+ <tree/>
+</some>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:copy count="1"/>
+</dm:diff>
@@ -0,0 +1,3 @@
+<?xml version="1.0"?>
+<node with="attr"/>
+
@@ -0,0 +1,3 @@
+<?xml version="1.0"?>
+<node with="other value"/>
+
@@ -0,0 +1,9 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:delete>
+ <node with="attr"/>
+ </dm:delete>
+ <dm:insert>
+ <node with="other value"/>
+ </dm:insert>
+</dm:diff>
@@ -0,0 +1,2 @@
+<some><tree/></some>
+
@@ -0,0 +1,4 @@
+<some>
+ <tree/>
+</some>
+
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:copy count="1"/>
+</dm:diff>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<node a="a" b="b"/>
\ No newline at end of file
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<node a="a" b="b"/>
\ No newline at end of file
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:copy count="1"/>
+</dm:diff>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<node a="a" b='b'/>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<node a='a' b="b"/>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:copy count="1"/>
+</dm:diff>
@@ -0,0 +1,10 @@
+<?xml version="1.0"?>
+ <w:old xmlns:w="http://random.old.com/a/">
+ <tree>
+ <with>
+ <some>
+ <subtree/>
+ </some>
+ </with>
+ </tree>
+ </w:old>
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<new xmlns:e="http://random.new.com/b/">
+ <e:tree>with the whole subtree, of course</e:tree>
+</new>
+
@@ -0,0 +1,11 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:delete>
+ <w:old xmlns:w="http://random.old.com/a/"/>
+ </dm:delete>
+ <dm:insert>
+ <new xmlns:e="http://random.new.com/b/">
+ <e:tree>with the whole subtree, of course</e:tree>
+ </new>
+ </dm:insert>
+</dm:diff>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+ <old xmlns:w="http://random.old.com/a/">
+ <w:tree/>
+ </old>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<new/>
@@ -0,0 +1,9 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:delete>
+ <old xmlns:w="http://random.old.com/a/"/>
+ </dm:delete>
+ <dm:insert>
+ <new/>
+ </dm:insert>
+</dm:diff>
@@ -0,0 +1,2 @@
+<root>
+</root>
@@ -0,0 +1,2 @@
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="cs" lang="cs">
+</html>
@@ -0,0 +1,6 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="cs" lang="cs" dm:update="root">
+ <dm:copy count="1"/>
+ </html>
+</dm:diff>
@@ -0,0 +1 @@
+<root></root>
@@ -0,0 +1,3 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
+ "http://www.w3.org/TR/html4/loose.dtd">
+<html></html>
@@ -0,0 +1,9 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:delete>
+ <root/>
+ </dm:delete>
+ <dm:insert>
+ <html/>
+ </dm:insert>
+</dm:diff>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<dm:node xmlns:dm="http://www.deadmouse.com/"/>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<dm:node xmlns:dm="http://www.deadmouse.com/"/>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm2:diff xmlns:dm2="http://www.locus.cz/diffmark">
+ <dm2:copy count="1"/>
+</dm2:diff>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<dm:old xmlns:dm="http://www.deadmouse.com/"/>
@@ -0,0 +1,3 @@
+<?xml version="1.0"?>
+<dm:new xmlns:dm="http://www.deadmouse.com/"/>
+
@@ -0,0 +1,9 @@
+<?xml version="1.0"?>
+<dm2:diff xmlns:dm2="http://www.locus.cz/diffmark">
+ <dm2:delete>
+ <dm:old xmlns:dm="http://www.deadmouse.com/"/>
+ </dm2:delete>
+ <dm2:insert>
+ <dm:new xmlns:dm="http://www.deadmouse.com/"/>
+ </dm2:insert>
+</dm2:diff>
@@ -0,0 +1,13 @@
+<?xml version="1.0"?>
+<top>
+ <a1>merged document actually isn't the same</a1>
+ <a2/>
+ <a3/>
+ <a4/>
+ <a5/>
+ <a6>
+ <b>
+ <c/>
+ </b>
+ </a6>
+</top>
@@ -0,0 +1,13 @@
+<?xml version="1.0"?>
+<top xmlns:x="some-url">
+ <a1>merged document actually isn't the same</a1>
+ <a2/>
+ <a3/>
+ <a4/>
+ <a5/>
+ <a6>
+ <b>
+ <x:c/>
+ </b>
+ </a6>
+</top>
@@ -0,0 +1,16 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <top xmlns:x="some-url" dm:update="top">
+ <dm:copy count="5"/>
+ <a6 xmlns:x="some-url">
+ <b xmlns:x="some-url">
+ <dm:delete>
+ <c/>
+ </dm:delete>
+ <dm:insert xmlns:x="some-url">
+ <x:c xmlns:x="some-url"/>
+ </dm:insert>
+ </b>
+ </a6>
+ </top>
+</dm:diff>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<top a="1" c="3" b="2"/>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<top b="2" a="1" c="3"/>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:copy count="1"/>
+</dm:diff>
@@ -0,0 +1,3 @@
+<pi>
+<?instr1?>
+</pi>
@@ -0,0 +1,3 @@
+<pi>
+<?instr2?>
+</pi>
@@ -0,0 +1,11 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <pi>
+ <dm:delete>
+<?instr1?>
+ </dm:delete>
+ <dm:insert>
+<?instr2?>
+ </dm:insert>
+ </pi>
+</dm:diff>
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<top>
+<node a="b" c="d"/>
+</top>
+
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<top>
+<node c="d" a="b"/>
+</top>
+
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:copy count="1"/>
+</dm:diff>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<some>
+ <tree/>
+</some>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<some>
+ <x:tree xmlns:x="http://www.locus.cz/diffmark"/>
+</some>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<tree/>
\ No newline at end of file
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<tree xmlns="http://www.locus.cz/diffmark"/>
\ No newline at end of file
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<some>
+ <tree/>
+</some>
\ No newline at end of file
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<some>
+ <tree/>
+</some>
\ No newline at end of file
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<some>
+ <tree/>
+</some>
\ No newline at end of file
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark"/>
\ No newline at end of file
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<some>
+ <tree/>
+</some>
\ No newline at end of file
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark"
+ xmlns:x="http://www.locus.cz/diffmark">
+ <x:copy count="1"/>
+</dm:diff>
@@ -0,0 +1,9 @@
+<a>
+ <b/>
+ <b/>
+ <c>
+ <d/>
+ <e/>
+ <f/>
+ </c>
+</a>
@@ -0,0 +1,16 @@
+<?xml version="1.0"?>
+<diff xmlns="http://www.locus.cz/diffmark">
+ <a>
+ <dm:copy xmlns:dm="http://www.locus.cz/diffmark" count="2"/>
+ <dm:delete xmlns:dm="http://www.locus.cz/diffmark">
+ <c/>
+ </dm:delete>
+ <dm:insert xmlns:dm="http://www.locus.cz/diffmark">
+ <c2>
+ <d/>
+ <e/>
+ <f/>
+ </c2>
+ </dm:insert>
+ </a>
+</diff>
@@ -0,0 +1,9 @@
+<a>
+ <b/>
+ <b/>
+ <c>
+ <d/>
+ <e/>
+ <f/>
+ </c>
+</a>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:changename from="some" to="other"/>
+</dm:diff>
@@ -0,0 +1,9 @@
+<a>
+ <b/>
+ <b/>
+ <c>
+ <d/>
+ <e/>
+ <f/>
+ </c>
+</a>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <top b="b" a="a" dm:reordered="a b"/>
+</dm:diff>
@@ -0,0 +1,9 @@
+<a>
+ <b/>
+ <b/>
+ <c>
+ <d/>
+ <e/>
+ <f/>
+ </c>
+</a>
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:copy/>
+</dm:diff>
+
@@ -0,0 +1,3 @@
+<top>
+<real/>
+</top>
@@ -0,0 +1,9 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <top>
+ <dm:delete>
+ <fake/>
+ </dm:delete>
+ </top>
+</dm:diff>
+
@@ -0,0 +1,3 @@
+<top>
+<real/>
+</top>
@@ -0,0 +1,10 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <top>
+ <dm:delete>
+ <real/>
+ <real/>
+ <real/>
+ </dm:delete>
+ </top>
+</dm:diff>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<some>
+ <tree/>
+</some>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<some>
+ <tree/>
+</some>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:copy count="1"/>
+</dm:diff>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<node with="attr"/>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<node with="other value"/>
@@ -0,0 +1,9 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:delete>
+ <node with="attr"/>
+ </dm:delete>
+ <dm:insert>
+ <node with="other value"/>
+ </dm:insert>
+</dm:diff>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<framework>
+<structure/>
+</framework>
@@ -0,0 +1,6 @@
+<?xml version="1.0"?>
+<framework><structure>
+with some
+</structure>
+inserted content...
+</framework>
@@ -0,0 +1,14 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <framework>
+ <structure>
+ <dm:insert xmlns:dm="http://www.locus.cz/diffmark">
+with some
+</dm:insert>
+ </structure>
+ <dm:insert xmlns:dm="http://www.locus.cz/diffmark">
+inserted content...
+</dm:insert>
+ </framework>
+</dm:diff>
+
@@ -0,0 +1,8 @@
+<?xml version="1.0"?>
+<framework>
+<with>
+<a>
+<structure/>
+</a>
+</with>
+</framework>
@@ -0,0 +1,6 @@
+<?xml version="1.0"?>
+<framework><with><a><structure>
+with some
+</structure></a></with>
+inserted content...
+</framework>
@@ -0,0 +1,17 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <framework>
+ <with>
+ <a>
+ <structure>
+ <dm:insert>
+with some
+</dm:insert>
+ </structure>
+ </a>
+ </with>
+ <dm:insert>
+inserted content...
+</dm:insert>
+ </framework>
+</dm:diff>
@@ -0,0 +1,13 @@
+<?xml version="1.0"?>
+<framework>
+<x1/>
+<x2/>
+<x3/>
+<with>
+<a>
+<structure/>
+</a>
+</with>
+<x4/>
+<x5/>
+</framework>
@@ -0,0 +1,6 @@
+<?xml version="1.0"?>
+<framework><x1/><x2/><x3/><with><a><structure>
+with some
+</structure></a></with><x4/>
+inserted content...
+<x5/></framework>
@@ -0,0 +1,20 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <framework>
+ <dm:copy count="3"/>
+ <with>
+ <a>
+ <structure>
+ <dm:insert>
+with some
+</dm:insert>
+ </structure>
+ </a>
+ </with>
+ <dm:copy count="1"/>
+ <dm:insert>
+inserted content...
+</dm:insert>
+ <dm:copy count="1"/>
+ </framework>
+</dm:diff>
@@ -0,0 +1,10 @@
+<?xml version="1.0"?>
+ <old>
+ <tree>
+ <with>
+ <some>
+ <subtree/>
+ </some>
+ </with>
+ </tree>
+ </old>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<new>
+ <tree>with the whole subtree, of course</tree>
+</new>
@@ -0,0 +1,11 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:delete>
+ <old/>
+ </dm:delete>
+ <dm:insert>
+ <new>
+ <tree>with the whole subtree, of course</tree>
+ </new>
+ </dm:insert>
+</dm:diff>
@@ -0,0 +1,10 @@
+<?xml version="1.0"?>
+<deep>
+ <tree>
+ <with>
+ <some>
+ <subtree/>
+ </some>
+ </with>
+ </tree>
+</deep>
@@ -0,0 +1,10 @@
+<?xml version="1.0"?>
+<different>
+ <tree>
+ <with>
+ <some>
+ <subtree/>
+ </some>
+ </with>
+ </tree>
+</different>
@@ -0,0 +1,6 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <different dm:update="deep">
+ <dm:copy count="1"/>
+ </different>
+</dm:diff>
@@ -0,0 +1,11 @@
+<?xml version="1.0"?>
+<top>
+ <a>
+ <with>
+a tree it would be nice to keep in the common subset
+</with>
+ </a>
+ <a/>
+ <x/>
+ <x/>
+</top>
@@ -0,0 +1,11 @@
+<?xml version="1.0"?>
+<top>
+ <x/>
+ <x/>
+ <a>
+ <with>
+a tree it would be nice to keep in the common subset
+</with>
+ </a>
+ <a/>
+</top>
@@ -0,0 +1,18 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <top>
+ <dm:delete>
+ <a/>
+ <a/>
+ </dm:delete>
+ <dm:copy count="2"/>
+ <dm:insert>
+ <a>
+ <with>
+a tree it would be nice to keep in the common subset
+</with>
+ </a>
+ <a/>
+ </dm:insert>
+ </top>
+</dm:diff>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<top>
+Some text.
+</top>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<top>
+A changed text.
+</top>
@@ -0,0 +1,11 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <top>
+ <dm:delete>
+Some text.
+</dm:delete>
+ <dm:insert>
+A changed text.
+</dm:insert>
+ </top>
+</dm:diff>
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<textnode>
+<!-- with just a comment -->
+</textnode>
+<!-- note that the comment outside the top node is not preserved -->
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<textnode>
+<!-- with a different comment -->
+</textnode>
@@ -0,0 +1,11 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <textnode>
+ <dm:delete>
+<!-- with just a comment -->
+ </dm:delete>
+ <dm:insert>
+<!-- with a different comment -->
+ </dm:insert>
+ </textnode>
+</dm:diff>
@@ -0,0 +1,8 @@
+<?xml version="1.0"?>
+<a>
+ <c>
+ <d/>
+ <e/>
+ <f/>
+ </c>
+</a>
@@ -0,0 +1,8 @@
+<?xml version="1.0"?>
+<a>
+ <c2>
+ <d/>
+ <e/>
+ <f/>
+ </c2>
+</a>
@@ -0,0 +1,8 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <a>
+ <c2 dm:update="c">
+ <dm:copy count="3"/>
+ </c2>
+ </a>
+</dm:diff>
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<textnode>
+<?do something?>
+</textnode>
+<!-- note that the comment outside the top node is not preserved -->
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<textnode>
+<?dont do it yet?>
+</textnode>
@@ -0,0 +1,11 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <textnode>
+ <dm:delete>
+<?do something?>
+ </dm:delete>
+ <dm:insert>
+<?dont do it yet?>
+ </dm:insert>
+ </textnode>
+</dm:diff>
@@ -0,0 +1,16 @@
+<?xml version="1.0"?>
+<a>
+ <little>
+ <bit>
+ <deeper>
+ <tree>
+ <with>
+ <additional>
+ <nodes/>
+ </additional>
+ </with>
+ </tree>
+ </deeper>
+ </bit>
+ </little>
+</a>
@@ -0,0 +1,10 @@
+<?xml version="1.0"?>
+<a>
+ <little>
+ <bit>
+ <deeper>
+ <tree/>
+ </deeper>
+ </bit>
+ </little>
+</a>
@@ -0,0 +1,16 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <a>
+ <little>
+ <bit>
+ <deeper>
+ <tree>
+ <dm:delete>
+ <with/>
+ </dm:delete>
+ </tree>
+ </deeper>
+ </bit>
+ </little>
+ </a>
+</dm:diff>
@@ -0,0 +1,15 @@
+<?xml version="1.0"?>
+<delta>
+ <uri value="first">
+ <word value="1."/>
+ </uri>
+ <uri value="second">
+ <word value="2."/>
+ </uri>
+ <uri value="third">
+ <word value="3."/>
+ </uri>
+ <uri value="fourth">
+ <word value="4."/>
+ </uri>
+</delta>
@@ -0,0 +1,12 @@
+<?xml version="1.0"?>
+<delta>
+ <uri value="first">
+ <word value="1."/>
+ </uri>
+ <uri value="second">
+ <word value="2."/>
+ </uri>
+ <uri value="fourth">
+ <word value="4."/>
+ </uri>
+</delta>
@@ -0,0 +1,10 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <delta>
+ <dm:copy count="2"/>
+ <dm:delete>
+ <uri value="third"/>
+ </dm:delete>
+ <dm:copy count="1"/>
+ </delta>
+</dm:diff>
@@ -0,0 +1,9 @@
+<?xml version="1.0"?>
+<top>
+ <a/>
+ <b/>
+ <c/>
+ <d/>
+ <e/>
+ <f/>
+</top>
@@ -0,0 +1,6 @@
+<?xml version="1.0"?>
+<top>
+ <d/>
+ <e/>
+ <f/>
+</top>
@@ -0,0 +1,11 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <top>
+ <dm:delete>
+ <a/>
+ <b/>
+ <c/>
+ </dm:delete>
+ <dm:copy count="3"/>
+ </top>
+</dm:diff>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<some>text<!-- and comment --></some>
@@ -0,0 +1,2 @@
+<?xml version="1.0"?>
+<some><!-- and comment -->text</some>
@@ -0,0 +1,8 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <some>
+ <dm:delete>text</dm:delete>
+ <dm:copy count="1"/>
+ <dm:insert>text</dm:insert>
+ </some>
+</dm:diff>
@@ -0,0 +1,8 @@
+<?xml version="1.0"?>
+<same>
+ <tree>
+ <top>
+ <some>text<!-- and comment --></some>
+ </top>
+ </tree>
+</same>
\ No newline at end of file
@@ -0,0 +1,8 @@
+<?xml version="1.0"?>
+<same>
+ <tree>
+ <top>
+ <some><!-- and comment -->text</some>
+ </top>
+ </tree>
+</same>
@@ -0,0 +1,14 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <same>
+ <tree>
+ <top>
+ <some>
+ <dm:delete>text</dm:delete>
+ <dm:copy count="1"/>
+ <dm:insert>text</dm:insert>
+ </some>
+ </top>
+ </tree>
+ </same>
+</dm:diff>
@@ -0,0 +1,9 @@
+<?xml version="1.0"?>
+<repetitive>
+ <a/>
+ <a/>
+ <a/>
+ <a/>
+ <a/>
+ <a/>
+</repetitive>
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<repetitive>
+ <a/>
+ <a/>
+</repetitive>
@@ -0,0 +1,12 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <repetitive>
+ <dm:copy count="2"/>
+ <dm:delete>
+ <a/>
+ <a/>
+ <a/>
+ <a/>
+ </dm:delete>
+ </repetitive>
+</dm:diff>
@@ -0,0 +1,13 @@
+<?xml version="1.0"?>
+<top xmlns:x="some-url">
+ <a1/>
+ <a2/>
+ <a3/>
+ <a4/>
+ <a5/>
+ <a6>
+ <b>
+ <x:c/>
+ </b>
+ </a6>
+</top>
@@ -0,0 +1,13 @@
+<?xml version="1.0"?>
+<top>
+ <a1/>
+ <a2/>
+ <a3/>
+ <a4/>
+ <a5/>
+ <a6>
+ <b>
+ <c/>
+ </b>
+ </a6>
+</top>
@@ -0,0 +1,16 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <top dm:update="top">
+ <dm:copy count="5"/>
+ <dm:delete>
+ <a6 xmlns:x="some-url"/>
+ </dm:delete>
+ <dm:insert>
+ <a6>
+ <b>
+ <c/>
+ </b>
+ </a6>
+ </dm:insert>
+ </top>
+</dm:diff>
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<top>
+ <a/>
+ <b/>
+</top>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<top>
+ <x/>
+</top>
@@ -0,0 +1,12 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <top>
+ <dm:delete>
+ <a/>
+ <b/>
+ </dm:delete>
+ <dm:insert>
+ <x/>
+ </dm:insert>
+ </top>
+</dm:diff>
@@ -0,0 +1,7 @@
+<?xml version="1.0"?>
+<top>
+ <a/>
+ <b>
+ <with/> a subtree
+ </b>
+</top>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<top>
+ <x/>
+</top>
@@ -0,0 +1,12 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <top>
+ <dm:delete>
+ <a/>
+ <b/>
+ </dm:delete>
+ <dm:insert>
+ <x/>
+ </dm:insert>
+ </top>
+</dm:diff>
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<page attr="1">
+ <word value="Arbeiter"/>
+ <word value="Kopf"/>
+</page>
@@ -0,0 +1,6 @@
+<?xml version="1.0"?>
+<page attr="1">
+ <word value="Kopf">
+ <trans value="hlava"/>
+ </word>
+</page>
@@ -0,0 +1,13 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <page attr="1">
+ <dm:delete>
+ <word value="Arbeiter"/>
+ </dm:delete>
+ <word value="Kopf">
+ <dm:insert>
+ <trans value="hlava"/>
+ </dm:insert>
+ </word>
+ </page>
+</dm:diff>
@@ -0,0 +1,7 @@
+<?xml version="1.0"?>
+<a:a xmlns:a="a">
+ <b:b xmlns:b="b"/>
+ <c:c xmlns:c="c">
+ <d:d xmlns:d="d"/>
+ </c:c>
+</a:a>
@@ -0,0 +1,7 @@
+<?xml version="1.0"?>
+<a:a xmlns:a="a" xmlns:b="b" xmlns:c="c" xmlns:d="d">
+ <b:b/>
+ <c:c>
+ <d:d/>
+ </c:c>
+</a:a>
@@ -0,0 +1,14 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:delete>
+ <a:a xmlns:a="a"/>
+ </dm:delete>
+ <dm:insert>
+ <a:a xmlns:a="a" xmlns:b="b" xmlns:c="c" xmlns:d="d">
+ <b:b/>
+ <c:c>
+ <d:d/>
+ </c:c>
+ </a:a>
+ </dm:insert>
+</dm:diff>
@@ -0,0 +1,7 @@
+<?xml version="1.0"?>
+<a>
+ <a2>
+ <tree/>
+ </a2>
+ <a3>another</a3>
+</a>
\ No newline at end of file
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<a>
+ <a2/>
+ <a3>difference</a3>
+</a>
@@ -0,0 +1,14 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <a>
+ <a2>
+ <dm:delete>
+ <tree/>
+ </dm:delete>
+ </a2>
+ <a3>
+ <dm:delete>another</dm:delete>
+ <dm:insert>difference</dm:insert>
+ </a3>
+ </a>
+</dm:diff>
@@ -0,0 +1,17 @@
+<?xml version="1.0"?>
+<a>
+ <a2>
+ <mostly>
+ <but>
+ <not>
+ <entirely>
+ <same>
+ <tree/>
+ </same>
+ </entirely>
+ </not>
+ </but>
+ </mostly>
+ </a2>
+ <a3>another</a3>
+</a>
@@ -0,0 +1,15 @@
+<?xml version="1.0"?>
+<a>
+ <a2>
+ <mostly>
+ <but>
+ <not>
+ <entirely>
+ <same/>
+ </entirely>
+ </not>
+ </but>
+ </mostly>
+ </a2>
+ <a3>difference</a3>
+</a>
@@ -0,0 +1,24 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <a>
+ <a2>
+ <mostly>
+ <but>
+ <not>
+ <entirely>
+ <same>
+ <dm:delete>
+ <tree/>
+ </dm:delete>
+ </same>
+ </entirely>
+ </not>
+ </but>
+ </mostly>
+ </a2>
+ <a3>
+ <dm:delete>another</dm:delete>
+ <dm:insert>difference</dm:insert>
+ </a3>
+ </a>
+</dm:diff>
@@ -0,0 +1,6 @@
+<?xml version="1.0"?>
+<top>
+ <a/>
+ <b/>
+ <c/>
+</top>
@@ -0,0 +1,8 @@
+<?xml version="1.0"?>
+<top>
+ <a>
+ <b>
+ <c/>
+ </b>
+ </a>
+</top>
@@ -0,0 +1,16 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <top>
+ <a>
+ <dm:insert>
+ <b>
+ <c/>
+ </b>
+ </dm:insert>
+ </a>
+ <dm:delete>
+ <b/>
+ <c/>
+ </dm:delete>
+ </top>
+</dm:diff>
@@ -0,0 +1,10 @@
+<?xml version="1.0"?>
+<table>
+<word value="reordered">
+<trans value="a"/>
+<trans value="b"/>
+<trans value="c"/>
+</word>
+<word value="leidenschaftlich"/>
+<word value="leider"/>
+</table>
@@ -0,0 +1,10 @@
+<?xml version="1.0"?>
+<table>
+ <word value="reordered">
+ <trans value="b"/>
+ <trans value="c"/>
+ <trans value="a"/>
+ </word>
+ <word value="leidenschaftlich"/>
+ <word value="leider"/>
+</table>
@@ -0,0 +1,15 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <table>
+ <word value="reordered">
+ <dm:delete>
+ <trans value="a"/>
+ </dm:delete>
+ <dm:copy count="2"/>
+ <dm:insert>
+ <trans value="a"/>
+ </dm:insert>
+ </word>
+ <dm:copy count="2"/>
+ </table>
+</dm:diff>
@@ -0,0 +1,4 @@
+<programlisting><![CDATA[<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/XML/diffmark">
+ <dm:copy count="1"/>
+</dm:diff>]]></programlisting>
@@ -0,0 +1,5 @@
+<?xml version="1.0"?>
+<programlisting><![CDATA[<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/XML/diffmark">
+ <dm:copy count="1"/>
+</dm:diff>]]></programlisting>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm:diff xmlns:dm="http://www.locus.cz/diffmark">
+ <dm:copy count="1"/>
+</dm:diff>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm:old xmlns:dm="http://www.deadmouse.com/">
+ <dm2:second xmlns:dm2="http://www.deadmouse.com/2"/>
+</dm:old>
@@ -0,0 +1,4 @@
+<?xml version="1.0"?>
+<dm:new xmlns:dm="http://www.deadmouse.com/">
+ <dm2:second xmlns:dm2="http://www.deadmouse.com/2"/>
+</dm:new>
@@ -0,0 +1,6 @@
+<?xml version="1.0"?>
+<dm3:diff xmlns:dm3="http://www.locus.cz/diffmark">
+ <dm:new xmlns:dm="http://www.deadmouse.com/" dm3:update="dm:old">
+ <dm3:copy count="1"/>
+ </dm:new>
+</dm3:diff>