package XML::TrivialParser; ###### Trivial XML Parser
###	$Id: TrivialParser.pm,v 1.3 2002/05/24 19:02:03 steve Exp $
###
###	This is really an _SGML_ _scanner_ capable of handling both XML and
###	HTML; it is specifically designed to handle constructs, like unquoted
###	attributes and attributes without values, that are legal in HTML but
###	not in XML.
###
###	It may fail horribly on ill-formed XML, and doesn't properly handle
###	entities or DTD's with internal sections yet.  By default it produces
###	a parse tree comprised of XML::Node objects, but can be subclassed
###	for other (e.g. SAX-like) behavior.  Unlike most other Perl XML
###	parsers, this one does not rely on expat, and so can be installed 
###	without having write access to Perl's library directory.
###

### Portions copied from HTML::Parser by Gisle Aas <aas@sn.no>
### Modified to fit into the pPIA code hierarchy by 
###	Stephen Savitzky <steve@crc.ricoh.com>, later <steve@rii.ricoh.com>
###     and from there to various internal projects.

# === note that we could make this a subclass of Node (or Nodelist, if there
# === was such a thing).  Then the "stack" would just be the content.  There
# === would have to be some renaming:  push -> startElement, add -> push
# === new method endElement to incorporate most of the code of end_tag.

# === note that this would allow a flow-through interface to a processor,
# === especially if we tested start tags to see if they had handlers and
# === passed them through if they didn't.

use strict;

use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/);


sub new {
    my ($class) = @_;

    my $self = bless { '_buf' => '', '_stack' => [], '_depth' => 0 }, $class;
    $self;
}


### Original notes by Gisle Aas <aas@sn.no>
# How does Netscape do it: It parse <xmp> in the depreceated 'literal'
# mode, i.e. no tags are recognized until a </xmp> is found.
# 
# <listing> is parsed like <pre>, i.e. tags are recognized.  <listing>
# are presentend in smaller font than <pre>
#
# Netscape does not parse this comment correctly (it terminates the comment
# too early):
#
#    <! -- comment -- --> more comment -->
#
# Netscape does not allow space after the initial "<" in the start tag.
# Like this "<a href='gisle'>"
#
# Netscape ignore '<!--' and '-->' within the <SCRIPT> tag.  This is used
# as a trick to make non-script-aware browsers ignore the scripts.


#############################################################################
###
### Parser:
###

