libxml-perl 0.08-2 / usr / share / perl5 / XML / ESISParser.pm

#
# Copyright (C) 1999 Ken MacLeod
# See the file COPYING for distribution terms.
#
# $Id: ESISParser.pm,v 1.9 2000/03/02 20:18:09 kmacleod Exp $
#

use strict;

use IO::File;
use UNIVERSAL;

package XML::ESISParser;

use vars qw{ $VERSION $NSGMLS_sgml $NSGMLS_FLAGS_sgml $NSGMLS_ENV_sgml
	     $NSGMLS_xml $NSGMLS_FLAGS_xml $NSGMLS_ENV_xml
	     $XML_DECL };

# will be substituted by make-rel script
$VERSION = "0.08";

$NSGMLS_sgml = 'nsgmls';
$NSGMLS_FLAGS_sgml = '-oentity -oempty -onotation-sysid -oincluded -oline -E0';
$NSGMLS_ENV_sgml = '';

$NSGMLS_xml = 'nsgmls';
$XML_DECL = '/usr/lib/sgml/declaration/xml.decl';
$NSGMLS_FLAGS_xml = '-oentity -oempty -onotation-sysid -oline -oincluded -wxml -E0 ';
$NSGMLS_ENV_xml = 'SP_CHARSET_FIXED=YES SP_ENCODING=XML';

sub new {
    my $type = shift;

    return bless { @_ }, $type;
}

sub parse {
    my $self = shift;

    die "XML::ESISParser: parser instance ($self) already parsing\n"
	if (defined $self->{ParseOptions});

    # If there's one arg and it has no ref, it's a string
    my $args;
    if (scalar (@_) == 1 && !ref($_[0])) {
	$args = { Source => { String => shift } };
    } else {
	$args = (scalar (@_) == 1) ? shift : { @_ };
    }

    my $parse_options = { %$self, %$args };
    $self->{ParseOptions} = $parse_options;

    # ensure that we have at least one source
    if (!defined $parse_options->{Source}
	|| !(defined $parse_options->{Source}{String}
	     || defined $parse_options->{Source}{ByteStream}
	     || defined $parse_options->{Source}{SystemId}
	     || defined $parse_options->{Source}{ESISStream})) {
	die "XML::ESISParser: no source defined for parse\n";
    }

    # assign default Handler to any undefined handlers
    if (defined $parse_options->{Handler}) {
	$parse_options->{DocumentHandler} = $parse_options->{Handler}
	    if (!defined $parse_options->{DocumentHandler});
	$parse_options->{DTDHandler} = $parse_options->{Handler}
	    if (!defined $parse_options->{DTDHandler});
	$parse_options->{ErrorHandler} = $parse_options->{Handler}
	    if (!defined $parse_options->{ErrorHandler});
    }

    # create the NSGMLS command
    my ($nsgmls_command, $nsgmls, $nsgmls_flags);
    if (defined $parse_options->{NSGMLSCommand}) {
	$nsgmls_command = $parse_options->{NSGMLSCommand};
    } elsif (defined $parse_options->{IsSGML}
	     && $parse_options->{IsSGML}) {
	my $declaration = (defined $parse_options->{Declaration})
	    ? " " . $parse_options->{Declaration} : "";
	$nsgmls = $parse_options->{NSGMLS} = $NSGMLS_sgml;
	$nsgmls_flags = $parse_options->{NSGMLS_FLAGS} = $NSGMLS_FLAGS_sgml;
	$nsgmls_command = $parse_options->{NSGMLS_COMMAND} = "$nsgmls $nsgmls_flags $declaration";
    } else {
	my $declaration = (defined $parse_options->{Declaration})
	    ? $parse_options->{Declaration} : $XML_DECL;
	$nsgmls = $parse_options->{NSGMLS} = $NSGMLS_xml;
	$nsgmls_flags = $parse_options->{NSGMLS_FLAGS} = $NSGMLS_FLAGS_xml;
	$nsgmls_command = $parse_options->{NSGMLS_COMMAND} = "$NSGMLS_ENV_xml $nsgmls $nsgmls_flags $declaration";
    }
	

    my $result;
    if (defined $self->{ParseOptions}{Source}{ESISStream}) {
	# read ESIS stream directly
	my $system_id = (defined $self->{ParseOptions}{Source}{SystemId})
	    ? "\`$self->{ParseOptions}{Source}{SystemId}'" : 'ESIS Stream';
	eval { $result = $self->parse_fh ($self->{ParseOptions}{Source}{ESISStream}) };
	my $retval = $@;

	if ($retval) {
	    die "XML::ESISParser::parse: unable to parse \`$system_id'\n$retval";
	}
    } elsif (defined $self->{ParseOptions}{Source}{ByteStream}) {
	# call nsgmls using file handle
	# FIXME special case stdin?

	# For ByteStreams (Perl file handles) we create a sub-process
	# that we feed the XML/SGML document and we get back the ESIS
	# stream
	my $retval;
	my $system_id = (defined $self->{ParseOptions}{Source}{SystemId})
	    ? "\`$self->{ParseOptions}{Source}{SystemId}'" : 'Byte Stream';
	my ($pid) = open (ESIS, "-|");
	if ($pid == 0) {
	    # 20% speed increase if grep swipes implieds (only 8% if
	    # we do it in `parse_fh').  XXX use a C routine or patch SP
	    open (SGML, "| $nsgmls_command 2>&1 | egrep -v '^A.* IMPLIED\$'")
	        or die "XML::ESISParser::parse: can't run \`$nsgmls' on \`$system_id'\n";

	    $self->{ParseOptions}{Source}{ByteStream}->print (*SGML);

	    close (SGML)
		or die "XML::ESISParser::parse: can't run \`$nsgmls' on \`$system_id'\n";

	    exit 0;
	} else {
	    eval { $result = $self->parse_fh (*ESIS) };
	    $retval = $@;
	    wait;		# clean up that process
	}
	close (ESIS);

	$self->{ParseOptions}{Source}{ByteStream}->close ();

	if ($retval) {
	    die "XML::ESISParser::parse: unable to parse \`$system_id'\n$retval";
	}
    } elsif (defined $self->{ParseOptions}{Source}{String}) {
	# call nsgmls with a literal string
    } elsif (defined $self->{ParseOptions}{Source}{SystemId}) {
	# if SystemId is a file, call nsgmls with file name
	# otherwise, open stream on SystemId and do ByteStream

	# FIXME this only handles file SystemIds right now
	# 20% speed increase if grep swipes implieds (only 8% if
	# we do it in `parse').  XXX use a C routine or patch SP
	my $system_id = $self->{ParseOptions}{Source}{SystemId};
	my ($fh) = IO::File->new
	    ("$nsgmls_command '$system_id' 2>&1 | egrep -v '^A.* IMPLIED\$' |");
	die "XML::ESISParser::parse: can't run \`$nsgmls' on \`$system_id'\n"
	    if (!defined $fh);

	eval { $result = $self->parse_fh ($fh) };
	my $retval = $@;

	close ($fh);

	if ($retval) {
	    die "XML::ESISParser::parse: unable to parse \`$system_id'\n$retval";
	}
    }
	

    # clean up parser instance
    delete $self->{ParseOptions};
    delete $self->{DocumentHandler};
    delete $self->{DTDHandler};
    delete $self->{ErrorHandler};

    return $result;
}

