#!/usr/bin/perl
#
# On-target value battery for libxml-perl 0.08 (BRINTOS-1325).
#
# WHY THIS PAYLOAD EXISTS, AND WHY IT DOES NOT USE XML::Parser.
# libxml-perl's own t/ drives every one of its handlers THROUGH
# XML::Parser::PerlSAX, and XML::Parser is an XS module that cannot load on this
# arm: the glibc interpreter is built -Uusedl -Uuseshrplib, so there is no
# DynaLoader and no Expat.so (BRINTOS-881). Sixteen modules ship in this
# distribution and exactly ONE of them -- XML::Parser::PerlSAX -- is behind that
# gap; the other fifteen load and run. Measured, not assumed: each was required
# in isolation on x86-64 with XML/Parser.pm shadowed by a stub that dies with
# the target's own diagnostic, and fifteen of sixteen loaded clean.
#
# So this payload feeds the handlers the PerlSAX event stream that PerlSAX
# itself would have emitted -- the exact call shapes read off
# XML/Parser/PerlSAX.pm's _handle_* subs -- and asserts the same outputs the
# distribution's t/ asserts. It recovers the semantics the criterion cannot
# reach on this arm, rather than reporting the whole port unmeasurable.
#
# Every expectation below was taken from a run on x86-64 (perl 5.38.2) against
# the same 0.08 sources with XML::Parser blocked the same way, so the control
# and the target execute identical Perl.
#
# Tagged output: one `R<n>-<name> <value>` line per measurement, plus a final
# ALL-LIBXML-PERL-OK when every internal check held. The .test greps the tags.

use strict;

my $fails = 0;
sub emit { my ($tag, $val) = @_; print "$tag $val\n"; }
sub note { my ($tag, $got, $want) = @_;
    emit($tag, $got);
    if (!defined($got) || $got ne $want) { $fails++; print "MISMATCH $tag: got '", (defined $got ? $got : '<undef>'), "' want '$want'\n"; }
}

# The PerlSAX event feeder. `Name`/`Attributes` on start_element and `Name` on
# end_element, `Data` on characters, an empty hashref on the document events --
# read off XML/Parser/PerlSAX.pm lines 196-265, not invented.
sub feed {
    my ($h, @ev) = @_;
    # PerlSAX registers an expat handler ONLY for the methods the document
    # handler `can' (XML/Parser/PerlSAX.pm lines 74-86), so a handler with no
    # characters() must not be called with one -- XML::Handler::Subs is exactly
    # that handler, and calling it unguarded is a bug in the feeder, not in the
    # module. The guard is what makes this feeder faithful.
    my $call = sub { my ($m, $arg) = @_; $h->$m($arg) if UNIVERSAL::can($h, $m) };
    $call->('start_document', {});
    for my $e (@ev) {
        my ($kind, @a) = @$e;
        if    ($kind eq 's') { $call->('start_element', { Name => $a[0], Attributes => ($a[1] || {}) }) }
        elsif ($kind eq 'e') { $call->('end_element', { Name => $a[0] }) }
        elsif ($kind eq 'c') { $call->('characters', { Data => $a[0] }) }
        elsif ($kind eq 'p') { $call->('processing_instruction', { Target => $a[0], Data => $a[1] }) }
        elsif ($kind eq 'm') { $call->('comment', { Data => $a[0] }) }
    }
    return UNIVERSAL::can($h, 'end_document') ? $h->end_document({}) : undef;
}

# ---------------------------------------------------------------- 1. loads ---
# Fifteen of the sixteen modules, each required in its own eval so one failure
# names itself instead of taking the rest of the battery with it.
my @PURE = qw(
    Data::Grove Data::Grove::Parent Data::Grove::Visitor
    XML::ESISParser
    XML::Handler::CanonXMLWriter XML::Handler::Sample XML::Handler::Subs
    XML::Handler::XMLWriter
    XML::PatAct::ActionTempl XML::PatAct::Amsterdam XML::PatAct::MatchName
    XML::PatAct::PatternTempl XML::PatAct::ToObjects
    XML::Perl2SAX XML::SAX2Perl
);
my $loaded = 0;
for my $m (@PURE) {
    eval "require $m; 1" ? $loaded++ : emit("R1-load-failed", "$m: " . (split /\n/, $@)[0]);
}
note("R1-loaded", $loaded, scalar(@PURE));

# The version every module carries. A distribution that half-upgraded would
# show two values here.
my %vers; no strict 'refs';
for my $m (@PURE) { my $v = ${"${m}::VERSION"}; $vers{$v}++ if defined $v }
use strict 'refs';
note("R1-versions", join(',', sort keys %vers), "0.08");

# ------------------------------------------------- 2. XML::Handler::Subs -----
# The dispatch contract: s_<name>/e_<name> by element name, the Names/Nodes
# stacks, and in_element/within_element read at depth.
{
    package BSTSubs;
    use vars qw{ @ISA };
    @ISA = qw{ XML::Handler::Subs };
    sub s_outer { my ($s,$el) = @_; push @{$s->{log}}, "s:outer(" . scalar(@{$s->{Names}}) . ")" }
    sub e_outer { my ($s,$el) = @_; push @{$s->{log}}, "e:outer" }
    sub s_inner { my ($s,$el) = @_;
        push @{$s->{log}}, "s:inner(" . join('/', @{$s->{Names}}) . ")";
        push @{$s->{log}}, "in:" . ($s->in_element('inner') ? 1 : 0);
        push @{$s->{log}}, "within-outer:" . $s->within_element('outer');
    }
    # deliberately NO e_inner and no s_other: start_element must return 0 for them
}
{
    my $h = BSTSubs->new(log => []);
    feed($h, ['s','outer'], ['s','inner'], ['c','x'], ['e','inner'], ['s','other'], ['e','other'], ['e','outer']);
    note("R2-subs-log", join(' ', @{$h->{log}}), "s:outer(1) s:inner(outer/inner) in:1 within-outer:1 e:outer");
    # the stacks are deleted by end_document -- a handler that leaked them would
    # keep a reference to every node of the last document parsed.
    note("R2-subs-stack-cleared", ((exists $h->{Names}) ? 'no' : 'yes'), "yes");
}
{
    # the name-mangling rule: any non-word character in an element name becomes
    # `_' before the method lookup, which is how `non-null' reaches e_non_null.
    package BSTMangle;
    use vars qw{ @ISA }; @ISA = qw{ XML::Handler::Subs };
    sub s_non_null { my $s = shift; $s->{hit}++ }
}
{
    my $h = BSTMangle->new;
    feed($h, ['s','non-null'], ['e','non-null']);
    note("R2-subs-mangled-name", ($h->{hit} || 0), "1");
}

# --------------------------------------- 3. XML::Handler::CanonXMLWriter -----
# Canonical XML: attributes in sorted order regardless of hash order, and the
# seven characters of %char_entities escaped. The escape table is the module's
# whole contract and is asserted character by character rather than in prose.
#
# NOTE the double quote: this module applies ONE table to attribute values and
# to character data alike, so `"' comes back as &quot; in text as well -- which
# canonical XML does not require. That is the module's behaviour on both arms
# and is pinned as such; an expectation written from the spec instead of from a
# run reds here, which is how it was found.
{
    my $w = XML::Handler::CanonXMLWriter->new;
    my $out = feed($w,
        ['s','a', { b => '2', a => '1', c => '3' }],
        ['c', 'text&<>"'],
        ['s','empty'], ['e','empty'],
        ['e','a']);
    note("R3-canon", $out, '<a a="1" b="2" c="3">text&amp;&lt;&gt;&quot;<empty></empty></a>');
}
{
    # attribute values escape the double quote as well; character data does not
    # (canonical XML only requires it inside attribute values).
    my $w = XML::Handler::CanonXMLWriter->new;
    my $out = feed($w, ['s','a', { q => 'he said "hi" & <b>' }], ['e','a']);
    note("R3-canon-attr-escape", $out, '<a q="he said &quot;hi&quot; &amp; &lt;b&gt;"></a>');
}
{
    # the three whitespace characters that canonical XML spells numerically.
    my $w = XML::Handler::CanonXMLWriter->new;
    my $out = feed($w, ['s','a'], ['c', "\x09\x0a\x0d "], ['e','a']);
    note("R3-canon-ws", $out, '<a>&#9;&#10;&#13; </a>');
}
{
    # comments and PIs: dropped unless PrintComments is set. Both arms, because
    # "it printed nothing" and "the option is not read" look the same otherwise.
    my $w = XML::Handler::CanonXMLWriter->new;
    my $out = feed($w, ['s','a'], ['m','hi'], ['p','tgt','d=1'], ['e','a']);
    note("R3-canon-nocomment", $out, '<a><?tgt d=1?></a>');
    my $w2 = XML::Handler::CanonXMLWriter->new(PrintComments => 1);
    my $out2 = feed($w2, ['s','a'], ['m','hi'], ['e','a']);
    note("R3-canon-comment", $out2, '<a><!--hi--></a>');
}

# ------------------------------------------ 4. XML::Handler::XMLWriter -------
# The plain writer, AsString. It subclasses Subs, so a subclass method still
# suppresses the default printing -- which is the reason the two share a base.
{
    my $w = XML::Handler::XMLWriter->new(AsString => 1);
    my $out = feed($w, ['s','a', { z => '1', a => '&' }], ['c','x<y'], ['e','a']);
    note("R4-xmlwriter", $out, qq{<?xml version="1.0" encoding="UTF-8"?>\n<a a="&amp;" z="1">x&lt;y</a>\n});
}
{
    package BSTWriterSub;
    use vars qw{ @ISA }; @ISA = qw{ XML::Handler::XMLWriter };
    sub s_skipme { my ($s,$el) = @_; $s->print("[SKIPPED]") }
}
{
    my $w = BSTWriterSub->new(AsString => 1);
    my $out = feed($w, ['s','skipme'], ['e','skipme']);
    note("R4-xmlwriter-override", $out, qq{<?xml version="1.0" encoding="UTF-8"?>\n[SKIPPED]</skipme>\n});
}

# ------------------------------------------- 5. XML::PatAct::MatchName -------
# The matcher is a pure function of the name path, so it is exercised directly
# as well as through Amsterdam: match() returns the pattern's INDEX/2, and
# undef for no match. Patterns match against the tail of `/a/b/c'.
{
    my $m = XML::PatAct::MatchName->new(Patterns => [ 'outer' => 1, 'inner' => 2, 'a/b' => 3 ]);
    note("R5-match-first",  (defined $m->match(undef, ['outer'], []) ? $m->match(undef, ['outer'], []) : 'undef'), "0");
    note("R5-match-second", (defined $m->match(undef, ['outer','inner'], []) ? $m->match(undef, ['outer','inner'], []) : 'undef'), "1");
    note("R5-match-path",   (defined $m->match(undef, ['x','a','b'], []) ? $m->match(undef, ['x','a','b'], []) : 'undef'), "2");
    note("R5-match-none",   (defined $m->match(undef, ['zzz'], []) ? 'defined' : 'undef'), "undef");
}

# ------------------------------------------- 6. XML::PatAct::Amsterdam -------
# t/amsterdam.t's assertion, reproduced without the parser. Same patterns, same
# document shape, same expected string -- so a red here is the same finding the
# distribution's own file would report if it could run.
{
    my $patterns = [
        'outer' => { Before => "Outer-before, '[attr]'", After => "Outer-after\n" },
        'inner' => { Before => "Inner" },
    ];
    my $matcher = XML::PatAct::MatchName->new(Patterns => $patterns);
    my $h = XML::PatAct::Amsterdam->new(Patterns => $patterns, Matcher => $matcher, AsString => 1);
    my $out = feed($h,
        ['s','outer', { attr => 'an attr' }],
        ['c', "\n  "],
        ['s','inner'], ['e','inner'],
        ['c', "\n"],
        ['e','outer']);
    note("R6-amsterdam", $out, "Outer-before, 'an attr'\n  Inner\nOuter-after\n");
}
{
    # the `[attr]' substitution is the module's one templating feature; an
    # attribute that is absent substitutes empty rather than dying.
    my $patterns = [ 'e' => { Before => "<[a]|[missing]>" } ];
    my $matcher = XML::PatAct::MatchName->new(Patterns => $patterns);
    my $h = XML::PatAct::Amsterdam->new(Patterns => $patterns, Matcher => $matcher, AsString => 1);
    my $out = feed($h, ['s','e', { a => 'A' }], ['e','e']);
    note("R6-amsterdam-attr", $out, "<A|>");
}

# ------------------------------------------- 7. XML::PatAct::ToObjects -------
# t/schema.t's assertion, reproduced without the parser: -holder, -make,
# -field/-as-string, -push-field and -value, checked at values on the built
# object graph rather than as a boolean.
{
    my $patterns = [
        'schema'      => [ qw{ -holder                                  } ],
        'table'       => [ qw{ -make Schema::Table                      } ],
        'name'        => [ qw{ -field Name -as-string                   } ],
        'summary'     => [ qw{ -field Summary -as-string                } ],
        'column'      => [ qw{ -make Schema::Column -push-field Columns } ],
        'unique'      => [ qw{ -field Unique -value 1                   } ],
        'default'     => [ qw{ -field Default -as-string                } ],
    ];
    my $matcher = XML::PatAct::MatchName->new(Patterns => $patterns);
    my $h = XML::PatAct::ToObjects->new(Patterns => $patterns, Matcher => $matcher);
    my $schema = feed($h,
        ['s','schema'],
          ['s','table'],
            ['s','name'], ['c','MyTable'], ['e','name'],
            ['s','summary'], ['c','A short summary'], ['e','summary'],
            ['s','column'],
              ['s','name'], ['c','MyColumn1'], ['e','name'],
              ['s','unique'], ['e','unique'],
              ['s','default'], ['c','42'], ['e','default'],
            ['e','column'],
          ['e','table'],
        ['e','schema']);
    note("R7-toobj-class",   (ref($schema->[0]) || 'undef'), "Schema::Table");
    note("R7-toobj-name",    (defined $schema->[0]{Name} ? $schema->[0]{Name} : 'undef'), "MyTable");
    note("R7-toobj-summary", (defined $schema->[0]{Summary} ? $schema->[0]{Summary} : 'undef'), "A short summary");
    note("R7-toobj-colclass",(ref($schema->[0]{Columns}[0]) || 'undef'), "Schema::Column");
    note("R7-toobj-colname", (defined $schema->[0]{Columns}[0]{Name} ? $schema->[0]{Columns}[0]{Name} : 'undef'), "MyColumn1");
    note("R7-toobj-unique",  (defined $schema->[0]{Columns}[0]{Unique} ? $schema->[0]{Columns}[0]{Unique} : 'undef'), "1");
    note("R7-toobj-default", (defined $schema->[0]{Columns}[0]{Default} ? $schema->[0]{Columns}[0]{Default} : 'undef'), "42");
}

