File Coverage

lib/YAX/Parser.pm

Criterion	Covered	Total	%
statement	97	153	63.4
branch	22	52	42.3
condition	0	18	0.0
subroutine	16	22	72.7
pod	5	10	50.0
total	140	255	54.9

package YAX::Parser;

use strict;

use YAX::Node;
use YAX::Text;
use YAX::Element;
use YAX::Fragment;
use YAX::Document;
use YAX::Constants qw/:all/;

#========================================================================
# These regular expressions have been gratefully borrowed from:
#
# REX/Perl 1.0
# 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.

our $TextSE = "[^<]+";
our $UntilHyphen = "[^-]*-";
our $Until2Hyphens = "$UntilHyphen(?:[^-]$UntilHyphen)*-";
our $CommentCE = "$Until2Hyphens>?";
our $UntilRSBs = "[^\\]]*](?:[^\\]]+])*]+";
our $CDATA_CE = "$UntilRSBs(?:[^\\]>]$UntilRSBs)*>";
our $S = "[ \\n\\t\\r]+";
our $NameStrt = "[A-Za-z_:]|[^\\x00-\\x7F]";
our $NameChar = "[A-Za-z0-9_:.-]|[^\\x00-\\x7F]";
our $Name = "(?:$NameStrt)(?:$NameChar)*";
our $QuoteSE = "\"[^\"]*\"|'[^']*'";
our $DT_IdentSE = "$S$Name(?:$S(?:$Name|$QuoteSE))*";
our $MarkupDeclCE = "(?:[^\\]\"'><]+|$QuoteSE)*>";
our $S1 = "[\\n\\r\\t ]";
our $UntilQMs = "[^?]*\\?+";
our $PI_Tail = "\\?>|$S1$UntilQMs(?:[^>?]$UntilQMs)*>";
our $DT_ItemSE = "<(?:!(?:--$Until2Hyphens>|[^-]$MarkupDeclCE)|\\?$Name(?:$PI_Tail))|%$Name;|$S";
our $DocTypeCE = "$DT_IdentSE(?:$S)?(?:\\[(?:$DT_ItemSE)*](?:$S)?)?>?";
our $DeclCE = "--(?:$CommentCE)?|\\[CDATA\\[(?:$CDATA_CE)?|DOCTYPE(?:$DocTypeCE)?";
our $PI_CE = "$Name(?:$PI_Tail)?";
our $EndTagCE = "$Name(?:$S)?>?";
our $AttValSE = "\"[^<\"]*\"|'[^<']*'";
our $ElemTagCE = "$Name(?:$S$Name(?:$S)?=(?:$S)?(?:$AttValSE))*(?:$S)?/?>?";
our $ElementCE = "/(?:$EndTagCE)?|(?:$ElemTagCE)?";
our $MarkupSPE = "<(?:!(?:$DeclCE)?|\\?(?:$PI_CE)?|(?:$ElementCE)?)";
our $XML_SPE = "$TextSE|$MarkupSPE";

#========================================================================

# these have captures for parsing attributes
our $AttValSE2 = "\"([^<\"]*)\"|'([^<']*)'";
our $ElemTagCE2 = "(?:($Name)(?:$S)?=(?:$S)?(?:$AttValSE2))+(?:$S)?/?>?";

sub new {
    my ( $class ) = @_;
    my $self = bless { }, $class;
    return $self;
}

sub parse {
    my ( $self, $xstr ) = ( shift, shift );
    return unless $xstr;
    my @nodes = $self->tokenize( $xstr );

    my $xdoc  = YAX::Document->new();
    my @stack = ( $xdoc );
    my ( $spec, $elmt );
    foreach my $node ( $self->tokenize( $xstr ) ) {
        $spec = substr( $node, 0, 2 );
        if ( index( $spec, '<' ) != 0 ) {
            $self->_mk_text( $node, $stack[-1] );
            next;
        }
        if ( $spec eq '
            pop @stack;
            next;
        }
        if ( $spec eq '
            $self->_mk_decl( $node, $stack[-1] );
            next;
        }
        if ( $spec eq '
            $self->_mk_proc( $node, $stack[-1] );
            next;
        }

        $elmt = $self->_mk_elmt( $node, $stack[-1] );
        push( @stack, $elmt ) unless ( $node =~ m{/>$} );
        $xdoc->set( $elmt->{id} => $elmt ) if $elmt->{id}
    }

    return $xdoc;
}

sub stream {
    my ( $self, $xstr, $state ) = ( shift, shift, shift );
    my %subs;
    if ( @_ == 1 and ref $_[0] eq 'HASH' ) {
        %subs = %{$_[0]};
    } else {
        %subs = @_;
    }

    my $text = delete $subs{text} || $subs{pass};
    my $decl = delete $subs{decl} || $subs{pass};
    my $proc = delete $subs{proc} || $subs{pass};
    my $elmt = delete $subs{elmt} || $subs{pass};
    my $elcl = delete $subs{elcl} || $subs{pass};

    my ( $spec, $name, $copy, $atts, %atts );
    foreach my $node ( $self->tokenize( $xstr ) ) {
        $spec = substr( $node, 0, 2 );
        if ( index( $spec, '<' ) != 0 ) {
            $text && $text->( $state, $node );
            next;
        }
        if ( $spec eq '
            $elcl && $elcl->( $state, substr( $node, 2, -1 ) );
            next;
        }
        if ( $spec eq '
            $decl && $decl->( $state, $node );
            next;
        }
        if ( $spec eq '
            $proc && $proc->( $state, $node );
            next;
        }

        $elmt && do {
            $copy = substr( $node, 1, -1 );
            ( $name, $atts ) = split( /\s+/, $copy, 2 );
            $name =~ s{/$}{};
            %atts = $atts ? $self->parse_attributes( $atts ) : ( );
            $elmt->( $state, $name, %atts );
        };

        if ( substr( $node, -2 ) eq '/>' ) {
            $elcl && $elcl->( $state, $name );
        }
    }
}

sub read_file {
    my ( $self, $file ) = @_;
    my $xstr;
    {
        open FH, $file or return;
        local $/ = undef;
        $xstr = ;
        close FH;
    }
    return $xstr;
}

sub parse_file {
    my ( $self, $file ) = @_;
    return $self->parse( $self->read_file( $file ) );
}

sub stream_file {
    my ( $self, $file, $state, %subs ) = @_;
    return $self->stream( $self->read_file( $file ), $state, %subs );
}

sub parse_as_fragment {
    my ( $self, $xstr ) = @_;
    my $xdoc = $self->parse( ''.$xstr.'' );
    my $root = $xdoc->root;
    my $frag = YAX::Fragment->new;
    $frag->append( $root->[0] ) while @$root;
    return $frag;
}

sub parse_file_as_fragment {
    my ( $self, $file ) = @_;
    my $xstr = $self->read_file( $file );
    my $frag = $self->parse_as_fragment( $xstr );
    return $frag;
}

sub tokenize {
    my ( $self, $xstr ) = @_;
    return $xstr =~ /$XML_SPE/g;
}

sub _mk_decl {
    my ( $self, $decl, $parent ) = @_;
    my ( $type, $name );
    my $offset = 1;
    my $length = length( $decl );

    substr( $decl, 0, 4 ) eq '