1 # $Id: PurePerl.pm,v 1.21 2007/02/07 09:33:50 grant Exp $

     2 

     3 package XML::SAX::PurePerl;

     4 

     5 use strict;

     6 use vars qw/$VERSION/;

     7 

     8 $VERSION = '0.91';

     9 

    10 use XML::SAX::PurePerl::Productions qw($Any $CharMinusDash $SingleChar);

    11 use XML::SAX::PurePerl::Reader;

    12 use XML::SAX::PurePerl::EncodingDetect ();

    13 use XML::SAX::Exception;

    14 use XML::SAX::PurePerl::DocType ();

    15 use XML::SAX::PurePerl::DTDDecls ();

    16 use XML::SAX::PurePerl::XMLDecl ();

    17 use XML::SAX::DocumentLocator ();

    18 use XML::SAX::Base ();

    19 use XML::SAX qw(Namespaces);

    20 use XML::NamespaceSupport ();

    21 use IO::File;

    22 

    23 if ($] < 5.006) {

    24     require XML::SAX::PurePerl::NoUnicodeExt;

    25 }

    26 else {

    27     require XML::SAX::PurePerl::UnicodeExt;

    28 }

    29 

    30 use vars qw(@ISA);

    31 @ISA = ('XML::SAX::Base');

    32 

    33 my %int_ents = (

    34         amp => '&',

    35         lt => '<',

    36         gt => '>',

    37         quot => '"',

    38         apos => "'",

    39         );

    40 

    41 my $xmlns_ns = "http://www.w3.org/2000/xmlns/";

    42 my $xml_ns = "http://www.w3.org/XML/1998/namespace";

    43 

    44 use Carp;

    45 sub _parse_characterstream {

    46     my $self = shift;

    47     my ($fh) = @_;

    48     confess("CharacterStream is not yet correctly implemented");

    49     my $reader = XML::SAX::PurePerl::Reader::Stream->new($fh);

    50     return $self->_parse($reader);

    51 }

    52 

    53 sub _parse_bytestream {

    54     my $self = shift;

    55     my ($fh) = @_;

    56     my $reader = XML::SAX::PurePerl::Reader::Stream->new($fh);

    57     return $self->_parse($reader);

    58 }

    59 

    60 sub _parse_string {

    61     my $self = shift;

    62     my ($str) = @_;

    63     my $reader = XML::SAX::PurePerl::Reader::String->new($str);

    64     return $self->_parse($reader);

    65 }

    66 

    67 sub _parse_systemid {

    68     my $self = shift;

    69     my ($uri) = @_;

    70     my $reader = XML::SAX::PurePerl::Reader::URI->new($uri);

    71     return $self->_parse($reader);

    72 }

    73 

    74 sub _parse {

    75     my ($self, $reader) = @_;

    76     

    77     $reader->public_id($self->{ParseOptions}{Source}{PublicId});

    78     $reader->system_id($self->{ParseOptions}{Source}{SystemId});

    79 

    80     $self->{NSHelper} = XML::NamespaceSupport->new({xmlns => 1});

    81 

    82     $self->set_document_locator(

    83         XML::SAX::DocumentLocator->new(

    84             sub { $reader->public_id },

    85             sub { $reader->system_id },

    86             sub { $reader->line },

    87             sub { $reader->column },

    88             sub { $reader->get_encoding },

    89             sub { $reader->get_xml_version },

    90         ),

    91     );

    92     

    93     $self->start_document({});

    94 

    95     if (defined $self->{ParseOptions}{Source}{Encoding}) {

    96         $reader->set_encoding($self->{ParseOptions}{Source}{Encoding});

    97     }

    98     else {

    99         $self->encoding_detect($reader);

   100     }

   101     

   102     # parse a document

   103     $self->document($reader);

   104     

   105     return $self->end_document({});

   106 }

   107 

   108 sub parser_error {

   109     my $self = shift;

   110     my ($error, $reader) = @_;

   111     

   112 # warn("parser error: $error from ", $reader->line, " : ", $reader->column, "\n");

   113     my $exception = XML::SAX::Exception::Parse->new(

   114                 Message => $error,

   115                 ColumnNumber => $reader->column,

   116                 LineNumber => $reader->line,

   117                 PublicId => $reader->public_id,

   118                 SystemId => $reader->system_id,

   119             );

   120 

   121     $self->fatal_error($exception);

   122     $exception->throw;

   123 }

   124 

   125 sub document {

   126     my ($self, $reader) = @_;

   127     

   128     # document ::= prolog element Misc*

   129     

   130     $self->prolog($reader);

   131     $self->element($reader) ||

   132         $self->parser_error("Document requires an element", $reader);

   133     

   134     while(length($reader->data)) {

   135         $self->Misc($reader) || 

   136                 $self->parser_error("Only Comments, PIs and whitespace allowed at end of document", $reader);

   137     }

   138 }

   139 

   140 sub prolog {

   141     my ($self, $reader) = @_;

   142     

   143     $self->XMLDecl($reader);

   144     

   145     # consume all misc bits

   146     1 while($self->Misc($reader));

   147     

   148     if ($self->doctypedecl($reader)) {

   149         while (length($reader->data)) {

   150             $self->Misc($reader) || last;

   151         }

   152     }

   153 }

   154 

   155 sub element {

   156     my ($self, $reader) = @_;

   157     

   158     return 0 unless $reader->match('<');

   159     

   160     my $name = $self->Name($reader) || $self->parser_error("Invalid element name", $reader);

   161     

   162     my %attribs;

   163     

   164     while( my ($k, $v) = $self->Attribute($reader) ) {

   165         $attribs{$k} = $v;

   166     }

   167     

   168     my $have_namespaces = $self->get_feature(Namespaces);

   169     

   170     # Namespace processing

   171     $self->{NSHelper}->push_context;

   172     my @new_ns;

   173 #        my %attrs = @attribs;

   174 #        while (my ($k,$v) = each %attrs) {

   175     if ($have_namespaces) {

   176         while ( my ($k, $v) = each %attribs ) {

   177             if ($k =~ m/^xmlns(:(.*))?$/) {

   178                 my $prefix = $2 || '';

   179                 $self->{NSHelper}->declare_prefix($prefix, $v);

   180                 my $ns = 

   181                     {

   182                         Prefix       => $prefix,

   183                         NamespaceURI => $v,

   184                     };

   185                 push @new_ns, $ns;

   186                 $self->SUPER::start_prefix_mapping($ns);

   187             }

   188         }

   189     }

   190 

   191     # Create element object and fire event

   192     my %attrib_hash;

   193     while (my ($name, $value) = each %attribs ) {

   194         # TODO normalise value here

   195         my ($ns, $prefix, $lname);

   196         if ($have_namespaces) {

   197             ($ns, $prefix, $lname) = $self->{NSHelper}->process_attribute_name($name);

   198         }

   199         $ns ||= ''; $prefix ||= ''; $lname ||= '';

   200         $attrib_hash{"{$ns}$lname"} = {

   201             Name => $name,

   202             LocalName => $lname,

   203             Prefix => $prefix,

   204             NamespaceURI => $ns,

   205             Value => $value,

   206         };

   207     }

   208     

   209     %attribs = (); # lose the memory since we recurse deep

   210     

   211     my ($ns, $prefix, $lname);

   212     if ($self->get_feature(Namespaces)) {

   213         ($ns, $prefix, $lname) = $self->{NSHelper}->process_element_name($name);

   214     }

   215     else {

   216         $lname = $name;

   217     }

   218     $ns ||= ''; $prefix ||= ''; $lname ||= '';

   219 

   220     # Process remainder of start_element

   221     $self->skip_whitespace($reader);

   222     my $have_content;

   223     my $data = $reader->data(2);

   224     if ($data =~ /^\/>/) {

   225         $reader->move_along(2);

   226     }

   227     else {

   228         $data =~ /^>/ or $self->parser_error("No close element tag", $reader);

   229         $reader->move_along(1);

   230         $have_content++;

   231     }

   232     

   233     my $el = 

   234     {

   235         Name => $name,

   236         LocalName => $lname,

   237         Prefix => $prefix,

   238         NamespaceURI => $ns,

   239         Attributes => \%attrib_hash,

   240     };

   241     $self->start_element($el);

   242     

   243     # warn("($name\n");

   244     

   245     if ($have_content) {

   246         $self->content($reader);

   247         

   248         my $data = $reader->data(2);

   249         $data =~ /^<\// or $self->parser_error("No close tag marker", $reader);

   250         $reader->move_along(2);

   251         my $end_name = $self->Name($reader);

   252         $end_name eq $name || $self->parser_error("End tag mismatch ($end_name != $name)", $reader);

   253         $self->skip_whitespace($reader);

   254         $reader->match('>') or $self->parser_error("No close '>' on end tag", $reader);

   255     }

   256         

   257     my %end_el = %$el;

   258     delete $end_el{Attributes};

   259     $self->end_element(\%end_el);

   260 

   261     for my $ns (@new_ns) {

   262         $self->end_prefix_mapping($ns);

   263     }

   264     $self->{NSHelper}->pop_context;

   265     

   266     return 1;

   267 }

   268 

   269 sub content {

   270     my ($self, $reader) = @_;

   271     

   272     while (1) {

   273         $self->CharData($reader);

   274         

   275         my $data = $reader->data(2);

   276         

   277         if ($data =~ /^<\//) {

   278             return 1;

   279         }

   280         elsif ($data =~ /^&/) {

   281             $self->Reference($reader) or $self->parser_error("bare & not allowed in content", $reader);

   282             next;

   283         }

   284         elsif ($data =~ /^<!/) {

   285             ($self->CDSect($reader)

   286              or

   287              $self->Comment($reader))

   288              and next;

   289         }

   290         elsif ($data =~ /^<\?/) {

   291             $self->PI($reader) and next;

   292         }

   293         elsif ($data =~ /^</) {

   294             $self->element($reader) and next;

   295         }

   296         last;

   297     }

   298     

   299     return 1;

   300 }

   301 

   302 sub CDSect {

   303     my ($self, $reader) = @_;

   304     

   305     my $data = $reader->data(9);

   306     return 0 unless $data =~ /^<!\[CDATA\[/;

   307     $reader->move_along(9);

   308     

   309     $self->start_cdata({});

   310     

   311     $data = $reader->data;

   312     while (1) {

   313         $self->parser_error("EOF looking for CDATA section end", $reader)

   314             unless length($data);

   315         

   316         if ($data =~ /^(.*?)\]\]>/s) {

   317             my $chars = $1;

   318             $reader->move_along(length($chars) + 3);

   319             $self->characters({Data => $chars});

   320             last;

   321         }

   322         elsif ($data =~ /(.*?)\]+$/s) {

   323             my $chars = $1;

   324             $reader->move_along(length($chars));

   325             $self->characters({Data => $chars});

   326             $data = $reader->data(3);

   327         }

   328         else {

   329             $self->characters({Data => $data});

   330             $reader->move_along(length($data));

   331             $data = $reader->data;

   332         }

   333     }

   334     $self->end_cdata({});

   335     return 1;

   336 }

   337 

   338 sub CharData {

   339     my ($self, $reader) = @_;

   340     

   341     my $data = $reader->data;

   342     

   343     while (1) {

   344         return unless length($data);

   345         

   346         if ($data =~ /^([^<&]*)[<&]/s) {

   347             my $chars = $1;

   348             $self->parser_error("String ']]>' not allowed in character data", $reader)

   349                 if $chars =~ /\]\]>/;

   350             $reader->move_along(length($chars));

   351             $self->characters({Data => $chars}) if length($chars);

   352             last;

   353         }

   354         else {

   355             $self->characters({Data => $data});

   356             $reader->move_along(length($data));

   357             $data = $reader->data;

   358         }

   359     }

   360 }

   361 

   362 sub Misc {

   363     my ($self, $reader) = @_;

   364     if ($self->Comment($reader)) {

   365         return 1;

   366     }

   367     elsif ($self->PI($reader)) {

   368         return 1;

   369     }

   370     elsif ($self->skip_whitespace($reader)) {

   371         return 1;

   372     }

   373     

   374     return 0;

   375 }

   376 

   377 sub Reference {

   378     my ($self, $reader) = @_;

   379     

   380     return 0 unless $reader->match('&');

   381     

   382     my $data = $reader->data;

   383     

   384     if ($data =~ /^#x([0-9a-fA-F]+);/) {

   385         my $ref = $1;

   386         $reader->move_along(length($ref) + 3);

   387         my $char = chr_ref(hex($ref));

   388         $self->parser_error("Character reference &#$ref; refers to an illegal XML character ($char)", $reader)

   389             unless $char =~ /$SingleChar/o;

   390         $self->characters({ Data => $char });

   391         return 1;

   392     }

   393     elsif ($data =~ /^#([0-9]+);/) {

   394         my $ref = $1;

   395         $reader->move_along(length($ref) + 2);

   396         my $char = chr_ref($ref);

   397         $self->parser_error("Character reference &#$ref; refers to an illegal XML character ($char)", $reader)

   398             unless $char =~ /$SingleChar/o;

   399         $self->characters({ Data => $char });

   400         return 1;

   401     }

   402     else {

   403         # EntityRef

   404         my $name = $self->Name($reader)

   405             || $self->parser_error("Invalid name in entity", $reader);

   406         $reader->match(';') or $self->parser_error("No semi-colon found after entity name", $reader);

   407         

   408         # warn("got entity: \&$name;\n");

   409         

   410         # expand it

   411         if ($self->_is_entity($name)) {

   412             

   413             if ($self->_is_external($name)) {

   414                 my $value = $self->_get_entity($name);

   415                 my $ent_reader = XML::SAX::PurePerl::Reader::URI->new($value);

   416                 $self->encoding_detect($ent_reader);

   417                 $self->extParsedEnt($ent_reader);

   418             }

   419             else {

   420                 my $value = $self->_stringify_entity($name);

   421                 my $ent_reader = XML::SAX::PurePerl::Reader::String->new($value);

   422                 $self->content($ent_reader);

   423             }

   424             return 1;

   425         }

   426         elsif ($name =~ /^(?:amp|gt|lt|quot|apos)$/) {

   427             $self->characters({ Data => $int_ents{$name} });

   428             return 1;

   429         }

   430         else {

   431             $self->parser_error("Undeclared entity", $reader);

   432         }

   433     }

   434 }

   435 

   436 sub AttReference {

   437     my ($self, $name, $reader) = @_;

   438     if ($name =~ /^#x([0-9a-fA-F]+)$/) {

   439         my $chr = chr_ref(hex($1));

   440         $chr =~ /$SingleChar/o or $self->parser_error("Character reference '&$name;' refers to an illegal XML character", $reader);

   441         return $chr;

   442     }

   443     elsif ($name =~ /^#([0-9]+)$/) {

   444         my $chr = chr_ref($1);

   445         $chr =~ /$SingleChar/o or $self->parser_error("Character reference '&$name;' refers to an illegal XML character", $reader);

   446         return $chr;

   447     }

   448     else {

   449         if ($self->_is_entity($name)) {

   450             if ($self->_is_external($name)) {

   451                 $self->parser_error("No external entity references allowed in attribute values", $reader);

   452             }

   453             else {

   454                 my $value = $self->_stringify_entity($name);

   455                 return $value;

   456             }

   457         }

   458         elsif ($name =~ /^(?:amp|lt|gt|quot|apos)$/) {

   459             return $int_ents{$name};

   460         }

   461         else {

   462             $self->parser_error("Undeclared entity '$name'", $reader);

   463         }

   464     }

   465 }

   466 

   467 sub extParsedEnt {

   468     my ($self, $reader) = @_;

   469     

   470     $self->TextDecl($reader);

   471     $self->content($reader);

   472 }

   473 

   474 sub _is_external {

   475     my ($self, $name) = @_;

   476 # TODO: Fix this to use $reader to store the entities perhaps.

   477     if ($self->{ParseOptions}{external_entities}{$name}) {

   478         return 1;

   479     }

   480     return ;

   481 }

   482 

   483 sub _is_entity {

   484     my ($self, $name) = @_;

   485 # TODO: ditto above

   486     if (exists $self->{ParseOptions}{entities}{$name}) {

   487         return 1;

   488     }

   489     return 0;

   490 }

   491 

   492 sub _stringify_entity {

   493     my ($self, $name) = @_;

   494 # TODO: ditto above

   495     if (exists $self->{ParseOptions}{expanded_entity}{$name}) {

   496         return $self->{ParseOptions}{expanded_entity}{$name};

   497     }

   498     # expand

   499     my $reader = XML::SAX::PurePerl::Reader::URI->new($self->{ParseOptions}{entities}{$name});

   500     my $ent = '';

   501     while(1) {

   502         my $data = $reader->data;

   503         $ent .= $data;

   504         $reader->move_along(length($data)) or last;

   505     }

   506     return $self->{ParseOptions}{expanded_entity}{$name} = $ent;

   507 }

   508 

   509 sub _get_entity {

   510     my ($self, $name) = @_;

   511 # TODO: ditto above

   512     return $self->{ParseOptions}{entities}{$name};

   513 }

   514 

   515 sub skip_whitespace {

   516     my ($self, $reader) = @_;

   517     

   518     my $data = $reader->data;

   519     

   520     my $found = 0;

   521     while ($data =~ s/^([\x20\x0A\x0D\x09]*)//) {

   522         last unless length($1);

   523         $found++;

   524         $reader->move_along(length($1));

   525         $data = $reader->data;

   526     }

   527     

   528     return $found;

   529 }

   530 

   531 sub Attribute {

   532     my ($self, $reader) = @_;

   533     

   534     $self->skip_whitespace($reader) || return;

   535     

   536     my $data = $reader->data(2);

   537     return if $data =~ /^\/?>/;

   538     

   539     if (my $name = $self->Name($reader)) {

   540         $self->skip_whitespace($reader);

   541         $reader->match('=') or $self->parser_error("No '=' in Attribute", $reader);

   542         $self->skip_whitespace($reader);

   543         my $value = $self->AttValue($reader);

   544 

   545         if (!$self->cdata_attrib($name)) {

   546             $value =~ s/^\x20*//; # discard leading spaces

   547             $value =~ s/\x20*$//; # discard trailing spaces

   548             $value =~ s/ {1,}/ /g; # all >1 space to single space

   549         }

   550         

   551         return $name, $value;

   552     }

   553     

   554     return;

   555 }

   556 

   557 sub cdata_attrib {

   558     # TODO implement this!

   559     return 1;

   560 }

   561 

   562 sub AttValue {

   563     my ($self, $reader) = @_;

   564     

   565     my $quote = $self->quote($reader);

   566     

   567     my $value = '';

   568     

   569     while (1) {

   570         my $data = $reader->data;

   571         $self->parser_error("EOF found while looking for the end of attribute value", $reader)

   572             unless length($data);

   573         if ($data =~ /^([^$quote]*)$quote/) {

   574             $reader->move_along(length($1) + 1);

   575             $value .= $1;

   576             last;

   577         }

   578         else {

   579             $value .= $data;

   580             $reader->move_along(length($data));

   581         }

   582     }

   583     

   584     if ($value =~ /</) {

   585         $self->parser_error("< character not allowed in attribute values", $reader);

   586     }

   587     

   588     $value =~ s/[\x09\x0A\x0D]/\x20/g;

   589     $value =~ s/&(#(x[0-9a-fA-F]+)|([0-9]+)|\w+);/$self->AttReference($1, $reader)/geo;

   590     

   591     return $value;

   592 }

   593 

   594 sub Comment {

   595     my ($self, $reader) = @_;

   596     

   597     my $data = $reader->data(4);

   598     if ($data =~ /^<!--/) {

   599         $reader->move_along(4);

   600         my $comment_str = '';

   601         while (1) {

   602             my $data = $reader->data;

   603             $self->parser_error("End of data seen while looking for close comment marker", $reader)

   604                 unless length($data);

   605             if ($data =~ /^(.*?)-->/s) {

   606                 $comment_str .= $1;

   607                 $self->parser_error("Invalid comment (dash)", $reader) if $comment_str =~ /-$/;

   608                 $reader->move_along(length($1) + 3);

   609                 last;

   610             }

   611             else {

   612                 $comment_str .= $data;

   613                 $reader->move_along(length($data));

   614             }

   615         }

   616         

   617         $self->comment({ Data => $comment_str });

   618         

   619         return 1;

   620     }

   621     return 0;

   622 }

   623 

   624 sub PI {

   625     my ($self, $reader) = @_;

   626     

   627     my $data = $reader->data(2);

   628     

   629     if ($data =~ /^<\?/) {

   630         $reader->move_along(2);

   631         my ($target, $data);

   632         $target = $self->Name($reader) ||

   633             $self->parser_error("PI has no target", $reader);

   634         if ($self->skip_whitespace($reader)) {

   635             $target = '';

   636             while (1) {

   637                 my $data = $reader->data;

   638                 $self->parser_error("End of data seen while looking for close PI marker", $reader)

   639                     unless length($data);

   640                 if ($data =~ /^(.*?)\?>/s) {

   641                     $target .= $1;

   642                     $reader->move_along(length($1) + 2);

   643                     last;

   644                 }

   645                 else {

   646                     $target .= $data;

   647                     $reader->move_along(length($data));

   648                 }

   649             }

   650         }

   651         else {

   652             my $data = $reader->data(2);

   653             $data =~ /^\?>/ or $self->parser_error("PI closing sequence not found", $reader);

   654             $reader->move_along(2);

   655         }

   656         $self->processing_instruction({ Target => $target, Data => $data });

   657         

   658         return 1;

   659     }

   660     return 0;

   661 }

   662 

   663 sub Name {

   664     my ($self, $reader) = @_;

   665     

   666     my $name = '';

   667     while(1) {

   668         my $data = $reader->data;

   669         return unless length($data);

   670         $data =~ /^([^\s>\/&\?;=<\)\(\[\],\%\#\!\*]*)/ or return;

   671         $name .= $1;

   672         my $len = length($1);

   673         $reader->move_along($len);

   674         last if ($len != length($data));

   675     }

   676     

   677     return unless length($name);

   678     

   679     $name =~ /$NameChar/o or $self->parser_error("Name <$name> does not match NameChar production", $reader);

   680 

   681     return $name;

   682 }

   683 

   684 sub quote {

   685     my ($self, $reader) = @_;

   686     

   687     my $data = $reader->data;

   688     

   689     $data =~ /^(['"])/ or $self->parser_error("Invalid quote token", $reader);

   690     $reader->move_along(1);

   691     return $1;

   692 }

   693 

   694 1;

   695 __END__

   696 

   697 =head1 NAME

   698 

   699 XML::SAX::PurePerl - Pure Perl XML Parser with SAX2 interface

   700 

   701 =head1 SYNOPSIS

   702 

   703   use XML::Handler::Foo;

   704   use XML::SAX::PurePerl;

   705   my $handler = XML::Handler::Foo->new();

   706   my $parser = XML::SAX::PurePerl->new(Handler => $handler);

   707   $parser->parse_uri("myfile.xml");

   708 

   709 =head1 DESCRIPTION

   710 

   711 This module implements an XML parser in pure perl. It is written around the

   712 upcoming perl 5.8's unicode support and support for multiple document 

   713 encodings (using the PerlIO layer), however it has been ported to work with

   714 ASCII/UTF8 documents under lower perl versions.

   715 

   716 The SAX2 API is described in detail at http://sourceforge.net/projects/perl-xml/, in

   717 the CVS archive, under libxml-perl/docs. Hopefully those documents will be in a

   718 better location soon.

   719 

   720 Please refer to the SAX2 documentation for how to use this module - it is merely a

   721 front end to SAX2, and implements nothing that is not in that spec (or at least tries

   722 not to - please email me if you find errors in this implementation).

   723 

   724 =head1 BUGS

   725 

   726 XML::SAX::PurePerl is B<slow>. Very slow. I suggest you use something else

   727 in fact. However it is great as a fallback parser for XML::SAX, where the

   728 user might not be able to install an XS based parser or C library.

   729 

   730 Currently lots, probably. At the moment the weakest area is parsing DOCTYPE declarations,

   731 though the code is in place to start doing this. Also parsing parameter entity

   732 references is causing me much confusion, since it's not exactly what I would call

   733 trivial, or well documented in the XML grammar. XML documents with internal subsets

   734 are likely to fail.

   735 

   736 I am however trying to work towards full conformance using the Oasis test suite.

   737 

   738 =head1 AUTHOR

   739 

   740 Matt Sergeant, matt@sergeant.org. Copyright 2001.

   741 

   742 Please report all bugs to the Perl-XML mailing list at perl-xml@listserv.activestate.com.

   743 

   744 =head1 LICENSE

   745 

   746 This is free software. You may use it or redistribute it under the same terms as

   747 Perl 5.7.2 itself.

   748 

   749 =cut

   750