File Coverage

blib/lib/XML/Parser/Lite.pm

Criterion	Covered	Total	%
statement	105	108	97.2
branch	26	34	76.4
condition	4	5	80.0
subroutine	26	27	96.3
pod	3	5	60.0
total	164	179	91.6

# ======================================================================
#
# Copyright (C) 2000-2007 Paul Kulchenko ([e-mail])
# Copyright (C) 2008 Martin Kutter ([e-mail])
# XML::Parser::Lite is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# ======================================================================

package XML::Parser::Lite;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.720_01';

sub new {
    my $class = shift;

    return $class if ref $class;
    my $self = bless {} => $class;

    my %parameters = @_;
    $self->setHandlers(); # clear first
    $self->setHandlers(%{$parameters{Handlers} || {}});

    return $self;
}

sub setHandlers {
    my $self = shift;

    # allow symbolic refs, avoid "subroutine redefined" warnings
    no strict 'refs';
    no warnings qw(redefine);
    # clear all handlers if called without parameters
    if (not @_) {
        for (qw(Start End Char Final Init Comment Doctype XMLDecl)) {
            *$_ = sub {}
        }
    }

    # we could use each here, too...
    while (@_) {
        my($name, $func) = splice(@_, 0, 2);
        *$name = defined $func
            ? $func
            : sub {}
    }
    return $self;
}

sub _regexp {
    my $patch = shift || '';
    my $package = __PACKAGE__;

    # This parser is based on "shallow parser" http://www.cs.sfu.ca/~cameron/REX.html

    # Robert D. Cameron "REX: XML Shallow Parsing with Regular Expressions",
    # Technical Report TR 1998-17, School of Computing Science, Simon Fraser University, November, 1998.
    # Copyright (c) 1998, Robert D. Cameron.
    # The following code may be freely used and distributed provided that
    # this copyright and citation notice remains intact and that modifications
    # or additions are clearly identified.

    # Modifications may be tracked on SOAP::Lite's SVN at
    # https://soaplite.svn.sourceforge.net/svnroot/soaplite/
    #
    use re 'eval';
    my $TextSE = "[^<]+";
    my $UntilHyphen = "[^-]*-";
    my $Until2Hyphens = "([^-]*)-(?:[^-]$[^-]*-)*-";
    #my $CommentCE = "$Until2Hyphens(?{${package}::comment(\$2)})>?";
    my $CommentCE = "(.+)--(?{${package}::comment(\$2)})>?";
#    my $Until2Hyphens = "$UntilHyphen(?:[^-]$UntilHyphen)*-";
#    my $CommentCE = "$Until2Hyphens>?";
    my $UntilRSBs = "[^\\]]*](?:[^\\]]+])*]+";
    my $CDATA_CE = "$UntilRSBs(?:[^\\]>]$UntilRSBs)*>";
    my $S = "[ \\n\\t\\r]+";
    my $NameStrt = "[A-Za-z_:]|[^\\x00-\\x7F]";
    my $NameChar = "[A-Za-z0-9_:.-]|[^\\x00-\\x7F]";
    my $Name = "(?:$NameStrt)(?:$NameChar)*";
    my $QuoteSE = "\"[^\"]*\"|'[^']*'";
    my $DT_IdentSE = "$Name(?:$S(?:$Name|$QuoteSE))*";
#    my $DT_IdentSE = "$S$Name(?:$S(?:$Name|$QuoteSE))*";
    my $MarkupDeclCE = "(?:[^\\]\"'><]+|$QuoteSE)*>";
    my $S1 = "[\\n\\r\\t ]";
    my $UntilQMs = "[^?]*\\?";
    my $PI_Tail = "\\?>|$S1$UntilQMs(?:[^>?]$UntilQMs)*";
    my $DT_ItemSE = "<(?:!(?:--$Until2Hyphens>|[^-]$MarkupDeclCE)|\\?$Name(?:$PI_Tail>))|%$Name;|$S";
    my $DocTypeCE = "$S($DT_IdentSE(?:$S)?(?:\\[(?:$DT_ItemSE)*](?:$S)?)?)>(?{${package}::_doctype(\$3)})";
#    my $PI_Tail = "\\?>|$S1$UntilQMs(?:[^>?]$UntilQMs)*>";
#    my $DT_ItemSE = "<(?:!(?:--$Until2Hyphens>|[^-]$MarkupDeclCE)|\\?$Name(?:$PI_Tail))|%$Name;|$S";
#    my $DocTypeCE = "$DT_IdentSE(?:$S)?(?:\\[(?:$DT_ItemSE)*](?:$S)?)?>?";
    my $DeclCE = "--(?:$CommentCE)?|\\[CDATA\\[(?:$CDATA_CE)?|DOCTYPE(?:$DocTypeCE)?";
#    my $PI_CE = "$Name(?:$PI_Tail)?";
    my $PI_CE = "($Name(?:$PI_Tail))>(?{${package}::_xmldecl(\$5)})";
    # these expressions were modified for backtracking and events
#    my $EndTagCE = "($Name)(?{${package}::_end(\$2)})(?:$S)?>";
    my $EndTagCE = "($Name)(?{${package}::_end(\$6)})(?:$S)?>";
    my $AttValSE = "\"([^<\"]*)\"|'([^<']*)'";
#    my $ElemTagCE = "($Name)(?:$S($Name)(?:$S)?=(?:$S)?(?:$AttValSE)(?{[\@{\$^R||[]},\$4=>defined\$5?\$5:\$6]}))*(?:$S)?(/)?>(?{${package}::_start( \$3,\@{\$^R||[]})})(?{\${7} and ${package}::_end(\$3)})";
    my $ElemTagCE = "($Name)"
        . "(?:$S($Name)(?:$S)?=(?:$S)?(?:$AttValSE)"
        . "(?{[\@{\$^R||[]},\$8=>defined\$9?\$9:\$10]}))*(?:$S)?(/)?>"
        . "(?{${package}::_start(\$7,\@{\$^R||[]})})(?{\$11 and ${package}::_end(\$7)})";

    my $MarkupSPE = "<(?:!(?:$DeclCE)?|\\?(?:$PI_CE)?|/(?:$EndTagCE)?|(?:$ElemTagCE)?)";

    # Next expression is under "black magic".
    # Ideally it should be '($TextSE)(?{${package}::char(\$1)})|$MarkupSPE',
    # but it doesn't work under Perl 5.005 and only magic with
    # (?:....)?? solved the problem.
    # I would appreciate if someone let me know what is the right thing to do
    # and what's the reason for all this magic.
    # Seems like a problem related to (?:....)? rather than to ?{} feature.
    # Tests are in t/31-xmlparserlite.t if you decide to play with it.
    #"(?{[]})(?:($TextSE)(?{${package}::_char(\$1)}))$patch|$MarkupSPE";
    "(?:($TextSE)(?{${package}::_char(\$1)}))$patch|$MarkupSPE";
}

