File Coverage

blib/lib/XML/Reader.pm

Criterion	Covered	Total	%
statement	17	539	3.1
branch	1	248	0.4
condition	0	42	0.0
subroutine	5	57	8.7
pod	25	37	67.5
total	48	923	5.2

package XML::Reader;
$XML::Reader::VERSION = '0.65';
use strict;
use warnings;
use Carp;

use Acme::HTTP;

set_timeout(10);
set_redir_max(5);

require Exporter;

our @ISA         = qw(Exporter);
our %EXPORT_TAGS = ( all => [ qw(slurp_xml) ] );
our @EXPORT_OK   = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT      = qw();

my $use_module;

sub import {
    my $calling_module = shift;

    my @plist;

    my $act_module;

    for my $sub (@_) {
        if ($sub eq 'XML::Parser' or $sub eq 'XML::Parsepp') {
            if (defined $act_module) {
                die "Duplicate module ('$act_module' and '$sub')";
            }
            $act_module = $sub;
        }
        else {
            push @plist, $sub;
        }
    }

    if (defined $act_module) {
        activate($act_module);
    }

    XML::Reader->export_to_level(1, $calling_module, @plist);
}

sub activate {
    my ($mod) = @_;

    if ($mod eq 'XML::Parser') {
        require XML::Parser;
    }
    elsif ($mod eq 'XML::Parsepp') {
        require XML::Parsepp;
    }
    else {
        die "Can't identify module = '$mod'";
    }

    $use_module = $mod;
}

# deprecated functions (Klaus EICHNER, 28 Apr 2010, ver. 0.35):
# only for backward compatibility

# Klaus EICHNER,  28 Oct 2011, ver 0.39):
# remove deprecated functions newhd() and rstem()

# sub newhd { new(@_);  } # newhd() is now deprecated, use new()  instead
# sub rstem { path(@_); } # rstem() is now deprecated, use path() instead