##* parse ($text)
#	Append $text to the buffer (which contains whatever couldn't 
#	be parsed from the previous chunk) and scan off as many tokens
#	as possible.  An appropriate token handler method (see below) is 
#	called for each token.
#
#	There's nothing here that keeps start tags and end tags in balance;
#	that's up to the token handlers.  Hence, this parser will work equally
#	well with HTML or even some flavors of SGML.  Note, too, that no 
#	validation is done and that attribute values may be blank-terminated
#	(as permitted in HTML) instead of quoted.
#
sub parse {
    my $self = shift;

    my $buf = \ $self->{'_buf'};
    unless (defined $_[0]) {
	# signals EOF (assume rest is plain text)
	$self->text($$buf) if length $$buf;
	$$buf = '';
	return $self;
    }
    $$buf .= $_[0];

    # Parse html text in $$buf.  The strategy is to remove complete
    # tokens from the beginning of $$buf until we can't deside whether
    # it is a token or not, or the $$buf is empty.
    while (1) {  # the loop will end by returning when text is parsed
	# First we try to pull off any plain text (anything before a "<" char)
	if ($$buf =~ s|^([^<]+)||) {
	    unless (length $$buf) {
		my $text = $1;
		# At the end of the buffer, we should not parse white space
		# but leave it for parsing on the next round.
		if ($text =~ s|(\s+)$||) {
		    $$buf = $1;
                # Same treatment for chopped up entites.
		} elsif ($text =~ s/(&(?:(?:\#\d*)?|[-.\w]*))$//) {
		    $$buf = $1;
		};
		$self -> text($text);
		return $self;
	    } else {
		$self -> text($1);
	    }
        # Look for 'CDATA sections' <![CDATA[ ... ]]> (steve)
	} elsif ($$buf =~ s|^(<!\[CDATA\[)||) {
	    my $eaten = $1;
	    my $text = '';
	    while ($$buf =~ s|^(([^\]]*)\])||) {
		$eaten .= $1;
		$text .= $2;
		if ($$buf =~ s|^(\]>)||s) { 
		    $eaten .= $1;
		    $self->cdata($text);
		} else {
		    $text .= ']';
		}
	    }
	    $$buf = $eaten . $$buf;  # must start with it all next time
	    return $self;
	# Then, markup declarations (usually either <!DOCTYPE...> or a comment)
	# === this is badly broken for XML. ===
	} elsif ($$buf =~ s|^(<!)||) {
	    my $eaten = $1;
	    my $text = '';
	    # Eat text and beginning of comment
	    while ($$buf =~ s|^(([^>]*?)--)||) {
		$eaten .= $1;
		$text .= $2;
		# Look for end of comment
		if ($$buf =~ s|^((.*?)--)||s) {
		    $eaten .= $1;
		    $self->comment($2);
		} else {
		    # Need more data to get all comment text.  This might
		    # result in the comment callback being called more than
		    # once for the several comment data.
		    $$buf = $eaten . $$buf;
		    return $self;
		}
	    }
	    # Can we finish the tag
	    if ($$buf =~ s|^([^>]*)>||) {
		$text .= $1;
		$self->declaration($text) if $text =~ /\S/;
		if ($$buf =~ s|^((.*?)\]\])||s) {
		    $eaten .= $1;
		    $self->comment($2);
		}
	    } else {
		$$buf = $eaten . $$buf;  # must start with it all next time
		return $self;
	    }
        # Look for 'processing instructions' <? ...?> (steve)
	} elsif ($$buf =~ s|(<\?)||) {
	    my $eaten = $1;
	    if ($$buf =~ s|^([^>]*)>||) {
		my $text = $1;
		$text =~ s|\?$||; # Remove the trailing ? if any.
		$self->pi($text);
	    } else {
		$$buf = $eaten . $$buf;  # must start with it all next time
		return $self;
	    }
	# Then, look for a end tag
	} elsif ($$buf =~ s|^</||) {
	    # end tag
	    if ($$buf =~ s|^\s*([a-z][a-z0-9\:\_\.\-]*)\s*>||i) {
		$self->end_tag(lc($1));
	    } elsif ($$buf =~ s|^\s*>||i) {
		$self->end_tag('', 1);	# Empty end tag
	    } elsif ($$buf =~ m|^\s*[a-z]*[a-z0-9\:\_\.\-]*\s*$|i) {
		$$buf = "</" . $$buf;  # need more data to be sure
		return $self;
	    } else {
		# it is plain text after all
		$self -> text($$buf);
		$$buf = "";
	    }
	# Then, finally we look for a start tag
	} elsif ($$buf =~ s|^<||) {
	    # start tag
	    my $eaten = '<';

	    # This first thing we must find is a tag name.  RFC1866 says:
	    #   A name consists of a letter followed by letters,
	    #   digits, periods, or hyphens. The length of a name is
	    #   limited to 72 characters by the `NAMELEN' parameter in
	    #   the SGML declaration for HTML, 9.5, "SGML Declaration
	    #   for HTML".  In a start-tag, the element name must
	    #   immediately follow the tag open delimiter `<'.
	    if ($$buf =~ s|^(([a-zA-Z][a-zA-Z0-9\:\_\.\-]*)\s*)||) {
		$eaten .= $1;
		my $tag = $2;
		my @attr;

		# Then we would like to find some attributes
		while ($$buf =~ s|^(([a-zA-Z][a-zA-Z0-9\:\_\.\-]*)\s*)||) {
		    $eaten .= $1;
		    my $attr = $2;
		    my $val;
		    # The attribute might take an optional value (first we
		    # check for an unquoted value)
		    if ($$buf =~ s|(^=\s*([^\"\'>\s][^>\s]*)\s*)||) { #"
			$eaten .= $1;
			$val = $2;
		    # or quoted by " "or ' '
		    } elsif ($$buf =~ s|(^=\s*([\"\'])(.*?)\2\s*)||s) { #"
			$eaten .= $1;
			$val = $3;
                    # truncated just after the '=' or inside the attribute
		    } elsif ($$buf =~ m|^(=\s*)$| or
			     $$buf =~ m|^(=\s*[\"\'].*)|s) { #"
			$$buf = "$eaten$1";
			return $self;
		    } else {
			# assume attribute with implicit value
			$val = $attr;
		    }
		    push(@attr, $attr, $val);
		    #$attr{$attr}=$val
		}
		
		# At the end there should be a closing ">"
		# XML: optional closing /> treated as empty end tag
		#      could be treated as attr with a funny name and an
		#      implicit value, but that would be cheating.
		#
		if ($$buf =~ s|^>||) {
		    $self->start_tag($tag, \@attr);
		} elsif ($$buf =~ s|^\/>||) {
		    push(@attr, '_empty'=>'/');
		    $self->start_tag($tag, \@attr);
		} elsif (length $$buf) {
		    # Not a conforming start tag, regard it as normal text
		    $self -> text($eaten);
		} else {
		    $$buf = $eaten;  # need more data to know
		    return $self;
		}
	    } elsif (length $$buf) {
		$self -> text($eaten);
	    } else {
		$$buf = $eaten . $$buf;  # need more data to parse
		return $self;
	    }

	} elsif (length $$buf) {
	    die; # This should never happen
	} else {
	    # The buffer is empty now
	    return $self;
	}
    }
    $self;
}

### parseFile($file)
#	Completely parse a file.
#
sub parseFile
{
    my($self, $file) = @_;
    no strict 'refs';  # so that a symbol ref as $file works
    local(*F);
    unless (ref($file) || $file =~ /^\*[\w:]+$/) {
	# Assume $file is a filename
	open(F, $file) || die "Can't open $file: $!";
	$file = \*F;
    }
    my $chunk = '';
    while(read($file, $chunk, 2048)) {
	$self->parse($chunk);
    }
    close($file);
    $self->parse(undef); #EOF
}

### XML::TrivialParser->readElementFromFile($file)
#	This is a class method.  Just feed it a filename and it returns
#	an XML element.  If all goes well, it should be *the* element.
sub readElementFromFile {
    my ($class, $file) = (@_);
    my $parser = XML::TrivialParser->new;
    $parser->filter(1);
    $parser->parseFile($file);
    return $parser->top;
}

### XML::TrivialParser->readNodesFromFile($file)
#	This is a class method.  Just feed it a filename and it returns
#	an array of XML nodes.
sub readNodesFromFile {
    my ($class, $file) = (@_);
    my $parser = XML::TrivialParser->new;
    $parser->filter(0);
    $parser->parseFile($file);
    return $parser->stack;
}


#############################################################################
###
### Tree building:
###
###	These are called by the token handlers to maintain a parse stack.
###	There's nothing in the "parse" function that matches start tags
###	and end tags.

### filter($v)
#	Access function for the _filter instance variable.
#	if set and non-null, declarations and PI's are filtered out.
sub filter {
    my ($self, $v) = (@_);
    
    return $self->{'_filter'} unless defined($v);
    $self->{'_filter'} = $v;
}

sub stack {
    my $self = shift;
    return $self->{'_stack'};    
}

### $p->depth
#	Element nesting depth.  Note that this is different from the 
#	size of the stack array!  It is incremented only when adding a
#	start tag.  The stack then ends up as the output nodelist.
sub depth {
    my $self = shift;
    return $self->{'_depth'};    
}

sub push {
    my $self = shift;
    my $stack = $self->{'_stack'};  
    for (@_) {
	push(@$stack, $_);
    }
}

sub pop {
    my $self = shift;
    my $stack = $self->{'_stack'};  
    return pop(@$stack);
}

sub top {
    my $self = shift;
    my $stack = $self->{'_stack'};  
    return (@$stack)? $stack->[@$stack -1] : undef;
}

sub add {
    my ($self, $node) = (@_);
    if ($self->depth == 0) { $self->push($node); return; }
    my $top = $self->top();
    if (ref($top) && $top->is_element && !($top->marked_empty)) {
	$top->push($node);
    } else {
	$self->push($node);
    }
}


#############################################################################
###
### Token Handling:
###
###	These routines are the ones that XML::Parser calls on itself
###	when it recognizes an input token:
###
###		declaration($text)
###		comment($text)
###		pi($text)
###		start_tag($tag, [attr => value, ...])
###		end_tag($tag)
###		text($text)
###
###	The default bindings build a parse tree out of XML::Node objects.
###	Overriding these in a subclass allows SAX-like on-the-fly processing.

sub declaration {
    my ($self, $text) = @_;

    ## HTML declaration, e.g. doctype.
    ##	initial "<!" and ending ">" stripped off.

    $self->add(XML::Node->declaration($text)) unless $self->filter();
}

sub comment {
    my ($self, $text) = @_;

    ## Comment.
    ##	The leading and trailing "<!--" and "-->" have been stripped off.

    $self->add(XML::Node->comment($text)) unless $self->filter();
}

sub end_tag {
    my ($self, $tag) = @_;

    ## End tag.
    --$self->{'_depth'};
    $self->add($self->pop());	# === need to do validity checking first
}

sub start_tag {
    my ($self, $tag, $attrs) = @_;

    ## Start tag.
    ##	Called with additional attribute _empty=>'/' if it ended in '/>'.

    my $node = XML::Node->element($tag, $attrs);
    if ($node->marked_empty()) { $self->add($node); }
    else { $self->push($node);  ++$self->{'_depth'};}
}

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

    ## Text.
    ##	  Entities must be expanded by the application if necessary.

    if ($self->depth() == 0 && $self->filter() ) { return; }
    $self->add($text);
}

sub pi {
    my ($self, $text) = @_;

    ## Processing instruction

    $self->add(XML::Node->pi($text)) unless $self->filter();
 
}

sub cdata {
    my ($self, $text) = @_;

    ## CDATA section

    $self->add(XML::Node->cdata($text));
}



1;