#
# Parse the `ESIS' information coming from `file'
#

sub parse_fh {
    my ($self, $file) = @_;
    my (@attributes, @properties, $files);

    my $doc_h = $self->{ParseOptions}{DocumentHandler};
    my $dtd_h = $self->{ParseOptions}{DTDHandler};
    my $err_h = $self->{ParseOptions}{ErrorHandler};

    # we cache these most commonly used `can()' calls
    my $can_start_element = $doc_h->can('start_element');
    my $can_end_element = $doc_h->can('end_element');
    my $can_characters = $doc_h->can('characters');
    my $can_record_end = $doc_h->can('record_end');

    my $line = 0;
    $doc_h->start_document( { } )
	if ($doc_h->can('start_document'));

    # 30% speed improvement by breaking the encapsulation
    my ($is_filehandle) = (ref ($file) eq "FileHandle"
			   || ref ($file) eq "IO::File");
    while ($_ = ($is_filehandle ? <$file> : $file->getline())) {
	chop;

	if (/^A/) {		# attribute
	    # Note: the output of `nsgmls' is `grep -v'ed to get rid of
	    # IMPLIED attributes, if we do it here we only get an 8%
	    # speed boost

	    my ($name, $type, $value) = split (/\s/, $', 3);

	    push (@attributes, $name => $value);

	    next;
	}

	if (/^\(/) {		# start element
	    # break the encapsulation for an 8% boost
	    if ($#attributes >= 0) {
		push (@properties, Attributes => { @attributes });
	    }
	    $doc_h->start_element ({ Name => $', @properties })
		if ($can_start_element);

	    @properties = (); @attributes = ();
	    next;
	}

	if (/^\)/) {		# end element
	    $doc_h->end_element ({ Name => $' })
		if ($can_end_element);

	    next;
	}

	if (/^L/) {		# line number
	    $line = $';

	    next;
	}

	if (/^-/) {		# data (including sdata entities)
	    # This section is derived from David Megginson's SGMLSpm
	    my $sdata_flag = 0;
	    my $out = '';
	    my $data = $';

	    while ($data =~ /\\(\\|n|\||[0-7]{1,3})/) {
		$out .= $`;
		$data = $';

		if ($1 eq '|') {
		    # beginning or end of SDATA
		    if ("$out" ne '') {
			if ($sdata_flag) {
			    $doc_h->internal_entity_ref({ Name => $self->{'internal_entities_by_value'}{$out} })
				if ($doc_h->can('internal_entity_ref'));
			} else {
			    $doc_h->characters({ Data => $out })
				if ($can_characters);
			}
			$out = '';
		    }
		    $sdata_flag = !$sdata_flag;

		} elsif ($1 eq 'n') {
		    # record end
		    if ("$out" ne '') {
			if ($sdata_flag) {
			    $doc_h->internal_entity_ref({ Name => $self->{'internal_entities_by_value'}{$out} })
				if ($doc_h->can('internal_entity_ref'));
			} else {
			    $doc_h->characters({ Data => $out })
				if ($can_characters);
			}
			$out = '';
		    }
		    if ($can_record_end) {
			$doc_h->record_end( { } );
		    } else {
			$doc_h->characters({ Data => "\n" })
			    if ($can_characters);
		    }
		} elsif ($1 eq '\\') {
		    $out .= '\\';
		} else {
		    $out .= chr(oct($1));
		}
	    }
	    $out .= $data;
	    if ("$out" ne '') {
		if ($sdata_flag) {
		    $doc_h->internal_entity_ref({ Name => $self->{'internal_entities_by_value'}{$out} })
			if ($doc_h->can('internal_entity_ref'));
		} else {
		    $doc_h->characters({ Data => $out })
			if ($can_characters);
		}
	    }

	    next;
	}

	if (/^s/) {		# sysid
	    push (@properties, SystemId => $');

	    next;
	}

	if (/^p/) {		# pubid
	    push (@properties, PublicId => $');

	    next;
	}

	if (/^f/) {		# file
	    if (!defined $files) {
		$files = $';
	    } elsif (!ref $files) {
		$files = [ $files, $' ];
	    } else {
		push (@$files, $');
	    }

	    next;
	}

	if (/^E/) {		# external entity definition
	    my ($entity_data) = $';
	    $entity_data =~ /^(\S+) (\S+) (\S+)$/
		or die "XML::ESISParser::parse_fh: bad external entity event data: $entity_data\n";
	    my ($name,$type,$notation) = ($1,$2,$3);
	    if (defined $files) {
		push (@properties, GeneratedId => $files);
	    }
	    $dtd_h->external_entity_decl ({ Name => $name, Type => $type,
					    Notation => $notation, @properties })
		if ($dtd_h->can('external_entity_decl'));

	    @properties = (); undef $files;
	    next;
	}

	if (/^I/) {             # internal entity definition
	    my ($name, $type, $value) = split (/\s/, $', 3);
	    $self->{'internal_entities_by_value'}{$value} = $name;
	    $dtd_h->internal_entity_decl ({ Name => $name, Type => $type,
					    Value => $value })
		if ($dtd_h->can('internal_entity_decl'));

	    next;
	}

	if (/^&/) {		# external entity reference
	    my ($name) = $';
	    $doc_h->external_entity_ref({ Name => $name })
		if ($doc_h->can('external_entity_ref'));

	    next;
	}

	if (/^\?/) {		# processing instruction (PI)
	    my ($data) = $';
	    if ($self->{ParseOptions}{IsSGML}) {
		$doc_h->processing_instruction({ Data => $data })
		    if ($doc_h->can('processing_instruction'));
	    } else {
		my ($target, $pi_data) = split (/\s+/, $data, 2);
		$doc_h->processing_instruction({ Target => $target, Data => $pi_data })
		    if ($doc_h->can('processing_instruction'));
	    }

	    next;
	}

	if (/^N/) {		# notation definition
	    my ($name) = $';
	    if (defined $files) {
		push (@properties, GeneratedId => $files);
	    }
	    $dtd_h->notation_decl ({ Name => $name, @properties })
		if ($dtd_h->can('notation_decl'));

	    @properties = (); undef $files;
	    next;
	}

	if (/^S/) {		# subdoc definition
	    my ($name) = $';
	    if (defined $files) {
		push (@properties, GeneratedId => $files);
	    }
	    $dtd_h->subdoc_entity_decl ({ Name => $name, @properties })
		if ($dtd_h->can('subdoc_entity_decl'));

	    @properties = (); undef $files;
	    next;
	}

	if (/^T/) {		# external SGML text entity definition
	    my ($name) = $';
	    if (defined $files) {
		push (@properties, GeneratedId => $files);
	    }
	    $dtd_h->external_sgml_entity_decl ({ Name => $name, @properties })
		if ($dtd_h->can('external_sgml_entity_decl'));

	    @properties = (); undef $files;
	    next;
	}

	if (/^D/) {             # data attribute
	    # FIXME
	    my $message = "XML::ESISParser: can't handle data attributes yet\n";
	    if ($err_h->can('error')) {
		$err_h->error ({ Message => $message });
	    } else {
		die "$message";
	    }

	    next;
	}

	if (/^D/) {             # link attribute
	    # FIXME
	    my $message = "XML::ESISParser: can't handle link attributes yet\n";
	    if ($err_h->can('error')) {
		$err_h->error ({ Message => $message });
	    } else {
		die "$message";
	    }

	    next;
	}

	if (/^{/) {		# subdoc start
	    my ($name) = $';
	    $doc_h->start_subdoc ({ Name => $name })
		if ($doc_h->can('start_subdoc'));

	    next;
	}

	if (/^}/) {		# subdoc end
	    my ($name) = $';
	    $doc_h->end_subdoc ({ Name => $name })
		if ($doc_h->can('end_subdoc'));

	    next;
	}

	if (/^#/) {		# appinfo
	    my ($text) = $';
	    $doc_h->appinfo ({ Text => $text })
	        if ($doc_h->can('appinfo'));

	    next;
	}

	if (/^i/) {             # next element is an included subelement
	    push (@properties, IncludedSubelement => 1);

	    next;
	}

	if (/^e/) {             # next element is declared empty
	    push (@properties, Empty => 1);

	    next;
	}

	if (/^C/) {		# conforming
	    $doc_h->conforming({})
		if ($doc_h->can('conforming'));

	    next;
	}

	if (/^$self->{ParseOptions}{NSGMLS}:/) {	# `nsgmls' error
	    my $message = $_;
	    if ($err_h->can('error')) {
		$err_h->error ({ Message => $message });
	    } else {
		die "$message\n";
	    }

	    next;
	}

	my ($op) = substr ($_, 0, 1);
	my $message = "XML::ESISParser::parse_fh: ESIS command character \`$op' not recognized when reading line \`$_' around line $line ($.)";
	if ($err_h->can('error')) {
	    $err_h->error ({ Message => $message });
	} else {
	    die "$message";
	}
    }

    if ($doc_h->can('end_document')) {
	return $doc_h->end_document({});
    } else {
	return ();
    }
}

1;

__END__

=head1 NAME

XML::ESISParser - Perl SAX parser using nsgmls

=head1 SYNOPSIS

 use XML::ESISParser;

 $parser = XML::ESISParser->new( [OPTIONS] );
 $result = $parser->parse( [OPTIONS] );

 $result = $parser->parse($string);

=head1 DESCRIPTION

C<XML::ESISParser> is a Perl SAX parser using the `nsgmls' command of
James Clark's SGML Parser (SP), a validating XML and SGML parser.
This man page summarizes the specific options, handlers, and
properties supported by C<XML::ESISParser>; please refer to the Perl
SAX standard in `C<SAX.pod>' for general usage information.

C<XML::ESISParser> defaults to parsing XML and has an option for
parsing SGML.

`C<nsgmls>' source, and binaries for some platforms, is available from
<http://www.jclark.com/>.  `C<nsgmls>' is included in both the SP and
Jade packages.

=head1 METHODS

=over 4

=item new

Creates a new parser object.  Default options for parsing, described
below, are passed as key-value pairs or as a single hash.  Options may
be changed directly in the parser object unless stated otherwise.
Options passed to `C<parse()>' override the default options in the
parser object for the duration of the parse.

=back

=head1 OPTIONS

The following options are supported by C<XML::ESISParser>:

 Handler          default handler to receive events
 DocumentHandler  handler to receive document events
 DTDHandler       handler to receive DTD events
 ErrorHandler     handler to receive error events
 Source           hash containing the input source for parsing
 IsSGML           the document to be parsed is in SGML

If no handlers are provided then all events will be silently ignored.

If a single string argument is passed to the `C<parse()>' method, it
is treated as if a `C<Source>' option was given with a `C<String>'
parameter.

The `C<Source>' hash may contain the following parameters:

 ByteStream       The raw byte stream (file handle) containing the
                  document.
 String           A string containing the document.
 SystemId         The system identifier (URI) of the document.

If more than one of `C<ByteStream>', `C<String>', or `C<SystemId>',
then preference is given first to `C<ByteStream>', then `C<String>',
then `C<SystemId>'.

=head1 HANDLERS

The following handlers and properties are supported by
C<XML::ESISParser>:

=head2 DocumentHandler methods

=over 4

=item start_document

Receive notification of the beginning of a document.

No properties defined.

=item end_document

Receive notification of the end of a document.

No properties defined.

=item start_element

Receive notification of the beginning of an element.

 Name             The element type name.
 Attributes       A hash containing the attributes attached to the
                  element, if any.
 IncludedSubelement This element is an included subelement.
 Empty            This element is declared empty.

The `C<Attributes>' hash contains only string values.  The `C<Empty>'
flag is not set for an element that merely has no content, it is set
only if the DTD declares it empty.

BETA: Attribute values currently do not expand SData entities into
entity objects, they are still in the system data notation used by
nsgmls (inside `|').  A future version of XML::ESISParser will also
convert other types of attributes into their respective objects,
currently just their notation or entity names are given.

=item end_element

Receive notification of the end of an element.

 Name             The element type name.

=item characters

Receive notification of character data.

 Data             The characters from the document.

=item record_end

Receive notification of a record end sequence.  XML applications
should convert this to a new-line.

=item processing_instruction

Receive notification of a processing instruction. 

 Target           The processing instruction target in XML.
 Data             The processing instruction data, if any.

=item internal_entity_ref

Receive notification of a system data (SData) internal entity
reference.

 Name             The name of the internal entity reference.

=item external_entity_ref

Receive notification of a external entity reference.

 Name             The name of the external entity reference.

=item start_subdoc

Receive notification of the start of a sub document.

 Name             The name of the external entity reference.

=item end_subdoc

Receive notification of the end of a sub document.

 Name             The name of the external entity reference.

=item conforming

Receive notification that the document just parsed conforms to it's
document type declaration (DTD).

No properties defined.

=back

=head2 DTDHandler methods

=over 4

=item external_entity_decl

Receive notification of an external entity declaration.

 Name             The entity's entity name.
 Type             The entity's type (CDATA, NDATA, etc.)
 SystemId         The entity's system identifier.
 PublicId         The entity's public identifier, if any.
 GeneratedId      Generated system identifiers, if any.

=item internal_entity_decl

Receive notification of an internal entity declaration.

 Name             The entity's entity name.
 Type             The entity's type (CDATA, NDATA, etc.)
 Value            The entity's character value.

=item notation_decl

Receive notification of a notation declaration.

 Name             The notation's name.
 SystemId         The notation's system identifier.
 PublicId         The notation's public identifier, if any.
 GeneratedId      Generated system identifiers, if any.

=item subdoc_entity_decl

Receive notification of a subdocument entity declaration.

 Name             The entity's entity name.
 SystemId         The entity's system identifier.
 PublicId         The entity's public identifier, if any.
 GeneratedId      Generated system identifiers, if any.

=item external_sgml_entity_decl

Receive notification of an external SGML-entity declaration.

 Name             The entity's entity name.
 SystemId         The entity's system identifier.
 PublicId         The entity's public identifier, if any.
 GeneratedId      Generated system identifiers, if any.

=back

=head1 AUTHOR

Ken MacLeod, ken@bitsko.slc.ut.us

=head1 SEE ALSO

perl(1), PerlSAX.pod(3)

 Extensible Markup Language (XML) <http://www.w3c.org/XML/>
 SAX 1.0: The Simple API for XML <http://www.megginson.com/SAX/>
 SGML Parser (SP) <http://www.jclark.com/sp/>

=cut