sub new {
    my $class = shift;
    my $self = {};

    my %opt;
    %opt = %{$_[1]} if defined $_[1];

    if (defined $opt{mode}) {
        my $flt;
        if    ($opt{mode} eq 'attr-bef-start') { $flt = 2; } # attributes appear on seperate lines * before * .
        elsif ($opt{mode} eq 'attr-in-hash')   { $flt = 3; } # no seperate lines for attributes, they appear in the hash %{$rdr->att_hash}.
        elsif ($opt{mode} eq 'pyx')            { $flt = 4; } # pyx compatible way: delivers attributes, , characters,  on individual lines.
        elsif ($opt{mode} eq 'branches')       { $flt = 5; } # reads roots and branches: $rdr->rx, $rdr->rvalue and $rdr->rval
        else {
            croak "Failed assertion #0010 in XML::Reader->new: invalid mode = '$opt{mode}', expected 'attr-bef-start', 'attr-in-hash', 'pyx' or 'branches'";
        }

        if (defined $opt{filter}) {
            unless ($opt{filter} eq $flt) {
                croak "Failed assertion #0020 in XML::Reader->new: filter = '$opt{filter}' does not match mode = '$opt{mode}' (which corresponds to filter = '$flt')";
            }
        }
        else {
            $opt{filter} = $flt;
        }
    }

    $opt{strip}    = 1 unless defined $opt{strip};
    $opt{filter}   = 2 unless defined $opt{filter};
    $opt{parse_pi} = 0 unless defined $opt{parse_pi};
    $opt{parse_ct} = 0 unless defined $opt{parse_ct};

    unless ($opt{filter} == 2 or $opt{filter} == 3 or $opt{filter} == 4 or $opt{filter} == 5) {
        croak "Failed assertion #0030 in XML::Reader->new: filter is set to '$opt{filter}', but must be 2, 3, 4 or 5";
    }

    my @parser_opt;

    if (defined $opt{dupatt} and $opt{dupatt} ne '') {
        unless ($use_module eq 'XML::Parsepp') {
            croak "Failed assertion #0035 in XML::Reader->new: expected use qw(XML::Parsepp), but found use qw($use_module)";
        }
        @parser_opt = (dupatt => $opt{dupatt});
    }

    my $XmlParser = $use_module->new(@parser_opt)
      or croak "Failed assertion #0040 in XML::Reader->new: Can't create $use_module -> new(@parser_opt)";

    # The following references to the handler-functions from the XML::Parser/XML::Parsepp object will be
    # copied into the ExpatNB object during the later call to XML::Parser/XML::Parsepp->parse_start.

    $XmlParser->setHandlers(
        Start   => \&handle_start,
        End     => \&handle_end,
        Proc    => \&handle_procinst,
        XMLDecl => \&handle_decl,
        Char    => \&handle_char,
        Comment => \&handle_comment,
    );

    # We are trying to open the file (the filename is held in in $_[0]). If the filename
    # happens to be a reference to a scalar, then it is opened quite naturally as an
    # 'in-memory-file'. If the open fails, then we return failure from XML::Reader->new
    # and the calling program has to check $! to handle the failed call.
    # If, however, the filename is already a filehandle (i.e. ref($_[0]) eq 'GLOB'), then
    # we use that filehandle directly

    my $fh;

    if (ref($_[0]) eq 'GLOB') {
        $fh = $_[0];
    }
    else {
        if ($_[0] =~ m{\A https?:}xms) {
            $fh = Acme::HTTP->new($_[0])
              or croak "Failed assertion #0042 in XML::Reader->new: Can't Acme::HTTP->new('$_[0]') because $@";
        }
        else {
            open $fh, '<', $_[0] or croak "Failed assertion #0045 in XML::Reader->new: Can't open < '$_[0]' because $!";
        }
    }

    # Now we bless into XML::Reader, and we bless *before* creating the ExpatNB-object.
    # Thereby, to avoid a memory leak, we ensure that for each ExpatNB-object we call
    # XML::Reader->DESTROY when the object goes away. (-- by the way, we create that
    # ExpatNB-object by calling the XML::Parser/XML::Parsepp->parse_start method --)

    bless $self, $class;

    # Now we are ready to call XML::Parser/XML::Parsepp->parse_start -- XML::Parser/XML::Parsepp->parse_start()
    # returns an object of type XML::Parser/XML::Parsepp::ExpatNB. The XML::Parser/XML::Parsepp::ExpatNB object
    # is where all the heavy lifting happens.

    # By calling the XML::Parser/XML::Parsepp::Expat->new method (-- XML::Parser::Expat is a super-class
    # of XML::Parser::ExpatNB --) we will have created a circular reference in
    # $self->{ExpatNB}{parser}.
    #
    # (-- unfortunately, the circular reference does not show up in Data::Dumper, there
    # is just an integer in $self->{ExpatNB}{parser} that represents a data-structure
    # within the C-function ParserCreate() --).
    #
    # See also the following line of code taken from XML::Parser::Expat->new:
    #
    #   $args{Parser} = ParserCreate($self, $args{ProtocolEncoding}, $args{Namespaces});

    # This means that, in order to avoid a memory leak, we have to break this circular
    # reference when we are done with the processing. The breaking of the circular reference
    # will be performed in XML::Reader->DESTROY, which calls XML::Parser::Expat->release.

    # This is an important moment (-- in terms of memory management, at least --).
    # XML::Parser/XML::Parsepp->parse_start creates an XML::Parser/XML::Parsepp::ExpatNB-object, which in turn generates
    # a circular reference (invisible with Data::Dumper). That circular reference will have to
    # be cleaned up when the XML::Reader-object goes away (see XML::Reader->DESTROY).

    $self->{ExpatNB} = $XmlParser->parse_start(
        XR_Data      => [],
        XR_Text      => '',
        XR_Comment   => '',
        XR_fh        => $fh,
        XR_Att       => [],
        XR_ProcInst  => [],
        XR_Decl      => {},
        XR_Prv_SPECD => '',
        XR_Emit_attr => ($opt{filter} == 3 ? 0 : 1),
        XR_Split_up  => ($opt{filter} == 4 || $opt{filter} == 5 ? 1 : 0),
        XR_Strip     => $opt{strip},
        XR_ParseInst => $opt{parse_pi},
        XR_ParseComm => $opt{parse_ct},
      ) or croak "Failed assertion #0050 in subroutine XML::Reader->new: Can't create $use_module -> parse_start";

    # for XML::Reader, version 0.21 (12-Sep-2009):
    # inject an {XR_debug} into $self->{ExpatNB}, if so requested by $opt{debug}

    if (exists $opt{debug}) { $self->{ExpatNB}{XR_debug} = $opt{debug}; }

    # The instruction "XR_Data => []" (-- the 'XR_...' prefix stands for 'Xml::Reader...' --)
    # inside XML::Parser/XML::Parsepp->parse_start() creates an empty array $ExpatNB{XR_Data} = []
    # inside the ExpatNB object. This array is the place where the handlers put their data.
    #
    # Likewise, the instructions "XR_Text => ''", "XR_Comment => ''", and "XR_fh => $fh" , etc...
    # create corresponding elements inside the $ExpatNB-object.

    $self->{sepchar} = defined $opt{sepchar} ? $opt{sepchar} : '';
    $self->{filter}  = $opt{filter};
    $self->{using}   = !defined($opt{using}) ? [] : ref($opt{using}) ? $opt{using} : [$opt{using}];

    # ********************************************************************************************
    # The following lines have been disabled by Klaus Eichner, 30 Oct 2009 (for version 0.29)
    # ********************************************************************************************
    # remove all spaces and then all leading and trailing '/', then put back a single leading '/'
    # for my $check (@{$self->{using}}) {
    #    $check =~ s{\s}''xmsg;
    #    $check =~ s{\A /+}''xms;
    #    $check =~ s{/+ \z}''xms;
    #    $check = '/'.$check;
    # }
    # ********************************************************************************************

    $self->{bush}  = [];
    $self->{rlist} = [];

    if ($self->{filter} == 5) {
        for my $object (@_[2..$#_]) {
            $object->{brna} = [];

            if (ref($object->{branch}) eq 'ARRAY') {
                for my $j (0..$#{$object->{branch}}) {
                    $object->{branch}[$j] =~ s{\A ([^/\s])}{/$1}xms;

                    $object->{brna}[$j] = [];

                    my $b_level = 0;
                    my $b_branch = $object->{branch}[$j];
                    $object->{branch}[$j] =~ s{\[ [^/\]]* \]}''xmsg;

                    $b_branch =~ s{\A /+}''xms;

                    for my $ele (split(m{/}xms, $b_branch)) {
                        $b_level++;

                        if ($ele =~ m{\[ \@ ([^\[\]=\s]+) = ['"] ([^'"]*) ['"] \]}xms) {
                            push @{$object->{brna}[$j]}, [ $b_level - 1, $1, $2 ];
                        }
                    }
                }
            }

            $object->{rota} = [];

            my $a_level = 0;
            my $a_root = $object->{root};
            $object->{root} =~ s{\[ [^/\]]* \]}''xmsg;
            $a_root =~ s{\A /+}''xms;

            for my $ele (split(m{/}xms, $a_root)) {
                $a_level++;

                if ($ele =~ m{\[ \@ ([^\[\]=\s]+) = ['"] ([^'"]*) ['"] \]}xms) {
                    push @{$object->{rota}}, [ $a_level - 1, $1, $2 ];
                }
            }

            if ($object->{root} =~ m{\A // ([^/] .*) \z}xms
            or  $object->{root} =~ m{\A    ([^/] .*) \z}xms) {
                my $chunk = $1;
                push @{$self->{rlist}}, {
                    root   => undef,
                    qr1    => qr{\A (.*) / \Q$chunk\E \z}xms,
                    rota   => $object->{rota},
                    qrfix  => undef,
                    branch => $object->{branch},
                    brna   => $object->{brna},
                  };
            }
            else {
                push @{$self->{rlist}}, {
                    root   => $object->{root},
                    rota   => $object->{rota},
                    qr1    => undef,
                    qrfix  => undef,
                    branch => $object->{branch},
                    brna   => $object->{brna},
                  };
            }
        }

        #~ use Data::Dump;
        #~ dd \@_;
    }

    $self->{plist}        = [];
    $self->{alist}        = [];
    $self->{path}         = '/';
    $self->{prefix}       = '';
    $self->{tag}          = '';
    $self->{value}        = '';
    $self->{att_hash}     = {};
    $self->{dec_hash}     = {};
    $self->{comment}      = '';
    $self->{pyx}          = '';
    $self->{rx}           = 0;
    $self->{rvalue}       = [];
    $self->{rresult}      = [];
    $self->{proc}         = '';
    $self->{type}         = '?';
    $self->{is_start}     = 0;
    $self->{is_end}       = 0;
    $self->{is_decl}      = 0;
    $self->{is_proc}      = 0;
    $self->{is_comment}   = 0;
    $self->{is_text}      = 0;
    $self->{is_attr}      = 0;
    $self->{is_value}     = 0;
    $self->{level}        = 0;
    $self->{item}         = '';

    return $self;
}

