File Coverage

blib/lib/simpleXMLParse.pm

Criterion	Covered	Total	%
statement	12	216	5.5
branch	0	54	0.0
condition			n/a
subroutine	4	10	40.0
pod	0	4	0.0
total	16	284	5.6

package simpleXMLParse;

# Perl Module: simpleXMLParse
# Author: Daniel Edward Graham
# Copyright (c) Daniel Edward Graham 2008-2014
# Date: 3/25/2014
# License: LGPL 3.0
#

require Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter);

# This allows declaration	use simpleXMLParse ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
%EXPORT_TAGS = ( 'all' => [ qw(

) ] );

@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

@EXPORT = qw(

);

$VERSION = '2.6';

use Carp;
use strict;

use open ':encoding(utf8)';

my @cdata;
my $cdataInd = 0;
my $MAXIND = 10000;

sub new {
    my $class = shift;
    if ( @_ != 1 ) {
        croak "Invalid usage (new)\n";
    }
    my $inputfile = shift;
    my $altstyle = 0;
    my $fn;
    if ( ref($inputfile) eq "HASH" ) {
        $fn = $inputfile->{"input"};
        $altstyle = 1 if ($inputfile->{"style"} eq '2');
    }
    my $self = {};
    $self->{"xml"}  = undef;
    $self->{"data"} = undef;
    open( INFILE, "$fn" ) or croak "Unable to process [$fn]\n";
    $self->{"xml"} = join '', ;
    close(INFILE);
    $self->{"xml"} =~ s/\<\?[^\>]*?\?\>//g;
    $self->{"xml"} =~ s/\<\!\-\-[^\>]*?\-\-\>//g;
    $self->{"data"} = _ParseXML( $self->{"xml"} );
    my $ret = bless $self;
    if ($altstyle) {
        warn "alt style";
        $ret->_convertToStyle();
    }
    $cdataInd = $cdataInd % $MAXIND;
    return $ret;
}

sub parse {
    my $self = shift;
    return $self->{data};
}

sub _convertToStyle {
    my $self = shift;
    my @recursearr = ($self->{"data"});
    while (@recursearr) {
        my $i = pop @recursearr;
        if (ref($i) eq "HASH") {
            foreach my $j (keys %$i) {
                if ($j =~ /^(.*?)\_(.*?)\_([0-9]+)\_attr$/) {
                    my ($attrnm, $tagnm, $cnt) = ($1, $2, $3);
                    my $n = undef;
                    if (ref($i->{$tagnm}) eq "ARRAY") {
                        my $hold;
                        if (ref($i->{$tagnm}->[$cnt]) eq '') {
                            $hold = $i->{$tagnm}->[$cnt];
                            $i->{$tagnm}->[$cnt] = { };
                            if ($hold !~ /^\s*$/ ) {
                                $i->{$tagnm}->[$cnt]->{VALUE} = $hold;
                            }
                        }
                        while (defined($i->{$tagnm}->[$cnt]->{$attrnm.$n})) {
                            $n++;
                        }
                        $i->{$tagnm}->[$cnt]->{$attrnm.$n} = $i->{$j};
                     } else {
                         if (ref($i->{$tagnm}) eq "HASH") {
                             my $n = undef;
                             while (defined($i->{$tagnm}->{$attrnm.$n})) {
                                $n++;
                             }
                             $i->{$tagnm}->{$attrnm.$n} = $i->{$j};
                         } else {
                             my $hold;
                             $hold = $i->{$tagnm};
                             $i->{$tagnm} = { };
                             if ($hold !~ /^\s*$/) {
                                 $i->{$tagnm}->{VALUE} = $hold;
                             }
                             $i->{$tagnm}->{$attrnm} = $i->{$j};
                         }
                     }
                     delete $i->{$j};
               } else {
                   push @recursearr, $i->{$j};
               }
           }
        } else {
            if (ref($i) eq "ARRAY") {
                foreach my $j (@$i) {
                    push @recursearr, $j;
                }
            }
       }
   }
}

