Import Upstream version 1.02
This commit is contained in:
su-fang
commit
661b9f3e47
|
|
@ -0,0 +1,108 @@
|
||||||
|
Revision history for Perl extension XML::SAX.
|
||||||
|
|
||||||
|
1.02 14 Jun 2019 Grant McLean
|
||||||
|
- Spelling fixes (patch from Ville Skyttä)
|
||||||
|
- Add repo location to metadata (patches from Ville Skyttä & Martin McGrath)
|
||||||
|
- Reorganise module files under lib/XML
|
||||||
|
- Regenerate MANIFEST using 'make manifest' to include missing test files
|
||||||
|
|
||||||
|
1.00 15 Feb 2018 Grant McLean
|
||||||
|
- Add makefile dependency to fix order of build steps RT#62289 (patch from
|
||||||
|
Ed J)
|
||||||
|
|
||||||
|
0.99 05 Sep 2011 Grant McLean
|
||||||
|
- Re-release without nested XML-SAX-Base distribution, add prereq instead
|
||||||
|
(note no other changes from 0.96 release)
|
||||||
|
|
||||||
|
0.96 06 Aug 2008 Grant McLean
|
||||||
|
- Fix breakage of Unicode regexes on 5.6 (introduced in 0.95 release)
|
||||||
|
|
||||||
|
0.95 05 Aug 2008 Grant McLean
|
||||||
|
- XML::SAX::PurePerl fixes:
|
||||||
|
- RT#37147: Fix handling of numeric character entities in attribute
|
||||||
|
values (report from Jools Smyth)
|
||||||
|
- RT#19442: Fix for numeric character entities spanning end of buffer
|
||||||
|
(report from Eivind Eklund)
|
||||||
|
- RT#29316: Performance fix for parsing from large strings (patch from
|
||||||
|
Gordon Lack)
|
||||||
|
- RT#26588: Fix for UTF8 bytes in first 4096 bytes of document not being
|
||||||
|
decoded to Perl-UTF8-characters (patch from Niko Tyni of the
|
||||||
|
Debian project)
|
||||||
|
- RT#37545: incorrect operator precedence breaks single quotes around
|
||||||
|
DTD entity declarations (report from Kevin Ryde)
|
||||||
|
- RT#28477: Fix test in ParserFactory.pm for parser module loaded (report
|
||||||
|
from Douglas Wilson)
|
||||||
|
- RT#28564: Fix XML::SAX::PurePerl versioning (report from Chapman Flack)
|
||||||
|
|
||||||
|
0.16 27 Jun 2007 Grant McLean
|
||||||
|
- Applied patch for PI handling from RT#19173
|
||||||
|
|
||||||
|
0.15 08 Feb 2007 Grant McLean
|
||||||
|
- Fixed handling of entities in attribute values
|
||||||
|
- Cleaned up some benign warnings
|
||||||
|
|
||||||
|
0.14 23 Apr 2006 Matt Sergeant
|
||||||
|
- Fixed CDATA section parsing (Uwe Voelker)
|
||||||
|
- Fix Makefile.PL for VMS
|
||||||
|
- Support calling set_handler() mid-parse
|
||||||
|
- Fix for when random modules overload UNIVERSAL::AUTOLOAD()
|
||||||
|
- Fix case when ParserDetails.ini isn't being updated but we are doing an
|
||||||
|
upgrade.
|
||||||
|
|
||||||
|
0.13 24 Oct 2005 Matt Sergeant
|
||||||
|
- Complete re-write of XML::SAX::PurePerl for performance
|
||||||
|
- Support Encoding & XMLVersion in DocumentLocator interface
|
||||||
|
- A few conformance tweaks to match perl SAX 2.1.
|
||||||
|
|
||||||
|
0.12 20 Nov 2002 Matt Sergeant
|
||||||
|
- Made sure SAX.ini works as documented
|
||||||
|
- Fixed when you specify Module (version)
|
||||||
|
|
||||||
|
0.11 03 Sep 2002 Matt Sergeant
|
||||||
|
- Base: Merged in XML::SAX::Base 1.04 (including memory leak fixes)
|
||||||
|
- ParserFactory: Made it do what the docs say when you specify
|
||||||
|
a module version number.
|
||||||
|
- SAX: Fixed XML::SAX::Intro typo.
|
||||||
|
- ParserFactory: Fixed (and test) broken version in parser pkg
|
||||||
|
|
||||||
|
0.10 14 Feb 2002 Matt Sergeant
|
||||||
|
- PurePerl: Fixed PubidChar missing '-'
|
||||||
|
- ParserFactory: Allow version in parser package
|
||||||
|
|
||||||
|
0.09 06 Feb 2002 Matt Sergeant
|
||||||
|
- PurePerl: Performance enhancements
|
||||||
|
- PurePerl: Line End handling implemented.
|
||||||
|
- PurePerl: Attribute Value Normalization implemented (mostly).
|
||||||
|
- PurePerl: Fixed element copying for end_element.
|
||||||
|
|
||||||
|
0.08 30 Jan 2002 Matt Sergeant
|
||||||
|
- Fixes for perl 5.7.2
|
||||||
|
|
||||||
|
0.07 29 Jan 2002 Matt Sergeant
|
||||||
|
- Fixed higher utf8 chars to work on both 5.005 and 5.6.1
|
||||||
|
(not tested on 5.6.0 since it's a bad perl)
|
||||||
|
|
||||||
|
0.06 28 Jan 2002 Matt Sergeant
|
||||||
|
- Fixed empty ParserDetails.ini bug
|
||||||
|
- Fixed overwriting ParserDetails.ini bug
|
||||||
|
- Added ability to specify dir to ParserDetails.ini
|
||||||
|
|
||||||
|
0.05 21 Jan 2002 Matt Sergeant
|
||||||
|
- Updated PREREQ_PM in Makefile.PL
|
||||||
|
- Updated Docs
|
||||||
|
|
||||||
|
0.04 21 Jan 2002 Matt Sergeant
|
||||||
|
- More PurePerl updates and fixes
|
||||||
|
- Added DocumentLocator class
|
||||||
|
- Added remove_parser() to XML::SAX
|
||||||
|
|
||||||
|
0.03 25 Nov 2001 Matt Sergeant
|
||||||
|
- Changes lost. Mostly PurePerl parser updates
|
||||||
|
|
||||||
|
0.02 14 Nov 2001 Matt Sergeant
|
||||||
|
- Removed windows line endings so perldocs look ok.
|
||||||
|
- Fixed some docs
|
||||||
|
|
||||||
|
0.01 Mon Nov 5 22:24:06 2001 Matt Sergeant
|
||||||
|
- original version; created by elves and penguins v1.32
|
||||||
|
|
||||||
|
|
@ -0,0 +1,7 @@
|
||||||
|
XML::SAX is dual licensed under the same terms as Perl itself.
|
||||||
|
|
||||||
|
This means at your choice, either the Perl Artistic License, or
|
||||||
|
the GNU GPL version 1 or higher.
|
||||||
|
|
||||||
|
(should we include the full text here?)
|
||||||
|
|
||||||
|
|
@ -0,0 +1,62 @@
|
||||||
|
Changes
|
||||||
|
lib/XML/SAX.pm
|
||||||
|
lib/XML/SAX/DocumentLocator.pm
|
||||||
|
lib/XML/SAX/Intro.pod
|
||||||
|
lib/XML/SAX/ParserFactory.pm
|
||||||
|
lib/XML/SAX/PurePerl.pm
|
||||||
|
lib/XML/SAX/PurePerl/DebugHandler.pm
|
||||||
|
lib/XML/SAX/PurePerl/DocType.pm
|
||||||
|
lib/XML/SAX/PurePerl/DTDDecls.pm
|
||||||
|
lib/XML/SAX/PurePerl/EncodingDetect.pm
|
||||||
|
lib/XML/SAX/PurePerl/Exception.pm
|
||||||
|
lib/XML/SAX/PurePerl/NoUnicodeExt.pm
|
||||||
|
lib/XML/SAX/PurePerl/Productions.pm
|
||||||
|
lib/XML/SAX/PurePerl/Reader.pm
|
||||||
|
lib/XML/SAX/PurePerl/Reader/NoUnicodeExt.pm
|
||||||
|
lib/XML/SAX/PurePerl/Reader/Stream.pm
|
||||||
|
lib/XML/SAX/PurePerl/Reader/String.pm
|
||||||
|
lib/XML/SAX/PurePerl/Reader/UnicodeExt.pm
|
||||||
|
lib/XML/SAX/PurePerl/Reader/URI.pm
|
||||||
|
lib/XML/SAX/PurePerl/UnicodeExt.pm
|
||||||
|
lib/XML/SAX/PurePerl/XMLDecl.pm
|
||||||
|
LICENSE
|
||||||
|
Makefile.PL
|
||||||
|
MANIFEST
|
||||||
|
META.yml Module meta-data (added by MakeMaker)
|
||||||
|
README
|
||||||
|
t/00basic.t
|
||||||
|
t/01known.t
|
||||||
|
t/10xmldecl1.t
|
||||||
|
t/11xmldecl2.t
|
||||||
|
t/12miscstart.t
|
||||||
|
t/13int_ent.t
|
||||||
|
t/14encoding.t
|
||||||
|
t/15element.t
|
||||||
|
t/16large.t
|
||||||
|
t/19pi.t
|
||||||
|
t/20factory.t
|
||||||
|
t/21saxini.t
|
||||||
|
t/30parse_file.t
|
||||||
|
t/40cdata.t
|
||||||
|
t/42entities.t
|
||||||
|
t/99cleanup.t
|
||||||
|
testfiles/01.xml
|
||||||
|
testfiles/02a.xml
|
||||||
|
testfiles/02b.xml
|
||||||
|
testfiles/03a.xml
|
||||||
|
testfiles/03b.xml
|
||||||
|
testfiles/04a.xml
|
||||||
|
testfiles/06a.xml
|
||||||
|
testfiles/06b.xml
|
||||||
|
testfiles/06c.xml
|
||||||
|
testfiles/06d.xml
|
||||||
|
testfiles/06e.xml
|
||||||
|
testfiles/06f.xml
|
||||||
|
testfiles/06g.xml
|
||||||
|
testfiles/iso8859_1.xml
|
||||||
|
testfiles/iso8859_2.xml
|
||||||
|
testfiles/koi8_r.xml
|
||||||
|
testfiles/utf-16.xml
|
||||||
|
testfiles/utf-16le.xml
|
||||||
|
testfiles/xmltest.xml
|
||||||
|
META.json Module JSON meta-data (added by MakeMaker)
|
||||||
|
|
@ -0,0 +1,50 @@
|
||||||
|
{
|
||||||
|
"abstract" : "unknown",
|
||||||
|
"author" : [
|
||||||
|
"unknown"
|
||||||
|
],
|
||||||
|
"dynamic_config" : 1,
|
||||||
|
"generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005",
|
||||||
|
"license" : [
|
||||||
|
"unknown"
|
||||||
|
],
|
||||||
|
"meta-spec" : {
|
||||||
|
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
|
||||||
|
"version" : "2"
|
||||||
|
},
|
||||||
|
"name" : "XML-SAX",
|
||||||
|
"no_index" : {
|
||||||
|
"directory" : [
|
||||||
|
"t",
|
||||||
|
"inc"
|
||||||
|
]
|
||||||
|
},
|
||||||
|
"prereqs" : {
|
||||||
|
"build" : {
|
||||||
|
"requires" : {
|
||||||
|
"ExtUtils::MakeMaker" : "0"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"configure" : {
|
||||||
|
"requires" : {
|
||||||
|
"ExtUtils::MakeMaker" : "0"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"runtime" : {
|
||||||
|
"requires" : {
|
||||||
|
"File::Temp" : "0",
|
||||||
|
"XML::NamespaceSupport" : "0.03",
|
||||||
|
"XML::SAX::Base" : "1.05"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"release_status" : "stable",
|
||||||
|
"resources" : {
|
||||||
|
"repository" : {
|
||||||
|
"type" : "git",
|
||||||
|
"web" : "https://github.com/grantm/xml-sax"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"version" : "1.02",
|
||||||
|
"x_serialization_backend" : "JSON::PP version 2.27300"
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,27 @@
|
||||||
|
---
|
||||||
|
abstract: unknown
|
||||||
|
author:
|
||||||
|
- unknown
|
||||||
|
build_requires:
|
||||||
|
ExtUtils::MakeMaker: '0'
|
||||||
|
configure_requires:
|
||||||
|
ExtUtils::MakeMaker: '0'
|
||||||
|
dynamic_config: 1
|
||||||
|
generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005'
|
||||||
|
license: unknown
|
||||||
|
meta-spec:
|
||||||
|
url: http://module-build.sourceforge.net/META-spec-v1.4.html
|
||||||
|
version: '1.4'
|
||||||
|
name: XML-SAX
|
||||||
|
no_index:
|
||||||
|
directory:
|
||||||
|
- t
|
||||||
|
- inc
|
||||||
|
requires:
|
||||||
|
File::Temp: '0'
|
||||||
|
XML::NamespaceSupport: '0.03'
|
||||||
|
XML::SAX::Base: '1.05'
|
||||||
|
resources:
|
||||||
|
repository: https://github.com/grantm/xml-sax
|
||||||
|
version: '1.02'
|
||||||
|
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
|
||||||
|
|
@ -0,0 +1,64 @@
|
||||||
|
use ExtUtils::MakeMaker;
|
||||||
|
use File::Basename ();
|
||||||
|
use File::Spec ();
|
||||||
|
|
||||||
|
|
||||||
|
WriteMakefile(
|
||||||
|
'NAME' => 'XML::SAX',
|
||||||
|
'VERSION_FROM' => 'lib/XML/SAX.pm', # finds $VERSION
|
||||||
|
'PREREQ_PM' => {
|
||||||
|
'File::Temp' => 0,
|
||||||
|
'XML::SAX::Base' => 1.05,
|
||||||
|
'XML::NamespaceSupport' => 0.03,
|
||||||
|
},
|
||||||
|
META_MERGE => {
|
||||||
|
"meta-spec" => { version => 2 },
|
||||||
|
resources => {
|
||||||
|
repository => {
|
||||||
|
type => 'git',
|
||||||
|
url => 'git@github.com:grantm/XML-SAX.git',
|
||||||
|
web => 'https://github.com/grantm/xml-sax',
|
||||||
|
},
|
||||||
|
},
|
||||||
|
},
|
||||||
|
);
|
||||||
|
|
||||||
|
sub MY::install {
|
||||||
|
package MY;
|
||||||
|
my $script = shift->SUPER::install(@_);
|
||||||
|
|
||||||
|
# Only modify existing ParserDetails.ini if user agrees
|
||||||
|
|
||||||
|
my $write_ini_ok = 0;
|
||||||
|
|
||||||
|
eval { require XML::SAX };
|
||||||
|
if ($@) {
|
||||||
|
$write_ini_ok = 1;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
my $dir = File::Basename::dirname($INC{'XML/SAX.pm'});
|
||||||
|
if (-e File::Spec->catfile($dir, 'SAX', 'ParserDetails.ini')) {
|
||||||
|
$write_ini_ok =
|
||||||
|
ExtUtils::MakeMaker::prompt(
|
||||||
|
"Do you want XML::SAX to alter ParserDetails.ini?", "Y"
|
||||||
|
) =~ /^y/i;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$write_ini_ok = 1;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($write_ini_ok) {
|
||||||
|
$script =~ s/install :: (.*)$/install :: $1 install_sax_pureperl/m;
|
||||||
|
$script .= <<"INSTALL";
|
||||||
|
|
||||||
|
install_sax_pureperl : pure_install
|
||||||
|
\t\@\$(PERL) -MXML::SAX -e "XML::SAX->add_parser(q(XML::SAX::PurePerl))->save_parsers()"
|
||||||
|
|
||||||
|
INSTALL
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
return $script;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
@ -0,0 +1,47 @@
|
||||||
|
XML::SAX
|
||||||
|
========
|
||||||
|
|
||||||
|
XML::SAX consists of several framework classes for using and building
|
||||||
|
Perl SAX2 XML parsers, filters, and drivers. It is designed around the
|
||||||
|
need to be able to "plug in" different SAX parsers to an application
|
||||||
|
without requiring programmer intervention. Those of you familiar with
|
||||||
|
the DBI will be right at home. Some of the designs come from the Java
|
||||||
|
JAXP specification (SAX part), only without the javaness.
|
||||||
|
|
||||||
|
INSTALLATION
|
||||||
|
============
|
||||||
|
|
||||||
|
All of this is 100% perl, so installation should be a breeze:
|
||||||
|
|
||||||
|
On Unix and Unix-like platforms:
|
||||||
|
|
||||||
|
$ perl Makefile.PL
|
||||||
|
$ make
|
||||||
|
$ make test
|
||||||
|
$ make install
|
||||||
|
|
||||||
|
On ActivePerl, or Perl's built with MSVC:
|
||||||
|
|
||||||
|
$ perl Makefile.PL
|
||||||
|
$ nmake
|
||||||
|
$ nmake test
|
||||||
|
$ nmake install
|
||||||
|
|
||||||
|
USAGE
|
||||||
|
=====
|
||||||
|
|
||||||
|
For usage, please read the included documentation after installation:
|
||||||
|
|
||||||
|
$ perldoc XML::SAX
|
||||||
|
$ perldoc XML::SAX::ParserFactory
|
||||||
|
|
||||||
|
And other documents leading off those pages.
|
||||||
|
|
||||||
|
LICENSE/COPYRIGHT
|
||||||
|
=================
|
||||||
|
|
||||||
|
Please see the LICENSE file for licensing issues.
|
||||||
|
|
||||||
|
The files in this distribution are copyrighted their respective authors
|
||||||
|
as detailed in the POD documentation of each module.
|
||||||
|
|
||||||
|
|
@ -0,0 +1,379 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use vars qw($VERSION @ISA @EXPORT_OK);
|
||||||
|
|
||||||
|
$VERSION = '1.02';
|
||||||
|
|
||||||
|
use Exporter ();
|
||||||
|
@ISA = ('Exporter');
|
||||||
|
|
||||||
|
@EXPORT_OK = qw(Namespaces Validation);
|
||||||
|
|
||||||
|
use File::Basename qw(dirname);
|
||||||
|
use File::Spec ();
|
||||||
|
use Symbol qw(gensym);
|
||||||
|
use XML::SAX::ParserFactory (); # loaded for simplicity
|
||||||
|
|
||||||
|
use constant PARSER_DETAILS => "ParserDetails.ini";
|
||||||
|
|
||||||
|
use constant Namespaces => "http://xml.org/sax/features/namespaces";
|
||||||
|
use constant Validation => "http://xml.org/sax/features/validation";
|
||||||
|
|
||||||
|
my $known_parsers = undef;
|
||||||
|
|
||||||
|
# load_parsers takes the ParserDetails.ini file out of the same directory
|
||||||
|
# that XML::SAX is in, and looks at it. Format in POD below
|
||||||
|
|
||||||
|
=begin EXAMPLE
|
||||||
|
|
||||||
|
[XML::SAX::PurePerl]
|
||||||
|
http://xml.org/sax/features/namespaces = 1
|
||||||
|
http://xml.org/sax/features/validation = 0
|
||||||
|
# a comment
|
||||||
|
|
||||||
|
# blank lines ignored
|
||||||
|
|
||||||
|
[XML::SAX::AnotherParser]
|
||||||
|
http://xml.org/sax/features/namespaces = 0
|
||||||
|
http://xml.org/sax/features/validation = 1
|
||||||
|
|
||||||
|
=end EXAMPLE
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
sub load_parsers {
|
||||||
|
my $class = shift;
|
||||||
|
my $dir = shift;
|
||||||
|
|
||||||
|
# reset parsers
|
||||||
|
$known_parsers = [];
|
||||||
|
|
||||||
|
# get directory from wherever XML::SAX is installed
|
||||||
|
if (!$dir) {
|
||||||
|
$dir = $INC{'XML/SAX.pm'};
|
||||||
|
$dir = dirname($dir);
|
||||||
|
}
|
||||||
|
|
||||||
|
my $fh = gensym();
|
||||||
|
if (!open($fh, File::Spec->catfile($dir, "SAX", PARSER_DETAILS))) {
|
||||||
|
XML::SAX->do_warn("could not find " . PARSER_DETAILS . " in $dir/SAX\n");
|
||||||
|
return $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
$known_parsers = $class->_parse_ini_file($fh);
|
||||||
|
|
||||||
|
return $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _parse_ini_file {
|
||||||
|
my $class = shift;
|
||||||
|
my ($fh) = @_;
|
||||||
|
|
||||||
|
my @config;
|
||||||
|
|
||||||
|
my $lineno = 0;
|
||||||
|
while (defined(my $line = <$fh>)) {
|
||||||
|
$lineno++;
|
||||||
|
my $original = $line;
|
||||||
|
# strip whitespace
|
||||||
|
$line =~ s/\s*$//m;
|
||||||
|
$line =~ s/^\s*//m;
|
||||||
|
# strip comments
|
||||||
|
$line =~ s/[#;].*$//m;
|
||||||
|
# ignore blanks
|
||||||
|
next if $line =~ /^$/m;
|
||||||
|
|
||||||
|
# heading
|
||||||
|
if ($line =~ /^\[\s*(.*)\s*\]$/m) {
|
||||||
|
push @config, { Name => $1 };
|
||||||
|
next;
|
||||||
|
}
|
||||||
|
|
||||||
|
# instruction
|
||||||
|
elsif ($line =~ /^(.*?)\s*?=\s*(.*)$/) {
|
||||||
|
unless(@config) {
|
||||||
|
push @config, { Name => '' };
|
||||||
|
}
|
||||||
|
$config[-1]{Features}{$1} = $2;
|
||||||
|
}
|
||||||
|
|
||||||
|
# not whitespace, comment, or instruction
|
||||||
|
else {
|
||||||
|
die "Invalid line in ini: $lineno\n>>> $original\n";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return \@config;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub parsers {
|
||||||
|
my $class = shift;
|
||||||
|
if (!$known_parsers) {
|
||||||
|
$class->load_parsers();
|
||||||
|
}
|
||||||
|
return $known_parsers;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub remove_parser {
|
||||||
|
my $class = shift;
|
||||||
|
my ($parser_module) = @_;
|
||||||
|
|
||||||
|
if (!$known_parsers) {
|
||||||
|
$class->load_parsers();
|
||||||
|
}
|
||||||
|
|
||||||
|
@$known_parsers = grep { $_->{Name} ne $parser_module } @$known_parsers;
|
||||||
|
|
||||||
|
return $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub add_parser {
|
||||||
|
my $class = shift;
|
||||||
|
my ($parser_module) = @_;
|
||||||
|
|
||||||
|
if (!$known_parsers) {
|
||||||
|
$class->load_parsers();
|
||||||
|
}
|
||||||
|
|
||||||
|
# first load module, then query features, then push onto known_parsers,
|
||||||
|
|
||||||
|
my $parser_file = $parser_module;
|
||||||
|
$parser_file =~ s/::/\//g;
|
||||||
|
$parser_file .= ".pm";
|
||||||
|
|
||||||
|
require $parser_file;
|
||||||
|
|
||||||
|
my @features = $parser_module->supported_features();
|
||||||
|
|
||||||
|
my $new = { Name => $parser_module };
|
||||||
|
foreach my $feature (@features) {
|
||||||
|
$new->{Features}{$feature} = 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
# If exists in list already, move to end.
|
||||||
|
my $done = 0;
|
||||||
|
my $pos = undef;
|
||||||
|
for (my $i = 0; $i < @$known_parsers; $i++) {
|
||||||
|
my $p = $known_parsers->[$i];
|
||||||
|
if ($p->{Name} eq $parser_module) {
|
||||||
|
$pos = $i;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
if (defined $pos) {
|
||||||
|
splice(@$known_parsers, $pos, 1);
|
||||||
|
push @$known_parsers, $new;
|
||||||
|
$done++;
|
||||||
|
}
|
||||||
|
|
||||||
|
# Otherwise (not in list), add at end of list.
|
||||||
|
if (!$done) {
|
||||||
|
push @$known_parsers, $new;
|
||||||
|
}
|
||||||
|
|
||||||
|
return $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub save_parsers {
|
||||||
|
my $class = shift;
|
||||||
|
|
||||||
|
# get directory from wherever XML::SAX is installed
|
||||||
|
my $dir = $INC{'XML/SAX.pm'};
|
||||||
|
$dir = dirname($dir);
|
||||||
|
|
||||||
|
my $file = File::Spec->catfile($dir, "SAX", PARSER_DETAILS);
|
||||||
|
chmod 0644, $file;
|
||||||
|
unlink($file);
|
||||||
|
|
||||||
|
my $fh = gensym();
|
||||||
|
open($fh, ">$file") ||
|
||||||
|
die "Cannot write to $file: $!";
|
||||||
|
|
||||||
|
foreach my $p (@$known_parsers) {
|
||||||
|
print $fh "[$p->{Name}]\n";
|
||||||
|
foreach my $key (keys %{$p->{Features}}) {
|
||||||
|
print $fh "$key = $p->{Features}{$key}\n";
|
||||||
|
}
|
||||||
|
print $fh "\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
print $fh "\n";
|
||||||
|
|
||||||
|
close $fh;
|
||||||
|
|
||||||
|
return $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub do_warn {
|
||||||
|
my $class = shift;
|
||||||
|
# Don't output warnings if running under Test::Harness
|
||||||
|
warn(@_) unless $ENV{HARNESS_ACTIVE};
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
__END__
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
XML::SAX - Simple API for XML
|
||||||
|
|
||||||
|
=head1 SYNOPSIS
|
||||||
|
|
||||||
|
use XML::SAX;
|
||||||
|
|
||||||
|
# get a list of known parsers
|
||||||
|
my $parsers = XML::SAX->parsers();
|
||||||
|
|
||||||
|
# add/update a parser
|
||||||
|
XML::SAX->add_parser(q(XML::SAX::PurePerl));
|
||||||
|
|
||||||
|
# remove parser
|
||||||
|
XML::SAX->remove_parser(q(XML::SAX::Foodelberry));
|
||||||
|
|
||||||
|
# save parsers
|
||||||
|
XML::SAX->save_parsers();
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
|
||||||
|
XML::SAX is a SAX parser access API for Perl. It includes classes
|
||||||
|
and APIs required for implementing SAX drivers, along with a factory
|
||||||
|
class for returning any SAX parser installed on the user's system.
|
||||||
|
|
||||||
|
=head1 USING A SAX2 PARSER
|
||||||
|
|
||||||
|
The factory class is XML::SAX::ParserFactory. Please see the
|
||||||
|
documentation of that module for how to instantiate a SAX parser:
|
||||||
|
L<XML::SAX::ParserFactory>. However if you don't want to load up
|
||||||
|
another manual page, here's a short synopsis:
|
||||||
|
|
||||||
|
use XML::SAX::ParserFactory;
|
||||||
|
use XML::SAX::XYZHandler;
|
||||||
|
my $handler = XML::SAX::XYZHandler->new();
|
||||||
|
my $p = XML::SAX::ParserFactory->parser(Handler => $handler);
|
||||||
|
$p->parse_uri("foo.xml");
|
||||||
|
# or $p->parse_string("<foo/>") or $p->parse_file($fh);
|
||||||
|
|
||||||
|
This will automatically load a SAX2 parser (defaulting to
|
||||||
|
XML::SAX::PurePerl if no others are found) and return it to you.
|
||||||
|
|
||||||
|
In order to learn how to use SAX to parse XML, you will need to read
|
||||||
|
L<XML::SAX::Intro> and for reference, L<XML::SAX::Specification>.
|
||||||
|
|
||||||
|
=head1 WRITING A SAX2 PARSER
|
||||||
|
|
||||||
|
The first thing to remember in writing a SAX2 parser is to subclass
|
||||||
|
XML::SAX::Base. This will make your life infinitely easier, by providing
|
||||||
|
a number of methods automagically for you. See L<XML::SAX::Base> for more
|
||||||
|
details.
|
||||||
|
|
||||||
|
When writing a SAX2 parser that is compatible with XML::SAX, you need
|
||||||
|
to inform XML::SAX of the presence of that driver when you install it.
|
||||||
|
In order to do that, XML::SAX contains methods for saving the fact that
|
||||||
|
the parser exists on your system to a "INI" file, which is then loaded
|
||||||
|
to determine which parsers are installed.
|
||||||
|
|
||||||
|
The best way to do this is to follow these rules:
|
||||||
|
|
||||||
|
=over 4
|
||||||
|
|
||||||
|
=item * Add XML::SAX as a prerequisite in Makefile.PL:
|
||||||
|
|
||||||
|
WriteMakefile(
|
||||||
|
...
|
||||||
|
PREREQ_PM => { 'XML::SAX' => 0 },
|
||||||
|
...
|
||||||
|
);
|
||||||
|
|
||||||
|
Alternatively you may wish to check for it in other ways that will
|
||||||
|
cause more than just a warning.
|
||||||
|
|
||||||
|
=item * Add the following code snippet to your Makefile.PL:
|
||||||
|
|
||||||
|
sub MY::install {
|
||||||
|
package MY;
|
||||||
|
my $script = shift->SUPER::install(@_);
|
||||||
|
if (ExtUtils::MakeMaker::prompt(
|
||||||
|
"Do you want to modify ParserDetails.ini?", 'Y')
|
||||||
|
=~ /^y/i) {
|
||||||
|
$script =~ s/install :: (.*)$/install :: $1 install_sax_driver/m;
|
||||||
|
$script .= <<"INSTALL";
|
||||||
|
|
||||||
|
install_sax_driver :
|
||||||
|
\t\@\$(PERL) -MXML::SAX -e "XML::SAX->add_parser(q(\$(NAME)))->save_parsers()"
|
||||||
|
|
||||||
|
INSTALL
|
||||||
|
}
|
||||||
|
return $script;
|
||||||
|
}
|
||||||
|
|
||||||
|
Note that you should check the output of this - \$(NAME) will use the name of
|
||||||
|
your distribution, which may not be exactly what you want. For example XML::LibXML
|
||||||
|
has a driver called XML::LibXML::SAX::Generator, which is used in place of
|
||||||
|
\$(NAME) in the above.
|
||||||
|
|
||||||
|
=item * Add an XML::SAX test:
|
||||||
|
|
||||||
|
A test file should be added to your t/ directory containing something like the
|
||||||
|
following:
|
||||||
|
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 3 }
|
||||||
|
use XML::SAX;
|
||||||
|
use XML::SAX::PurePerl::DebugHandler;
|
||||||
|
XML::SAX->add_parser(q(XML::SAX::MyDriver));
|
||||||
|
local $XML::SAX::ParserPackage = 'XML::SAX::MyDriver';
|
||||||
|
eval {
|
||||||
|
my $handler = XML::SAX::PurePerl::DebugHandler->new();
|
||||||
|
ok($handler);
|
||||||
|
my $parser = XML::SAX::ParserFactory->parser(Handler => $handler);
|
||||||
|
ok($parser);
|
||||||
|
ok($parser->isa('XML::SAX::MyDriver');
|
||||||
|
$parser->parse_string("<tag/>");
|
||||||
|
ok($handler->{seen}{start_element});
|
||||||
|
};
|
||||||
|
|
||||||
|
=back
|
||||||
|
|
||||||
|
=head1 EXPORTS
|
||||||
|
|
||||||
|
By default, XML::SAX exports nothing into the caller's namespace. However you
|
||||||
|
can request the symbols C<Namespaces> and C<Validation> which are the
|
||||||
|
URIs for those features, allowing an easier way to request those features
|
||||||
|
via ParserFactory:
|
||||||
|
|
||||||
|
use XML::SAX qw(Namespaces Validation);
|
||||||
|
my $factory = XML::SAX::ParserFactory->new();
|
||||||
|
$factory->require_feature(Namespaces);
|
||||||
|
$factory->require_feature(Validation);
|
||||||
|
my $parser = $factory->parser();
|
||||||
|
|
||||||
|
=head1 AUTHOR
|
||||||
|
|
||||||
|
Current maintainer: Grant McLean, grantm@cpan.org
|
||||||
|
|
||||||
|
Originally written by:
|
||||||
|
|
||||||
|
Matt Sergeant, matt@sergeant.org
|
||||||
|
|
||||||
|
Kip Hampton, khampton@totalcinema.com
|
||||||
|
|
||||||
|
Robin Berjon, robin@knowscape.com
|
||||||
|
|
||||||
|
=head1 LICENSE
|
||||||
|
|
||||||
|
This is free software, you may use it and distribute it under
|
||||||
|
the same terms as Perl itself.
|
||||||
|
|
||||||
|
=head1 SEE ALSO
|
||||||
|
|
||||||
|
L<XML::SAX::Base> for writing SAX Filters and Parsers
|
||||||
|
|
||||||
|
L<XML::SAX::PurePerl> for an XML parser written in 100%
|
||||||
|
pure perl.
|
||||||
|
|
||||||
|
L<XML::SAX::Exception> for details on exception handling
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
|
@ -0,0 +1,134 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::DocumentLocator;
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $class = shift;
|
||||||
|
my %object;
|
||||||
|
tie %object, $class, @_;
|
||||||
|
|
||||||
|
return bless \%object, $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub TIEHASH {
|
||||||
|
my $class = shift;
|
||||||
|
my ($pubmeth, $sysmeth, $linemeth, $colmeth, $encmeth, $xmlvmeth) = @_;
|
||||||
|
return bless {
|
||||||
|
pubmeth => $pubmeth,
|
||||||
|
sysmeth => $sysmeth,
|
||||||
|
linemeth => $linemeth,
|
||||||
|
colmeth => $colmeth,
|
||||||
|
encmeth => $encmeth,
|
||||||
|
xmlvmeth => $xmlvmeth,
|
||||||
|
}, $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub FETCH {
|
||||||
|
my ($self, $key) = @_;
|
||||||
|
my $method;
|
||||||
|
if ($key eq 'PublicId') {
|
||||||
|
$method = $self->{pubmeth};
|
||||||
|
}
|
||||||
|
elsif ($key eq 'SystemId') {
|
||||||
|
$method = $self->{sysmeth};
|
||||||
|
}
|
||||||
|
elsif ($key eq 'LineNumber') {
|
||||||
|
$method = $self->{linemeth};
|
||||||
|
}
|
||||||
|
elsif ($key eq 'ColumnNumber') {
|
||||||
|
$method = $self->{colmeth};
|
||||||
|
}
|
||||||
|
elsif ($key eq 'Encoding') {
|
||||||
|
$method = $self->{encmeth};
|
||||||
|
}
|
||||||
|
elsif ($key eq 'XMLVersion') {
|
||||||
|
$method = $self->{xmlvmeth};
|
||||||
|
}
|
||||||
|
if ($method) {
|
||||||
|
my $value = $method->($key);
|
||||||
|
return $value;
|
||||||
|
}
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub EXISTS {
|
||||||
|
my ($self, $key) = @_;
|
||||||
|
if ($key =~ /^(PublicId|SystemId|LineNumber|ColumnNumber|Encoding|XMLVersion)$/) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub STORE {
|
||||||
|
my ($self, $key, $value) = @_;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub DELETE {
|
||||||
|
my ($self, $key) = @_;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub CLEAR {
|
||||||
|
my ($self) = @_;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub FIRSTKEY {
|
||||||
|
my ($self) = @_;
|
||||||
|
# assignment resets.
|
||||||
|
$self->{keys} = {
|
||||||
|
PublicId => 1,
|
||||||
|
SystemId => 1,
|
||||||
|
LineNumber => 1,
|
||||||
|
ColumnNumber => 1,
|
||||||
|
Encoding => 1,
|
||||||
|
XMLVersion => 1,
|
||||||
|
};
|
||||||
|
return each %{$self->{keys}};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub NEXTKEY {
|
||||||
|
my ($self, $lastkey) = @_;
|
||||||
|
return each %{$self->{keys}};
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
__END__
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
XML::SAX::DocumentLocator - Helper class for document locators
|
||||||
|
|
||||||
|
=head1 SYNOPSIS
|
||||||
|
|
||||||
|
my $locator = XML::SAX::DocumentLocator->new(
|
||||||
|
sub { $object->get_public_id },
|
||||||
|
sub { $object->get_system_id },
|
||||||
|
sub { $reader->current_line },
|
||||||
|
sub { $reader->current_column },
|
||||||
|
sub { $reader->get_encoding },
|
||||||
|
sub { $reader->get_xml_version },
|
||||||
|
);
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
|
||||||
|
This module gives you a tied hash reference that calls the
|
||||||
|
specified closures when asked for PublicId, SystemId,
|
||||||
|
LineNumber and ColumnNumber.
|
||||||
|
|
||||||
|
It is useful for writing SAX Parsers so that you don't have
|
||||||
|
to constantly update the line numbers in a hash reference on
|
||||||
|
the object you pass to set_document_locator(). See the source
|
||||||
|
code for XML::SAX::PurePerl for a usage example.
|
||||||
|
|
||||||
|
=head1 API
|
||||||
|
|
||||||
|
There is only 1 method: C<new>. Simply pass it a list of
|
||||||
|
closures that when called will return the PublicId, the
|
||||||
|
SystemId, the LineNumber, the ColumnNumber, the Encoding
|
||||||
|
and the XMLVersion respectively.
|
||||||
|
|
||||||
|
The closures are passed a single parameter, the key being
|
||||||
|
requested. But you're free to ignore that.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
|
@ -0,0 +1,407 @@
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
XML::SAX::Intro - An Introduction to SAX Parsing with Perl
|
||||||
|
|
||||||
|
=head1 Introduction
|
||||||
|
|
||||||
|
XML::SAX is a new way to work with XML Parsers in Perl. In this article
|
||||||
|
we'll discuss why you should be using SAX, why you should be using
|
||||||
|
XML::SAX, and we'll see some of the finer implementation details. The
|
||||||
|
text below assumes some familiarity with callback, or push based
|
||||||
|
parsing, but if you are unfamiliar with these techniques then a good
|
||||||
|
place to start is Kip Hampton's excellent series of articles on XML.com.
|
||||||
|
|
||||||
|
=head1 Replacing XML::Parser
|
||||||
|
|
||||||
|
The de-facto way of parsing XML under perl is to use Larry Wall and
|
||||||
|
Clark Cooper's XML::Parser. This module is a Perl and XS wrapper around
|
||||||
|
the expat XML parser library by James Clark. It has been a hugely
|
||||||
|
successful project, but suffers from a couple of rather major flaws.
|
||||||
|
Firstly it is a proprietary API, designed before the SAX API was
|
||||||
|
conceived, which means that it is not easily replaceable by other
|
||||||
|
streaming parsers. Secondly it's callbacks are subrefs. This doesn't
|
||||||
|
sound like much of an issue, but unfortunately leads to code like:
|
||||||
|
|
||||||
|
sub handle_start {
|
||||||
|
my ($e, $el, %attrs) = @_;
|
||||||
|
if ($el eq 'foo') {
|
||||||
|
$e->{inside_foo}++; # BAD! $e is an XML::Parser::Expat object.
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
As you can see, we're using the $e object to hold our state
|
||||||
|
information, which is a bad idea because we don't own that object - we
|
||||||
|
didn't create it. It's an internal object of XML::Parser, that happens
|
||||||
|
to be a hashref. We could all too easily overwrite XML::Parser internal
|
||||||
|
state variables by using this, or Clark could change it to an array ref
|
||||||
|
(not that he would, because it would break so much code, but he could).
|
||||||
|
|
||||||
|
The only way currently with XML::Parser to safely maintain state is to
|
||||||
|
use a closure:
|
||||||
|
|
||||||
|
my $state = MyState->new();
|
||||||
|
$parser->setHandlers(Start => sub { handle_start($state, @_) });
|
||||||
|
|
||||||
|
This closure traps the $state variable, which now gets passed as the
|
||||||
|
first parameter to your callback. Unfortunately very few people use
|
||||||
|
this technique, as it is not documented in the XML::Parser POD files.
|
||||||
|
|
||||||
|
Another reason you might not want to use XML::Parser is because you
|
||||||
|
need some feature that it doesn't provide (such as validation), or you
|
||||||
|
might need to use a library that doesn't use expat, due to it not being
|
||||||
|
installed on your system, or due to having a restrictive ISP. Using SAX
|
||||||
|
allows you to work around these restrictions.
|
||||||
|
|
||||||
|
=head1 Introducing SAX
|
||||||
|
|
||||||
|
SAX stands for the Simple API for XML. And simple it really is.
|
||||||
|
Constructing a SAX parser and passing events to handlers is done as
|
||||||
|
simply as:
|
||||||
|
|
||||||
|
use XML::SAX;
|
||||||
|
use MySAXHandler;
|
||||||
|
|
||||||
|
my $parser = XML::SAX::ParserFactory->parser(
|
||||||
|
Handler => MySAXHandler->new
|
||||||
|
);
|
||||||
|
|
||||||
|
$parser->parse_uri("foo.xml");
|
||||||
|
|
||||||
|
The important concept to grasp here is that SAX uses a factory class
|
||||||
|
called XML::SAX::ParserFactory to create a new parser instance. The
|
||||||
|
reason for this is so that you can support other underlying
|
||||||
|
parser implementations for different feature sets. This is one thing
|
||||||
|
that XML::Parser has always sorely lacked.
|
||||||
|
|
||||||
|
In the code above we see the parse_uri method used, but we could
|
||||||
|
have equally well
|
||||||
|
called parse_file, parse_string, or parse(). Please see XML::SAX::Base
|
||||||
|
for what these methods take as parameters, but don't be fooled into
|
||||||
|
believing parse_file takes a filename. No, it takes a file handle, a
|
||||||
|
glob, or a subclass of IO::Handle. Beware.
|
||||||
|
|
||||||
|
SAX works very similarly to XML::Parser's default callback method,
|
||||||
|
except it has one major difference: rather than setting individual
|
||||||
|
callbacks, you create a new class in which to receive the callbacks.
|
||||||
|
Each callback is called as a method call on an instance of that handler
|
||||||
|
class. An example will best demonstrate this:
|
||||||
|
|
||||||
|
package MySAXHandler;
|
||||||
|
use base qw(XML::SAX::Base);
|
||||||
|
|
||||||
|
sub start_document {
|
||||||
|
my ($self, $doc) = @_;
|
||||||
|
# process document start event
|
||||||
|
}
|
||||||
|
|
||||||
|
sub start_element {
|
||||||
|
my ($self, $el) = @_;
|
||||||
|
# process element start event
|
||||||
|
}
|
||||||
|
|
||||||
|
Now, when we instantiate this as above, and parse some XML with this as
|
||||||
|
the handler, the methods start_document and start_element will be
|
||||||
|
called as method calls, so this would be the equivalent of directly
|
||||||
|
calling:
|
||||||
|
|
||||||
|
$object->start_element($el);
|
||||||
|
|
||||||
|
Notice how this is different to XML::Parser's calling style, which
|
||||||
|
calls:
|
||||||
|
|
||||||
|
start_element($e, $name, %attribs);
|
||||||
|
|
||||||
|
It's the difference between function calling and method calling which
|
||||||
|
allows you to subclass SAX handlers which contributes to SAX being a
|
||||||
|
powerful solution.
|
||||||
|
|
||||||
|
As you can see, unlike XML::Parser, we have to define a new package in
|
||||||
|
which to do our processing (there are hacks you can do to make this
|
||||||
|
uneccessary, but I'll leave figuring those out to the experts). The
|
||||||
|
biggest benefit of this is that you maintain your own state variable
|
||||||
|
($self in the above example) thus freeing you of the concerns listed
|
||||||
|
above. It is also an improvement in maintainability - you can place the
|
||||||
|
code in a separate file if you wish to, and your callback methods are
|
||||||
|
always called the same thing, rather than having to choose a suitable
|
||||||
|
name for them as you had to with XML::Parser. This is an obvious win.
|
||||||
|
|
||||||
|
SAX parsers are also very flexible in how you pass a handler to them.
|
||||||
|
You can use a constructor parameter as we saw above, or we can pass the
|
||||||
|
handler directly in the call to one of the parse methods:
|
||||||
|
|
||||||
|
$parser->parse(Handler => $handler,
|
||||||
|
Source => { SystemId => "foo.xml" });
|
||||||
|
# or...
|
||||||
|
$parser->parse_file($fh, Handler => $handler);
|
||||||
|
|
||||||
|
This flexibility allows for one parser to be used in many different
|
||||||
|
scenarios throughout your script (though one shouldn't feel pressure to
|
||||||
|
use this method, as parser construction is generally not a time
|
||||||
|
consuming process).
|
||||||
|
|
||||||
|
=head1 Callback Parameters
|
||||||
|
|
||||||
|
The only other thing you need to know to understand basic SAX is the
|
||||||
|
structure of the parameters passed to each of the callbacks. In
|
||||||
|
XML::Parser, all parameters are passed as multiple options to the
|
||||||
|
callbacks, so for example the Start callback would be called as
|
||||||
|
my_start($e, $name, %attributes), and the PI callback would be called
|
||||||
|
as my_processing_instruction($e, $target, $data). In SAX, every
|
||||||
|
callback is passed a hash reference, containing entries that define our
|
||||||
|
"node". The key callbacks and the structures they receive are:
|
||||||
|
|
||||||
|
=head2 start_element
|
||||||
|
|
||||||
|
The start_element handler is called whenever a parser sees an opening
|
||||||
|
tag. It is passed an element structure consisting of:
|
||||||
|
|
||||||
|
=over 4
|
||||||
|
|
||||||
|
=item LocalName
|
||||||
|
|
||||||
|
The name of the element minus any namespace prefix it may
|
||||||
|
have come with in the document.
|
||||||
|
|
||||||
|
=item NamespaceURI
|
||||||
|
|
||||||
|
The URI of the namespace associated with this element,
|
||||||
|
or the empty string for none.
|
||||||
|
|
||||||
|
=item Attributes
|
||||||
|
|
||||||
|
A set of attributes as described below.
|
||||||
|
|
||||||
|
=item Name
|
||||||
|
|
||||||
|
The name of the element as it was seen in the document (i.e.
|
||||||
|
including any prefix associated with it)
|
||||||
|
|
||||||
|
=item Prefix
|
||||||
|
|
||||||
|
The prefix used to qualify this element's namespace, or the
|
||||||
|
empty string if none.
|
||||||
|
|
||||||
|
=back
|
||||||
|
|
||||||
|
The B<Attributes> are a hash reference, keyed by what we have called
|
||||||
|
"James Clark" notation. This means that the attribute name has been
|
||||||
|
expanded to include any associated namespace URI, and put together as
|
||||||
|
{ns}name, where "ns" is the expanded namespace URI of the attribute if
|
||||||
|
and only if the attribute had a prefix, and "name" is the LocalName of
|
||||||
|
the attribute.
|
||||||
|
|
||||||
|
The value of each entry in the attributes hash is another hash
|
||||||
|
structure consisting of:
|
||||||
|
|
||||||
|
=over 4
|
||||||
|
|
||||||
|
=item LocalName
|
||||||
|
|
||||||
|
The name of the attribute minus any namespace prefix it may have
|
||||||
|
come with in the document.
|
||||||
|
|
||||||
|
=item NamespaceURI
|
||||||
|
|
||||||
|
The URI of the namespace associated with this attribute. If the
|
||||||
|
attribute had no prefix, then this consists of just the empty string.
|
||||||
|
|
||||||
|
=item Name
|
||||||
|
|
||||||
|
The attribute's name as it appeared in the document, including any
|
||||||
|
namespace prefix.
|
||||||
|
|
||||||
|
=item Prefix
|
||||||
|
|
||||||
|
The prefix used to qualify this attribute's namepace, or the
|
||||||
|
empty string if none.
|
||||||
|
|
||||||
|
=item Value
|
||||||
|
|
||||||
|
The value of the attribute.
|
||||||
|
|
||||||
|
=back
|
||||||
|
|
||||||
|
So a full example, as output by Data::Dumper might be:
|
||||||
|
|
||||||
|
....
|
||||||
|
|
||||||
|
=head2 end_element
|
||||||
|
|
||||||
|
The end_element handler is called either when a parser sees a closing
|
||||||
|
tag, or after start_element has been called for an empty element (do
|
||||||
|
note however that a parser may if it is so inclined call characters
|
||||||
|
with an empty string when it sees an empty element. There is no simple
|
||||||
|
way in SAX to determine if the parser in fact saw an empty element, a
|
||||||
|
start and end element with no content..
|
||||||
|
|
||||||
|
The end_element handler receives exactly the same structure as
|
||||||
|
start_element, minus the Attributes entry. One must note though that it
|
||||||
|
should not be a reference to the same data as start_element receives,
|
||||||
|
so you may change the values in start_element but this will not affect
|
||||||
|
the values later seen by end_element.
|
||||||
|
|
||||||
|
=head2 characters
|
||||||
|
|
||||||
|
The characters callback may be called in serveral circumstances. The
|
||||||
|
most obvious one is when seeing ordinary character data in the markup.
|
||||||
|
But it is also called for text in a CDATA section, and is also called
|
||||||
|
in other situations. A SAX parser has to make no guarantees whatsoever
|
||||||
|
about how many times it may call characters for a stretch of text in an
|
||||||
|
XML document - it may call once, or it may call once for every
|
||||||
|
character in the text. In order to work around this it is often
|
||||||
|
important for the SAX developer to use a bundling technique, where text
|
||||||
|
is gathered up and processed in one of the other callbacks. This is not
|
||||||
|
always necessary, but it is a worthwhile technique to learn, which we
|
||||||
|
will cover in XML::SAX::Advanced (when I get around to writing it).
|
||||||
|
|
||||||
|
The characters handler is called with a very simple structure - a hash
|
||||||
|
reference consisting of just one entry:
|
||||||
|
|
||||||
|
=over 4
|
||||||
|
|
||||||
|
=item Data
|
||||||
|
|
||||||
|
The text data that was received.
|
||||||
|
|
||||||
|
=back
|
||||||
|
|
||||||
|
=head2 comment
|
||||||
|
|
||||||
|
The comment callback is called for comment text. Unlike with
|
||||||
|
C<characters()>, the comment callback *must* be invoked just once for an
|
||||||
|
entire comment string. It receives a single simple structure - a hash
|
||||||
|
reference containing just one entry:
|
||||||
|
|
||||||
|
=over 4
|
||||||
|
|
||||||
|
=item Data
|
||||||
|
|
||||||
|
The text of the comment.
|
||||||
|
|
||||||
|
=back
|
||||||
|
|
||||||
|
=head2 processing_instruction
|
||||||
|
|
||||||
|
The processing instruction handler is called for all processing
|
||||||
|
instructions in the document. Note that these processing instructions
|
||||||
|
may appear before the document root element, or after it, or anywhere
|
||||||
|
where text and elements would normally appear within the document,
|
||||||
|
according to the XML specification.
|
||||||
|
|
||||||
|
The handler is passed a structure containing just two entries:
|
||||||
|
|
||||||
|
=over 4
|
||||||
|
|
||||||
|
=item Target
|
||||||
|
|
||||||
|
The target of the processing instrcution
|
||||||
|
|
||||||
|
=item Data
|
||||||
|
|
||||||
|
The text data in the processing instruction. Can be an empty
|
||||||
|
string for a processing instruction that has no data element.
|
||||||
|
For example E<lt>?wiggle?E<gt> is a perfectly valid processing instruction.
|
||||||
|
|
||||||
|
=back
|
||||||
|
|
||||||
|
=head1 Tip of the iceberg
|
||||||
|
|
||||||
|
What we have discussed above is really the tip of the SAX iceberg. And
|
||||||
|
so far it looks like there's not much of interest to SAX beyond what we
|
||||||
|
have seen with XML::Parser. But it does go much further than that, I
|
||||||
|
promise.
|
||||||
|
|
||||||
|
People who hate Object Oriented code for the sake of it may be thinking
|
||||||
|
here that creating a new package just to parse something is a waste
|
||||||
|
when they've been parsing things just fine up to now using procedural
|
||||||
|
code. But there's reason to all this madness. And that reason is SAX
|
||||||
|
Filters.
|
||||||
|
|
||||||
|
As you saw right at the very start, to let the parser know about our
|
||||||
|
class, we pass it an instance of our class as the Handler to the
|
||||||
|
parser. But now imagine what would happen if our class could also take
|
||||||
|
a Handler option, and simply do some processing and pass on our data
|
||||||
|
further down the line? That in a nutshell is how SAX filters work. It's
|
||||||
|
Unix pipes for the 21st century!
|
||||||
|
|
||||||
|
There are two downsides to this. Number 1 - writing SAX filters can be
|
||||||
|
tricky. If you look into the future and read the advanced tutorial I'm
|
||||||
|
writing, you'll see that Handler can come in several shapes and sizes.
|
||||||
|
So making sure your filter does the right thing can be tricky.
|
||||||
|
Secondly, constructing complex filter chains can be difficult, and
|
||||||
|
simple thinking tells us that we only get one pass at our document,
|
||||||
|
when often we'll need more than that.
|
||||||
|
|
||||||
|
Luckily though, those downsides have been fixed by the release of two
|
||||||
|
very cool modules. What's even better is that I didn't write either of
|
||||||
|
them!
|
||||||
|
|
||||||
|
The first module is XML::SAX::Base. This is a VITAL SAX module that
|
||||||
|
acts as a base class for all SAX parsers and filters. It provides an
|
||||||
|
abstraction away from calling the handler methods, that makes sure your
|
||||||
|
filter or parser does the right thing, and it does it FAST. So, if you
|
||||||
|
ever need to write a SAX filter, which if you're processing XML -> XML,
|
||||||
|
or XML -> HTML, then you probably do, then you need to be writing it as
|
||||||
|
a subclass of XML::SAX::Base. Really - this is advice not to ignore
|
||||||
|
lightly. I will not go into the details of writing a SAX filter here.
|
||||||
|
Kip Hampton, the author of XML::SAX::Base has covered this nicely in
|
||||||
|
his article on XML.com here <URI>.
|
||||||
|
|
||||||
|
To construct SAX pipelines, Barrie Slaymaker, a long time Perl hacker
|
||||||
|
whose modules you will probably have heard of or used, wrote a very
|
||||||
|
clever module called XML::SAX::Machines. This combines some really
|
||||||
|
clever SAX filter-type modules, with a construction toolkit for filters
|
||||||
|
that makes building pipelines easy. But before we see how it makes
|
||||||
|
things easy, first lets see how tricky it looks to build complex SAX
|
||||||
|
filter pipelines.
|
||||||
|
|
||||||
|
use XML::SAX::ParserFactory;
|
||||||
|
use XML::Filter::Filter1;
|
||||||
|
use XML::Filter::Filter2;
|
||||||
|
use XML::SAX::Writer;
|
||||||
|
|
||||||
|
my $output_string;
|
||||||
|
my $writer = XML::SAX::Writer->new(Output => \$output_string);
|
||||||
|
my $filter2 = XML::SAX::Filter2->new(Handler => $writer);
|
||||||
|
my $filter1 = XML::SAX::Filter1->new(Handler => $filter2);
|
||||||
|
my $parser = XML::SAX::ParserFactory->parser(Handler => $filter1);
|
||||||
|
|
||||||
|
$parser->parse_uri("foo.xml");
|
||||||
|
|
||||||
|
This is a lot easier with XML::SAX::Machines:
|
||||||
|
|
||||||
|
use XML::SAX::Machines qw(Pipeline);
|
||||||
|
|
||||||
|
my $output_string;
|
||||||
|
my $parser = Pipeline(
|
||||||
|
XML::SAX::Filter1 => XML::SAX::Filter2 => \$output_string
|
||||||
|
);
|
||||||
|
|
||||||
|
$parser->parse_uri("foo.xml");
|
||||||
|
|
||||||
|
One of the main benefits of XML::SAX::Machines is that the pipelines
|
||||||
|
are constructed in natural order, rather than the reverse order we saw
|
||||||
|
with manual pipeline construction. XML::SAX::Machines takes care of all
|
||||||
|
the internals of pipe construction, providing you at the end with just
|
||||||
|
a parser you can use (and you can re-use the same parser as many times
|
||||||
|
as you need to).
|
||||||
|
|
||||||
|
Just a final tip. If you ever get stuck and are confused about what is
|
||||||
|
being passed from one SAX filter or parser to the next, then
|
||||||
|
Devel::TraceSAX will come to your rescue. This perl debugger plugin
|
||||||
|
will allow you to dump the SAX stream of events as it goes by. Usage is
|
||||||
|
really very simple just call your perl script that uses SAX as follows:
|
||||||
|
|
||||||
|
$ perl -d:TraceSAX <scriptname>
|
||||||
|
|
||||||
|
And preferably pipe the output to a pager of some sort, such as more or
|
||||||
|
less. The output is extremely verbose, but should help clear some
|
||||||
|
issues up.
|
||||||
|
|
||||||
|
=head1 AUTHOR
|
||||||
|
|
||||||
|
Matt Sergeant, matt@sergeant.org
|
||||||
|
|
||||||
|
$Id$
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
@ -0,0 +1,230 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::ParserFactory;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use vars qw($VERSION);
|
||||||
|
|
||||||
|
$VERSION = '1.02';
|
||||||
|
|
||||||
|
use Symbol qw(gensym);
|
||||||
|
use XML::SAX;
|
||||||
|
use XML::SAX::Exception;
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $class = shift;
|
||||||
|
my %params = @_; # TODO : Fix this in spec.
|
||||||
|
my $self = bless \%params, $class;
|
||||||
|
$self->{KnownParsers} = XML::SAX->parsers();
|
||||||
|
return $self;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub parser {
|
||||||
|
my $self = shift;
|
||||||
|
my @parser_params = @_;
|
||||||
|
if (!ref($self)) {
|
||||||
|
$self = $self->new();
|
||||||
|
}
|
||||||
|
|
||||||
|
my $parser_class = $self->_parser_class();
|
||||||
|
|
||||||
|
my $version = '';
|
||||||
|
if ($parser_class =~ s/\s*\(([\d\.]+)\)\s*$//) {
|
||||||
|
$version = " $1";
|
||||||
|
}
|
||||||
|
|
||||||
|
if (!$parser_class->can('new')) {
|
||||||
|
eval "require $parser_class $version;";
|
||||||
|
die $@ if $@;
|
||||||
|
}
|
||||||
|
|
||||||
|
return $parser_class->new(@parser_params);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub require_feature {
|
||||||
|
my $self = shift;
|
||||||
|
my ($feature) = @_;
|
||||||
|
$self->{RequiredFeatures}{$feature}++;
|
||||||
|
return $self;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _parser_class {
|
||||||
|
my $self = shift;
|
||||||
|
|
||||||
|
# First try ParserPackage
|
||||||
|
if ($XML::SAX::ParserPackage) {
|
||||||
|
return $XML::SAX::ParserPackage;
|
||||||
|
}
|
||||||
|
|
||||||
|
# Now check if required/preferred is there
|
||||||
|
if ($self->{RequiredFeatures}) {
|
||||||
|
my %required = %{$self->{RequiredFeatures}};
|
||||||
|
# note - we never go onto the next try (ParserDetails.ini),
|
||||||
|
# because if we can't provide the requested feature
|
||||||
|
# we need to throw an exception.
|
||||||
|
PARSER:
|
||||||
|
foreach my $parser (reverse @{$self->{KnownParsers}}) {
|
||||||
|
foreach my $feature (keys %required) {
|
||||||
|
if (!exists $parser->{Features}{$feature}) {
|
||||||
|
next PARSER;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
# got here - all features must exist!
|
||||||
|
return $parser->{Name};
|
||||||
|
}
|
||||||
|
# TODO : should this be NotSupported() ?
|
||||||
|
throw XML::SAX::Exception (
|
||||||
|
Message => "Unable to provide required features",
|
||||||
|
);
|
||||||
|
}
|
||||||
|
|
||||||
|
# Next try SAX.ini
|
||||||
|
for my $dir (@INC) {
|
||||||
|
my $fh = gensym();
|
||||||
|
if (open($fh, "$dir/SAX.ini")) {
|
||||||
|
my $param_list = XML::SAX->_parse_ini_file($fh);
|
||||||
|
my $params = $param_list->[0]->{Features};
|
||||||
|
if ($params->{ParserPackage}) {
|
||||||
|
return $params->{ParserPackage};
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
# we have required features (or nothing?)
|
||||||
|
PARSER:
|
||||||
|
foreach my $parser (reverse @{$self->{KnownParsers}}) {
|
||||||
|
foreach my $feature (keys %$params) {
|
||||||
|
if (!exists $parser->{Features}{$feature}) {
|
||||||
|
next PARSER;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return $parser->{Name};
|
||||||
|
}
|
||||||
|
XML::SAX->do_warn("Unable to provide SAX.ini required features. Using fallback\n");
|
||||||
|
}
|
||||||
|
last; # stop after first INI found
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
if (@{$self->{KnownParsers}}) {
|
||||||
|
return $self->{KnownParsers}[-1]{Name};
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
return "XML::SAX::PurePerl"; # backup plan!
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
__END__
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
XML::SAX::ParserFactory - Obtain a SAX parser
|
||||||
|
|
||||||
|
=head1 SYNOPSIS
|
||||||
|
|
||||||
|
use XML::SAX::ParserFactory;
|
||||||
|
use XML::SAX::XYZHandler;
|
||||||
|
my $handler = XML::SAX::XYZHandler->new();
|
||||||
|
my $p = XML::SAX::ParserFactory->parser(Handler => $handler);
|
||||||
|
$p->parse_uri("foo.xml");
|
||||||
|
# or $p->parse_string("<foo/>") or $p->parse_file($fh);
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
|
||||||
|
XML::SAX::ParserFactory is a factory class for providing an application
|
||||||
|
with a Perl SAX2 XML parser. It is akin to DBI - a front end for other
|
||||||
|
parser classes. Each new SAX2 parser installed will register itself
|
||||||
|
with XML::SAX, and then it will become available to all applications
|
||||||
|
that use XML::SAX::ParserFactory to obtain a SAX parser.
|
||||||
|
|
||||||
|
Unlike DBI however, XML/SAX parsers almost all work alike (especially
|
||||||
|
if they subclass XML::SAX::Base, as they should), so rather than
|
||||||
|
specifying the parser you want in the call to C<parser()>, XML::SAX
|
||||||
|
has several ways to automatically choose which parser to use:
|
||||||
|
|
||||||
|
=over 4
|
||||||
|
|
||||||
|
=item * $XML::SAX::ParserPackage
|
||||||
|
|
||||||
|
If this package variable is set, then this package is C<require()>d
|
||||||
|
and an instance of this package is returned by calling the C<new()>
|
||||||
|
class method in that package. If it cannot be loaded or there is
|
||||||
|
an error, an exception will be thrown. The variable can also contain
|
||||||
|
a version number:
|
||||||
|
|
||||||
|
$XML::SAX::ParserPackage = "XML::SAX::Expat (0.72)";
|
||||||
|
|
||||||
|
And the number will be treated as a minimum version number.
|
||||||
|
|
||||||
|
=item * Required features
|
||||||
|
|
||||||
|
It is possible to require features from the parsers. For example, you
|
||||||
|
may wish for a parser that supports validation via a DTD. To do that,
|
||||||
|
use the following code:
|
||||||
|
|
||||||
|
use XML::SAX::ParserFactory;
|
||||||
|
my $factory = XML::SAX::ParserFactory->new();
|
||||||
|
$factory->require_feature('http://xml.org/sax/features/validation');
|
||||||
|
my $parser = $factory->parser(...);
|
||||||
|
|
||||||
|
Alternatively, specify the required features in the call to the
|
||||||
|
ParserFactory constructor:
|
||||||
|
|
||||||
|
my $factory = XML::SAX::ParserFactory->new(
|
||||||
|
RequiredFeatures => {
|
||||||
|
'http://xml.org/sax/features/validation' => 1,
|
||||||
|
}
|
||||||
|
);
|
||||||
|
|
||||||
|
If the features you have asked for are unavailable (for example the
|
||||||
|
user might not have a validating parser installed), then an
|
||||||
|
exception will be thrown.
|
||||||
|
|
||||||
|
The list of known parsers is searched in reverse order, so it will
|
||||||
|
always return the last installed parser that supports all of your
|
||||||
|
requested features (Note: this is subject to change if someone
|
||||||
|
comes up with a better way of making this work).
|
||||||
|
|
||||||
|
=item * SAX.ini
|
||||||
|
|
||||||
|
ParserFactory will search @INC for a file called SAX.ini, which
|
||||||
|
is in a simple format:
|
||||||
|
|
||||||
|
# a comment looks like this,
|
||||||
|
; or like this, and are stripped anywhere in the file
|
||||||
|
key = value # SAX.in contains key/value pairs.
|
||||||
|
|
||||||
|
All whitespace is non-significant.
|
||||||
|
|
||||||
|
This file can contain either a line:
|
||||||
|
|
||||||
|
ParserPackage = MyParserModule (1.02)
|
||||||
|
|
||||||
|
Where MyParserModule is the module to load and use for the parser,
|
||||||
|
and the number in brackets is a minimum version to load.
|
||||||
|
|
||||||
|
Or you can list required features:
|
||||||
|
|
||||||
|
http://xml.org/sax/features/validation = 1
|
||||||
|
|
||||||
|
And each feature with a true value will be required.
|
||||||
|
|
||||||
|
=item * Fallback
|
||||||
|
|
||||||
|
If none of the above works, the last parser installed on the user's
|
||||||
|
system will be used. The XML::SAX package ships with a pure perl
|
||||||
|
XML parser, XML::SAX::PurePerl, so that there will always be a
|
||||||
|
fallback parser.
|
||||||
|
|
||||||
|
=back
|
||||||
|
|
||||||
|
=head1 AUTHOR
|
||||||
|
|
||||||
|
Matt Sergeant, matt@sergeant.org
|
||||||
|
|
||||||
|
=head1 LICENSE
|
||||||
|
|
||||||
|
This is free software, you may use it and distribute it under the same
|
||||||
|
terms as Perl itself.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
|
@ -0,0 +1,751 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use vars qw/$VERSION/;
|
||||||
|
|
||||||
|
$VERSION = '1.02';
|
||||||
|
|
||||||
|
use XML::SAX::PurePerl::Productions qw($NameChar $SingleChar);
|
||||||
|
use XML::SAX::PurePerl::Reader;
|
||||||
|
use XML::SAX::PurePerl::EncodingDetect ();
|
||||||
|
use XML::SAX::Exception;
|
||||||
|
use XML::SAX::PurePerl::DocType ();
|
||||||
|
use XML::SAX::PurePerl::DTDDecls ();
|
||||||
|
use XML::SAX::PurePerl::XMLDecl ();
|
||||||
|
use XML::SAX::DocumentLocator ();
|
||||||
|
use XML::SAX::Base ();
|
||||||
|
use XML::SAX qw(Namespaces);
|
||||||
|
use XML::NamespaceSupport ();
|
||||||
|
use IO::File;
|
||||||
|
|
||||||
|
if ($] < 5.006) {
|
||||||
|
require XML::SAX::PurePerl::NoUnicodeExt;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
require XML::SAX::PurePerl::UnicodeExt;
|
||||||
|
}
|
||||||
|
|
||||||
|
use vars qw(@ISA);
|
||||||
|
@ISA = ('XML::SAX::Base');
|
||||||
|
|
||||||
|
my %int_ents = (
|
||||||
|
amp => '&',
|
||||||
|
lt => '<',
|
||||||
|
gt => '>',
|
||||||
|
quot => '"',
|
||||||
|
apos => "'",
|
||||||
|
);
|
||||||
|
|
||||||
|
my $xmlns_ns = "http://www.w3.org/2000/xmlns/";
|
||||||
|
my $xml_ns = "http://www.w3.org/XML/1998/namespace";
|
||||||
|
|
||||||
|
use Carp;
|
||||||
|
sub _parse_characterstream {
|
||||||
|
my $self = shift;
|
||||||
|
my ($fh) = @_;
|
||||||
|
confess("CharacterStream is not yet correctly implemented");
|
||||||
|
my $reader = XML::SAX::PurePerl::Reader::Stream->new($fh);
|
||||||
|
return $self->_parse($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _parse_bytestream {
|
||||||
|
my $self = shift;
|
||||||
|
my ($fh) = @_;
|
||||||
|
my $reader = XML::SAX::PurePerl::Reader::Stream->new($fh);
|
||||||
|
return $self->_parse($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _parse_string {
|
||||||
|
my $self = shift;
|
||||||
|
my ($str) = @_;
|
||||||
|
my $reader = XML::SAX::PurePerl::Reader::String->new($str);
|
||||||
|
return $self->_parse($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _parse_systemid {
|
||||||
|
my $self = shift;
|
||||||
|
my ($uri) = @_;
|
||||||
|
my $reader = XML::SAX::PurePerl::Reader::URI->new($uri);
|
||||||
|
return $self->_parse($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _parse {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
$reader->public_id($self->{ParseOptions}{Source}{PublicId});
|
||||||
|
$reader->system_id($self->{ParseOptions}{Source}{SystemId});
|
||||||
|
|
||||||
|
$self->{NSHelper} = XML::NamespaceSupport->new({xmlns => 1});
|
||||||
|
|
||||||
|
$self->set_document_locator(
|
||||||
|
XML::SAX::DocumentLocator->new(
|
||||||
|
sub { $reader->public_id },
|
||||||
|
sub { $reader->system_id },
|
||||||
|
sub { $reader->line },
|
||||||
|
sub { $reader->column },
|
||||||
|
sub { $reader->get_encoding },
|
||||||
|
sub { $reader->get_xml_version },
|
||||||
|
),
|
||||||
|
);
|
||||||
|
|
||||||
|
$self->start_document({});
|
||||||
|
|
||||||
|
if (defined $self->{ParseOptions}{Source}{Encoding}) {
|
||||||
|
$reader->set_encoding($self->{ParseOptions}{Source}{Encoding});
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$self->encoding_detect($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
# parse a document
|
||||||
|
$self->document($reader);
|
||||||
|
|
||||||
|
return $self->end_document({});
|
||||||
|
}
|
||||||
|
|
||||||
|
sub parser_error {
|
||||||
|
my $self = shift;
|
||||||
|
my ($error, $reader) = @_;
|
||||||
|
|
||||||
|
# warn("parser error: $error from ", $reader->line, " : ", $reader->column, "\n");
|
||||||
|
my $exception = XML::SAX::Exception::Parse->new(
|
||||||
|
Message => $error,
|
||||||
|
ColumnNumber => $reader->column,
|
||||||
|
LineNumber => $reader->line,
|
||||||
|
PublicId => $reader->public_id,
|
||||||
|
SystemId => $reader->system_id,
|
||||||
|
);
|
||||||
|
|
||||||
|
$self->fatal_error($exception);
|
||||||
|
$exception->throw;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub document {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
# document ::= prolog element Misc*
|
||||||
|
|
||||||
|
$self->prolog($reader);
|
||||||
|
$self->element($reader) ||
|
||||||
|
$self->parser_error("Document requires an element", $reader);
|
||||||
|
|
||||||
|
while(length($reader->data)) {
|
||||||
|
$self->Misc($reader) ||
|
||||||
|
$self->parser_error("Only Comments, PIs and whitespace allowed at end of document", $reader);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub prolog {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
$self->XMLDecl($reader);
|
||||||
|
|
||||||
|
# consume all misc bits
|
||||||
|
1 while($self->Misc($reader));
|
||||||
|
|
||||||
|
if ($self->doctypedecl($reader)) {
|
||||||
|
while (length($reader->data)) {
|
||||||
|
$self->Misc($reader) || last;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub element {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
return 0 unless $reader->match('<');
|
||||||
|
|
||||||
|
my $name = $self->Name($reader) || $self->parser_error("Invalid element name", $reader);
|
||||||
|
|
||||||
|
my %attribs;
|
||||||
|
|
||||||
|
while( my ($k, $v) = $self->Attribute($reader) ) {
|
||||||
|
$attribs{$k} = $v;
|
||||||
|
}
|
||||||
|
|
||||||
|
my $have_namespaces = $self->get_feature(Namespaces);
|
||||||
|
|
||||||
|
# Namespace processing
|
||||||
|
$self->{NSHelper}->push_context;
|
||||||
|
my @new_ns;
|
||||||
|
# my %attrs = @attribs;
|
||||||
|
# while (my ($k,$v) = each %attrs) {
|
||||||
|
if ($have_namespaces) {
|
||||||
|
while ( my ($k, $v) = each %attribs ) {
|
||||||
|
if ($k =~ m/^xmlns(:(.*))?$/) {
|
||||||
|
my $prefix = $2 || '';
|
||||||
|
$self->{NSHelper}->declare_prefix($prefix, $v);
|
||||||
|
my $ns =
|
||||||
|
{
|
||||||
|
Prefix => $prefix,
|
||||||
|
NamespaceURI => $v,
|
||||||
|
};
|
||||||
|
push @new_ns, $ns;
|
||||||
|
$self->SUPER::start_prefix_mapping($ns);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# Create element object and fire event
|
||||||
|
my %attrib_hash;
|
||||||
|
while (my ($name, $value) = each %attribs ) {
|
||||||
|
# TODO normalise value here
|
||||||
|
my ($ns, $prefix, $lname);
|
||||||
|
if ($have_namespaces) {
|
||||||
|
($ns, $prefix, $lname) = $self->{NSHelper}->process_attribute_name($name);
|
||||||
|
}
|
||||||
|
$ns ||= ''; $prefix ||= ''; $lname ||= '';
|
||||||
|
$attrib_hash{"{$ns}$lname"} = {
|
||||||
|
Name => $name,
|
||||||
|
LocalName => $lname,
|
||||||
|
Prefix => $prefix,
|
||||||
|
NamespaceURI => $ns,
|
||||||
|
Value => $value,
|
||||||
|
};
|
||||||
|
}
|
||||||
|
|
||||||
|
%attribs = (); # lose the memory since we recurse deep
|
||||||
|
|
||||||
|
my ($ns, $prefix, $lname);
|
||||||
|
if ($self->get_feature(Namespaces)) {
|
||||||
|
($ns, $prefix, $lname) = $self->{NSHelper}->process_element_name($name);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$lname = $name;
|
||||||
|
}
|
||||||
|
$ns ||= ''; $prefix ||= ''; $lname ||= '';
|
||||||
|
|
||||||
|
# Process remainder of start_element
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
my $have_content;
|
||||||
|
my $data = $reader->data(2);
|
||||||
|
if ($data =~ /^\/>/) {
|
||||||
|
$reader->move_along(2);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$data =~ /^>/ or $self->parser_error("No close element tag", $reader);
|
||||||
|
$reader->move_along(1);
|
||||||
|
$have_content++;
|
||||||
|
}
|
||||||
|
|
||||||
|
my $el =
|
||||||
|
{
|
||||||
|
Name => $name,
|
||||||
|
LocalName => $lname,
|
||||||
|
Prefix => $prefix,
|
||||||
|
NamespaceURI => $ns,
|
||||||
|
Attributes => \%attrib_hash,
|
||||||
|
};
|
||||||
|
$self->start_element($el);
|
||||||
|
|
||||||
|
# warn("($name\n");
|
||||||
|
|
||||||
|
if ($have_content) {
|
||||||
|
$self->content($reader);
|
||||||
|
|
||||||
|
my $data = $reader->data(2);
|
||||||
|
$data =~ /^<\// or $self->parser_error("No close tag marker", $reader);
|
||||||
|
$reader->move_along(2);
|
||||||
|
my $end_name = $self->Name($reader);
|
||||||
|
$end_name eq $name || $self->parser_error("End tag mismatch ($end_name != $name)", $reader);
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
$reader->match('>') or $self->parser_error("No close '>' on end tag", $reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
my %end_el = %$el;
|
||||||
|
delete $end_el{Attributes};
|
||||||
|
$self->end_element(\%end_el);
|
||||||
|
|
||||||
|
for my $ns (@new_ns) {
|
||||||
|
$self->end_prefix_mapping($ns);
|
||||||
|
}
|
||||||
|
$self->{NSHelper}->pop_context;
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub content {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
while (1) {
|
||||||
|
$self->CharData($reader);
|
||||||
|
|
||||||
|
my $data = $reader->data(2);
|
||||||
|
|
||||||
|
if ($data =~ /^<\//) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^&/) {
|
||||||
|
$self->Reference($reader) or $self->parser_error("bare & not allowed in content", $reader);
|
||||||
|
next;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^<!/) {
|
||||||
|
($self->CDSect($reader)
|
||||||
|
or
|
||||||
|
$self->Comment($reader))
|
||||||
|
and next;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^<\?/) {
|
||||||
|
$self->PI($reader) and next;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^</) {
|
||||||
|
$self->element($reader) and next;
|
||||||
|
}
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub CDSect {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(9);
|
||||||
|
return 0 unless $data =~ /^<!\[CDATA\[/;
|
||||||
|
$reader->move_along(9);
|
||||||
|
|
||||||
|
$self->start_cdata({});
|
||||||
|
|
||||||
|
$data = $reader->data;
|
||||||
|
while (1) {
|
||||||
|
$self->parser_error("EOF looking for CDATA section end", $reader)
|
||||||
|
unless length($data);
|
||||||
|
|
||||||
|
if ($data =~ /^(.*?)\]\]>/s) {
|
||||||
|
my $chars = $1;
|
||||||
|
$reader->move_along(length($chars) + 3);
|
||||||
|
$self->characters({Data => $chars});
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$self->characters({Data => $data});
|
||||||
|
$reader->move_along(length($data));
|
||||||
|
$data = $reader->data;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
$self->end_cdata({});
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub CharData {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data;
|
||||||
|
|
||||||
|
while (1) {
|
||||||
|
return unless length($data);
|
||||||
|
|
||||||
|
if ($data =~ /^([^<&]*)[<&]/s) {
|
||||||
|
my $chars = $1;
|
||||||
|
$self->parser_error("String ']]>' not allowed in character data", $reader)
|
||||||
|
if $chars =~ /\]\]>/;
|
||||||
|
$reader->move_along(length($chars));
|
||||||
|
$self->characters({Data => $chars}) if length($chars);
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$self->characters({Data => $data});
|
||||||
|
$reader->move_along(length($data));
|
||||||
|
$data = $reader->data;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub Misc {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
if ($self->Comment($reader)) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
elsif ($self->PI($reader)) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
elsif ($self->skip_whitespace($reader)) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub Reference {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
return 0 unless $reader->match('&');
|
||||||
|
|
||||||
|
my $data = $reader->data;
|
||||||
|
|
||||||
|
# Fetch more data if we have an incomplete numeric reference
|
||||||
|
if ($data =~ /^(#\d*|#x[0-9a-fA-F]*)$/) {
|
||||||
|
$data = $reader->data(length($data) + 6);
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($data =~ /^#x([0-9a-fA-F]+);/) {
|
||||||
|
my $ref = $1;
|
||||||
|
$reader->move_along(length($ref) + 3);
|
||||||
|
my $char = chr_ref(hex($ref));
|
||||||
|
$self->parser_error("Character reference &#$ref; refers to an illegal XML character ($char)", $reader)
|
||||||
|
unless $char =~ /$SingleChar/o;
|
||||||
|
$self->characters({ Data => $char });
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^#([0-9]+);/) {
|
||||||
|
my $ref = $1;
|
||||||
|
$reader->move_along(length($ref) + 2);
|
||||||
|
my $char = chr_ref($ref);
|
||||||
|
$self->parser_error("Character reference &#$ref; refers to an illegal XML character ($char)", $reader)
|
||||||
|
unless $char =~ /$SingleChar/o;
|
||||||
|
$self->characters({ Data => $char });
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
# EntityRef
|
||||||
|
my $name = $self->Name($reader)
|
||||||
|
|| $self->parser_error("Invalid name in entity", $reader);
|
||||||
|
$reader->match(';') or $self->parser_error("No semi-colon found after entity name", $reader);
|
||||||
|
|
||||||
|
# warn("got entity: \&$name;\n");
|
||||||
|
|
||||||
|
# expand it
|
||||||
|
if ($self->_is_entity($name)) {
|
||||||
|
|
||||||
|
if ($self->_is_external($name)) {
|
||||||
|
my $value = $self->_get_entity($name);
|
||||||
|
my $ent_reader = XML::SAX::PurePerl::Reader::URI->new($value);
|
||||||
|
$self->encoding_detect($ent_reader);
|
||||||
|
$self->extParsedEnt($ent_reader);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
my $value = $self->_stringify_entity($name);
|
||||||
|
my $ent_reader = XML::SAX::PurePerl::Reader::String->new($value);
|
||||||
|
$self->content($ent_reader);
|
||||||
|
}
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
elsif ($name =~ /^(?:amp|gt|lt|quot|apos)$/) {
|
||||||
|
$self->characters({ Data => $int_ents{$name} });
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$self->parser_error("Undeclared entity", $reader);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub AttReference {
|
||||||
|
my ($self, $name, $reader) = @_;
|
||||||
|
if ($name =~ /^#x([0-9a-fA-F]+)$/) {
|
||||||
|
my $chr = chr_ref(hex($1));
|
||||||
|
$chr =~ /$SingleChar/o or $self->parser_error("Character reference '&$name;' refers to an illegal XML character", $reader);
|
||||||
|
return $chr;
|
||||||
|
}
|
||||||
|
elsif ($name =~ /^#([0-9]+)$/) {
|
||||||
|
my $chr = chr_ref($1);
|
||||||
|
$chr =~ /$SingleChar/o or $self->parser_error("Character reference '&$name;' refers to an illegal XML character", $reader);
|
||||||
|
return $chr;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
if ($self->_is_entity($name)) {
|
||||||
|
if ($self->_is_external($name)) {
|
||||||
|
$self->parser_error("No external entity references allowed in attribute values", $reader);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
my $value = $self->_stringify_entity($name);
|
||||||
|
return $value;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
elsif ($name =~ /^(?:amp|lt|gt|quot|apos)$/) {
|
||||||
|
return $int_ents{$name};
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$self->parser_error("Undeclared entity '$name'", $reader);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub extParsedEnt {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
$self->TextDecl($reader);
|
||||||
|
$self->content($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _is_external {
|
||||||
|
my ($self, $name) = @_;
|
||||||
|
# TODO: Fix this to use $reader to store the entities perhaps.
|
||||||
|
if ($self->{ParseOptions}{external_entities}{$name}) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
return ;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _is_entity {
|
||||||
|
my ($self, $name) = @_;
|
||||||
|
# TODO: ditto above
|
||||||
|
if (exists $self->{ParseOptions}{entities}{$name}) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _stringify_entity {
|
||||||
|
my ($self, $name) = @_;
|
||||||
|
# TODO: ditto above
|
||||||
|
if (exists $self->{ParseOptions}{expanded_entity}{$name}) {
|
||||||
|
return $self->{ParseOptions}{expanded_entity}{$name};
|
||||||
|
}
|
||||||
|
# expand
|
||||||
|
my $reader = XML::SAX::PurePerl::Reader::URI->new($self->{ParseOptions}{entities}{$name});
|
||||||
|
my $ent = '';
|
||||||
|
while(1) {
|
||||||
|
my $data = $reader->data;
|
||||||
|
$ent .= $data;
|
||||||
|
$reader->move_along(length($data)) or last;
|
||||||
|
}
|
||||||
|
return $self->{ParseOptions}{expanded_entity}{$name} = $ent;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub _get_entity {
|
||||||
|
my ($self, $name) = @_;
|
||||||
|
# TODO: ditto above
|
||||||
|
return $self->{ParseOptions}{entities}{$name};
|
||||||
|
}
|
||||||
|
|
||||||
|
sub skip_whitespace {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data;
|
||||||
|
|
||||||
|
my $found = 0;
|
||||||
|
while ($data =~ s/^([\x20\x0A\x0D\x09]*)//) {
|
||||||
|
last unless length($1);
|
||||||
|
$found++;
|
||||||
|
$reader->move_along(length($1));
|
||||||
|
$data = $reader->data;
|
||||||
|
}
|
||||||
|
|
||||||
|
return $found;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub Attribute {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader) || return;
|
||||||
|
|
||||||
|
my $data = $reader->data(2);
|
||||||
|
return if $data =~ /^\/?>/;
|
||||||
|
|
||||||
|
if (my $name = $self->Name($reader)) {
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
$reader->match('=') or $self->parser_error("No '=' in Attribute", $reader);
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
my $value = $self->AttValue($reader);
|
||||||
|
|
||||||
|
if (!$self->cdata_attrib($name)) {
|
||||||
|
$value =~ s/^\x20*//; # discard leading spaces
|
||||||
|
$value =~ s/\x20*$//; # discard trailing spaces
|
||||||
|
$value =~ s/ {1,}/ /g; # all >1 space to single space
|
||||||
|
}
|
||||||
|
|
||||||
|
return $name, $value;
|
||||||
|
}
|
||||||
|
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub cdata_attrib {
|
||||||
|
# TODO implement this!
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub AttValue {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $quote = $self->quote($reader);
|
||||||
|
|
||||||
|
my $value = '';
|
||||||
|
|
||||||
|
while (1) {
|
||||||
|
my $data = $reader->data;
|
||||||
|
$self->parser_error("EOF found while looking for the end of attribute value", $reader)
|
||||||
|
unless length($data);
|
||||||
|
if ($data =~ /^([^$quote]*)$quote/) {
|
||||||
|
$reader->move_along(length($1) + 1);
|
||||||
|
$value .= $1;
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$value .= $data;
|
||||||
|
$reader->move_along(length($data));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($value =~ /</) {
|
||||||
|
$self->parser_error("< character not allowed in attribute values", $reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
$value =~ s/[\x09\x0A\x0D]/\x20/g;
|
||||||
|
$value =~ s/&(#(x[0-9a-fA-F]+)|#([0-9]+)|\w+);/$self->AttReference($1, $reader)/geo;
|
||||||
|
|
||||||
|
return $value;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub Comment {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(4);
|
||||||
|
if ($data =~ /^<!--/) {
|
||||||
|
$reader->move_along(4);
|
||||||
|
my $comment_str = '';
|
||||||
|
while (1) {
|
||||||
|
my $data = $reader->data;
|
||||||
|
$self->parser_error("End of data seen while looking for close comment marker", $reader)
|
||||||
|
unless length($data);
|
||||||
|
if ($data =~ /^(.*?)-->/s) {
|
||||||
|
$comment_str .= $1;
|
||||||
|
$self->parser_error("Invalid comment (dash)", $reader) if $comment_str =~ /-$/;
|
||||||
|
$reader->move_along(length($1) + 3);
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$comment_str .= $data;
|
||||||
|
$reader->move_along(length($data));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
$self->comment({ Data => $comment_str });
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub PI {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(2);
|
||||||
|
|
||||||
|
if ($data =~ /^<\?/) {
|
||||||
|
$reader->move_along(2);
|
||||||
|
my ($target);
|
||||||
|
$target = $self->Name($reader) ||
|
||||||
|
$self->parser_error("PI has no target", $reader);
|
||||||
|
|
||||||
|
my $pi_data = '';
|
||||||
|
if ($self->skip_whitespace($reader)) {
|
||||||
|
while (1) {
|
||||||
|
my $data = $reader->data;
|
||||||
|
$self->parser_error("End of data seen while looking for close PI marker", $reader)
|
||||||
|
unless length($data);
|
||||||
|
if ($data =~ /^(.*?)\?>/s) {
|
||||||
|
$pi_data .= $1;
|
||||||
|
$reader->move_along(length($1) + 2);
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$pi_data .= $data;
|
||||||
|
$reader->move_along(length($data));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
my $data = $reader->data(2);
|
||||||
|
$data =~ /^\?>/ or $self->parser_error("PI closing sequence not found", $reader);
|
||||||
|
$reader->move_along(2);
|
||||||
|
}
|
||||||
|
|
||||||
|
$self->processing_instruction({ Target => $target, Data => $pi_data });
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub Name {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $name = '';
|
||||||
|
while(1) {
|
||||||
|
my $data = $reader->data;
|
||||||
|
return unless length($data);
|
||||||
|
$data =~ /^([^\s>\/&\?;=<\)\(\[\],\%\#\!\*\|]*)/ or return;
|
||||||
|
$name .= $1;
|
||||||
|
my $len = length($1);
|
||||||
|
$reader->move_along($len);
|
||||||
|
last if ($len != length($data));
|
||||||
|
}
|
||||||
|
|
||||||
|
return unless length($name);
|
||||||
|
|
||||||
|
$name =~ /$NameChar/o or $self->parser_error("Name <$name> does not match NameChar production", $reader);
|
||||||
|
|
||||||
|
return $name;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub quote {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data;
|
||||||
|
|
||||||
|
$data =~ /^(['"])/ or $self->parser_error("Invalid quote token", $reader);
|
||||||
|
$reader->move_along(1);
|
||||||
|
return $1;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
__END__
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
XML::SAX::PurePerl - Pure Perl XML Parser with SAX2 interface
|
||||||
|
|
||||||
|
=head1 SYNOPSIS
|
||||||
|
|
||||||
|
use XML::Handler::Foo;
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
my $handler = XML::Handler::Foo->new();
|
||||||
|
my $parser = XML::SAX::PurePerl->new(Handler => $handler);
|
||||||
|
$parser->parse_uri("myfile.xml");
|
||||||
|
|
||||||
|
=head1 DESCRIPTION
|
||||||
|
|
||||||
|
This module implements an XML parser in pure perl. It is written around the
|
||||||
|
upcoming perl 5.8's unicode support and support for multiple document
|
||||||
|
encodings (using the PerlIO layer), however it has been ported to work with
|
||||||
|
ASCII/UTF8 documents under lower perl versions.
|
||||||
|
|
||||||
|
The SAX2 API is described in detail at http://sourceforge.net/projects/perl-xml/, in
|
||||||
|
the CVS archive, under libxml-perl/docs. Hopefully those documents will be in a
|
||||||
|
better location soon.
|
||||||
|
|
||||||
|
Please refer to the SAX2 documentation for how to use this module - it is merely a
|
||||||
|
front end to SAX2, and implements nothing that is not in that spec (or at least tries
|
||||||
|
not to - please email me if you find errors in this implementation).
|
||||||
|
|
||||||
|
=head1 BUGS
|
||||||
|
|
||||||
|
XML::SAX::PurePerl is B<slow>. Very slow. I suggest you use something else
|
||||||
|
in fact. However it is great as a fallback parser for XML::SAX, where the
|
||||||
|
user might not be able to install an XS based parser or C library.
|
||||||
|
|
||||||
|
Currently lots, probably. At the moment the weakest area is parsing DOCTYPE declarations,
|
||||||
|
though the code is in place to start doing this. Also parsing parameter entity
|
||||||
|
references is causing me much confusion, since it's not exactly what I would call
|
||||||
|
trivial, or well documented in the XML grammar. XML documents with internal subsets
|
||||||
|
are likely to fail.
|
||||||
|
|
||||||
|
I am however trying to work towards full conformance using the Oasis test suite.
|
||||||
|
|
||||||
|
=head1 AUTHOR
|
||||||
|
|
||||||
|
Matt Sergeant, matt@sergeant.org. Copyright 2001.
|
||||||
|
|
||||||
|
Please report all bugs to the Perl-XML mailing list at perl-xml@listserv.activestate.com.
|
||||||
|
|
||||||
|
=head1 LICENSE
|
||||||
|
|
||||||
|
This is free software. You may use it or redistribute it under the same terms as
|
||||||
|
Perl 5.7.2 itself.
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
||||||
|
|
@ -0,0 +1,603 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use XML::SAX::PurePerl::Productions qw($SingleChar);
|
||||||
|
|
||||||
|
sub elementdecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(9);
|
||||||
|
return 0 unless $data =~ /^<!ELEMENT/;
|
||||||
|
$reader->move_along(9);
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader) ||
|
||||||
|
$self->parser_error("No whitespace after ELEMENT declaration", $reader);
|
||||||
|
|
||||||
|
my $name = $self->Name($reader);
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader) ||
|
||||||
|
$self->parser_error("No whitespace after ELEMENT's name", $reader);
|
||||||
|
|
||||||
|
$self->contentspec($reader, $name);
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
$reader->match('>') or $self->parser_error("Closing angle bracket not found on ELEMENT declaration", $reader);
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub contentspec {
|
||||||
|
my ($self, $reader, $name) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(5);
|
||||||
|
|
||||||
|
my $model;
|
||||||
|
if ($data =~ /^EMPTY/) {
|
||||||
|
$reader->move_along(5);
|
||||||
|
$model = 'EMPTY';
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^ANY/) {
|
||||||
|
$reader->move_along(3);
|
||||||
|
$model = 'ANY';
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$model = $self->Mixed_or_children($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($model) {
|
||||||
|
# call SAX callback now.
|
||||||
|
$self->element_decl({Name => $name, Model => $model});
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
$self->parser_error("contentspec not found in ELEMENT declaration", $reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub Mixed_or_children {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(8);
|
||||||
|
$data =~ /^\(/ or return; # $self->parser_error("No opening bracket in Mixed or children", $reader);
|
||||||
|
|
||||||
|
if ($data =~ /^\(\s*\#PCDATA/) {
|
||||||
|
$reader->match('(');
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
$reader->move_along(7);
|
||||||
|
my $model = $self->Mixed($reader);
|
||||||
|
return $model;
|
||||||
|
}
|
||||||
|
|
||||||
|
# not matched - must be Children
|
||||||
|
return $self->children($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
# Mixed ::= ( '(' S* PCDATA ( S* '|' S* QName )* S* ')' '*' )
|
||||||
|
# | ( '(' S* PCDATA S* ')' )
|
||||||
|
sub Mixed {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
# Mixed_or_children already matched '(' S* '#PCDATA'
|
||||||
|
|
||||||
|
my $model = '(#PCDATA';
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
my %seen;
|
||||||
|
|
||||||
|
while (1) {
|
||||||
|
last unless $reader->match('|');
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
my $name = $self->Name($reader) ||
|
||||||
|
$self->parser_error("No 'Name' after Mixed content '|'", $reader);
|
||||||
|
|
||||||
|
if ($seen{$name}) {
|
||||||
|
$self->parser_error("Element '$name' has already appeared in this group", $reader);
|
||||||
|
}
|
||||||
|
$seen{$name}++;
|
||||||
|
|
||||||
|
$model .= "|$name";
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
$reader->match(')') || $self->parser_error("no closing bracket on mixed content", $reader);
|
||||||
|
|
||||||
|
$model .= ")";
|
||||||
|
|
||||||
|
if ($reader->match('*')) {
|
||||||
|
$model .= "*";
|
||||||
|
}
|
||||||
|
|
||||||
|
return $model;
|
||||||
|
}
|
||||||
|
|
||||||
|
# [[47]] Children ::= ChoiceOrSeq Cardinality?
|
||||||
|
# [[48]] Cp ::= ( QName | ChoiceOrSeq ) Cardinality?
|
||||||
|
# ChoiceOrSeq ::= '(' S* Cp ( Choice | Seq )? S* ')'
|
||||||
|
# [[49]] Choice ::= ( S* '|' S* Cp )+
|
||||||
|
# [[50]] Seq ::= ( S* ',' S* Cp )+
|
||||||
|
# // Children ::= (Choice | Seq) Cardinality?
|
||||||
|
# // Cp ::= ( QName | Choice | Seq) Cardinality?
|
||||||
|
# // Choice ::= '(' S* Cp ( S* '|' S* Cp )+ S* ')'
|
||||||
|
# // Seq ::= '(' S* Cp ( S* ',' S* Cp )* S* ')'
|
||||||
|
# [[51]] Mixed ::= ( '(' S* PCDATA ( S* '|' S* QName )* S* ')' MixedCardinality )
|
||||||
|
# | ( '(' S* PCDATA S* ')' )
|
||||||
|
# Cardinality ::= '?' | '+' | '*'
|
||||||
|
# MixedCardinality ::= '*'
|
||||||
|
sub children {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
return $self->ChoiceOrSeq($reader) . $self->Cardinality($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub ChoiceOrSeq {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
$reader->match('(') or $self->parser_error("choice/seq contains no opening bracket", $reader);
|
||||||
|
|
||||||
|
my $model = '(';
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
$model .= $self->Cp($reader);
|
||||||
|
|
||||||
|
if (my $choice = $self->Choice($reader)) {
|
||||||
|
$model .= $choice;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$model .= $self->Seq($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
$reader->match(')') or $self->parser_error("choice/seq contains no closing bracket", $reader);
|
||||||
|
|
||||||
|
$model .= ')';
|
||||||
|
|
||||||
|
return $model;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub Cardinality {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
# cardinality is always optional
|
||||||
|
my $data = $reader->data;
|
||||||
|
if ($data =~ /^([\?\+\*])/) {
|
||||||
|
$reader->move_along(1);
|
||||||
|
return $1;
|
||||||
|
}
|
||||||
|
return '';
|
||||||
|
}
|
||||||
|
|
||||||
|
sub Cp {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $model;
|
||||||
|
my $name = eval
|
||||||
|
{
|
||||||
|
if (my $name = $self->Name($reader)) {
|
||||||
|
return $name . $self->Cardinality($reader);
|
||||||
|
}
|
||||||
|
};
|
||||||
|
return $name if defined $name;
|
||||||
|
return $self->ChoiceOrSeq($reader) . $self->Cardinality($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub Choice {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $model = '';
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
while ($reader->match('|')) {
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
$model .= '|';
|
||||||
|
$model .= $self->Cp($reader);
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
return $model;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub Seq {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $model = '';
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
while ($reader->match(',')) {
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
my $cp = $self->Cp($reader);
|
||||||
|
if ($cp) {
|
||||||
|
$model .= ',';
|
||||||
|
$model .= $cp;
|
||||||
|
}
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
return $model;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub AttlistDecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(9);
|
||||||
|
if ($data =~ /^<!ATTLIST/) {
|
||||||
|
# It's an attlist
|
||||||
|
|
||||||
|
$reader->move_along(9);
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader) ||
|
||||||
|
$self->parser_error("No whitespace after ATTLIST declaration", $reader);
|
||||||
|
my $name = $self->Name($reader);
|
||||||
|
|
||||||
|
$self->AttDefList($reader, $name);
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
$reader->match('>') or $self->parser_error("Closing angle bracket not found on ATTLIST declaration", $reader);
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub AttDefList {
|
||||||
|
my ($self, $reader, $name) = @_;
|
||||||
|
|
||||||
|
1 while $self->AttDef($reader, $name);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub AttDef {
|
||||||
|
my ($self, $reader, $el_name) = @_;
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader) || return 0;
|
||||||
|
my $att_name = $self->Name($reader) || return 0;
|
||||||
|
$self->skip_whitespace($reader) ||
|
||||||
|
$self->parser_error("No whitespace after Name in attribute definition", $reader);
|
||||||
|
my $att_type = $self->AttType($reader);
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader) ||
|
||||||
|
$self->parser_error("No whitespace after AttType in attribute definition", $reader);
|
||||||
|
my ($mode, $value) = $self->DefaultDecl($reader);
|
||||||
|
|
||||||
|
# fire SAX event here!
|
||||||
|
$self->attribute_decl({
|
||||||
|
eName => $el_name,
|
||||||
|
aName => $att_name,
|
||||||
|
Type => $att_type,
|
||||||
|
Mode => $mode,
|
||||||
|
Value => $value,
|
||||||
|
});
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub AttType {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
return $self->StringType($reader) ||
|
||||||
|
$self->TokenizedType($reader) ||
|
||||||
|
$self->EnumeratedType($reader) ||
|
||||||
|
$self->parser_error("Can't match AttType", $reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub StringType {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(5);
|
||||||
|
return unless $data =~ /^CDATA/;
|
||||||
|
$reader->move_along(5);
|
||||||
|
return 'CDATA';
|
||||||
|
}
|
||||||
|
|
||||||
|
sub TokenizedType {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(8);
|
||||||
|
if ($data =~ /^(IDREFS?|ID|ENTITIES|ENTITY|NMTOKENS?)/) {
|
||||||
|
$reader->move_along(length($1));
|
||||||
|
return $1;
|
||||||
|
}
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub EnumeratedType {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
return $self->NotationType($reader) || $self->Enumeration($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub NotationType {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(8);
|
||||||
|
return unless $data =~ /^NOTATION/;
|
||||||
|
$reader->move_along(8);
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader) ||
|
||||||
|
$self->parser_error("No whitespace after NOTATION", $reader);
|
||||||
|
$reader->match('(') or $self->parser_error("No opening bracket in notation section", $reader);
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
my $model = 'NOTATION (';
|
||||||
|
my $name = $self->Name($reader) ||
|
||||||
|
$self->parser_error("No name in notation section", $reader);
|
||||||
|
$model .= $name;
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
$data = $reader->data;
|
||||||
|
while ($data =~ /^\|/) {
|
||||||
|
$reader->move_along(1);
|
||||||
|
$model .= '|';
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
my $name = $self->Name($reader) ||
|
||||||
|
$self->parser_error("No name in notation section", $reader);
|
||||||
|
$model .= $name;
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
$data = $reader->data;
|
||||||
|
}
|
||||||
|
$data =~ /^\)/ or $self->parser_error("No closing bracket in notation section", $reader);
|
||||||
|
$reader->move_along(1);
|
||||||
|
|
||||||
|
$model .= ')';
|
||||||
|
|
||||||
|
return $model;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub Enumeration {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
return unless $reader->match('(');
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
my $model = '(';
|
||||||
|
my $nmtoken = $self->Nmtoken($reader) ||
|
||||||
|
$self->parser_error("No Nmtoken in enumerated declaration", $reader);
|
||||||
|
$model .= $nmtoken;
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
my $data = $reader->data;
|
||||||
|
while ($data =~ /^\|/) {
|
||||||
|
$model .= '|';
|
||||||
|
$reader->move_along(1);
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
my $nmtoken = $self->Nmtoken($reader) ||
|
||||||
|
$self->parser_error("No Nmtoken in enumerated declaration", $reader);
|
||||||
|
$model .= $nmtoken;
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
$data = $reader->data;
|
||||||
|
}
|
||||||
|
$data =~ /^\)/ or $self->parser_error("No closing bracket in enumerated declaration", $reader);
|
||||||
|
$reader->move_along(1);
|
||||||
|
|
||||||
|
$model .= ')';
|
||||||
|
|
||||||
|
return $model;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub Nmtoken {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
return $self->Name($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub DefaultDecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(9);
|
||||||
|
if ($data =~ /^(\#REQUIRED|\#IMPLIED)/) {
|
||||||
|
$reader->move_along(length($1));
|
||||||
|
return $1;
|
||||||
|
}
|
||||||
|
my $model = '';
|
||||||
|
if ($data =~ /^\#FIXED/) {
|
||||||
|
$reader->move_along(6);
|
||||||
|
$self->skip_whitespace($reader) || $self->parser_error(
|
||||||
|
"no whitespace after FIXED specifier", $reader);
|
||||||
|
my $value = $self->AttValue($reader);
|
||||||
|
return "#FIXED", $value;
|
||||||
|
}
|
||||||
|
my $value = $self->AttValue($reader);
|
||||||
|
return undef, $value;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub EntityDecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(8);
|
||||||
|
return 0 unless $data =~ /^<!ENTITY/;
|
||||||
|
$reader->move_along(8);
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader) || $self->parser_error(
|
||||||
|
"No whitespace after ENTITY declaration", $reader);
|
||||||
|
|
||||||
|
$self->PEDecl($reader) || $self->GEDecl($reader);
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
$reader->match('>') or $self->parser_error("No closing '>' in entity definition", $reader);
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub GEDecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $name = $self->Name($reader) || $self->parser_error("No entity name given", $reader);
|
||||||
|
$self->skip_whitespace($reader) || $self->parser_error("No whitespace after entity name", $reader);
|
||||||
|
|
||||||
|
# TODO: ExternalID calls lexhandler method. Wrong place for it.
|
||||||
|
my $value;
|
||||||
|
if ($value = $self->ExternalID($reader)) {
|
||||||
|
$value .= $self->NDataDecl($reader);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$value = $self->EntityValue($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($self->{ParseOptions}{entities}{$name}) {
|
||||||
|
warn("entity $name already exists\n");
|
||||||
|
} else {
|
||||||
|
$self->{ParseOptions}{entities}{$name} = 1;
|
||||||
|
$self->{ParseOptions}{expanded_entity}{$name} = $value; # ???
|
||||||
|
}
|
||||||
|
# do callback?
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub PEDecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
return 0 unless $reader->match('%');
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader) || $self->parser_error("No whitespace after parameter entity marker", $reader);
|
||||||
|
my $name = $self->Name($reader) || $self->parser_error("No parameter entity name given", $reader);
|
||||||
|
$self->skip_whitespace($reader) || $self->parser_error("No whitespace after parameter entity name", $reader);
|
||||||
|
my $value = $self->ExternalID($reader) ||
|
||||||
|
$self->EntityValue($reader) ||
|
||||||
|
$self->parser_error("PE is not a value or an external resource", $reader);
|
||||||
|
# do callback?
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
my $quotre = qr/[^%&\"]/;
|
||||||
|
my $aposre = qr/[^%&\']/;
|
||||||
|
|
||||||
|
sub EntityValue {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data;
|
||||||
|
my $quote = '"';
|
||||||
|
my $re = $quotre;
|
||||||
|
if ($data !~ /^"/) {
|
||||||
|
$data =~ /^'/ or $self->parser_error("Not a quote character", $reader);
|
||||||
|
$quote = "'";
|
||||||
|
$re = $aposre;
|
||||||
|
}
|
||||||
|
$reader->move_along(1);
|
||||||
|
|
||||||
|
my $value = '';
|
||||||
|
|
||||||
|
while (1) {
|
||||||
|
my $data = $reader->data;
|
||||||
|
|
||||||
|
$self->parser_error("EOF found while reading entity value", $reader)
|
||||||
|
unless length($data);
|
||||||
|
|
||||||
|
if ($data =~ /^($re+)/) {
|
||||||
|
my $match = $1;
|
||||||
|
$value .= $match;
|
||||||
|
$reader->move_along(length($match));
|
||||||
|
}
|
||||||
|
elsif ($reader->match('&')) {
|
||||||
|
# if it's a char ref, expand now:
|
||||||
|
if ($reader->match('#')) {
|
||||||
|
my $char;
|
||||||
|
my $ref = '';
|
||||||
|
if ($reader->match('x')) {
|
||||||
|
my $data = $reader->data;
|
||||||
|
while (1) {
|
||||||
|
$self->parser_error("EOF looking for reference end", $reader)
|
||||||
|
unless length($data);
|
||||||
|
if ($data !~ /^([0-9a-fA-F]*)/) {
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
$ref .= $1;
|
||||||
|
$reader->move_along(length($1));
|
||||||
|
if (length($1) == length($data)) {
|
||||||
|
$data = $reader->data;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
$char = chr_ref(hex($ref));
|
||||||
|
$ref = "x$ref";
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
my $data = $reader->data;
|
||||||
|
while (1) {
|
||||||
|
$self->parser_error("EOF looking for reference end", $reader)
|
||||||
|
unless length($data);
|
||||||
|
if ($data !~ /^([0-9]*)/) {
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
$ref .= $1;
|
||||||
|
$reader->move_along(length($1));
|
||||||
|
if (length($1) == length($data)) {
|
||||||
|
$data = $reader->data;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
$char = chr($ref);
|
||||||
|
}
|
||||||
|
$reader->match(';') ||
|
||||||
|
$self->parser_error("No semi-colon found after character reference", $reader);
|
||||||
|
if ($char !~ $SingleChar) { # match a single character
|
||||||
|
$self->parser_error("Character reference '&#$ref;' refers to an illegal XML character ($char)", $reader);
|
||||||
|
}
|
||||||
|
$value .= $char;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
# entity refs in entities get expanded later, so don't parse now.
|
||||||
|
$value .= '&';
|
||||||
|
}
|
||||||
|
}
|
||||||
|
elsif ($reader->match('%')) {
|
||||||
|
$value .= $self->PEReference($reader);
|
||||||
|
}
|
||||||
|
elsif ($reader->match($quote)) {
|
||||||
|
# end of attrib
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$self->parser_error("Invalid character in attribute value: " . substr($reader->data, 0, 1), $reader);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
return $value;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub NDataDecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
$self->skip_whitespace($reader) || return '';
|
||||||
|
my $data = $reader->data(5);
|
||||||
|
return '' unless $data =~ /^NDATA/;
|
||||||
|
$reader->move_along(5);
|
||||||
|
$self->skip_whitespace($reader) || $self->parser_error("No whitespace after NDATA declaration", $reader);
|
||||||
|
my $name = $self->Name($reader) || $self->parser_error("NDATA declaration lacks a proper Name", $reader);
|
||||||
|
return " NDATA $name";
|
||||||
|
}
|
||||||
|
|
||||||
|
sub NotationDecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(10);
|
||||||
|
return 0 unless $data =~ /^<!NOTATION/;
|
||||||
|
$reader->move_along(10);
|
||||||
|
$self->skip_whitespace($reader) ||
|
||||||
|
$self->parser_error("No whitespace after NOTATION declaration", $reader);
|
||||||
|
$data = $reader->data;
|
||||||
|
my $value = '';
|
||||||
|
while(1) {
|
||||||
|
$self->parser_error("EOF found while looking for end of NotationDecl", $reader)
|
||||||
|
unless length($data);
|
||||||
|
|
||||||
|
if ($data =~ /^([^>]*)>/) {
|
||||||
|
$value .= $1;
|
||||||
|
$reader->move_along(length($1) + 1);
|
||||||
|
$self->notation_decl({Name => "FIXME", SystemId => "FIXME", PublicId => "FIXME" });
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$value .= $data;
|
||||||
|
$reader->move_along(length($data));
|
||||||
|
$data = $reader->data;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
@ -0,0 +1,95 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl::DebugHandler;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $class = shift;
|
||||||
|
my %opts = @_;
|
||||||
|
return bless \%opts, $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
# DocumentHandler
|
||||||
|
|
||||||
|
sub set_document_locator {
|
||||||
|
my $self = shift;
|
||||||
|
print "set_document_locator\n" if $ENV{DEBUG_XML};
|
||||||
|
$self->{seen}{set_document_locator}++;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub start_document {
|
||||||
|
my $self = shift;
|
||||||
|
print "start_document\n" if $ENV{DEBUG_XML};
|
||||||
|
$self->{seen}{start_document}++;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub end_document {
|
||||||
|
my $self = shift;
|
||||||
|
print "end_document\n" if $ENV{DEBUG_XML};
|
||||||
|
$self->{seen}{end_document}++;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub start_element {
|
||||||
|
my $self = shift;
|
||||||
|
print "start_element\n" if $ENV{DEBUG_XML};
|
||||||
|
$self->{seen}{start_element}++;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub end_element {
|
||||||
|
my $self = shift;
|
||||||
|
print "end_element\n" if $ENV{DEBUG_XML};
|
||||||
|
$self->{seen}{end_element}++;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub characters {
|
||||||
|
my $self = shift;
|
||||||
|
print "characters\n" if $ENV{DEBUG_XML};
|
||||||
|
# warn "Char: ", $_[0]->{Data}, "\n";
|
||||||
|
$self->{seen}{characters}++;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub processing_instruction {
|
||||||
|
my $self = shift;
|
||||||
|
print "processing_instruction\n" if $ENV{DEBUG_XML};
|
||||||
|
$self->{seen}{processing_instruction}++;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub ignorable_whitespace {
|
||||||
|
my $self = shift;
|
||||||
|
print "ignorable_whitespace\n" if $ENV{DEBUG_XML};
|
||||||
|
$self->{seen}{ignorable_whitespace}++;
|
||||||
|
}
|
||||||
|
|
||||||
|
# LexHandler
|
||||||
|
|
||||||
|
sub comment {
|
||||||
|
my $self = shift;
|
||||||
|
print "comment\n" if $ENV{DEBUG_XML};
|
||||||
|
$self->{seen}{comment}++;
|
||||||
|
}
|
||||||
|
|
||||||
|
# DTDHandler
|
||||||
|
|
||||||
|
sub notation_decl {
|
||||||
|
my $self = shift;
|
||||||
|
print "notation_decl\n" if $ENV{DEBUG_XML};
|
||||||
|
$self->{seen}{notation_decl}++;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub unparsed_entity_decl {
|
||||||
|
my $self = shift;
|
||||||
|
print "unparsed_entity_decl\n" if $ENV{DEBUG_XML};
|
||||||
|
$self->{seen}{entity_decl}++;
|
||||||
|
}
|
||||||
|
|
||||||
|
# EntityResolver
|
||||||
|
|
||||||
|
sub resolve_entity {
|
||||||
|
my $self = shift;
|
||||||
|
print "resolve_entity\n" if $ENV{DEBUG_XML};
|
||||||
|
$self->{seen}{resolve_entity}++;
|
||||||
|
return '';
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
@ -0,0 +1,180 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use XML::SAX::PurePerl::Productions qw($PubidChar);
|
||||||
|
|
||||||
|
sub doctypedecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(9);
|
||||||
|
if ($data =~ /^<!DOCTYPE/) {
|
||||||
|
$reader->move_along(9);
|
||||||
|
$self->skip_whitespace($reader) ||
|
||||||
|
$self->parser_error("No whitespace after doctype declaration", $reader);
|
||||||
|
|
||||||
|
my $root_name = $self->Name($reader) ||
|
||||||
|
$self->parser_error("Doctype declaration has no root element name", $reader);
|
||||||
|
|
||||||
|
if ($self->skip_whitespace($reader)) {
|
||||||
|
# might be externalid...
|
||||||
|
my %dtd = $self->ExternalID($reader);
|
||||||
|
# TODO: Call SAX event
|
||||||
|
}
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
$self->InternalSubset($reader);
|
||||||
|
|
||||||
|
$reader->match('>') or $self->parser_error("Doctype not closed", $reader);
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub ExternalID {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(6);
|
||||||
|
|
||||||
|
if ($data =~ /^SYSTEM/) {
|
||||||
|
$reader->move_along(6);
|
||||||
|
$self->skip_whitespace($reader) ||
|
||||||
|
$self->parser_error("No whitespace after SYSTEM identifier", $reader);
|
||||||
|
return (SYSTEM => $self->SystemLiteral($reader));
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^PUBLIC/) {
|
||||||
|
$reader->move_along(6);
|
||||||
|
$self->skip_whitespace($reader) ||
|
||||||
|
$self->parser_error("No whitespace after PUBLIC identifier", $reader);
|
||||||
|
|
||||||
|
my $quote = $self->quote($reader) ||
|
||||||
|
$self->parser_error("Not a quote character in PUBLIC identifier", $reader);
|
||||||
|
|
||||||
|
my $data = $reader->data;
|
||||||
|
my $pubid = '';
|
||||||
|
while(1) {
|
||||||
|
$self->parser_error("EOF while looking for end of PUBLIC identifiier", $reader)
|
||||||
|
unless length($data);
|
||||||
|
|
||||||
|
if ($data =~ /^([^$quote]*)$quote/) {
|
||||||
|
$pubid .= $1;
|
||||||
|
$reader->move_along(length($1) + 1);
|
||||||
|
last;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$pubid .= $data;
|
||||||
|
$reader->move_along(length($data));
|
||||||
|
$data = $reader->data;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($pubid !~ /^($PubidChar)+$/) {
|
||||||
|
$self->parser_error("Invalid characters in PUBLIC identifier", $reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader) ||
|
||||||
|
$self->parser_error("Not whitespace after PUBLIC ID in DOCTYPE", $reader);
|
||||||
|
|
||||||
|
return (PUBLIC => $pubid,
|
||||||
|
SYSTEM => $self->SystemLiteral($reader));
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub SystemLiteral {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $quote = $self->quote($reader);
|
||||||
|
|
||||||
|
my $data = $reader->data;
|
||||||
|
my $systemid = '';
|
||||||
|
while (1) {
|
||||||
|
$self->parser_error("EOF found while looking for end of System Literal", $reader)
|
||||||
|
unless length($data);
|
||||||
|
if ($data =~ /^([^$quote]*)$quote/) {
|
||||||
|
$systemid .= $1;
|
||||||
|
$reader->move_along(length($1) + 1);
|
||||||
|
return $systemid;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$systemid .= $data;
|
||||||
|
$reader->move_along(length($data));
|
||||||
|
$data = $reader->data;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub InternalSubset {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
return 0 unless $reader->match('[');
|
||||||
|
|
||||||
|
1 while $self->IntSubsetDecl($reader);
|
||||||
|
|
||||||
|
$reader->match(']') or $self->parser_error("No close bracket on internal subset (found: " . $reader->data, $reader);
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub IntSubsetDecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
return $self->DeclSep($reader) || $self->markupdecl($reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub DeclSep {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
if ($self->skip_whitespace($reader)) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($self->PEReference($reader)) {
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
# if ($self->ParsedExtSubset($reader)) {
|
||||||
|
# return 1;
|
||||||
|
# }
|
||||||
|
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub PEReference {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
return 0 unless $reader->match('%');
|
||||||
|
|
||||||
|
my $peref = $self->Name($reader) ||
|
||||||
|
$self->parser_error("PEReference did not find a Name", $reader);
|
||||||
|
# TODO - load/parse the peref
|
||||||
|
|
||||||
|
$reader->match(';') or $self->parser_error("Invalid token in PEReference", $reader);
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub markupdecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
if ($self->elementdecl($reader) ||
|
||||||
|
$self->AttlistDecl($reader) ||
|
||||||
|
$self->EntityDecl($reader) ||
|
||||||
|
$self->NotationDecl($reader) ||
|
||||||
|
$self->PI($reader) ||
|
||||||
|
$self->Comment($reader))
|
||||||
|
{
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
@ -0,0 +1,105 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl; # NB, not ::EncodingDetect!
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
sub encoding_detect {
|
||||||
|
my ($parser, $reader) = @_;
|
||||||
|
|
||||||
|
my $error = "Invalid byte sequence at start of file";
|
||||||
|
|
||||||
|
my $data = $reader->data;
|
||||||
|
if ($data =~ /^\x00\x00\xFE\xFF/) {
|
||||||
|
# BO-UCS4-be
|
||||||
|
$reader->move_along(4);
|
||||||
|
$reader->set_encoding('UCS-4BE');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\x00\x00\xFF\xFE/) {
|
||||||
|
# BO-UCS-4-2143
|
||||||
|
$reader->move_along(4);
|
||||||
|
$reader->set_encoding('UCS-4-2143');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\x00\x00\x00\x3C/) {
|
||||||
|
$reader->set_encoding('UCS-4BE');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\x00\x00\x3C\x00/) {
|
||||||
|
$reader->set_encoding('UCS-4-2143');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\x00\x3C\x00\x00/) {
|
||||||
|
$reader->set_encoding('UCS-4-3412');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\x00\x3C\x00\x3F/) {
|
||||||
|
$reader->set_encoding('UTF-16BE');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\xFF\xFE\x00\x00/) {
|
||||||
|
# BO-UCS-4LE
|
||||||
|
$reader->move_along(4);
|
||||||
|
$reader->set_encoding('UCS-4LE');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\xFF\xFE/) {
|
||||||
|
$reader->move_along(2);
|
||||||
|
$reader->set_encoding('UTF-16LE');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\xFE\xFF\x00\x00/) {
|
||||||
|
$reader->move_along(4);
|
||||||
|
$reader->set_encoding('UCS-4-3412');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\xFE\xFF/) {
|
||||||
|
$reader->move_along(2);
|
||||||
|
$reader->set_encoding('UTF-16BE');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\xEF\xBB\xBF/) { # UTF-8 BOM
|
||||||
|
$reader->move_along(3);
|
||||||
|
$reader->set_encoding('UTF-8');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\x3C\x00\x00\x00/) {
|
||||||
|
$reader->set_encoding('UCS-4LE');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\x3C\x00\x3F\x00/) {
|
||||||
|
$reader->set_encoding('UTF-16LE');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\x3C\x3F\x78\x6D/) {
|
||||||
|
# $reader->set_encoding('UTF-8');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\x3C\x3F\x78/) {
|
||||||
|
# $reader->set_encoding('UTF-8');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\x3C\x3F/) {
|
||||||
|
# $reader->set_encoding('UTF-8');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\x3C/) {
|
||||||
|
# $reader->set_encoding('UTF-8');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^[\x20\x09\x0A\x0D]+\x3C[^\x3F]/) {
|
||||||
|
# $reader->set_encoding('UTF-8');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
elsif ($data =~ /^\x4C\x6F\xA7\x94/) {
|
||||||
|
$reader->set_encoding('EBCDIC');
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
warn("Unable to recognise encoding of this document");
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,67 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl::Exception;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
use overload '""' => "stringify";
|
||||||
|
|
||||||
|
use vars qw/$StackTrace/;
|
||||||
|
|
||||||
|
$StackTrace = $ENV{XML_DEBUG} || 0;
|
||||||
|
|
||||||
|
sub throw {
|
||||||
|
my $class = shift;
|
||||||
|
die $class->new(@_);
|
||||||
|
}
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $class = shift;
|
||||||
|
my %opts = @_;
|
||||||
|
die "Invalid options" unless exists $opts{Message};
|
||||||
|
|
||||||
|
if ($opts{reader}) {
|
||||||
|
return bless { Message => $opts{Message},
|
||||||
|
Exception => undef, # not sure what this is for!!!
|
||||||
|
ColumnNumber => $opts{reader}->column,
|
||||||
|
LineNumber => $opts{reader}->line,
|
||||||
|
PublicId => $opts{reader}->public_id,
|
||||||
|
SystemId => $opts{reader}->system_id,
|
||||||
|
$StackTrace ? (StackTrace => stacktrace()) : (),
|
||||||
|
}, $class;
|
||||||
|
}
|
||||||
|
return bless { Message => $opts{Message},
|
||||||
|
Exception => undef, # not sure what this is for!!!
|
||||||
|
}, $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub stringify {
|
||||||
|
my $self = shift;
|
||||||
|
local $^W;
|
||||||
|
return $self->{Message} . " [Ln: " . $self->{LineNumber} .
|
||||||
|
", Col: " . $self->{ColumnNumber} . "]" .
|
||||||
|
($StackTrace ? stackstring($self->{StackTrace}) : "") . "\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
sub stacktrace {
|
||||||
|
my $i = 2;
|
||||||
|
my @fulltrace;
|
||||||
|
while (my @trace = caller($i++)) {
|
||||||
|
my %hash;
|
||||||
|
@hash{qw(Package Filename Line)} = @trace[0..2];
|
||||||
|
push @fulltrace, \%hash;
|
||||||
|
}
|
||||||
|
return \@fulltrace;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub stackstring {
|
||||||
|
my $stacktrace = shift;
|
||||||
|
my $string = "\nFrom:\n";
|
||||||
|
foreach my $current (@$stacktrace) {
|
||||||
|
$string .= $current->{Filename} . " Line: " . $current->{Line} . "\n";
|
||||||
|
}
|
||||||
|
return $string;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,28 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl;
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
sub chr_ref {
|
||||||
|
my $n = shift;
|
||||||
|
if ($n < 0x80) {
|
||||||
|
return chr ($n);
|
||||||
|
}
|
||||||
|
elsif ($n < 0x800) {
|
||||||
|
return pack ("CC", (($n >> 6) | 0xc0), (($n & 0x3f) | 0x80));
|
||||||
|
}
|
||||||
|
elsif ($n < 0x10000) {
|
||||||
|
return pack ("CCC", (($n >> 12) | 0xe0), ((($n >> 6) & 0x3f) | 0x80),
|
||||||
|
(($n & 0x3f) | 0x80));
|
||||||
|
}
|
||||||
|
elsif ($n < 0x110000)
|
||||||
|
{
|
||||||
|
return pack ("CCCC", (($n >> 18) | 0xf0), ((($n >> 12) & 0x3f) | 0x80),
|
||||||
|
((($n >> 6) & 0x3f) | 0x80), (($n & 0x3f) | 0x80));
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
return undef;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
@ -0,0 +1,147 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl::Productions;
|
||||||
|
|
||||||
|
use Exporter;
|
||||||
|
@ISA = ('Exporter');
|
||||||
|
@EXPORT_OK = qw($S $Char $VersionNum $BaseChar $Ideographic
|
||||||
|
$Extender $Digit $CombiningChar $EncNameStart $EncNameEnd $NameChar $CharMinusDash
|
||||||
|
$PubidChar $Any $SingleChar);
|
||||||
|
|
||||||
|
### WARNING!!! All productions here must *only* match a *single* character!!! ###
|
||||||
|
|
||||||
|
BEGIN {
|
||||||
|
$S = qr/[\x20\x09\x0D\x0A]/;
|
||||||
|
|
||||||
|
$CharMinusDash = qr/[^-]/x;
|
||||||
|
|
||||||
|
$Any = qr/ . /xms;
|
||||||
|
|
||||||
|
$VersionNum = qr/ [a-zA-Z0-9_.:-]+ /x;
|
||||||
|
|
||||||
|
$EncNameStart = qr/ [A-Za-z] /x;
|
||||||
|
$EncNameEnd = qr/ [A-Za-z0-9\._-] /x;
|
||||||
|
|
||||||
|
$PubidChar = qr/ [\x20\x0D\x0Aa-zA-Z0-9'()\+,.\/:=\?;!*\#@\$_\%-] /x;
|
||||||
|
|
||||||
|
if ($] < 5.006) {
|
||||||
|
eval <<' PERL';
|
||||||
|
$Char = qr/^ [\x09\x0A\x0D\x20-\x7F]|([\xC0-\xFD][\x80-\xBF]+) $/x;
|
||||||
|
|
||||||
|
$SingleChar = qr/^$Char$/;
|
||||||
|
|
||||||
|
$BaseChar = qr/ [\x41-\x5A\x61-\x7A]|([\xC0-\xFD][\x80-\xBF]+) /x;
|
||||||
|
|
||||||
|
$Extender = qr/ \xB7 /x;
|
||||||
|
|
||||||
|
$Digit = qr/ [\x30-\x39] /x;
|
||||||
|
|
||||||
|
# can't do this one without unicode
|
||||||
|
# $CombiningChar = qr/^$/msx;
|
||||||
|
|
||||||
|
$NameChar = qr/^ (?: $BaseChar | $Digit | [._:-] | $Extender )+ $/x;
|
||||||
|
PERL
|
||||||
|
die $@ if $@;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
eval <<' PERL';
|
||||||
|
|
||||||
|
use utf8; # for 5.6
|
||||||
|
|
||||||
|
$Char = qr/^ [\x09\x0A\x0D\x{0020}-\x{D7FF}\x{E000}-\x{FFFD}\x{10000}-\x{10FFFF}] $/x;
|
||||||
|
|
||||||
|
$SingleChar = qr/^$Char$/;
|
||||||
|
|
||||||
|
$BaseChar = qr/
|
||||||
|
[\x{0041}-\x{005A}\x{0061}-\x{007A}\x{00C0}-\x{00D6}\x{00D8}-\x{00F6}] |
|
||||||
|
[\x{00F8}-\x{00FF}\x{0100}-\x{0131}\x{0134}-\x{013E}\x{0141}-\x{0148}] |
|
||||||
|
[\x{014A}-\x{017E}\x{0180}-\x{01C3}\x{01CD}-\x{01F0}\x{01F4}-\x{01F5}] |
|
||||||
|
[\x{01FA}-\x{0217}\x{0250}-\x{02A8}\x{02BB}-\x{02C1}\x{0386}\x{0388}-\x{038A}] |
|
||||||
|
[\x{038C}\x{038E}-\x{03A1}\x{03A3}-\x{03CE}\x{03D0}-\x{03D6}\x{03DA}] |
|
||||||
|
[\x{03DC}\x{03DE}\x{03E0}\x{03E2}-\x{03F3}\x{0401}-\x{040C}\x{040E}-\x{044F}] |
|
||||||
|
[\x{0451}-\x{045C}\x{045E}-\x{0481}\x{0490}-\x{04C4}\x{04C7}-\x{04C8}] |
|
||||||
|
[\x{04CB}-\x{04CC}\x{04D0}-\x{04EB}\x{04EE}-\x{04F5}\x{04F8}-\x{04F9}] |
|
||||||
|
[\x{0531}-\x{0556}\x{0559}\x{0561}-\x{0586}\x{05D0}-\x{05EA}\x{05F0}-\x{05F2}] |
|
||||||
|
[\x{0621}-\x{063A}\x{0641}-\x{064A}\x{0671}-\x{06B7}\x{06BA}-\x{06BE}] |
|
||||||
|
[\x{06C0}-\x{06CE}\x{06D0}-\x{06D3}\x{06D5}\x{06E5}-\x{06E6}\x{0905}-\x{0939}] |
|
||||||
|
[\x{093D}\x{0958}-\x{0961}\x{0985}-\x{098C}\x{098F}-\x{0990}] |
|
||||||
|
[\x{0993}-\x{09A8}\x{09AA}-\x{09B0}\x{09B2}\x{09B6}-\x{09B9}\x{09DC}-\x{09DD}] |
|
||||||
|
[\x{09DF}-\x{09E1}\x{09F0}-\x{09F1}\x{0A05}-\x{0A0A}\x{0A0F}-\x{0A10}] |
|
||||||
|
[\x{0A13}-\x{0A28}\x{0A2A}-\x{0A30}\x{0A32}-\x{0A33}\x{0A35}-\x{0A36}] |
|
||||||
|
[\x{0A38}-\x{0A39}\x{0A59}-\x{0A5C}\x{0A5E}\x{0A72}-\x{0A74}\x{0A85}-\x{0A8B}] |
|
||||||
|
[\x{0A8D}\x{0A8F}-\x{0A91}\x{0A93}-\x{0AA8}\x{0AAA}-\x{0AB0}] |
|
||||||
|
[\x{0AB2}-\x{0AB3}\x{0AB5}-\x{0AB9}\x{0ABD}\x{0AE0}\x{0B05}-\x{0B0C}] |
|
||||||
|
[\x{0B0F}-\x{0B10}\x{0B13}-\x{0B28}\x{0B2A}-\x{0B30}\x{0B32}-\x{0B33}] |
|
||||||
|
[\x{0B36}-\x{0B39}\x{0B3D}\x{0B5C}-\x{0B5D}\x{0B5F}-\x{0B61}\x{0B85}-\x{0B8A}] |
|
||||||
|
[\x{0B8E}-\x{0B90}\x{0B92}-\x{0B95}\x{0B99}-\x{0B9A}\x{0B9C}] |
|
||||||
|
[\x{0B9E}-\x{0B9F}\x{0BA3}-\x{0BA4}\x{0BA8}-\x{0BAA}\x{0BAE}-\x{0BB5}] |
|
||||||
|
[\x{0BB7}-\x{0BB9}\x{0C05}-\x{0C0C}\x{0C0E}-\x{0C10}\x{0C12}-\x{0C28}] |
|
||||||
|
[\x{0C2A}-\x{0C33}\x{0C35}-\x{0C39}\x{0C60}-\x{0C61}\x{0C85}-\x{0C8C}] |
|
||||||
|
[\x{0C8E}-\x{0C90}\x{0C92}-\x{0CA8}\x{0CAA}-\x{0CB3}\x{0CB5}-\x{0CB9}\x{0CDE}] |
|
||||||
|
[\x{0CE0}-\x{0CE1}\x{0D05}-\x{0D0C}\x{0D0E}-\x{0D10}\x{0D12}-\x{0D28}] |
|
||||||
|
[\x{0D2A}-\x{0D39}\x{0D60}-\x{0D61}\x{0E01}-\x{0E2E}\x{0E30}\x{0E32}-\x{0E33}] |
|
||||||
|
[\x{0E40}-\x{0E45}\x{0E81}-\x{0E82}\x{0E84}\x{0E87}-\x{0E88}\x{0E8A}] |
|
||||||
|
[\x{0E8D}\x{0E94}-\x{0E97}\x{0E99}-\x{0E9F}\x{0EA1}-\x{0EA3}\x{0EA5}\x{0EA7}] |
|
||||||
|
[\x{0EAA}-\x{0EAB}\x{0EAD}-\x{0EAE}\x{0EB0}\x{0EB2}-\x{0EB3}\x{0EBD}] |
|
||||||
|
[\x{0EC0}-\x{0EC4}\x{0F40}-\x{0F47}\x{0F49}-\x{0F69}\x{10A0}-\x{10C5}] |
|
||||||
|
[\x{10D0}-\x{10F6}\x{1100}\x{1102}-\x{1103}\x{1105}-\x{1107}\x{1109}] |
|
||||||
|
[\x{110B}-\x{110C}\x{110E}-\x{1112}\x{113C}\x{113E}\x{1140}\x{114C}\x{114E}] |
|
||||||
|
[\x{1150}\x{1154}-\x{1155}\x{1159}\x{115F}-\x{1161}\x{1163}\x{1165}] |
|
||||||
|
[\x{1167}\x{1169}\x{116D}-\x{116E}\x{1172}-\x{1173}\x{1175}\x{119E}\x{11A8}] |
|
||||||
|
[\x{11AB}\x{11AE}-\x{11AF}\x{11B7}-\x{11B8}\x{11BA}\x{11BC}-\x{11C2}] |
|
||||||
|
[\x{11EB}\x{11F0}\x{11F9}\x{1E00}-\x{1E9B}\x{1EA0}-\x{1EF9}\x{1F00}-\x{1F15}] |
|
||||||
|
[\x{1F18}-\x{1F1D}\x{1F20}-\x{1F45}\x{1F48}-\x{1F4D}\x{1F50}-\x{1F57}] |
|
||||||
|
[\x{1F59}\x{1F5B}\x{1F5D}\x{1F5F}-\x{1F7D}\x{1F80}-\x{1FB4}\x{1FB6}-\x{1FBC}] |
|
||||||
|
[\x{1FBE}\x{1FC2}-\x{1FC4}\x{1FC6}-\x{1FCC}\x{1FD0}-\x{1FD3}] |
|
||||||
|
[\x{1FD6}-\x{1FDB}\x{1FE0}-\x{1FEC}\x{1FF2}-\x{1FF4}\x{1FF6}-\x{1FFC}] |
|
||||||
|
[\x{2126}\x{212A}-\x{212B}\x{212E}\x{2180}-\x{2182}\x{3041}-\x{3094}] |
|
||||||
|
[\x{30A1}-\x{30FA}\x{3105}-\x{312C}\x{AC00}-\x{D7A3}]
|
||||||
|
/x;
|
||||||
|
|
||||||
|
$Extender = qr/
|
||||||
|
[\x{00B7}\x{02D0}\x{02D1}\x{0387}\x{0640}\x{0E46}\x{0EC6}\x{3005}\x{3031}-\x{3035}\x{309D}-\x{309E}\x{30FC}-\x{30FE}]
|
||||||
|
/x;
|
||||||
|
|
||||||
|
$Digit = qr/
|
||||||
|
[\x{0030}-\x{0039}\x{0660}-\x{0669}\x{06F0}-\x{06F9}\x{0966}-\x{096F}] |
|
||||||
|
[\x{09E6}-\x{09EF}\x{0A66}-\x{0A6F}\x{0AE6}-\x{0AEF}\x{0B66}-\x{0B6F}] |
|
||||||
|
[\x{0BE7}-\x{0BEF}\x{0C66}-\x{0C6F}\x{0CE6}-\x{0CEF}\x{0D66}-\x{0D6F}] |
|
||||||
|
[\x{0E50}-\x{0E59}\x{0ED0}-\x{0ED9}\x{0F20}-\x{0F29}]
|
||||||
|
/x;
|
||||||
|
|
||||||
|
$CombiningChar = qr/
|
||||||
|
[\x{0300}-\x{0345}\x{0360}-\x{0361}\x{0483}-\x{0486}\x{0591}-\x{05A1}] |
|
||||||
|
[\x{05A3}-\x{05B9}\x{05BB}-\x{05BD}\x{05BF}\x{05C1}-\x{05C2}\x{05C4}] |
|
||||||
|
[\x{064B}-\x{0652}\x{0670}\x{06D6}-\x{06DC}\x{06DD}-\x{06DF}\x{06E0}-\x{06E4}] |
|
||||||
|
[\x{06E7}-\x{06E8}\x{06EA}-\x{06ED}\x{0901}-\x{0903}\x{093C}] |
|
||||||
|
[\x{093E}-\x{094C}\x{094D}\x{0951}-\x{0954}\x{0962}-\x{0963}\x{0981}-\x{0983}] |
|
||||||
|
[\x{09BC}\x{09BE}\x{09BF}\x{09C0}-\x{09C4}\x{09C7}-\x{09C8}] |
|
||||||
|
[\x{09CB}-\x{09CD}\x{09D7}\x{09E2}-\x{09E3}\x{0A02}\x{0A3C}\x{0A3E}\x{0A3F}] |
|
||||||
|
[\x{0A40}-\x{0A42}\x{0A47}-\x{0A48}\x{0A4B}-\x{0A4D}\x{0A70}-\x{0A71}] |
|
||||||
|
[\x{0A81}-\x{0A83}\x{0ABC}\x{0ABE}-\x{0AC5}\x{0AC7}-\x{0AC9}\x{0ACB}-\x{0ACD}] |
|
||||||
|
[\x{0B01}-\x{0B03}\x{0B3C}\x{0B3E}-\x{0B43}\x{0B47}-\x{0B48}] |
|
||||||
|
[\x{0B4B}-\x{0B4D}\x{0B56}-\x{0B57}\x{0B82}-\x{0B83}\x{0BBE}-\x{0BC2}] |
|
||||||
|
[\x{0BC6}-\x{0BC8}\x{0BCA}-\x{0BCD}\x{0BD7}\x{0C01}-\x{0C03}\x{0C3E}-\x{0C44}] |
|
||||||
|
[\x{0C46}-\x{0C48}\x{0C4A}-\x{0C4D}\x{0C55}-\x{0C56}\x{0C82}-\x{0C83}] |
|
||||||
|
[\x{0CBE}-\x{0CC4}\x{0CC6}-\x{0CC8}\x{0CCA}-\x{0CCD}\x{0CD5}-\x{0CD6}] |
|
||||||
|
[\x{0D02}-\x{0D03}\x{0D3E}-\x{0D43}\x{0D46}-\x{0D48}\x{0D4A}-\x{0D4D}\x{0D57}] |
|
||||||
|
[\x{0E31}\x{0E34}-\x{0E3A}\x{0E47}-\x{0E4E}\x{0EB1}\x{0EB4}-\x{0EB9}] |
|
||||||
|
[\x{0EBB}-\x{0EBC}\x{0EC8}-\x{0ECD}\x{0F18}-\x{0F19}\x{0F35}\x{0F37}\x{0F39}] |
|
||||||
|
[\x{0F3E}\x{0F3F}\x{0F71}-\x{0F84}\x{0F86}-\x{0F8B}\x{0F90}-\x{0F95}] |
|
||||||
|
[\x{0F97}\x{0F99}-\x{0FAD}\x{0FB1}-\x{0FB7}\x{0FB9}\x{20D0}-\x{20DC}\x{20E1}] |
|
||||||
|
[\x{302A}-\x{302F}\x{3099}\x{309A}]
|
||||||
|
/x;
|
||||||
|
|
||||||
|
$Ideographic = qr/
|
||||||
|
[\x{4E00}-\x{9FA5}\x{3007}\x{3021}-\x{3029}]
|
||||||
|
/x;
|
||||||
|
|
||||||
|
$NameChar = qr/^ (?: $BaseChar | $Ideographic | $Digit | [._:-] | $CombiningChar | $Extender )+ $/x;
|
||||||
|
PERL
|
||||||
|
|
||||||
|
die $@ if $@;
|
||||||
|
}
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
@ -0,0 +1,136 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl::Reader;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use XML::SAX::PurePerl::Reader::URI;
|
||||||
|
use Exporter ();
|
||||||
|
|
||||||
|
use vars qw(@ISA @EXPORT_OK);
|
||||||
|
@ISA = qw(Exporter);
|
||||||
|
@EXPORT_OK = qw(
|
||||||
|
EOF
|
||||||
|
BUFFER
|
||||||
|
LINE
|
||||||
|
COLUMN
|
||||||
|
ENCODING
|
||||||
|
XML_VERSION
|
||||||
|
);
|
||||||
|
|
||||||
|
use constant EOF => 0;
|
||||||
|
use constant BUFFER => 1;
|
||||||
|
use constant LINE => 2;
|
||||||
|
use constant COLUMN => 3;
|
||||||
|
use constant ENCODING => 4;
|
||||||
|
use constant SYSTEM_ID => 5;
|
||||||
|
use constant PUBLIC_ID => 6;
|
||||||
|
use constant XML_VERSION => 7;
|
||||||
|
|
||||||
|
require XML::SAX::PurePerl::Reader::Stream;
|
||||||
|
require XML::SAX::PurePerl::Reader::String;
|
||||||
|
|
||||||
|
if ($] >= 5.007002) {
|
||||||
|
require XML::SAX::PurePerl::Reader::UnicodeExt;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
require XML::SAX::PurePerl::Reader::NoUnicodeExt;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $class = shift;
|
||||||
|
my $thing = shift;
|
||||||
|
|
||||||
|
# try to figure if this $thing is a handle of some sort
|
||||||
|
if (ref($thing) && UNIVERSAL::isa($thing, 'IO::Handle')) {
|
||||||
|
return XML::SAX::PurePerl::Reader::Stream->new($thing)->init;
|
||||||
|
}
|
||||||
|
my $ioref;
|
||||||
|
if (tied($thing)) {
|
||||||
|
my $class = ref($thing);
|
||||||
|
no strict 'refs';
|
||||||
|
$ioref = $thing if defined &{"${class}::TIEHANDLE"};
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
eval {
|
||||||
|
$ioref = *{$thing}{IO};
|
||||||
|
};
|
||||||
|
undef $@;
|
||||||
|
}
|
||||||
|
if ($ioref) {
|
||||||
|
return XML::SAX::PurePerl::Reader::Stream->new($thing)->init;
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($thing =~ /</) {
|
||||||
|
# assume it's a string
|
||||||
|
return XML::SAX::PurePerl::Reader::String->new($thing)->init;
|
||||||
|
}
|
||||||
|
|
||||||
|
# assume it is a uri
|
||||||
|
return XML::SAX::PurePerl::Reader::URI->new($thing)->init;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub init {
|
||||||
|
my $self = shift;
|
||||||
|
$self->[LINE] = 1;
|
||||||
|
$self->[COLUMN] = 1;
|
||||||
|
$self->read_more;
|
||||||
|
return $self;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub data {
|
||||||
|
my ($self, $min_length) = (@_, 1);
|
||||||
|
if (length($self->[BUFFER]) < $min_length) {
|
||||||
|
$self->read_more;
|
||||||
|
}
|
||||||
|
return $self->[BUFFER];
|
||||||
|
}
|
||||||
|
|
||||||
|
sub match {
|
||||||
|
my ($self, $char) = @_;
|
||||||
|
my $data = $self->data;
|
||||||
|
if (substr($data, 0, 1) eq $char) {
|
||||||
|
$self->move_along(1);
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub public_id {
|
||||||
|
my $self = shift;
|
||||||
|
@_ and $self->[PUBLIC_ID] = shift;
|
||||||
|
$self->[PUBLIC_ID];
|
||||||
|
}
|
||||||
|
|
||||||
|
sub system_id {
|
||||||
|
my $self = shift;
|
||||||
|
@_ and $self->[SYSTEM_ID] = shift;
|
||||||
|
$self->[SYSTEM_ID];
|
||||||
|
}
|
||||||
|
|
||||||
|
sub line {
|
||||||
|
shift->[LINE];
|
||||||
|
}
|
||||||
|
|
||||||
|
sub column {
|
||||||
|
shift->[COLUMN];
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_encoding {
|
||||||
|
my $self = shift;
|
||||||
|
return $self->[ENCODING];
|
||||||
|
}
|
||||||
|
|
||||||
|
sub get_xml_version {
|
||||||
|
my $self = shift;
|
||||||
|
return $self->[XML_VERSION];
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
__END__
|
||||||
|
|
||||||
|
=head1 NAME
|
||||||
|
|
||||||
|
XML::Parser::PurePerl::Reader - Abstract Reader factory class
|
||||||
|
|
||||||
|
=cut
|
||||||
|
|
@ -0,0 +1,25 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl::Reader;
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
sub set_raw_stream {
|
||||||
|
# no-op
|
||||||
|
}
|
||||||
|
|
||||||
|
sub switch_encoding_stream {
|
||||||
|
my ($fh, $encoding) = @_;
|
||||||
|
throw XML::SAX::Exception::Parse (
|
||||||
|
Message => "Only ASCII encoding allowed without perl 5.7.2 or higher. You tried: $encoding",
|
||||||
|
) if $encoding !~ /(ASCII|UTF\-?8)/i;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub switch_encoding_string {
|
||||||
|
my (undef, $encoding) = @_;
|
||||||
|
throw XML::SAX::Exception::Parse (
|
||||||
|
Message => "Only ASCII encoding allowed without perl 5.7.2 or higher. You tried: $encoding",
|
||||||
|
) if $encoding !~ /(ASCII|UTF\-?8)/i;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,84 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl::Reader::Stream;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use vars qw(@ISA);
|
||||||
|
|
||||||
|
use XML::SAX::PurePerl::Reader qw(
|
||||||
|
EOF
|
||||||
|
BUFFER
|
||||||
|
LINE
|
||||||
|
COLUMN
|
||||||
|
ENCODING
|
||||||
|
XML_VERSION
|
||||||
|
);
|
||||||
|
use XML::SAX::Exception;
|
||||||
|
|
||||||
|
@ISA = ('XML::SAX::PurePerl::Reader');
|
||||||
|
|
||||||
|
# subclassed by adding 1 to last element
|
||||||
|
use constant FH => 8;
|
||||||
|
use constant BUFFER_SIZE => 4096;
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $class = shift;
|
||||||
|
my $ioref = shift;
|
||||||
|
XML::SAX::PurePerl::Reader::set_raw_stream($ioref);
|
||||||
|
my @parts;
|
||||||
|
@parts[FH, LINE, COLUMN, BUFFER, EOF, XML_VERSION] =
|
||||||
|
($ioref, 1, 0, '', 0, '1.0');
|
||||||
|
return bless \@parts, $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub read_more {
|
||||||
|
my $self = shift;
|
||||||
|
my $buf;
|
||||||
|
my $bytesread = read($self->[FH], $buf, BUFFER_SIZE);
|
||||||
|
if ($bytesread) {
|
||||||
|
$self->[BUFFER] .= $buf;
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
elsif (defined($bytesread)) {
|
||||||
|
$self->[EOF]++;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
throw XML::SAX::Exception::Parse(
|
||||||
|
Message => "Error reading from filehandle: $!",
|
||||||
|
);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub move_along {
|
||||||
|
my $self = shift;
|
||||||
|
my $discarded = substr($self->[BUFFER], 0, $_[0], '');
|
||||||
|
|
||||||
|
# Wish I could skip this lot - tells us where we are in the file
|
||||||
|
my $lines = $discarded =~ tr/\n//;
|
||||||
|
$self->[LINE] += $lines;
|
||||||
|
if ($lines) {
|
||||||
|
$discarded =~ /\n([^\n]*)$/;
|
||||||
|
$self->[COLUMN] = length($1);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$self->[COLUMN] += $_[0];
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub set_encoding {
|
||||||
|
my $self = shift;
|
||||||
|
my ($encoding) = @_;
|
||||||
|
# warn("set encoding to: $encoding\n");
|
||||||
|
XML::SAX::PurePerl::Reader::switch_encoding_stream($self->[FH], $encoding);
|
||||||
|
XML::SAX::PurePerl::Reader::switch_encoding_string($self->[BUFFER], $encoding);
|
||||||
|
$self->[ENCODING] = $encoding;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub bytepos {
|
||||||
|
my $self = shift;
|
||||||
|
tell($self->[FH]);
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,78 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl::Reader::String;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use vars qw(@ISA);
|
||||||
|
|
||||||
|
use XML::SAX::PurePerl::Reader qw(
|
||||||
|
LINE
|
||||||
|
COLUMN
|
||||||
|
BUFFER
|
||||||
|
ENCODING
|
||||||
|
EOF
|
||||||
|
);
|
||||||
|
|
||||||
|
@ISA = ('XML::SAX::PurePerl::Reader');
|
||||||
|
|
||||||
|
use constant DISCARDED => 8;
|
||||||
|
use constant STRING => 9;
|
||||||
|
use constant USED => 10;
|
||||||
|
use constant CHUNK_SIZE => 2048;
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $class = shift;
|
||||||
|
my $string = shift;
|
||||||
|
my @parts;
|
||||||
|
@parts[BUFFER, EOF, LINE, COLUMN, DISCARDED, STRING, USED] =
|
||||||
|
('', 0, 1, 0, 0, $string, 0);
|
||||||
|
return bless \@parts, $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub read_more () {
|
||||||
|
my $self = shift;
|
||||||
|
if ($self->[USED] >= length($self->[STRING])) {
|
||||||
|
$self->[EOF]++;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
my $bytes = CHUNK_SIZE;
|
||||||
|
if ($bytes > (length($self->[STRING]) - $self->[USED])) {
|
||||||
|
$bytes = (length($self->[STRING]) - $self->[USED]);
|
||||||
|
}
|
||||||
|
$self->[BUFFER] .= substr($self->[STRING], $self->[USED], $bytes);
|
||||||
|
$self->[USED] += $bytes;
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
sub move_along {
|
||||||
|
my($self, $bytes) = @_;
|
||||||
|
my $discarded = substr($self->[BUFFER], 0, $bytes, '');
|
||||||
|
$self->[DISCARDED] += length($discarded);
|
||||||
|
|
||||||
|
# Wish I could skip this lot - tells us where we are in the file
|
||||||
|
my $lines = $discarded =~ tr/\n//;
|
||||||
|
$self->[LINE] += $lines;
|
||||||
|
if ($lines) {
|
||||||
|
$discarded =~ /\n([^\n]*)$/;
|
||||||
|
$self->[COLUMN] = length($1);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$self->[COLUMN] += $_[0];
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub set_encoding {
|
||||||
|
my $self = shift;
|
||||||
|
my ($encoding) = @_;
|
||||||
|
|
||||||
|
XML::SAX::PurePerl::Reader::switch_encoding_string($self->[BUFFER], $encoding, "utf-8");
|
||||||
|
$self->[ENCODING] = $encoding;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub bytepos {
|
||||||
|
my $self = shift;
|
||||||
|
$self->[DISCARDED];
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
@ -0,0 +1,57 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl::Reader::URI;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
use XML::SAX::PurePerl::Reader;
|
||||||
|
use File::Temp qw(tempfile);
|
||||||
|
use Symbol;
|
||||||
|
|
||||||
|
## NOTE: This is *not* a subclass of Reader. It just returns Stream or String
|
||||||
|
## Reader objects depending on what it's capabilities are.
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $class = shift;
|
||||||
|
my $uri = shift;
|
||||||
|
# request the URI
|
||||||
|
if (-e $uri && -f _) {
|
||||||
|
my $fh = gensym;
|
||||||
|
open($fh, $uri) || die "Cannot open file $uri : $!";
|
||||||
|
return XML::SAX::PurePerl::Reader::Stream->new($fh);
|
||||||
|
}
|
||||||
|
elsif ($uri =~ /^file:(.*)$/ && -e $1 && -f _) {
|
||||||
|
my $file = $1;
|
||||||
|
my $fh = gensym;
|
||||||
|
open($fh, $file) || die "Cannot open file $file : $!";
|
||||||
|
return XML::SAX::PurePerl::Reader::Stream->new($fh);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
# request URI, return String reader
|
||||||
|
require LWP::UserAgent;
|
||||||
|
my $ua = LWP::UserAgent->new;
|
||||||
|
$ua->agent("Perl/XML/SAX/PurePerl/1.0 " . $ua->agent);
|
||||||
|
|
||||||
|
my $req = HTTP::Request->new(GET => $uri);
|
||||||
|
|
||||||
|
my $fh = tempfile();
|
||||||
|
|
||||||
|
my $callback = sub {
|
||||||
|
my ($data, $response, $protocol) = @_;
|
||||||
|
print $fh $data;
|
||||||
|
};
|
||||||
|
|
||||||
|
my $res = $ua->request($req, $callback, 4096);
|
||||||
|
|
||||||
|
if ($res->is_success) {
|
||||||
|
seek($fh, 0, 0);
|
||||||
|
return XML::SAX::PurePerl::Reader::Stream->new($fh);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
die "LWP Request Failed";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
@ -0,0 +1,23 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl::Reader;
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
use Encode ();
|
||||||
|
|
||||||
|
sub set_raw_stream {
|
||||||
|
my ($fh) = @_;
|
||||||
|
binmode($fh, ":bytes");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub switch_encoding_stream {
|
||||||
|
my ($fh, $encoding) = @_;
|
||||||
|
binmode($fh, ":encoding($encoding)");
|
||||||
|
}
|
||||||
|
|
||||||
|
sub switch_encoding_string {
|
||||||
|
$_[0] = Encode::decode($_[1], $_[0]);
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,22 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl;
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
no warnings 'utf8';
|
||||||
|
|
||||||
|
sub chr_ref {
|
||||||
|
return chr(shift);
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($] >= 5.007002) {
|
||||||
|
require Encode;
|
||||||
|
|
||||||
|
Encode::define_alias( "UTF-16" => "UCS-2" );
|
||||||
|
Encode::define_alias( "UTF-16BE" => "UCS-2" );
|
||||||
|
Encode::define_alias( "UTF-16LE" => "ucs-2le" );
|
||||||
|
Encode::define_alias( "UTF16LE" => "ucs-2le" );
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,129 @@
|
||||||
|
# $Id$
|
||||||
|
|
||||||
|
package XML::SAX::PurePerl;
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
use XML::SAX::PurePerl::Productions qw($S $VersionNum $EncNameStart $EncNameEnd);
|
||||||
|
|
||||||
|
sub XMLDecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(5);
|
||||||
|
# warn("Looking for xmldecl in: $data");
|
||||||
|
if ($data =~ /^<\?xml$S/o) {
|
||||||
|
$reader->move_along(5);
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
# get version attribute
|
||||||
|
$self->VersionInfo($reader) ||
|
||||||
|
$self->parser_error("XML Declaration lacks required version attribute, or version attribute does not match XML specification", $reader);
|
||||||
|
|
||||||
|
if (!$self->skip_whitespace($reader)) {
|
||||||
|
my $data = $reader->data(2);
|
||||||
|
$data =~ /^\?>/ or $self->parser_error("Syntax error", $reader);
|
||||||
|
$reader->move_along(2);
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
if ($self->EncodingDecl($reader)) {
|
||||||
|
if (!$self->skip_whitespace($reader)) {
|
||||||
|
my $data = $reader->data(2);
|
||||||
|
$data =~ /^\?>/ or $self->parser_error("Syntax error", $reader);
|
||||||
|
$reader->move_along(2);
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
$self->SDDecl($reader);
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
my $data = $reader->data(2);
|
||||||
|
$data =~ /^\?>/ or $self->parser_error("Syntax error", $reader);
|
||||||
|
$reader->move_along(2);
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
# warn("first 5 bytes: ", join(',', unpack("CCCCC", $data)), "\n");
|
||||||
|
# no xml decl
|
||||||
|
if (!$reader->get_encoding) {
|
||||||
|
$reader->set_encoding("UTF-8");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub VersionInfo {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(11);
|
||||||
|
|
||||||
|
# warn("Looking for version in $data");
|
||||||
|
|
||||||
|
$data =~ /^(version$S*=$S*(["'])($VersionNum)\2)/o or return 0;
|
||||||
|
$reader->move_along(length($1));
|
||||||
|
my $vernum = $3;
|
||||||
|
|
||||||
|
if ($vernum ne "1.0") {
|
||||||
|
$self->parser_error("Only XML version 1.0 supported. Saw: '$vernum'", $reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub SDDecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(15);
|
||||||
|
|
||||||
|
$data =~ /^(standalone$S*=$S*(["'])(yes|no)\2)/o or return 0;
|
||||||
|
$reader->move_along(length($1));
|
||||||
|
my $yesno = $3;
|
||||||
|
|
||||||
|
if ($yesno eq 'yes') {
|
||||||
|
$self->{standalone} = 1;
|
||||||
|
}
|
||||||
|
else {
|
||||||
|
$self->{standalone} = 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub EncodingDecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(12);
|
||||||
|
|
||||||
|
$data =~ /^(encoding$S*=$S*(["'])($EncNameStart$EncNameEnd*)\2)/o or return 0;
|
||||||
|
$reader->move_along(length($1));
|
||||||
|
my $encoding = $3;
|
||||||
|
|
||||||
|
$reader->set_encoding($encoding);
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub TextDecl {
|
||||||
|
my ($self, $reader) = @_;
|
||||||
|
|
||||||
|
my $data = $reader->data(6);
|
||||||
|
$data =~ /^<\?xml$S+/ or return;
|
||||||
|
$reader->move_along(5);
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
if ($self->VersionInfo($reader)) {
|
||||||
|
$self->skip_whitespace($reader) ||
|
||||||
|
$self->parser_error("Lack of whitespace after version attribute in text declaration", $reader);
|
||||||
|
}
|
||||||
|
|
||||||
|
$self->EncodingDecl($reader) ||
|
||||||
|
$self->parser_error("Encoding declaration missing from external entity text declaration", $reader);
|
||||||
|
|
||||||
|
$self->skip_whitespace($reader);
|
||||||
|
|
||||||
|
$data = $reader->data(2);
|
||||||
|
$data =~ /^\?>/ or $self->parser_error("Syntax error", $reader);
|
||||||
|
|
||||||
|
return 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
@ -0,0 +1,11 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 2 }
|
||||||
|
END { ok($loaded == 2) }
|
||||||
|
use XML::SAX;
|
||||||
|
$loaded++;
|
||||||
|
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
$loaded++;
|
||||||
|
|
||||||
|
ok(XML::SAX->VERSION eq XML::SAX::PurePerl->VERSION);
|
||||||
|
|
||||||
|
|
@ -0,0 +1,6 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 3 }
|
||||||
|
use XML::SAX;
|
||||||
|
ok(XML::SAX->save_parsers);
|
||||||
|
ok(XML::SAX->load_parsers);
|
||||||
|
ok(@{XML::SAX->parsers}, 0);
|
||||||
|
|
@ -0,0 +1,19 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 5 }
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
use XML::SAX::PurePerl::DebugHandler;
|
||||||
|
use IO::File;
|
||||||
|
|
||||||
|
my $handler = XML::SAX::PurePerl::DebugHandler->new();
|
||||||
|
ok($handler);
|
||||||
|
|
||||||
|
my $parser = XML::SAX::PurePerl->new(Handler => $handler);
|
||||||
|
ok($parser);
|
||||||
|
|
||||||
|
my $file = IO::File->new("testfiles/01.xml") || die $!;
|
||||||
|
ok($file);
|
||||||
|
|
||||||
|
$parser->parse_file($file);
|
||||||
|
ok($handler->{seen}{start_document});
|
||||||
|
ok($handler->{seen}{end_document});
|
||||||
|
|
||||||
|
|
@ -0,0 +1,38 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 10 }
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
use XML::SAX::PurePerl::DebugHandler;
|
||||||
|
use IO::File;
|
||||||
|
|
||||||
|
my $handler = XML::SAX::PurePerl::DebugHandler->new();
|
||||||
|
ok($handler);
|
||||||
|
|
||||||
|
my $parser = XML::SAX::PurePerl->new(Handler => $handler);
|
||||||
|
ok($parser);
|
||||||
|
|
||||||
|
my $file = IO::File->new("testfiles/02a.xml");
|
||||||
|
ok($file);
|
||||||
|
|
||||||
|
# check invalid characters
|
||||||
|
eval {
|
||||||
|
$parser->parse_file($file);
|
||||||
|
};
|
||||||
|
ok($@);
|
||||||
|
|
||||||
|
print $@;
|
||||||
|
|
||||||
|
ok($@->{Message});
|
||||||
|
ok($@->{LineNumber}, 1);
|
||||||
|
ok($@->{ColumnNumber}, 6);
|
||||||
|
|
||||||
|
# check invalid version number
|
||||||
|
eval {
|
||||||
|
$parser->parse_uri("file:testfiles/02b.xml");
|
||||||
|
};
|
||||||
|
ok($@);
|
||||||
|
|
||||||
|
print $@;
|
||||||
|
|
||||||
|
ok($@->{LineNumber}, 1);
|
||||||
|
ok($@->{ColumnNumber}, 19);
|
||||||
|
|
||||||
|
|
@ -0,0 +1,25 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 6 }
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
use XML::SAX::PurePerl::DebugHandler;
|
||||||
|
|
||||||
|
my $handler = XML::SAX::PurePerl::DebugHandler->new();
|
||||||
|
ok($handler);
|
||||||
|
|
||||||
|
my $parser = XML::SAX::PurePerl->new(Handler => $handler,
|
||||||
|
"http://xml.org/sax/handlers/LexicalHandler" => $handler);
|
||||||
|
ok($parser);
|
||||||
|
|
||||||
|
# check PIs and comments before document element parse ok
|
||||||
|
$parser->parse_uri("testfiles/03a.xml");
|
||||||
|
ok($handler->{seen}{processing_instruction}, 2);
|
||||||
|
ok($handler->{seen}{comment});
|
||||||
|
|
||||||
|
# check invalid version number
|
||||||
|
eval {
|
||||||
|
$parser->parse_uri("testfiles/03b.xml");
|
||||||
|
};
|
||||||
|
ok($@);
|
||||||
|
ok($@->{LineNumber}, 4);
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,14 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 3 }
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
use XML::SAX::PurePerl::DebugHandler;
|
||||||
|
|
||||||
|
my $handler = XML::SAX::PurePerl::DebugHandler->new();
|
||||||
|
ok($handler);
|
||||||
|
|
||||||
|
my $parser = XML::SAX::PurePerl->new(Handler => $handler);
|
||||||
|
ok($parser);
|
||||||
|
|
||||||
|
$parser->parse_uri("testfiles/04a.xml");
|
||||||
|
ok(1);
|
||||||
|
|
||||||
|
|
@ -0,0 +1,53 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { $tests = 0;
|
||||||
|
if ($] >= 5.007002) { $tests = 9 }
|
||||||
|
plan tests => $tests;
|
||||||
|
}
|
||||||
|
if ($tests) {
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
|
||||||
|
my $handler = TestHandler->new(); # see below for the TestHandler class
|
||||||
|
ok($handler);
|
||||||
|
|
||||||
|
my $parser = XML::SAX::PurePerl->new(Handler => $handler);
|
||||||
|
ok($parser);
|
||||||
|
|
||||||
|
# warn("utf-16\n");
|
||||||
|
# verify that the first element is correctly decoded
|
||||||
|
$handler->{test_elements} = [ "\x{9031}\x{5831}" ];
|
||||||
|
$parser->parse_uri("testfiles/utf-16.xml");
|
||||||
|
ok(1);
|
||||||
|
|
||||||
|
# warn("utf-16le\n");
|
||||||
|
$handler->{test_elements} = [ "foo" ];
|
||||||
|
$parser->parse_uri("testfiles/utf-16le.xml");
|
||||||
|
ok(1);
|
||||||
|
|
||||||
|
# warn("koi8_r\n");
|
||||||
|
$parser->parse_uri("testfiles/koi8_r.xml");
|
||||||
|
ok(1);
|
||||||
|
|
||||||
|
# warn("8859-1\n");
|
||||||
|
$parser->parse_uri("testfiles/iso8859_1.xml");
|
||||||
|
ok(1);
|
||||||
|
|
||||||
|
# warn("8859-2\n");
|
||||||
|
$parser->parse_uri("testfiles/iso8859_2.xml");
|
||||||
|
ok(1);
|
||||||
|
}
|
||||||
|
|
||||||
|
package TestHandler;
|
||||||
|
use XML::SAX::PurePerl::DebugHandler;
|
||||||
|
use base qw(XML::SAX::PurePerl::DebugHandler);
|
||||||
|
use Test;
|
||||||
|
|
||||||
|
sub start_element {
|
||||||
|
my $self = shift;
|
||||||
|
if ($self->{test_elements} and
|
||||||
|
my $value = pop @{$self->{test_elements}}) {
|
||||||
|
ok($_[0]->{Name}, $value);
|
||||||
|
}
|
||||||
|
$self->SUPER::start_element(@_);
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
@ -0,0 +1,113 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 32 }
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
use XML::SAX::PurePerl::DebugHandler;
|
||||||
|
|
||||||
|
my $handler = TestElementHandler->new();
|
||||||
|
ok($handler);
|
||||||
|
|
||||||
|
my $parser = XML::SAX::PurePerl->new(Handler => $handler);
|
||||||
|
ok($parser);
|
||||||
|
|
||||||
|
$handler->{test_el}{Name} = "foo";
|
||||||
|
$handler->{test_el}{LocalName} = "foo";
|
||||||
|
$handler->{test_el}{Prefix} = "";
|
||||||
|
$handler->{test_el}{NamespaceURI} = "";
|
||||||
|
$parser->parse_uri("testfiles/06a.xml");
|
||||||
|
|
||||||
|
$handler->reset;
|
||||||
|
|
||||||
|
$handler->{attr_name} = "{}a";
|
||||||
|
$handler->{test_attr}{Name} = "a";
|
||||||
|
$handler->{test_attr}{Value} = "1";
|
||||||
|
$handler->{test_attr}{Prefix} = "";
|
||||||
|
$handler->{test_attr}{LocalName} = "a";
|
||||||
|
$handler->{test_attr}{NamespaceURI} = "";
|
||||||
|
$parser->parse_uri("testfiles/06b.xml");
|
||||||
|
|
||||||
|
$handler->reset;
|
||||||
|
|
||||||
|
$handler->{test_el}{Name} = "foo";
|
||||||
|
$handler->{test_el}{LocalName} = "foo";
|
||||||
|
$handler->{test_el}{Prefix} = "";
|
||||||
|
$handler->{test_el}{NamespaceURI} = "http://foo.com";
|
||||||
|
$parser->parse_uri("testfiles/06c.xml");
|
||||||
|
|
||||||
|
$handler->reset;
|
||||||
|
$handler->{test_el}{Name} = "x:foo";
|
||||||
|
$handler->{test_el}{LocalName} = "foo";
|
||||||
|
$handler->{test_el}{Prefix} = "x";
|
||||||
|
$handler->{test_el}{NamespaceURI} = "http://foo.com";
|
||||||
|
$handler->{attr_name} = "{http://foo.com}a";
|
||||||
|
$handler->{test_attr}{Name} = "x:a";
|
||||||
|
$handler->{test_attr}{Value} = "2";
|
||||||
|
$handler->{test_attr}{Prefix} = "x";
|
||||||
|
$handler->{test_attr}{LocalName} = "a";
|
||||||
|
$handler->{test_attr}{NamespaceURI} = "http://foo.com";
|
||||||
|
$parser->parse_uri("testfiles/06d.xml");
|
||||||
|
|
||||||
|
$handler->reset;
|
||||||
|
$handler->{test_el}{Name} = "foo";
|
||||||
|
$handler->{test_el}{LocalName} = "foo";
|
||||||
|
$handler->{test_el}{Prefix} = "";
|
||||||
|
$handler->{test_el}{NamespaceURI} = "http://foo.com";
|
||||||
|
$handler->{attr_name} = "{}a";
|
||||||
|
$handler->{test_attr}{Name} = "a";
|
||||||
|
$handler->{test_attr}{NamespaceURI} = "";
|
||||||
|
$parser->parse_uri("testfiles/06e.xml");
|
||||||
|
|
||||||
|
$handler->reset;
|
||||||
|
# prefix with no ns binding. Error.
|
||||||
|
eval {
|
||||||
|
$parser->parse_uri("testfiles/06f.xml");
|
||||||
|
};
|
||||||
|
ok($@);
|
||||||
|
|
||||||
|
$handler->reset;
|
||||||
|
$handler->{test_chr}{Data} = "bar";
|
||||||
|
$parser->parse_uri("testfiles/06g.xml");
|
||||||
|
|
||||||
|
## HELPER PACKAGE ##
|
||||||
|
|
||||||
|
package TestElementHandler;
|
||||||
|
|
||||||
|
use Test;
|
||||||
|
|
||||||
|
sub new {
|
||||||
|
my $class = shift;
|
||||||
|
my %opts = @_;
|
||||||
|
bless \%opts, $class;
|
||||||
|
}
|
||||||
|
|
||||||
|
sub reset {
|
||||||
|
my $self = shift;
|
||||||
|
%$self = ();
|
||||||
|
}
|
||||||
|
|
||||||
|
sub start_element {
|
||||||
|
my ($self, $el) = @_;
|
||||||
|
if ($self->{test_el}) {
|
||||||
|
foreach my $key (keys %{ $self->{test_el} }) {
|
||||||
|
#warn $key, "\n";
|
||||||
|
ok("$key: $el->{$key}", "$key: $self->{test_el}{$key}");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
if ($self->{test_attr}) {
|
||||||
|
foreach my $key (keys %{ $self->{test_attr} }) {
|
||||||
|
#warn $key, "\n";
|
||||||
|
ok("$key: $el->{Attributes}{ $self->{attr_name} }{$key}", "$key: $self->{test_attr}{$key}");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
sub characters {
|
||||||
|
my ($self, @text) = @_;
|
||||||
|
if ($self->{test_chr}) {
|
||||||
|
foreach my $text (@text) {
|
||||||
|
foreach my $key (keys %{ $self->{test_chr} }) {
|
||||||
|
#warn $key, "\n";
|
||||||
|
ok("$key: $text->{$key}", "$key: $self->{test_chr}{$key}");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,16 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 3 }
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
use XML::SAX::PurePerl::DebugHandler;
|
||||||
|
|
||||||
|
my $handler = XML::SAX::PurePerl::DebugHandler->new();
|
||||||
|
ok($handler);
|
||||||
|
|
||||||
|
my $parser = XML::SAX::PurePerl->new(Handler => $handler);
|
||||||
|
ok($parser);
|
||||||
|
|
||||||
|
my $time = time;
|
||||||
|
$parser->parse_uri("testfiles/xmltest.xml");
|
||||||
|
warn("parsed ", -s "testfiles/xmltest.xml", " bytes in ", time - $time, " seconds\n");
|
||||||
|
ok(1);
|
||||||
|
|
||||||
|
|
@ -0,0 +1,26 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 2 }
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
use XML::SAX::PurePerl::DebugHandler;
|
||||||
|
|
||||||
|
my $value = do { local $/ = undef; my $data = <DATA>; };
|
||||||
|
|
||||||
|
my $parser = XML::SAX::PurePerl->new(Handler => My::SAXFilter->new());
|
||||||
|
$parser->parse_string($value);
|
||||||
|
|
||||||
|
package My::SAXFilter;
|
||||||
|
|
||||||
|
use base qw(XML::SAX::Base);
|
||||||
|
|
||||||
|
sub processing_instruction {
|
||||||
|
my $this = shift;
|
||||||
|
my $data = shift;
|
||||||
|
|
||||||
|
main::ok($data->{Target},"xml-stylesheet");
|
||||||
|
main::ok($data->{Data},"type=\"text/xsl\" href=\"processorinxml/base.xsl\"");
|
||||||
|
}
|
||||||
|
|
||||||
|
__END__
|
||||||
|
<?xml version="1.0"?>
|
||||||
|
<?xml-stylesheet type="text/xsl" href="processorinxml/base.xsl"?>
|
||||||
|
<body/>
|
||||||
|
|
@ -0,0 +1,42 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 16 }
|
||||||
|
use XML::SAX::ParserFactory;
|
||||||
|
|
||||||
|
# load SAX parsers (no ParserDetails.ini available at first in blib)
|
||||||
|
use XML::SAX qw(Namespaces Validation);
|
||||||
|
ok(@{XML::SAX->parsers}, 0);
|
||||||
|
ok(XML::SAX->add_parser(q(XML::SAX::PurePerl)));
|
||||||
|
ok(@{XML::SAX->parsers}, 1);
|
||||||
|
|
||||||
|
ok(XML::SAX::ParserFactory->parser); # test class method
|
||||||
|
my $factory = XML::SAX::ParserFactory->new();
|
||||||
|
ok($factory);
|
||||||
|
ok($factory->parser);
|
||||||
|
|
||||||
|
ok($factory->require_feature(Namespaces));
|
||||||
|
ok($factory->parser);
|
||||||
|
|
||||||
|
ok($factory->require_feature(Validation));
|
||||||
|
eval {
|
||||||
|
my $parser = $factory->parser;
|
||||||
|
# should never get here unless PurePerl starts providing validation
|
||||||
|
ok(!$parser);
|
||||||
|
};
|
||||||
|
ok($@);
|
||||||
|
ok($@->isa('XML::SAX::Exception'));
|
||||||
|
|
||||||
|
$factory = XML::SAX::ParserFactory->new();
|
||||||
|
my $parser = $factory->parser;
|
||||||
|
ok($parser);
|
||||||
|
eval {
|
||||||
|
$parser->parse_string('<widget/>');
|
||||||
|
ok(1);
|
||||||
|
};
|
||||||
|
ok(!$@);
|
||||||
|
|
||||||
|
local $XML::SAX::ParserPackage = 'XML::SAX::PurePerl';
|
||||||
|
ok(XML::SAX::ParserFactory->parser);
|
||||||
|
|
||||||
|
local $XML::SAX::ParserPackage = 'XML::SAX::PurePerl (0.01)';
|
||||||
|
ok(XML::SAX::ParserFactory->parser);
|
||||||
|
|
||||||
|
|
@ -0,0 +1,63 @@
|
||||||
|
use strict;
|
||||||
|
use Test;
|
||||||
|
plan tests => 8;
|
||||||
|
|
||||||
|
use File::Path;
|
||||||
|
use Fatal qw(open close chdir mkpath);
|
||||||
|
use XML::SAX;
|
||||||
|
use vars qw(*FILE);
|
||||||
|
|
||||||
|
ok(@{XML::SAX->parsers}, 0);
|
||||||
|
ok(XML::SAX->add_parser(q(XML::SAX::PurePerl)));
|
||||||
|
ok(@{XML::SAX->parsers}, 1);
|
||||||
|
|
||||||
|
rmtree('t/lib', 0, 0);
|
||||||
|
mkpath('t/lib', 0, 0777);
|
||||||
|
|
||||||
|
push @INC, 't/lib';
|
||||||
|
write_file('t/lib/TestParserPackage.pm', <<EOT);
|
||||||
|
package TestParserPackage;
|
||||||
|
use XML::SAX::Base;
|
||||||
|
\@ISA = qw(XML::SAX::Base);
|
||||||
|
sub new {
|
||||||
|
return bless {}, shift
|
||||||
|
}
|
||||||
|
sub supported_features {
|
||||||
|
return ('http://axkit.org/sax/frobnosticating');
|
||||||
|
}
|
||||||
|
1;
|
||||||
|
EOT
|
||||||
|
|
||||||
|
my $parser;
|
||||||
|
|
||||||
|
# Test we can get TestParserPackage out
|
||||||
|
write_file('t/lib/SAX.ini', 'ParserPackage = TestParserPackage');
|
||||||
|
$parser = XML::SAX::ParserFactory->parser();
|
||||||
|
ok(ref($parser), "TestParserPackage", "Parser was not TestParserPackage");
|
||||||
|
|
||||||
|
# Test we can get XML::SAX::PurePerl out
|
||||||
|
write_file('t/lib/SAX.ini', 'ParserPackage = XML::SAX::PurePerl');
|
||||||
|
$parser = XML::SAX::ParserFactory->parser();
|
||||||
|
ok(ref($parser), "XML::SAX::PurePerl", "Parser was not XML::SAX::PurePerl");
|
||||||
|
|
||||||
|
# Test we can ask for a frobnosticating parser, but not get it
|
||||||
|
write_file('t/lib/SAX.ini', 'http://axkit.org/sax/frobnosticating = 1');
|
||||||
|
$parser = XML::SAX::ParserFactory->parser();
|
||||||
|
ok(ref($parser), "XML::SAX::PurePerl", "Parser was not PurePerl (frobnosticating)");
|
||||||
|
|
||||||
|
# Test we can ask for a frobnosticating parser, and get it
|
||||||
|
XML::SAX->add_parser('TestParserPackage');
|
||||||
|
$parser = XML::SAX::ParserFactory->parser();
|
||||||
|
ok(ref($parser), "TestParserPackage", "Parser was not TestParserPackage (frobnosticating)");
|
||||||
|
|
||||||
|
# Test we can get a namespaces parser
|
||||||
|
write_file('t/lib/SAX.ini', 'http://xml.org/sax/features/namespaces = 1');
|
||||||
|
$parser = XML::SAX::ParserFactory->parser();
|
||||||
|
ok(ref($parser), "XML::SAX::PurePerl", "Parser was not PurePerl (namespaces)");
|
||||||
|
|
||||||
|
sub write_file {
|
||||||
|
my ($file, $data) = @_;
|
||||||
|
open(FILE, ">$file");
|
||||||
|
print FILE $data, "\n";
|
||||||
|
close FILE;
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,29 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 5 }
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
use XML::SAX::PurePerl::DebugHandler;
|
||||||
|
use IO::File;
|
||||||
|
|
||||||
|
my $handler = XML::SAX::PurePerl::DebugHandler->new();
|
||||||
|
ok($handler);
|
||||||
|
|
||||||
|
my $parser = XML::SAX::PurePerl->new(Handler => $handler);
|
||||||
|
ok($parser);
|
||||||
|
|
||||||
|
my $file1 = IO::File->new("testfiles/01.xml");
|
||||||
|
ok($file1);
|
||||||
|
|
||||||
|
eval {
|
||||||
|
$parser->parse_file($file1);
|
||||||
|
};
|
||||||
|
print $@;
|
||||||
|
ok(!$@);
|
||||||
|
|
||||||
|
my $file2 = "testfiles/01.xml";
|
||||||
|
|
||||||
|
eval {
|
||||||
|
$parser->parse_file($file2);
|
||||||
|
};
|
||||||
|
print $@;
|
||||||
|
ok(!$@);
|
||||||
|
|
||||||
|
|
@ -0,0 +1,31 @@
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 4 }
|
||||||
|
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
|
||||||
|
my $handler = CDataHandler->new();
|
||||||
|
ok($handler);
|
||||||
|
|
||||||
|
my $parser = XML::SAX::PurePerl->new(Handler => $handler);
|
||||||
|
ok($parser);
|
||||||
|
|
||||||
|
$parser->parse_string('<code><![CDATA[<crackers & cheese>]]></code>');
|
||||||
|
ok(1); # parser didn't die
|
||||||
|
|
||||||
|
my $expected = '<crackers & cheese>';
|
||||||
|
ok($handler->cbuffer, $expected);
|
||||||
|
|
||||||
|
exit;
|
||||||
|
|
||||||
|
|
||||||
|
package CDataHandler;
|
||||||
|
|
||||||
|
use base 'XML::SAX::Base';
|
||||||
|
|
||||||
|
sub start_document { shift->{_buf} = ''; }
|
||||||
|
sub characters { shift->{_buf} .= shift->{Data}; }
|
||||||
|
sub cbuffer { shift->{_buf}; }
|
||||||
|
|
||||||
|
|
@ -0,0 +1,37 @@
|
||||||
|
use strict;
|
||||||
|
use warnings;
|
||||||
|
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 4 }
|
||||||
|
|
||||||
|
use XML::SAX::PurePerl;
|
||||||
|
|
||||||
|
my $handler = AttrHandler->new();
|
||||||
|
ok($handler);
|
||||||
|
|
||||||
|
my $parser = XML::SAX::PurePerl->new(Handler => $handler);
|
||||||
|
ok($parser);
|
||||||
|
|
||||||
|
$parser->parse_string('<code amp="&" x3E=">" num="A" />');
|
||||||
|
ok(1); # parser didn't die
|
||||||
|
|
||||||
|
my $expected = "amp=& num=A x3E=> ";
|
||||||
|
ok($handler->attributes, $expected);
|
||||||
|
|
||||||
|
exit;
|
||||||
|
|
||||||
|
|
||||||
|
package AttrHandler;
|
||||||
|
|
||||||
|
use base 'XML::SAX::Base';
|
||||||
|
|
||||||
|
sub start_document { shift->{_buf} = ''; }
|
||||||
|
sub attributes { shift->{_buf}; }
|
||||||
|
|
||||||
|
sub start_element {
|
||||||
|
my($self, $data) = @_;
|
||||||
|
my $attr = $data->{Attributes};
|
||||||
|
foreach (sort keys %$attr) {
|
||||||
|
$self->{_buf} .= "$attr->{$_}->{LocalName}=$attr->{$_}->{Value} ";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,8 @@
|
||||||
|
use Test;
|
||||||
|
BEGIN { plan tests => 1 }
|
||||||
|
use File::Spec;
|
||||||
|
ok(unlink(
|
||||||
|
File::Spec->catdir(qw(blib lib XML SAX ParserDetails.ini))),
|
||||||
|
1,
|
||||||
|
'delete ParserDetails.ini'
|
||||||
|
);
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
<?xml version="1.0"?>
|
||||||
|
<foo/>
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
<?xml version="1.0!"?>
|
||||||
|
|
@ -0,0 +1,4 @@
|
||||||
|
<?xml version="2.0" standalone="yes"?>
|
||||||
|
<foo>
|
||||||
|
Hello World
|
||||||
|
</foo>
|
||||||
|
|
@ -0,0 +1,5 @@
|
||||||
|
<?xml version="1.0"?>
|
||||||
|
<?foo foo?>
|
||||||
|
<?foo?>
|
||||||
|
<!--comment-->
|
||||||
|
<foo/>
|
||||||
|
|
@ -0,0 +1,5 @@
|
||||||
|
<?xml version="1.0"?>
|
||||||
|
<?foo foo?>
|
||||||
|
<?foo?>
|
||||||
|
<!--bad comment--->
|
||||||
|
<foo/>
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
<foo>text &</foo>
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
<foo/>
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
<foo a="1"/>
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
<foo xmlns="http://foo.com"/>
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
<x:foo xmlns:x="http://foo.com" a="1" x:a="2"/>
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
<foo xmlns="http://foo.com" a="1"/>
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
<!-- namespace validation error -->
|
||||||
|
<b:foo xmlns:a="http://foo.com"/>
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
<foo><![CDATA[bar]]></foo>
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
<?xml version="1.0" encoding="ISO8859-1"?>
|
||||||
|
<foo>Some Latin-1 chars: éÊË</foo>
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
<?xml version="1.0" encoding="ISO8859-2"?>
|
||||||
|
<foo>Some Latin-2 chars: ñýÎ (could do with some real latin-2 here)</foo>
|
||||||
|
|
@ -0,0 +1,9 @@
|
||||||
|
<?xml version="1.0" encoding="koi8-r"?>
|
||||||
|
|
||||||
|
<документ атт="русский">
|
||||||
|
<раздел>
|
||||||
|
<голова>Тест</голова>
|
||||||
|
Здравствуй Мир!
|
||||||
|
</раздел>
|
||||||
|
</документ>
|
||||||
|
|
||||||
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue