init III

Perl OTRS/Kernel/cpan-lib/XML/LibXML/Simple.pm

@@ -0,0 +1,502 @@
+# Copyrights 2008-2016 by [Mark Overmeer].
+#  For other contributors see ChangeLog.
+# See the manual pages for details on the licensing terms.
+# Pod stripped from pm file by OODoc 2.02.
+package XML::LibXML::Simple;
+use vars '$VERSION';
+$VERSION = '0.97';
+
+use base 'Exporter';
+
+use strict;
+use warnings;
+
+our @EXPORT    = qw(XMLin);
+our @EXPORT_OK = qw(xml_in);
+
+use XML::LibXML       ();
+use File::Slurp::Tiny qw/read_file/;
+use File::Basename    qw/fileparse/;
+use File::Spec        ();
+use Carp;
+use Scalar::Util      qw/blessed/;
+
+use Data::Dumper;  #to be removed
+
+
+my %known_opts = map +($_ => 1),
+  qw(keyattr keeproot forcecontent contentkey noattr searchpath
+     forcearray grouptags nsexpand normalisespace normalizespace
+     valueattr nsstrip parser parseropts hooknodes);
+
+my @default_attributes  = qw(name key id);
+my $default_content_key = 'content';
+
+#-------------
+
+sub new(@)
+{   my $class = shift;
+    my $self  = bless {}, $class;
+    my $opts  = $self->{opts} = $self->_take_opts(@_);
+
+    # parser object cannot be reused
+    !defined $opts->{parser}
+        or error __x"parser option for XMLin only";
+
+    $self;
+}
+
+#-------------
+
+sub XMLin
+{   my $self = @_ > 1 && blessed $_[0] && $_[0]->isa(__PACKAGE__) ? shift
+      : __PACKAGE__->new;
+    my $target = shift;
+
+    my $this = $self->_take_opts(@_);
+    my $opts = $self->_init($self->{opts}, $this);
+
+    my $xml  = $self->_get_xml($target, $opts)
+        or return;
+
+    if(my $cb = $opts->{hooknodes})
+    {   $self->{XCS_hooks} = $cb->($self, $xml);
+    }
+
+    my $top  = $self->collapse($xml, $opts);
+    if($opts->{keeproot})
+    {   my $subtop
+          = $opts->{forcearray_always} && ref $top ne 'ARRAY' ? [$top] : $top;
+        $top = +{ $xml->localName => $subtop };
+    }
+
+    $top;
+}
+*xml_in = \&XMLin;
+
+sub _get_xml($$)
+{   my ($self, $source, $opts) = @_;
+
+    $source    = $self->default_data_source($opts)
+        unless defined $source;
+
+    $source    = \*STDIN
+        if $source eq '-';
+
+    my $parser = $opts->{parser}
+              || $self->_create_parser($opts->{parseropts});
+
+    my $xml
+      = blessed $source &&
+        (  $source->isa('XML::LibXML::Document')
+        || $source->isa('XML::LibXML::Element' )) ? $source
+      : ref $source eq 'SCALAR' ? $parser->parse_string($$source)
+      : ref $source             ? $parser->parse_fh($source)
+      : $source =~ m{^\s*\<.*?\>\s*$}s ? $parser->parse_string($source)
+      :    $parser->parse_file
+              ($self->find_xml_file($source, @{$opts->{searchpath}}));
+
+    $xml = $xml->documentElement
+         if $xml->isa('XML::LibXML::Document');
+
+    $xml;
+}
+
+sub _create_parser(@)
+{   my $self = shift;
+    my @popt = @_ != 1 ? @_ : ref $_[0] eq 'HASH' ? %{$_[0]} : @{$_[0]};
+
+    XML::LibXML->new
+      ( line_numbers    => 1
+      , no_network      => 1
+      , expand_xinclude => 0
+      , expand_entities => 1
+      , load_ext_dtd    => 0
+      , ext_ent_handler =>
+           sub { alert __x"parsing external entities disabled"; '' }
+      , @popt
+      );
+}
+
+sub _take_opts(@)
+{   my $self = shift;
+   
+    my %opts;
+    @_ % 2==0
+        or die "ERROR: odd number of options.\n";
+
+    while(@_)
+    {   my ($key, $val) = (shift, shift);
+        my $lkey = lc $key;
+        $lkey =~ s/_//g;
+        $known_opts{$lkey} or croak "Unrecognised option: $key";
+        $opts{$lkey} = $val;
+    }
+
+    \%opts;
+}
+
+# Returns the name of the XML file to parse if no filename or XML string 
+# was provided explictly.
+
+sub default_data_source($)
+{   my ($self, $opts) = @_;
+
+    my ($basename, $script_dir, $ext) = fileparse $0, qr[\.[^\.]+];
+
+    # Add script directory to searchpath
+    unshift @{$opts->{searchpath}}, $script_dir
+        if $script_dir;
+
+    "$basename.xml";
+}
+
+sub _init($$)
+{   my ($self, $global, $this) = @_;
+    my %opt = (%$global, %$this);
+
+    if(defined $opt{contentkey})
+         { $opt{collapseagain} = $opt{contentkey} =~ s/^\-// }
+    else { $opt{contentkey} = $default_content_key }
+
+    $opt{normalisespace} ||= $opt{normalizespace} || 0;
+
+    $opt{searchpath} ||= [];
+    ref $opt{searchpath} eq 'ARRAY'
+        or $opt{searchpath} = [ $opt{searchpath} ];
+
+    my $fa = delete $opt{forcearray} || 0;
+    my (@fa_regex, %fa_elem);
+    if(ref $fa)
+     {   foreach (ref $fa eq 'ARRAY' ? @$fa : $fa)
+         {   if(ref $_ eq 'Regexp') { push @fa_regex, $_ }
+             else { $fa_elem{$_} = 1 }
+         }
+    }
+    else { $opt{forcearray_always} = $fa }
+    $opt{forcearray_regex} = \@fa_regex;
+    $opt{forcearray_elem}  = \%fa_elem;
+
+    # Special cleanup for {keyattr} which could be arrayref or hashref,
+    # which behave differently.
+
+    my $ka = $opt{keyattr} || \@default_attributes;
+    $ka    = [ $ka ] unless ref $ka;
+ 
+    if(ref $ka eq 'ARRAY')
+    {   if(@$ka) { $opt{keyattr} = $ka }
+        else { delete $opt{keyattr} }
+    }
+    elsif(ref $ka eq 'HASH')
+    {   # Convert keyattr => { elem => '+attr' }
+        # to keyattr => { elem => [ 'attr', '+' ] } 
+        my %at;
+        while(my($k,$v) = each %$ka)
+        {   $v =~ /^(\+|-)?(.*)$/;
+            $at{$k} = [ $2, $1 || '' ];
+        }
+        $opt{keyattr} = \%at;
+    }
+
+    # Special cleanup for {valueattr} which could be arrayref or hashref
+
+    my $va = delete $opt{valueattr} || {};
+    $va = +{ map +($_ => 1), @$va } if ref $va eq 'ARRAY';
+    $opt{valueattrlist} = $va;
+
+    # make sure there's nothing weird in {grouptags}
+
+    !$opt{grouptags} || ref $opt{grouptags} eq 'HASH'
+         or croak "Illegal value for 'GroupTags' option -expected a hashref";
+
+    $opt{parseropts} ||= {};
+
+    \%opt;
+}
+
+sub find_xml_file($@)
+{   my ($self, $file) = (shift, shift);
+    my @search_path = @_ ? @_ : '.';
+
+    my ($filename, $filedir) = fileparse $file;
+
+    if($filename eq $file)
+    {   foreach my $path (@search_path)
+        {   my $fullpath = File::Spec->catfile($path, $file);
+            return $fullpath if -e $fullpath;
+        }
+    }
+    elsif(-e $file)        # Ignore searchpath if dir component
+    {   return $file;
+    }
+
+    local $" = ':';
+    die "data source $file not found in @search_path\n";
+}
+
+sub _add_kv($$$$)
+{   my ($d, $k, $v, $opts) = @_;
+
+    if(defined $d->{$k})
+    {   # Combine duplicate attributes into arrayref if required
+        if(ref $d->{$k} eq 'ARRAY')   { push @{$d->{$k}}, $v }
+        else                          { $d->{$k} = [ $d->{$k}, $v ] } }
+    elsif(ref $v eq 'ARRAY')          { push @{$d->{$k}}, $v }
+    elsif(ref $v eq 'HASH'
+       && $k ne $opts->{contentkey} 
+       && $opts->{forcearray_always}) { push @{$d->{$k}}, $v }
+    elsif($opts->{forcearray_elem}{$k}
+        || grep $k =~ $_, @{$opts->{forcearray_regex}}
+         )                            { push @{$d->{$k}}, $v }
+    else                              { $d->{$k} = $v }
+    $d->{$k};
+}
+
+# Takes the parse tree that XML::LibXML::Parser produced from the supplied
+# XML and recurse through it 'collapsing' unnecessary levels of indirection
+# (nested arrays etc) to produce a data structure that is easier to work with.
+
+sub _expand_name($)
+{   my $node = shift;
+    my $uri  = $node->namespaceURI || '';
+    (length $uri ? "{$uri}" : '') . $node->localName;
+}
+
+sub collapse($$)
+{   my ($self, $xml, $opts) = @_;
+    $xml->isa('XML::LibXML::Element') or return;
+
+    my (%data, $text);
+    my $hooks = $self->{XCS_hooks};
+
+    unless($opts->{noattr})
+    {
+      ATTR:
+        foreach my $attr ($xml->attributes)
+        {
+            my $value;
+            if($hooks && (my $hook = $hooks->{$attr->unique_key}))
+            {   $value = $hook->($attr);
+                defined $value or next ATTR;
+            }
+            else
+            {   $value = $attr->value;
+            }
+
+            $value = $self->normalise_space($value)
+                if !ref $value && $opts->{normalisespace}==2;
+
+            my $name
+              = !$attr->isa('XML::LibXML::Attr') ? $attr->nodeName
+              : $opts->{nsexpand} ? _expand_name($attr)
+              : $opts->{nsstrip}  ? $attr->localName
+              :                     $attr->nodeName;
+
+            _add_kv \%data, $name => $value, $opts;
+        }
+    }
+    my $nr_attrs = keys %data;
+    my $nr_elems = 0;
+
+  CHILD:
+    foreach my $child ($xml->childNodes)
+    {
+        if($child->isa('XML::LibXML::Text'))
+        {   $text .= $child->data;
+            next CHILD;
+        }
+
+        $child->isa('XML::LibXML::Element')
+            or next CHILD;
+
+        $nr_elems++;
+
+        my $v;
+        if($hooks && (my $hook = $hooks->{$child->unique_key}))
+             { $v = $hook->($child) }
+        else { $v = $self->collapse($child, $opts) }
+        defined $v or next CHILD;
+
+        my $name
+          = $opts->{nsexpand} ? _expand_name($child)
+          : $opts->{nsstrip}  ? $child->localName
+          :                     $child->nodeName;
+
+        _add_kv \%data, $name => $v, $opts;
+    }
+
+    $text = $self->normalise_space($text)
+        if defined $text && $opts->{normalisespace}==2;
+
+    return $opts->{forcecontent} ? { $opts->{contentkey} => $text } : $text
+        if $nr_attrs+$nr_elems==0 && defined $text;
+
+    $data{$opts->{contentkey}} = $text
+        if defined $text && $nr_elems==0;
+
+    # Roll up 'value' attributes (but only if no nested elements)
+
+    if(keys %data==1)
+    {   my ($k) = keys %data;
+        return $data{$k} if $opts->{valueattrlist}{$k};
+    }
+
+    # Turn arrayrefs into hashrefs if key fields present
+
+    if($opts->{keyattr})
+    {   while(my ($key, $val) = each %data)
+        {   $data{$key} = $self->array_to_hash($key, $val, $opts)
+                if ref $val eq 'ARRAY';
+        }
+    }
+
+    # disintermediate grouped tags
+
+    if(my $gr = $opts->{grouptags})
+    {
+      ELEMENT:
+        while(my ($key, $val) = each %data)
+        {   my $sub = $gr->{$key} or next;
+            if(ref $val eq 'ARRAY')
+            {   next ELEMENT
+                    if grep { keys %$_!=1 || !exists $_->{$sub} } @$val;
+                $data{$key} = { map { %{$_->{$sub}} } @$val };
+            }
+            else
+            {   ref $val eq 'HASH' && keys %$val==1 or next;
+                my ($child_key, $child_val) = %$val;
+                $data{$key} = $child_val
+                   if $gr->{$key} eq $child_key;
+            }
+        }
+    }
+
+    # Fold hashes containing a single anonymous array up into just the array
+    return $data{anon}
+        if keys %data == 1
+        && exists $data{anon}
+        && ref $data{anon} eq 'ARRAY';
+
+    # Roll up named elements with named nested 'value' attributes
+    if(my $va = $opts->{valueattrlist})
+    {   while(my($key, $val) = each %data)
+        {   $va->{$key} && ref $val eq 'HASH' && keys %$val==1 or next;
+            $data{$key} = $val->{$va->{$key}};
+        }
+    }
+
+      $nr_elems+$nr_attrs    ? \%data
+    : !defined $text         ? {}
+    : $opts->{forcecontent}  ? { $opts->{contentkey} => $text }
+    :                          $text;
+}
+
+sub normalise_space($)
+{   my $self = shift;
+    local $_ = shift;
+    s/^\s+//s;
+    s/\s+$//s;
+    s/\s\s+/ /sg;
+    $_;
+}
+
+# Attempts to 'fold' an array of hashes into an hash of hashes.  Returns a
+# reference to the hash on success or the original array if folding is
+# not possible.  Behaviour is controlled by 'keyattr' option.
+#
+
+sub array_to_hash($$$$)
+{   my ($self, $name, $in, $opts) = @_;
+    my %out;
+
+    my $ka = $opts->{keyattr} or return $in;
+
+    if(ref $ka eq 'HASH')
+    {   my $newkey = $ka->{$name} or return $in;
+        my ($key, $flag) = @$newkey;
+
+        foreach my $h (@$in)
+        {   unless(ref $h eq 'HASH' && defined $h->{$key})
+            {   warn "<$name> element has no '$key' key attribute\n" if $^W;
+                return $in;
+            }
+
+            my $val = $h->{$key};
+            if(ref $val)
+            {   warn "<$name> element has non-scalar '$key' key attribute\n" if $^W;
+                return $in;
+            }
+
+            $val = $self->normalise_space($val)
+                if $opts->{normalisespace}==1;
+
+            warn "<$name> element has non-unique value in '$key' "
+               . "key attribute: $val\n" if $^W && defined $out{$val};
+
+            $out{$val} = { %$h };
+            $out{$val}{"-$key"} = $out{$val}{$key} if $flag eq '-';
+            delete $out{$val}{$key} if $flag ne '+';
+        }
+    }
+
+    else  # Arrayref
+    {   my $default_keys = "@default_attributes" eq "@$ka";
+
+      ELEMENT:
+        foreach my $h (@$in)
+        {   ref $h eq 'HASH' or return $in;
+
+            foreach my $key (@$ka)
+            {   my $val = $h->{$key};
+                defined $val or next;
+
+                if(ref $val)
+                {   warn "<$name> element has non-scalar '$key' key attribute"
+                        if $^W && ! $default_keys;
+                    return $in;
+                }
+
+                $val = $self->normalise_space($val)
+                    if $opts->{normalisespace} == 1;
+
+                warn "<$name> element has non-unique value in '$key' "
+                   . "key attribute: $val" if $^W && $out{$val};
+
+                $out{$val} = { %$h };
+                delete $out{$val}{$key};
+                next ELEMENT;
+            }
+            return $in;    # No keyfield matched
+        }
+    }
+
+    $opts->{collapseagain}
+        or return \%out;
+
+    # avoid over-complicated structures like
+    # dir => { libexecdir    => { content => '$exec_prefix/libexec' },
+    #          localstatedir => { content => '$prefix' },
+    #        }
+    # into
+    # dir => { libexecdir    => '$exec_prefix/libexec',
+    #          localstatedir => '$prefix',
+    #        }
+
+    my $contentkey = $opts->{contentkey};
+
+    # first go through the values, checking that they are fit to collapse
+    foreach my $v (values %out)
+    {   next if !defined $v;
+        next if ref $v eq 'HASH' && keys %$v == 1 && exists $v->{$contentkey};
+        next if ref $v eq 'HASH' && !keys %$v;
+        return \%out;
+    }
+
+    $out{$_} = $out{$_}{$contentkey} for keys %out;
+    \%out;
+}
+  
+1;
+
+__END__
+

Perl OTRS/Kernel/cpan-lib/XML/Parser/Lite.pm

@@ -0,0 +1,382 @@
+# ======================================================================
+#
+# Copyright (C) 2000-2007 Paul Kulchenko (paulclinger@yahoo.com)
+# Copyright (C) 2008 Martin Kutter (martin.kutter@fen-net.de)
+# 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.721';
+
+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('<soap:foo xmlns:soap="foo">bar</soap:foo>'); 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__
+
+=head1 NAME
+
+XML::Parser::Lite - Lightweight pure-perl XML Parser (based on regexps)
+
+=head1 SYNOPSIS
+
+  use XML::Parser::Lite;
+
+  $p1 = new XML::Parser::Lite;
+  $p1->setHandlers(
+    Start => sub { shift; print "start: @_\n" },
+    Char => sub { shift; print "char: @_\n" },
+    End => sub { shift; print "end: @_\n" },
+  );
+  $p1->parse('<foo id="me">Hello World!</foo>');
+
+  $p2 = new XML::Parser::Lite
+    Handlers => {
+      Start => sub { shift; print "start: @_\n" },
+      Char => sub { shift; print "char: @_\n" },
+      End => sub { shift; print "end: @_\n" },
+    }
+  ;
+  $p2->parse('<foo id="me">Hello <bar>cruel</bar> World!</foo>');
+
+=head1 DESCRIPTION
+
+This module implements an XML parser with a interface similar to
+L<XML::Parser>. Though not all callbacks are supported, you should be able to
+use it in the same way you use XML::Parser. Due to using experimental regexp
+features it'll work only on Perl 5.6 and above and may behave differently on
+different platforms.
+
+Note that you cannot use regular expressions or split in callbacks. This is
+due to a limitation of perl's regular expression implementation (which is
+not re-entrant).
+
+=head1 SUBROUTINES/METHODS
+
+=head2 new
+
+Constructor.
+
+The new() method returns the object called on when called as object method.
+This behaviour was inherited from L<SOAP::Lite>,
+which XML::Parser::Lite was split out from.
+This means that the following effectively is
+a no-op if $obj is a object:
+
+ $obj = $obj->new();
+
+New accepts a single named parameter, C<Handlers> with a hash ref as value:
+
+ my $parser = XML::Parser::Lite->new(
+    Handlers => {
+        Start => sub { shift; print "start: @_\n" },
+        Char => sub { shift; print "char: @_\n" },
+        End => sub { shift; print "end: @_\n" },
+    }
+ );
+
+The handlers given will be passed to setHandlers.
+
+=head2 setHandlers
+
+Sets (or resets) the parsing handlers. Accepts a hash with the handler names
+and handler code references as parameters. Passing C<undef> instead of a
+code reference replaces the handler by a no-op.
+
+The following handlers can be set:
+
+ Init
+ Start
+ Char
+ End
+ Final
+
+All other handlers are ignored.
+
+Calling setHandlers without parameters resets all handlers to no-ops.
+
+=head2 parse
+
+Parses the XML given. In contrast to L<XML::Parser|XML::Parser>'s parse
+method, parse() only parses strings.
+
+=head1 Handler methods
+
+=head2 Init
+
+Called before parsing starts. You should perform any necessary initializations
+in Init.
+
+=head2 Start
+
+Called at the start of each XML node. See L<XML::Parser> for details.
+
+=head2 Char
+
+Called for each character sequence. May be called multiple times for the
+characters contained in an XML node (even for every single character).
+Your implementation has to make sure that it captures all characters.
+
+=head2 End
+
+Called at the end of each XML node. See L<XML::Parser> for details
+
+=head2 Comment
+
+See L<XML::Parser> for details
+
+=head2 XMLDecl
+
+See L<XML::Parser> for details
+
+=head2 Doctype
+
+See L<XML::Parser> for details
+
+=head2 Final
+
+Called at the end of the parsing process. You should perform any necessary
+cleanup here.
+
+=head1 SEE ALSO
+
+L<XML::Parser> - a full-blown XML Parser, on which XML::Parser::Lite is based.
+Requires a C compiler and the I<expat> XML parser.
+
+L<XML::Parser::LiteCopy> - a fork in L<XML::Parser::Lite::Tree>.
+
+L<YAX> - another pure-perl module for XML parsing.
+
+L<XML::Parser::REX> - another module that parses XML with regular expressions.
+
+=head1 COPYRIGHT
+
+Copyright (C) 2000-2007 Paul Kulchenko. All rights reserved.
+
+Copyright (C) 2008- Martin Kutter. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+This parser is based on "shallow parser"
+L<http://www.cs.sfu.ca/~cameron/REX.html>
+Copyright (c) 1998, Robert D. Cameron.
+
+=head1 AUTHOR
+
+Paul Kulchenko (paulclinger@yahoo.com)
+
+Martin Kutter (martin.kutter@fen-net.de)
+
+Additional handlers supplied by Adam Leggett.
+
+=cut
+
+
+
+