sub cdatasub {
    my $cdata = shift;
    my $tmpind = $cdataInd++;
    $cdata[$tmpind] = $cdata;
    return "0x0CDATA0x0".($tmpind)."0x0";
}

sub cdatasubout {
    my $ind = shift;
    my $cdata = $cdata[$ind];
    return $cdata;
}

sub _ParseXML {
    my ($xml) = @_;
    $xml =~ s/\n//g;
    $xml =~ s/\<\!\-\-.*?\-\-\>//g;
    $xml =~ s/\<\?xml.*?\?\>//g;
    $xml =~ s/\<\!\[CDATA\[(.*?)\]\]\>/&cdatasub($1)/eg;
    my $rethash = ();
    my @retarr;
    my $firsttag = $xml;
    my ( $attr, $innerxml, $xmlfragment );
    $firsttag =~ s/^[\s\n]*\<([^\s\>\n\/]*).*$/$1/g;
    $firsttag =~ s/\\/\\\\/g;
    $firsttag =~ s/\*/\\\*/g;
    $firsttag =~ s/\{/\\\{/g;
    $firsttag =~ s/\}/\\\}/g;
    $firsttag =~ s/\(/\\\(/g;
    $firsttag =~ s/\)/\\\)/g;
    $firsttag =~ s/\=/\\\=/g;
    $firsttag =~ s/\+/\\\+/g;
    $firsttag =~ s/\[/\\\[/g;
    $firsttag =~ s/\]/\\\]/g;
    $firsttag =~ s/\./\\\./g;
    $firsttag =~ s/\-/\\\-/g;

    if ( $xml =~ /^[\s\n]*\<${firsttag}(\>|\s[^\>]*[^\/]\>)(.*?)\<\/${firsttag}\>(.*)$/ )
    {
        $attr        = $1;
        $innerxml    = $2;
        $xmlfragment = $3;
        $attr =~ s/\>$//g;
    }
    else {
      if ( $xml =~ /^[\s\n]*\<${firsttag}(\/\>|\s[^\>]*\/\>)(.*)$/ ) {
        $attr = $1;
        $innerxml = "";
        $xmlfragment = $2;
      } else {
        if (!ref($xml)) {
            $xml =~ s/0x0CDATA0x0(\d+?)0x0/&cdatasubout($1)/eg;
        }
        return $xml;
      }
    }
    my $ixml = $innerxml;
    while ($ixml =~ /^.*?\<${firsttag}(\>|\s[^\>]*[^\/]\>)(.*?)$/) {
        $ixml = $2;
        print STDERR "***\n";
        $innerxml .= "";
        if ($xmlfragment =~ /^(.*?)\<\/${firsttag}\>(.*)$/) {
            my $ix = $1;
            $innerxml .= $ix;
            $ixml .= $ix;
            $xmlfragment = $2;
        } else {
            die "Invalid XML innerxml: $innerxml\nixml: $ixml\nxmlfragment: $xmlfragment\n";
        }
    }
    my $nextparse = _ParseXML($innerxml);
    $rethash->{"$firsttag"} = $nextparse;
    my @attrarr;
    while ( $attr =~ s/^[\s\n]*([^\s\=\n]+)\s*\=\s*(\".*?\"|\'.*?\')(.*)$/$3/g ) {
        my ($name, $val) = ($1, $2);
        $val =~ s/^\'(.*)\'$/$1/g;
        $val =~ s/^\"(.*)\"$/$1/g;
        push @attrarr, $name;
        push @attrarr, $val;
    }
    my $attrcnt = 0;
    while ( my $val = shift(@attrarr) ) {
        $rethash->{ "$val" . "_${firsttag}_" . $attrcnt . "_attr" } = shift(@attrarr);
    }
    my $retflag = 0;
    my ( $xmlfragment1, $xmlfragment2 );
    my %attrhash;
    $attrcnt++;
    while (1) {
        if ( $xmlfragment =~
            /^(.*?)\<${firsttag}(\>|\s[^\>]*[^\/]\>)(.*?)\<\/${firsttag}\>(.*)$/ )
        {
            if ( !$retflag ) {
                push @retarr, $nextparse;
            }
            $retflag      = 1;
            $xmlfragment1 = $1;
            $attr         = $2;
            $innerxml     = $3;
            $xmlfragment2 = $4;
        } else {
          if ( $xmlfragment =~ /^(.*?)\<${firsttag}(\/\>|\s[^\>]*\/\>)(.*)$/ ) {
            if ( !$retflag ) {
                push @retarr, $nextparse;
            }
            $retflag      = 1;
            $xmlfragment1 = $1;
            $attr = $2;
            $innerxml = "";
            $xmlfragment2 = $3;
          } else {
            last;
          }
        }
        $attr =~ s/\>$//g;
        my %opening = ( );
        my %closing = ( );
        my $frag = $xmlfragment1;
        while ($frag =~ /^(.*?)\<([^\s\n\/]+)[^\/]*?\>(.*)$/) {
            my $tg = $2;
            $frag = $3;
            $opening{$tg}++;
        }
        my $frag = $xmlfragment1;
        while ($frag =~ /^(.*?)\<\/([^\s\n]+)\>(.*)$/) {
            my $tg = $2;
            $frag = $3;
            $closing{$tg}++;
        }
        my $flag = 0;
        foreach my $k (keys %opening) {
            if ($opening{$k} > $closing{$k}) {
                $xmlfragment = $xmlfragment1 . "<${firsttag}0x0 ${attr}>${innerxml}". $xmlfragment2;
                $flag = 1;
                last;
            }
        }
        next if ($flag);
#        $xmlfragment  = $xmlfragment1 . $xmlfragment2;
        my $ixml = $innerxml;
        while ($ixml =~ /.*?\<${firsttag}(\>|\s[^\>]*[^\/]\>)(.*?)$/) {
            $ixml = $2;
            $innerxml .= "";
            if ($xmlfragment2 =~ /(.*?)\<\/${firsttag}\>(.*)$/) {
                my $ix = $1;
                $innerxml .= $ix;
                $ixml .= $ix;
                $xmlfragment2 = $2;
            } else {
                die "Invalid XML";
            }
        }
        $xmlfragment  = $xmlfragment1 . $xmlfragment2;
        while ( $attr =~ s/^[\s\n]*([^\s\=\n]+)\s*\=\s*(\".*?\"|\'.*?\')(.*)$/$3/g ) {
            my ($name, $val) = ($1, $2);
            $val =~ s/^\'(.*)\'$/$1/g;
            $val =~ s/^\"(.*)\"$/$1/g;
            push @attrarr, $name;
            push @attrarr, $val;
        }
        while ( my $val = shift(@attrarr) ) {
#            if (defined($rethash->{"$val" . "_$firsttag" . "_attr" })) {
#                $rethash->{ "$val" . "_${firsttag}_" . ++$attrhash{"$val" . "_$firsttag" . "_attr"} . "_attr" } = shift(@attrarr);
                $rethash->{ "$val" . "_${firsttag}_" . $attrcnt . "_attr" } = shift(@attrarr);
#            } else {
#                $rethash->{ "$val" . "_$firsttag" . "_attr" } = shift(@attrarr);
#            }
        }
        $attrcnt++;
        $nextparse    = _ParseXML($innerxml);
        push @retarr, $nextparse;
    }
    if (@retarr) {
        $rethash->{"$firsttag"} = \@retarr;
    }
    $xmlfragment =~ s/${firsttag}0x0/${firsttag}/g;
    my $remainderparse = _ParseXML($xmlfragment);
    my $attrcnt;
    my $attrfrag;
    if ( ref($remainderparse) eq "HASH" ) {
        foreach ( keys %{$remainderparse} ) {
            $rethash->{"$_"} = $remainderparse->{"$_"};
        }
    }
    if ( keys %{$rethash} ) {
        return $rethash;
    }
    else {
        return undef;
    }
}

1;
__END__