File Coverage

blib/lib/XML/YYLex.pm

Criterion	Covered	Total	%
statement	9	80	11.2
branch	0	44	0.0
condition	0	15	0.0
subroutine	3	11	27.2
pod	5	5	100.0
total	17	155	10.9

#!/usr/local/bin/perl -w
##
##  XML/YYLex.pm
##
##  Daniel Bößwetter, Thu Nov 14 21:06:34 CET 2002
##  [e-mail]
##
##  $Log: YYLex.pm,v $
##  Revision 1.4  2003/01/11 00:50:18  daniel
##  Oops, forgor versions numbers for CPAN compatibility and added homepage url
##  in several places (all PODs and README)
##
##  Revision 1.3  2003/01/10 22:30:50  daniel
##  version 0.3 (perl 5.6 and sablot 0.90)
##
##  Revision 1.2  2002/11/24 17:33:06  daniel
##  KNOWN BUGS added
##
##  Revision 1.1.1.1  2002/11/24 17:18:15  daniel
##  initial checkin
##
##

package XML::YYLex;
our $VERSION = '0.04';
use strict qw(subs vars);
use vars qw(
	$STATE_NEW_NODE
	$STATE_DESCEND_NODE
	$STATE_NODE_DONE
	$PREFIX_OPENING
	$PREFIX_CLOSING
	$TOKEN_OTHER_TAG
	$TOKEN_TEXT
);

use Carp;

$STATE_NEW_NODE		= 0;
$STATE_DESCEND_NODE	= 1;
$STATE_NODE_DONE	= 2;

$PREFIX_CLOSING		= "_";
$PREFIX_OPENING		= "";
$TOKEN_OTHER_TAG	= "OTHER";
$TOKEN_TEXT		= "TEXT";

=pod

=head1 NAME

XML::YYLex - Perl module for using perl-byacc with XML-data

=head1 SYNOPSIS

  use XML::YYLex;

  ## create an object of a sublass of XML::YYLex suitable for your
  ## DOM-parser:

  my $parser = XML::YYLex::create_object(
	document => $xmldom_or_sablotron_dom_object
	debug => 0,              # or 1
	ignore_empty_text => 1,  # probably what you would expect
	yydebug => \&some_func,  # defaults to a croak
	yyerror => \&other_func  # defaults to a carp
  );

  ## return the result of yyparse
  my $result = $parser->run( "ByaccPackage" );

=head1 ABSTRACT

C is a perl module that helps you build XML-parsers with
perl-byacc (a version of Berkeley Yacc that can produce perl-code).
It uses a regular DOM-parser (currently C or C)
as what would normally be called a scanner (hence the name 'yylex' which
is what scanner-functions are traditionally called). You can then specify
grammars in byacc in which XML-tags or text-blocks appear as tokens and
thus simplifies interpretation of XML-data (sometimes :).

=head1 DESCRIPTION

XML::YYLex implements an abstract base-class that can be subclassed for
specific DOM-parsers. As of this writing, C and C
are supported, but others might be easily added. If you want to add
support for another DOM-parser, copy one of the modules C
or C to an appropriate name and modify it
to work with your DOM-parser.

C contains two public functions:

=over 4

=item C

serves as a static factory method that creates an instance of the approptiate
subclass. The possible keye for %args are

=over 4

=item C

a reference to your DOM-document (whichever class that may be). This
is used for determining which parser-specific subclass to create. This
argument must be given. If you pass a single scalar to C
instead of a hash, it is assumed to be the C.

=item C

when set to a true value, produces lots of debug information, as well
from the yacc-parser as from C itself. Defaults to false.

=item C and C

code-refs with the same purpose as in byacc itself: called with a single
argument which is a warning or an error. Defaults are the functions
C and C (see below).

=item C

when set to a true value, emtpy text-nodes are not considered to be tokens
(which reduces your grammars complexity a lot). True by default.

=back

=cut

sub create_object {

    my %args;
    if ( $#_ == 0 ) {
	$args{document} = shift;
    } else {
	%args = @_;
    }

    if ( !$args{debug} ) {
        # omit those ugly warnings
        $SIG{__WARN__} = sub{ warn @_ if $_[0] !~ /^yy/ };
    }

    die "no DOM-document given" if ref !$args{document};

    if ( ref( $args{document} ) =~ /^XML::Sablotron/ ) {
	eval "use XML::Sablotron::DOM::YYLex;";
	return new XML::Sablotron::DOM::YYLex( \%args );
    } else {
	eval "use XML::DOM::YYLex;";
	return new XML::DOM::YYLex( \%args );
    }
}

=pod

=item C

which calls the byacc-generated C() function with the appropriate
parameters and returns it's value. C<$namespace_of_parser> is (you
won't believe it) the namespace of the parser generated by perl-byacc
(actually the same string that you specified with C<-P> on the byacc
command line).

=back

=cut

sub run {
    my ( $self, $class ) = @_;

    eval "use $class";
    die( $@ ) if $@;
    $self->{parser_package} = $class;
    my $ref = &{$class."::new"}( $class, \&_yylex, $self->{yyerror}, $self->{yydebug} );

    return $ref->yyparse( [ $self, $self->{document} ] );
}

=pod

Furthermore the following functions are implemented in this package,
but you will most likely never call them directly. However, knowledge
of these might be necassary when subclassing C.

=over 4

=item C<_yylex( $self, $doc )>

This function implements the traversal of the DOM-tree in an order that
would be the order of nodes in the XML-file (why don't we use a SAX-parser
right-away? Because SAX-parsers don't implement nice objects for
Nodes of the tree and their attributes like DOM-parsers do, that's why).
This one's where the magic happens.

=cut

sub _yylex {
	my $ref = shift;
	my ( $self, $doc ) = @$ref;

	print STDERR "entering _yylex with state $self->{state}\n"
		if $self->{debug};

	##
	## initialization
	##
	if ( !defined( $self->{current_node} ) ) {
	    $self->{current_node} = $self->_xml_getDocumentElement( $doc );
	    $self->{state} = $STATE_NEW_NODE;
	}

	my @res;
	##
	## new node
	##
	if ( $self->{state} == $STATE_NEW_NODE ) {

	    $self->{state} = !$self->_xml_isTextNode( $self->{current_node} )
		? $STATE_DESCEND_NODE : $STATE_NODE_DONE;

	    @res = ( $self->_node_to_token( $self->{current_node},
		    $PREFIX_OPENING ), $self->{current_node} );

	##
	## node's children
	##
	} elsif ( $self->{state} == $STATE_DESCEND_NODE ) {

	    ## has children ?
	    if ( my @c = @{$self->{current_node}->getChildNodes} ) {

		## yes

		#$self->{state} = $STATE_DESCEND_NODE;
		$self->{current_node} = $c[0];
	        $self->{state} = !$self->_xml_isTextNode( $self->{current_node} )
		    ? $STATE_DESCEND_NODE : $STATE_NODE_DONE;

		#while ( $self->_xml_isElementNode( $c[0] ) ) { shift @c }
		@res = ( $self->_node_to_token( $c[0], $PREFIX_OPENING ), $c[0] );

	    } else {

		## no children

		$self->{state} = $STATE_NODE_DONE;
		@res =( $self->_node_to_token( $self->{current_node}, $PREFIX_CLOSING ) );
	    }
	##
	## node done
	##
	} elsif ( $self->{state} == $STATE_NODE_DONE ) {

	    if ( defined( my $c = $self->{current_node}->getNextSibling ) ) {
		## same as STATE_NEW_NODE above:
		$self->{current_node} = $c;
	        $self->{state} = $STATE_DESCEND_NODE;
	        @res = ( $self->_node_to_token( $self->{current_node}, $PREFIX_OPENING ),
		    $self->{current_node} );
	    } elsif ( !$self->_xml_isDocumentNode( $self->{current_node}->getParentNode ) )
	    {
		$self->{current_node} = $self->{current_node}->getParentNode;
		$self->{state} = $STATE_NODE_DONE;
		@res =( $self->_node_to_token( $self->{current_node}, $PREFIX_CLOSING ) );
	    } else {
		## end of document
		@res = ( 0 );
	    }
	}

	#print STDERR "res=".$res[0]." ".( defined( $res[1] ) ? $res[1]->getNodeName : "" )."\n";
	print STDERR "leaving _yylex with state $self->{state}\n"
		if $self->{debug};

	if ( $self->{ignore_empty_text} and defined( $res[1] )
		and $self->_xml_isTextNode( $res[1] )
		and $res[1]->getNodeValue =~ /^\s*$/ )
	{
	    ## ignore empty text-nodes
	    $self->{state} = $STATE_NODE_DONE;
	    return &_yylex( [ $self, $doc ] ); ## recursion
	} else {
	    print "res=".join( ", ", @res )."\n" if ( $self->{debug} );
	    return @res;
	}
}

=pod

=item C<_node_to_token( $self, $node, $prefix )>

This function determines the token-number for a given node. C<$prefix>
equals C<$XML::YYLex::PREFIX_OPENING> (usually empty) for opening
tags and C<$XML::YYLex::PREFIX_CLOSING> (the underscore "_" by
default). The default behaviour is to look for a symbol with the name
of the node (for elements) in the namespace of your byacc-generated
parser. C<$XML::YYLex::TOKEN_TEXT> is used for text-nodes and
C<$XML::YYLex::TOKEN_OTHER> (I by default) is used for unknwon
tags (when no token with that name exists). For closing elements, the
prefix is prepended to the tagname (i.e. C<_html> for C<>).

=cut

sub _node_to_token {
    my $self = shift;
    my $node = shift;
    my $prefix = shift;

    #print STDERR "_node_to_token: ".$node->getNodeName." ".$prefix."\n";
    my $res;
    if ( $self->_xml_isTextNode( $node ) ) {
	#print STDERR ">>>>>Täxt ".$node->getNodeValue."\n";
	$res = ${$self->{parser_package}."::".$TOKEN_TEXT};
    } elsif ( !defined( $res =
	${$self->{parser_package}."::".$prefix.$node->getNodeName} ) )
    {
	$res = ${$self->{parser_package}."::".$prefix.$TOKEN_OTHER_TAG};
    }

    print STDERR "_node_to_token: res=$res\n" if ( $self->{debug} );
    return $res;
}

=pod

=item C and C

These are the default debug- and error-handlers respectively if no
other functions are given to create_object. C croaks and
C carps it's arguments.

=cut

sub yyerror {
    croak( "yyerror: @_" );
}

sub yydebug {
    carp( "yyerror: @_" );
}

=pod

=item C

Don't call it. It serves as constructor for child-classes and must be
given an almost initialized object (an C<$unblessed_hashref>). See the code
for details.

=cut

sub new {
    #print "new: ".join( ",", @_ )."\n";
    my ( $class, $args_ref ) = @_;
    #print $args_ref."\n";
    my $self = bless $args_ref, $class;
    $self->{yyerror} = $self->{yyerror} || \&yyerror;
    $self->{yydebug} = $self->{yydebug} || \&yydebug;
    $self->{ignore_empty_text} = $self->{ignore_empty_text} || 1;
    return $self;
}

1;
__END__