# path() and value() are the two main functions:
# **********************************************

sub path  { $_[0]{path}; }

sub value {
    if ($_[0]{filter} == 5) {
        ref $_[0]{rvalue} eq 'ARRAY' ? @{$_[0]{rvalue}} : $_[0]{rvalue};
    }
    else {
        $_[0]{value};
    }
}

sub tag          { $_[0]{tag};          }
sub attr         { $_[0]{attr};         }
sub att_hash     { $_[0]{att_hash};     }
sub dec_hash     { $_[0]{dec_hash};     }
sub type         { $_[0]{type};         }
sub level        { $_[0]{level};        }
sub prefix       { $_[0]{prefix};       }
sub comment      { $_[0]{comment};      }
sub pyx          { $_[0]{pyx};          }
sub rx           { $_[0]{rx};           }
sub rvalue       { $_[0]{rvalue};       }
sub proc_tgt     { $_[0]{proc_tgt};     }
sub proc_data    { $_[0]{proc_data};    }
sub is_decl      { $_[0]{is_decl};      }
sub is_start     { $_[0]{is_start};     }
sub is_proc      { $_[0]{is_proc};      }
sub is_comment   { $_[0]{is_comment};   }
sub is_text      { $_[0]{is_text};      }
sub is_attr      { $_[0]{is_attr};      }
sub is_value     { $_[0]{is_value};     }
sub is_end       { $_[0]{is_end};       }