# ------------------------------------------------------ 8. Data::Grove -------
# new() from a list, from a hashref, and the shallow-copy-from-an-object form;
# Parent's tied FETCH giving a parent pointer the raw object does not carry;
# Visitor's accept dispatching by $type_name.
{
    my $g = Data::Grove::Characters->new(Data => 'hi');
    note("R8-grove-class", ref($g), "Data::Grove::Characters");
    note("R8-grove-prop",  $g->{Data}, "hi");
    my $copy = Data::Grove::Characters->new($g);
    $copy->{Data} = 'changed';
    note("R8-grove-shallow-copy", $g->{Data}, "hi");
    note("R8-grove-typename", $Data::Grove::Characters::type_name, "characters");
}
{
    package BSTNode; use vars qw{ @ISA $type_name };
    @ISA = qw{ Data::Grove }; $type_name = 'bstnode';
    package BSTVisitor;
    sub new { bless {}, shift }
    sub visit_bstnode { my ($s,$n,@a) = @_; return "visited:" . $n->{Name} . ":" . join(',',@a) }
}
{
    my $root = BSTNode->new(Name => 'root', Contents => []);
    my $kid  = BSTNode->new(Name => 'kid');
    my $p    = Data::Grove::Parent->new($kid, $root);
    note("R8-parent-class",  ref($p), "BSTNode");
    note("R8-parent-name",   $p->{Name}, "kid");
    note("R8-parent-parent", (defined $p->{Parent} ? $p->{Parent}{Name} : 'undef'), "root");
    note("R8-parent-raw",    (defined $kid->{Parent} ? 'leaked' : 'clean'), "clean");
    # Re-wrapping does NOT short-circuit, although new()'s first line looks as
    # though it should: the wrapper it returns is blessed into the RAW object's
    # class (`bless {}, ref($raw)'), so the `UNIVERSAL::isa($raw,
    # 'Data::Grove::Parent')' test that guards the short-circuit is false for it.
    # Pinned as the behaviour it is, on both arms, rather than as the behaviour
    # the POD implies -- an expectation of `same' reds here, which is how this
    # was found. A wrapped wrapper still reads through to the same properties,
    # which is what the next two cases assert and is what callers depend on.
    my $pp = Data::Grove::Parent->new($p);
    note("R8-parent-rewrap-identity", (($pp == $p) ? 'same' : 'new'), "new");
    note("R8-parent-rewrap-name",     $pp->{Name}, "kid");
    note("R8-parent-rewrap-parent",   (defined $pp->{Parent} ? $pp->{Parent}{Name} : 'undef'), "root");
}
{
    require Data::Grove::Visitor;
    my $n = BSTNode->new(Name => 'n1');
    note("R8-visitor-accept", $n->accept(BSTVisitor->new, 'x', 'y'), "visited:n1:x,y");
}

# ------------------------------------------ 9. Perl2SAX / SAX2Perl ------------
# The two translators between the Perl-style (hashref) and Java-style
# (positional) SAX1 calling conventions. Each wraps a handler and forwards; a
# round trip through both must arrive with the properties intact.
{
    package BSTSax1;   # a Java-style SAX1 DocumentHandler
    sub new { bless { log => [] }, shift }
    sub startDocument { push @{$_[0]{log}}, "sd" }
    sub endDocument   { push @{$_[0]{log}}, "ed" }
    sub startElement  { my ($s,$name,$attrs) = @_;
        push @{$s->{log}}, "s:$name(" . join(',', map { "$_=$attrs->{$_}" } sort keys %{$attrs || {}}) . ")" }
    sub endElement    { my ($s,$name) = @_; push @{$s->{log}}, "e:$name" }
    # the Java signature: (string, start, length) -- Perl2SAX always passes the
    # whole string with start 0, and the offsets are asserted so a translator
    # that dropped them would not read as equivalent.
    sub characters    { my ($s,$data,$start,$len) = @_; push @{$s->{log}}, "c:$data\@$start+$len" }
    sub processingInstruction { my ($s,$t,$d) = @_; push @{$s->{log}}, "pi:$t=$d" }
}
{
    # BOTH translators read `DocumentHandler', although both PODs say
    # `Handler' -- an upstream doc/code mismatch, identical on x86-64, and the
    # reason this pair is worth covering at all: a caller following the SYNOPSIS
    # gets a handler that is never called and no error.
    my $sax1 = BSTSax1->new;
    my $p2s  = XML::Perl2SAX->new(DocumentHandler => $sax1);
    feed($p2s, ['s','a', { k => 'v' }], ['c','txt'], ['p','tgt','d=1'], ['e','a']);
    note("R9-perl2sax", join(' ', @{$sax1->{log}}), "sd s:a(k=v) c:txt\@0+3 pi:tgt=d=1 e:a ed");
}
{
    # and back. SAX2Perl re-emits PerlSAX as a KEY/VALUE LIST, not as the
    # hashref PerlSAX itself passes, so it does not compose with this
    # distribution's own handlers -- CanonXMLWriter's `my $element = shift'
    # would receive the string 'Name'. Measured, not worked around: the
    # recorder below takes the list form, which is what the module emits.
    package BSTPerlRec;
    sub new { bless { log => [] }, shift }
    sub start_document { my $s = shift; push @{$s->{log}}, "sd" }
    sub end_document   { my $s = shift; push @{$s->{log}}, "ed" }
    sub start_element  { my ($s,%p) = @_;
        push @{$s->{log}}, "s:$p{Name}(" . join(',', map { "$_=$p{Attributes}{$_}" } sort keys %{$p{Attributes} || {}}) . ")" }
    sub end_element    { my ($s,%p) = @_; push @{$s->{log}}, "e:$p{Name}" }
    sub characters     { my ($s,%p) = @_; push @{$s->{log}}, "c:$p{Data}" }
    sub processing_instruction { my ($s,%p) = @_; push @{$s->{log}}, "pi:$p{Target}=$p{Data}" }
}
{
    my $rec = BSTPerlRec->new;
    my $s2p = XML::SAX2Perl->new(DocumentHandler => $rec);
    $s2p->startDocument;
    $s2p->startElement('a', { k => 'v' });
    $s2p->characters('xxt&tyy', 2, 3);   # start/length are honoured, not ignored
    $s2p->processingInstruction('tgt', 'd=1');
    $s2p->endElement('a');
    $s2p->endDocument;
    note("R9-sax2perl", join(' ', @{$rec->{log}}), "sd s:a(k=v) c:t&t pi:tgt=d=1 e:a ed");
}

# --------------------------------------------- 10. XML::ESISParser -----------
# The nsgmls-driven parser. It LOADS -- it is pure Perl -- but it drives an
# external `nsgmls' binary this image does not ship, so what is asserted is the
# class surface, not a parse. Reported as a value rather than as a red: a
# missing external tool is not a defect in this port.
{
    note("R10-esis-loaded", (XML::ESISParser->can('new') ? 'yes' : 'no'), "yes");
    my $nsgmls = 0;
    for my $d (split /:/, ($ENV{PATH} || '')) { $nsgmls = 1 if -x "$d/nsgmls" }
    emit("R10-nsgmls-present", ($nsgmls ? 'yes' : 'no'));
}

# ---------------------------------------- 11. the XS gap, measured here ------
# The one module that cannot load, and WHY -- taken from this interpreter rather
# than cited, so the .test's attribution rests on evidence from the same boot.
{
    my $ok = eval { require XML::Parser::PerlSAX; 1 };
    if ($ok) { emit("R11-perlsax-load", "ok") }
    else {
        my $e = (split /\n/, $@)[0]; $e =~ s/\s+/ /g;
        emit("R11-perlsax-load", "failed");
        emit("R11-perlsax-diag", substr($e, 0, 160));
    }
}

print $fails ? "LIBXML-PERL-FAILS $fails\n" : "ALL-LIBXML-PERL-OK\n";
exit($fails ? 1 : 0);