setHandlers();

# Try 5.6 and 5.10 regex first
my $REGEXP = _regexp('??');

sub _parse_re {
    use re "eval";
    undef $^R;
    no strict 'refs';
    1 while $_[0] =~ m{$REGEXP}go
};

# fixup regex if it does not work...
{
    if (not eval { _parse_re('bar'); 1; } ) {
        $REGEXP = _regexp();
        local $^W;
        *_parse_re = sub {
                use re "eval";
                undef $^R;
                1 while $_[0] =~ m{$REGEXP}go
            };
    }
}

sub parse {
    _init();
    _parse_re($_[1]);
    _final();
}

my(@stack, $level);

sub _init {
    @stack = ();
    $level = 0;
    Init(__PACKAGE__, @_);
}

sub _final {
    die "not properly closed tag '$stack[-1]'\n" if @stack;
    die "no element found\n" unless $level;
    Final(__PACKAGE__, @_)
}

sub _start {
    die "multiple roots, wrong element '$_[0]'\n" if $level++ && !@stack;
    push(@stack, $_[0]);
    my $r=Start(__PACKAGE__, @_);
    return ref($r) eq 'ARRAY' ? $r : undef;
}

sub _char {
    Char(__PACKAGE__, $_[0]), return if @stack;

    # check for junk before or after element
    # can't use split or regexp due to limitations in ?{} implementation,
    # will iterate with loop, but we'll do it no more than two times, so
    # it shouldn't affect performance
    for (my $i=0; $i < length $_[0]; $i++) {
        die "junk '$_[0]' @{[$level ? 'after' : 'before']} XML element\n"
        if index("\n\r\t ", substr($_[0],$i,1)) < 0; # or should '< $[' be there
    }
}

sub _end {
    no warnings qw(uninitialized);
    pop(@stack) eq $_[0] or die "mismatched tag '$_[0]'\n";
    my $r=End(__PACKAGE__, $_[0]);
    return ref($r) eq 'ARRAY' ? $r : undef;
}

sub comment {
    my $r=Comment(__PACKAGE__, $_[0]);
    return ref($r) eq 'ARRAY' ? $r : undef;
}

sub end {
    pop(@stack) eq $_[0] or die "mismatched tag '$_[0]'\n";
    my $r=End(__PACKAGE__, $_[0]);
    return ref($r) eq 'ARRAY' ? $r : undef;
}

sub _doctype {
    my $r=Doctype(__PACKAGE__, $_[0]);
    return ref($r) eq 'ARRAY' ? $r : undef;
}

sub _xmldecl {
    XMLDecl(__PACKAGE__, $_[0]);
}



# ======================================================================
1;

__END__