sub NB_data      { $_[0]{ExpatNB}{XR_Data}; }
sub NB_fh        { $_[0]{ExpatNB}{XR_fh};   }

sub iterate {
    my $self = shift;

    {
        if ($self->{filter} == 5) {
            my $res = shift @{$self->{rresult}};
            if ($res) {
                $self->{rx}     = $res->[0];
                $self->{rvalue} = $res->[1];
                return 1;
            }
        }

        my $token = $self->get_token;
        unless (defined $token) {
            return;
        }

        if ($token->found_start_tag) {
            push @{$self->{plist}}, $token->extract_tag;
            push @{$self->{alist}}, {};
            redo;
        }

        if ($token->found_end_tag) {
            pop @{$self->{plist}};
            pop @{$self->{alist}};
            redo;
        }

        my $prv_SPECD = $token->extract_prv_SPECD;
        my $nxt_SPECD = $token->extract_nxt_SPECD;

        $self->{rx}     = 0;
        $self->{rvalue} = [];

        if ($token->found_text) {
            my $text    = $token->extract_text;
            my $comment = $token->extract_comment;

            my $proc_tgt  = '';
            my $proc_data = '';
            if (@{$token->extract_proc} == 2) {
                $proc_tgt  = ${$token->extract_proc}[0];
                $proc_data = ${$token->extract_proc}[1];
            }

            $self->{is_decl}      = $prv_SPECD eq 'D'  ? 1 : 0;
            $self->{is_start}     = $prv_SPECD eq 'S'  ? 1 : 0;
            $self->{is_proc}      = $prv_SPECD eq 'P'  ? 1 : 0;
            $self->{is_comment}   = $prv_SPECD eq 'C'  ? 1 : 0;
            $self->{is_end}       = $nxt_SPECD eq 'E'  ? 1 : 0;

            $self->{is_text}      = 1;
            $self->{is_attr}      = 0;

            $self->{path}         = '/'.join('/', @{$self->{plist}});
            $self->{attr}         = '';
            $self->{value}        = $text;
            $self->{comment}      = $comment;
            $self->{proc_tgt}     = $proc_tgt;
            $self->{proc_data}    = $proc_data;
            $self->{level}        = @{$self->{plist}};
            $self->{tag}          = @{$self->{plist}} ? ${$self->{plist}}[-1] : '';
            $self->{type}         = 'T';
            $self->{att_hash}     = {@{$token->extract_attr}};
            $self->{dec_hash}     = {@{$token->extract_decl}};

            for (keys %{$self->{att_hash}}) {
                $self->{alist}[-1]{$_} = $self->{att_hash}{$_};
            }
        }
        elsif ($token->found_attr) {
            my $key = $token->extract_attkey;
            my $val = $token->extract_attval;

            $self->{is_decl}      = 0;
            $self->{is_start}     = 0;
            $self->{is_proc}      = 0;
            $self->{is_comment}   = 0;
            $self->{is_end}       = 0;

            $self->{is_text}      = 0;
            $self->{is_attr}      = 1;

            $self->{path}         = '/'.join('/', @{$self->{plist}}).'/@'.$key;
            $self->{attr}         = $key;
            $self->{value}        = $val;
            $self->{comment}      = '';
            $self->{proc_tgt}     = '';
            $self->{proc_data}    = '';
            $self->{level}        = @{$self->{plist}} + 1;
            $self->{tag}          = '@'.$key;
            $self->{type}         = '@';
            $self->{att_hash}     = {};
            $self->{dec_hash}     = {};

            $self->{alist}[-1]{$key} = $val;
        }
        else {
            croak "Failed assertion #0060 in subroutine XML::Reader->iterate: Found data type '".$token->[0]."'";
        }

        # for {filter => 4 or 5}
        #   - promote $self->{type}    -- from 'T'/'@' to any of the following codes: 'D', '?', 'S', 'E', '#', 'T', '@'
        #   - update  $self->{is_text}
        #   - setup   $self->{pyx}

        if ($self->{filter} == 4 or $self->{filter} == 5) {
            if    ($self->{type} eq '@') { $self->{pyx} = 'A'.$self->{attr}.' '.$self->{value}; }
            elsif ($self->{is_decl})     { my $dc = $self->{dec_hash};
                                           $self->{type} = 'D'; $self->{pyx} = '?xml'.join('', map {" $_='$dc->{$_}'"} sort {$b cmp $a} keys %$dc); }
            elsif ($self->{is_proc})     { $self->{type} = '?'; $self->{pyx} = '?'.$self->{proc_tgt}.' '.$self->{proc_data}; }
            elsif ($self->{is_start})    { $self->{type} = 'S'; $self->{pyx} = '('.$self->{tag}; }
            elsif ($self->{is_end})      { $self->{type} = 'E'; $self->{pyx} = ')'.$self->{tag}; }
            elsif ($self->{is_comment})  { $self->{type} = '#'; $self->{pyx} = '#'.$self->{comment}; }
            else                         { $self->{type} = 'T'; $self->{pyx} = '-'.$self->{value}; }
            $self->{pyx} =~ s{\\}'\\\\'xmsg; # replace each backslash by a double-backslash
            $self->{pyx} =~ s{\t}'\\t'xmsg; # replace tabs by a literal "\\t"
            $self->{pyx} =~ s{\n}'\\n'xmsg; # replace newlines by a literal "\\n"

            # update $self->{is_text}
            $self->{is_text} = $self->{type} eq 'T' ? 1 : 0;
        }
        else {
            $self->{pyx} = undef;
        }

        $self->{is_value} = ($self->{is_text} || $self->{is_attr}) ? 1 : 0;

        # for {filter => 5} check roots
        if ($self->{filter} == 5) {
            for my $r (0..$#{$self->{rlist}}) {
                my $param = $self->{rlist}[$r];

                my $twig;
                my $border;

                my $root;
                my $rotn = 0;

                if (defined $param->{root}) {
                    $root = $param->{root};
                }
                elsif (defined $param->{qrfix}) {
                    $root = $param->{qrfix};
                }
                elsif (defined $param->{qr1}) {
                    if ($self->{path} =~ $param->{qr1}) { my $prf = $1;
                        $rotn = () = $prf =~ m{/}xmsg;
                        $root = $self->{path};
                        $param->{qrfix} = $root;
                    }
                }

                if (defined $root) {
                    if ($root eq '/') {
                        if (@{$self->{plist}} == 1) {
                            $twig = $self->{path};
                            $border = 1;
                        }
                        elsif (@{$self->{plist}} > 1) {
                            $twig = $self->{path};
                            $border = 0;
                        }
                    }
                    else {
                        if ($self->{path} eq $root) {
                            $twig = '/';
                            $border = 1;
                        }
                        elsif (substr($self->{path}, 0, length($root) + 1) eq $root.'/') {
                            $twig = substr($self->{path}, length($root));
                            $border = 0;
                        }
                    }
                }

                next unless defined $twig;

                my $block = 0;

                #~ if (@{$param->{rota}}) {
                    #~ use Data::Dump;
                    #~ print "\nDeb-0010: param->{rota}:\n";
                    #~ dd $param->{rota};
                    #~ print "\nDeb-0020: self->{alist}:\n";
                    #~ dd $self->{alist};
                #~ }

                for (@{$param->{rota}}) {
                    my ($offset, $attr, $val) = ($_->[0] + $rotn, $_->[1], $_->[2]);

                    #~ print "Deb-0030: offset = $offset ($_->[0] + $rotn), attr = '$attr', val = '$val'\n";

                    my $e = $self->{alist}[$offset];

                    unless ($e) {
                        #~ print "Deb-0100: Block-01\n";
                        $block++;
                        next;
                    }

                    my $v = $e->{$attr};

                    unless (defined $v) {
                        #~ print "Deb-0110: Block-02\n";
                        $block++;
                        next;
                    }

                    unless ($v eq $val) {
                        #~ print "Deb-0120: Block-03\n";
                        $block++;
                        next;
                    }

                    #~ print "Deb-0150: Good...\n";
                }

                next if $block;

                my $bran;

                if ($root eq '/') {
                    $bran = 0;
                }
                else {
                    $bran = () = $root =~ m{/}xmsg;
                }

                if (ref $param->{branch}) { # here we have an array of branches...
                    if ($border and $self->{is_start}) {
                        $self->{bush}[$r] = [];
                    }

                    if ($self->{is_value}) {
                        for my $i (0..$#{$param->{branch}}) {
                            if ($param->{branch}[$i] eq $twig) {

                                my $block = 0;

                                #~ if (@{$param->{brna}[$i]}) {
                                    #~ use Data::Dump;
                                    #~ print "\nDeb-0010: param->{brna}[$i]:\n";
                                    #~ dd $param->{brna}[$i];
                                    #~ print "\nDeb-0020: self->{alist}:\n";
                                    #~ dd $self->{alist};
                                #~ }

                                for (@{$param->{brna}[$i]}) {
                                    my ($offset, $attr, $val) = ($_->[0] + $bran, $_->[1], $_->[2]);

                                    #~ print "Deb-0030: offset = $offset ($_->[0] + $bran), attr = '$attr', val = '$val'\n";

                                    my $e = $self->{alist}[$offset];

                                    unless ($e) {
                                        #~ print "Deb-0100: Block-01\n";
                                        $block++;
                                        next;
                                    }

                                    my $v = $e->{$attr};

                                    unless (defined $v) {
                                        #~ print "Deb-0110: Block-02\n";
                                        $block++;
                                        next;
                                    }

                                    unless ($v eq $val) {
                                        #~ print "Deb-0120: Block-03\n";
                                        $block++;
                                        next;
                                    }

                                    #~ print "Deb-0150: Good...\n";
                                }

                                unless ($block) {
                                    my $ref = \$self->{bush}[$r][$i];
                                    $$ref .= (defined $$ref ? $self->{sepchar} : '').$self->{value};
                                }
                            }
                        }
                    }
                }
                elsif ($param->{branch} eq '+') { # collect PYX array, addition for ver 0.39 (Klaus Eichner, 28th Oct 2011)
                    if ($border and $self->{is_start}) {
                        $self->{bush}[$r] = [];
                    }
                    push @{$self->{bush}[$r]}, $self->{pyx};
                }
                elsif ($param->{branch} eq '*') { # collect pure XML data, addition for ver 0.34 (Klaus Eichner, 26th Apr 2010)
                    if ($border and $self->{is_start}) {
                        $self->{bush}[$r] = '';
                    }

                    my $element = '';
                    if ($self->{is_decl}) {
                        $element .= '
                        for my $key (sort keys %{$self->{dec_hash}}) {
                            my $kval = $self->{dec_hash}{$key};
                            $kval =~ s{&}'&'xmsg;
                            $kval =~ s{'}'''xmsg;
                            $kval =~ s{<}'<'xmsg;
                            $kval =~ s{>}'>'xmsg;
                            $element .= qq{ $key='$kval'};
                        }
                        $element .= '?>';
                    }
                    if ($self->{is_start}) {
                        $element .= '<'.$self->{tag};
                        for my $key (sort keys %{$self->{att_hash}}) {
                            my $kval = $self->{att_hash}{$key};
                            $kval =~ s{&}'&'xmsg;
                            $kval =~ s{'}'''xmsg;
                            $kval =~ s{<}'<'xmsg;
                            $kval =~ s{>}'>'xmsg;
                            $element .= qq{ $key='$kval'};
                        }
                        $element .= '>';
                    }
                    if ($self->{is_proc}) {
                        my $tgt = $self->{proc_tgt};
                        my $dat = $self->{proc_data};
                        for ($tgt, $dat) {
                            s{&}'&'xmsg;
                            s{'}'''xmsg;
                            s{<}'<'xmsg;
                            s{>}'>'xmsg;
                        }
                        $element .= "";
                    }
                    if ($self->{is_text}) {
                        my $tval = $self->{value};
                        if ($tval ne '') {
                            $tval =~ s{&}'&'xmsg;
                            $tval =~ s{<}'<'xmsg;
                            $tval =~ s{>}'>'xmsg;
                            $element .= $tval;
                        }
                    }
                    if ($self->{is_comment}) {
                        my $tval = $self->{comment};
                        $tval =~ s{&}'&'xmsg;
                        $tval =~ s{<}'<'xmsg;
                        $tval =~ s{>}'>'xmsg;
                        $element .= "";
                    }
                    if ($self->{is_end}) {
                        $element .= '{tag}.'>';
                    }

                    $self->{bush}[$r] .= $element;
                }

                if ($border and $self->{is_end}) {
                    push @{$self->{rresult}}, [$r, $self->{bush}[$r]];
                    $param->{qrfix} = undef;
                }
            }
            redo;
        }

        # Here we check for the {using => ...} option
        $self->{prefix} = '';

        for my $check (@{$self->{using}}) {
            if ($check eq $self->{path}) {
                $self->{prefix} = $check;
                $self->{path}   = '/';
                $self->{level}  = 0;
                $self->{tag}    = ''; # unfortunately we have to nullify the tag here...
                last;
            }
            if ($check.'/' eq substr($self->{path}, 0, length($check) + 1)) { my @temp = split m{/}xms, $check;
                $self->{prefix} = $check;
                $self->{path}   = substr($self->{path}, length($check));
                $self->{level} -= @temp - 1;
                last;
            }
        }

        # check if option {using => ...} has been requested, and if so, then skip all
        # lines that don't have a prefix...
        if (@{$self->{using}} and $self->{prefix} eq '') {
            redo;
        }
    }

    return 1;
}

sub get_token {
    my $self = shift;

    until (@{$self->NB_data}) {
        # Here is the all important reading of a chunk of XML-data from the filehandle...

        my $buf;

        if (ref($self->NB_fh) eq 'Acme::HTTP') {
            my $ct = $self->NB_fh->read_entity_body($buf, 4096); # returns number of bytes read, or undef if IO-Error
            last unless $ct;
        }
        else {
            read($self->NB_fh, $buf, 4096);
        }

        # We leave immediately as soon as there is no more data left (EOF)
        last if $buf eq '';

        # and here is the all important parsing of that chunk:
        # and we could get exceptions thrown here if the XML is invalid...

        $self->{ExpatNB}->parse_more($buf);

        # ...the recommended way to catch those exceptions is not here, but by wrapping
        # eval{} around $rdr->iterate like follows
        #
        #    while (eval{$rdr->iterate}) {
        #        my $text = $rdr->value;
        #        # ...
        #    }
        #    if ($@) {
        #        print "found an error: $@\n";
        #    }
    }

    # return failure if end-of-file...
    unless (@{$self->NB_data}) {
        return;
    }

    my $token = shift @{$self->NB_data};
    bless $token, 'XML::Reader::Token';
}
sub handle_decl {
    my ($ExpatNB, $ver, $encoding, $standalone) = @_;

    return unless $ExpatNB->{XR_ParseInst};

    convert_structure($ExpatNB, 'D');
    $ExpatNB->{XR_Decl} = [(defined $ver        ? (version    => $ver)                         : ()),
                           (defined $encoding   ? (encoding   => $encoding)                    : ()),
                           (defined $standalone ? (standalone => ($standalone ? 'yes' : 'no')) : ()),
                          ];
}

sub handle_procinst {
    my ($ExpatNB, $target, $data) = @_;

    return unless $ExpatNB->{XR_ParseInst};

    convert_structure($ExpatNB, 'P');
    $ExpatNB->{XR_ProcInst} = [$target, $data];
}

sub handle_comment {
    my ($ExpatNB, $comment) = @_;

    return unless $ExpatNB->{XR_ParseComm};

    convert_structure($ExpatNB, 'C');
    $ExpatNB->{XR_Comment} = $comment;
}

sub handle_start {
    my ($ExpatNB, $element, @attr) = @_;

    convert_structure($ExpatNB, 'S');
    $ExpatNB->{XR_Att} = \@attr;
    push @{$ExpatNB->{XR_Data}}, ['<', $element];
}

sub handle_end {
    my ($ExpatNB, $element) = @_;

    convert_structure($ExpatNB, 'E');
    push @{$ExpatNB->{XR_Data}}, ['>', $element];
}

sub handle_char {
    my ($ExpatNB, $text) = @_;

    $ExpatNB->{XR_Text} .= $text;
}

sub convert_structure {
    my ($ExpatNB, $Param_SPECD) = @_; # $Param_SPECD can be either 'S', 'P', 'E', 'C' or 'D' (or even '*')

    # These are the text and comment that may be stripped
    my $text    = $ExpatNB->{XR_Text};
    my $comment = $ExpatNB->{XR_Comment};

    # strip spaces if requested...
    if ($ExpatNB->{XR_Strip}) {
        for my $item ($text, $comment) {
            $item =~ s{\A \s+}''xms;
            $item =~ s{\s+ \z}''xms;
            $item =~ s{\s+}' 'xmsg;
        }
    }

    # Don't do anything for the first tag...
    unless ($ExpatNB->{XR_Prv_SPECD} eq '') {
        # Here we save the previous 'SPECD' and the current (i.e. next) 'SPECD' into lexicals
        # so that we can manipulate them
        my $prev_SPECD = $ExpatNB->{XR_Prv_SPECD};
        my $next_SPECD = $Param_SPECD;

        # Do we want , ,  and  split up into separate lines ?
        if ($ExpatNB->{XR_Split_up}) {
            if ($prev_SPECD ne 'E') {
                # emit the opening tag with empty text
                push @{$ExpatNB->{XR_Data}},
                  ['T', '', $comment, $prev_SPECD, '*', $ExpatNB->{XR_Att}, $ExpatNB->{XR_ProcInst}, $ExpatNB->{XR_Decl}];
            }

            if ($ExpatNB->{XR_Emit_attr}) {
                # Here we emit attributes on their proper lines -- *after* the start-line (see above) ...
                my %at = @{$ExpatNB->{XR_Att}};
                for my $key (sort keys %at) {
                    push @{$ExpatNB->{XR_Data}}, ['A', $key, $at{$key}];
                }
            }

            # emit text (only if it is not empty)
            unless ($text eq '') {
                push @{$ExpatNB->{XR_Data}},
                  ['T', $text, '', '-', '*', [], [], []];
            }

            if ($next_SPECD eq 'E') {
                # emit the closing tag with empty text
                push @{$ExpatNB->{XR_Data}},
                  ['T', '', '', '*', $next_SPECD, [], [], []];
            }
        }
        # Here we don't want , ,  and  split up into separate lines !
        else {
            # Do we really want to emit attributes on their proper lines ? -- or do we just
            # want to publish the attributes on element ${$ExpatNB->{XR_Data}}[5] ?
            if ($ExpatNB->{XR_Emit_attr}) {

                my %at = @{$ExpatNB->{XR_Att}};

                # Here we emit attributes on their proper lines -- *before* the start line (see below) ...
                for my $key (sort keys %at) {
                    push @{$ExpatNB->{XR_Data}}, ['A', $key, $at{$key}];
                }
            }

            # And here we emit the text
            push @{$ExpatNB->{XR_Data}},
              ['T', $text, $comment, $prev_SPECD, $next_SPECD, $ExpatNB->{XR_Att}, $ExpatNB->{XR_ProcInst}, $ExpatNB->{XR_Decl}];
        }
    }

    # Initialise values:
    $ExpatNB->{XR_Text}      = '';
    $ExpatNB->{XR_Comment}   = '';
    $ExpatNB->{XR_Att}       = [];
    $ExpatNB->{XR_ProcInst}  = [];
    $ExpatNB->{XR_Decl}      = [];

    $ExpatNB->{XR_Prv_SPECD} = $Param_SPECD;
}

sub DESTROY {
    my $self = shift;

    # There are circular references inside an XML::Parser::ExpatNB-object
    # which need to be cleaned up by calling XML::Parser::Expat->release.

    # I quote from the documentation of 'XML::Parser::Expat' (-- XML::Parser::Expat
    # is a super-class of XML::Parser::ExpatNB --)
    #
    # >> ------------------------------------------------------------------------
    # >> =item release
    # >>
    # >> There are data structures used by XML::Parser::Expat that have circular
    # >> references. This means that these structures will never be garbage
    # >> collected unless these references are explicitly broken. Calling this
    # >> method breaks those references (and makes the instance unusable.)
    # >>
    # >> Normally, higher level calls handle this for you, but if you are using
    # >> XML::Parser::Expat directly, then it's your responsibility to call it.
    # >> ------------------------------------------------------------------------

    # There is a possibility that the XML::Parser::ExpatNB-object did not get
    # created, while still blessing the XML::Reader object. Therefore we have to
    # test for this case before calling XML::Parser::ExpatNB->release.

    if ($self->{ExpatNB}) {
        $self->{ExpatNB}->release; # ...and not $self->{ExpatNB}->parse_done;
    }
}

sub slurp_xml {
    my $data = shift;

    my @roots;
    my $filter = { filter => 5 };

    for my $r (@_) {
        if (defined $r->{dupatt}) {
            $filter->{dupatt} = $r->{dupatt};
        }
        else {
            push @roots, $r;
        }
    }

    my @tree = map {[]} @roots; # start with as many empty lists as there are roots

    my $rdr = XML::Reader->new($data, $filter, @roots);

    while ($rdr->iterate) {
        push @{$tree[$rdr->rx]}, $rdr->rvalue;
    }

    return \@tree;
}

# The package used here - XML::Reader::Token
# has been inspired by    XML::TokeParser::Token

package XML::Reader::Token;
$XML::Reader::Token::VERSION = '0.65';
sub found_start_tag   { $_[0][0] eq '<'; }
sub found_end_tag     { $_[0][0] eq '>'; }
sub found_attr        { $_[0][0] eq 'A'; }
sub found_text        { $_[0][0] eq 'T'; }

sub extract_tag       { $_[0][1]; } # type eq '<' or '>'

sub extract_attkey    { $_[0][1]; } # type eq 'A'
sub extract_attval    { $_[0][2]; } # type eq 'A'

sub extract_text      { $_[0][1]; } # type eq 'T'
sub extract_comment   { $_[0][2]; } # type eq 'T'

sub extract_prv_SPECD { $_[0][3]; } # type eq 'T'
sub extract_nxt_SPECD { $_[0][4]; } # type eq 'T'
sub extract_attr      { $_[0][5]; } # type eq 'T'
sub extract_proc      { $_[0][6]; } # type eq 'T'
sub extract_decl      { $_[0][7]; } # type eq 'T'

1;

__END__