File Coverage

blib/lib/XML/Parser/LiteCopy.pm

Criterion	Covered	Total	%
statement	93	96	96.8
branch	25	30	83.3
condition	6	7	85.7
subroutine	22	24	91.6
pod	3	6	50.0
total	149	163	91.4

# NOTE: This module originally came from SOAP::Lite, which you probably
# don't have. It was first repackaged here just to avoid the huge
# dependancy tree, but this version has several features (CDATA
# support, better PI and Comment support) that have been added.

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

package XML::Parser::LiteCopy;

use strict;
use vars qw($VERSION);
$VERSION = '0.720.00';

my $ReturnErrors = 0;

sub new {
    my $class = shift;

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

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

    $ReturnErrors = $parameters{ReturnErrors} || 0;

    return $self;
}

sub setHandlers {
    my $self = shift;

    # allow symbolic refs, avoid "subroutine redefined" warnings
    no strict 'refs'; local $^W;
    # clear all handlers if called without parameters
    if (not @_) {
        for (qw(Start End Char Final Init CData Comment Doctype PI Error)) {
            *$_ = 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.

    use re 'eval';
    my $TextSE = "[^<]+";

    # the following backrefs have been added:
    # 1 : TextSE
    # 2 : MarkupSPE / DeclCE / CommentCE
    # 3 : MarkupSPE / DeclCE / CDATA_CE
    # 4 : MarkupSPE / DeclCE / DocTypeCE
    # 5 : MarkupSPE / PI_CE
    # 6 : MarkupSPE / EndTagCE
    # 7+: MarkupSPE / ElemTagCE

    my $Until2Hyphens = "(?:[^-]*)-(?:[^-]+-)*-";
    my $CommentCE = "($Until2Hyphens)(?{${package}::comment(\$2)})>?";

    my $UntilRSBs = "[^\\]]*](?:[^\\]]+])*]+";
    my $CDATA_CE = "($UntilRSBs(?:[^\\]>]$UntilRSBs)*)(?{${package}::cdata(\$3)})>";

    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 $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(\$4)})";

    my $DeclCE = "--(?:$CommentCE)?|\\[CDATA\\[(?:$CDATA_CE)?|DOCTYPE(?:$DocTypeCE)?";

    my $PI_CE = "($Name(?:$PI_Tail))>(?{${package}::_pi(\$5); undef})";

    # these expressions were modified for backtracking and events

    my $EndTagCE = "($Name)(?{${package}::_end(\$6); undef})(?:$S)?>";
    my $AttValSE = "\"([^<\"]*)\"|'([^<']*)'";

    my $ElemTagCE = "($Name)"
        . "(?:$S($Name)(?:$S)?=(?:$S)?(?:$AttValSE)"
        . "(?{[\@{\$^R||[]},\$8=>defined\$9?\$9:\$10]}))*(?:$S)?(/)?>"
        . "(?{${package}::_start(\$7,\@{\$^R||[]}),\$^R=[]})(?{\$11 and ${package}::_end(\$7); undef})";

    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;
    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 {
    return _error("not properly closed tag '$stack[-1]'") if @stack;
    return _error("no element found") unless $level;
    Final(__PACKAGE__, @_)
}

sub _start {
    return _error("multiple roots, wrong element '$_[0]'") if $level++ && !@stack;
    push(@stack, $_[0]);
    Start(__PACKAGE__, @_);
}

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++) {
        return _error("junk '$_[0]' @{[$level ? 'after' : 'before']} XML element")
        if index("\n\r\t ", substr($_[0],$i,1)) < 0; # or should '< $[' be there
    }
}

sub _end {
    return _error("unexpected closing tag '$_[0]'") if !@stack;
    pop(@stack) eq $_[0] or return _error("mismatched tag '$_[0]'");
    End(__PACKAGE__, $_[0]);
}

sub comment {
    Comment(__PACKAGE__, substr $_[0], 0, -2);
}

sub end {
     pop(@stack) eq $_[0] or return _error("mismatched tag '$_[0]'");
     End(__PACKAGE__, $_[0]);
}

sub cdata {
    return _error("CDATA outside of tag stack") unless @stack;
    CData(__PACKAGE__, substr $_[0], 0, -2);
}

sub _doctype {
    Doctype(__PACKAGE__, $_[0]);
}

sub _pi {
    PI(__PACKAGE__, substr $_[0], 0, -1);
}

sub _error {
    if ($ReturnErrors){
      Error(__PACKAGE__, $_[0]);
      return;
    }
    die "$_[0]\n";
}

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

__END__