mirror of
https://github.com/paparazzi/paparazzi.git
synced 2026-09-28 16:12:40 +08:00
Adding more perl modules
Adding more support modules that are needed by XML::Simple to read the conf/conf.xml.example. Adding these files into the repository means that users don't need to install them on their computers.
This commit is contained in:
@@ -175,3 +175,7 @@ sw/ground_segment/lpc21iap/lpc21iap.dSYM/Contents/Info.plist
|
||||
sw/ground_segment/lpc21iap/lpc21iap.dSYM/Contents/Resources/DWARF/lpc21iap
|
||||
|
||||
tests/results/*
|
||||
|
||||
sw/logalizer/plotprofile.dSYM/Contents/Resources/DWARF/plotprofile
|
||||
|
||||
sw/logalizer/plotprofile.dSYM/Contents/Info.plist
|
||||
|
||||
@@ -259,9 +259,6 @@ dist_clean_irreversible: clean
|
||||
ab_clean:
|
||||
find sw/airborne -name '*~' -exec rm -f {} \;
|
||||
|
||||
test_all_example_airframes: replace_current_conf_xml
|
||||
for ap in `grep name conf/conf.xml.example | sed -e 's/.*name=\"//' | sed -e 's/".*//'`; do for airframe in `grep $$ap conf/conf.xml.example | sed -e 's/.*airframe=\"//' | sed -e 's/".*//'`; do for target in `grep target conf/$$airframe | grep name | sed -e 's/.*name=\"//' | sed -e 's/\".*//'`; do echo "Making $$ap $$target"; make -C ./ AIRCRAFT=$$ap clean_ac $$target.compile || exit 1; done; done; done
|
||||
|
||||
replace_current_conf_xml:
|
||||
test conf/conf.xml || mv conf/conf.xml conf/conf.xml.backup.`date +%Y%m%d-%H%M%s`
|
||||
cp conf/conf.xml.example conf/conf.xml
|
||||
@@ -276,7 +273,9 @@ sw/simulator/launchsitl:
|
||||
cat src/$(@F) | sed s#OCAMLRUN#$(OCAMLRUN)# | sed s#OCAML#$(OCAML)# > $@
|
||||
chmod a+x $@
|
||||
|
||||
|
||||
test: all replace_current_conf_xml
|
||||
cd tests; $(MAKE) $(@)
|
||||
|
||||
test_all_example_airframes: replace_current_conf_xml
|
||||
cd tests; $(MAKE) $(@) TARGET_BOARD=examples
|
||||
|
||||
|
||||
@@ -24,7 +24,7 @@ my $upload_output = run_program(
|
||||
"Attempting to build and upload the firmware.",
|
||||
$ENV{'PAPARAZZI_SRC'},
|
||||
"make $make_upload_options",
|
||||
1,1);
|
||||
0,1);
|
||||
unlike($upload_output, '/Error/i', "The upload output does not contain the word \"Error\"");
|
||||
|
||||
|
||||
|
||||
Executable
+583
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -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,129 @@
|
||||
package XML::SAX::Exception;
|
||||
BEGIN {
|
||||
$XML::SAX::Exception::VERSION = '1.08';
|
||||
}
|
||||
|
||||
use strict;
|
||||
|
||||
use overload '""' => "stringify",
|
||||
'fallback' => 1;
|
||||
|
||||
use vars qw($StackTrace);
|
||||
|
||||
use Carp;
|
||||
|
||||
$StackTrace = $ENV{XML_DEBUG} || 0;
|
||||
|
||||
# Other exception classes:
|
||||
|
||||
@XML::SAX::Exception::NotRecognized::ISA = ('XML::SAX::Exception');
|
||||
@XML::SAX::Exception::NotSupported::ISA = ('XML::SAX::Exception');
|
||||
@XML::SAX::Exception::Parse::ISA = ('XML::SAX::Exception');
|
||||
|
||||
|
||||
sub throw {
|
||||
my $class = shift;
|
||||
if (ref($class)) {
|
||||
die $class;
|
||||
}
|
||||
die $class->new(@_);
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %opts = @_;
|
||||
confess "Invalid options: " . join(', ', keys %opts) unless exists $opts{Message};
|
||||
|
||||
bless { ($StackTrace ? (StackTrace => stacktrace()) : ()), %opts },
|
||||
$class;
|
||||
}
|
||||
|
||||
sub stringify {
|
||||
my $self = shift;
|
||||
local $^W;
|
||||
my $error;
|
||||
if (exists $self->{LineNumber}) {
|
||||
$error = $self->{Message} . " [Ln: " . $self->{LineNumber} .
|
||||
", Col: " . $self->{ColumnNumber} . "]";
|
||||
}
|
||||
else {
|
||||
$error = $self->{Message};
|
||||
}
|
||||
if ($StackTrace) {
|
||||
$error .= stackstring($self->{StackTrace});
|
||||
}
|
||||
$error .= "\n";
|
||||
return $error;
|
||||
}
|
||||
|
||||
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;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::SAX::Exception - Exception classes for XML::SAX
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
throw XML::SAX::Exception::NotSupported(
|
||||
Message => "The foo feature is not supported",
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is the base class for all SAX Exceptions, those defined in
|
||||
the spec as well as those that one may create for one's own SAX errors.
|
||||
|
||||
There are three subclasses included, corresponding to those of the SAX
|
||||
spec:
|
||||
|
||||
XML::SAX::Exception::NotSupported
|
||||
XML::SAX::Exception::NotRecognized
|
||||
XML::SAX::Exception::Parse
|
||||
|
||||
Use them wherever you want, and as much as possible when you encounter
|
||||
such errors. SAX is meant to use exceptions as much as possible to
|
||||
flag problems.
|
||||
|
||||
=head1 CREATING NEW EXCEPTION CLASSES
|
||||
|
||||
All you need to do to create a new exception class is:
|
||||
|
||||
@XML::SAX::Exception::MyException::ISA = ('XML::SAX::Exception')
|
||||
|
||||
The given package doesn't need to exist, it'll behave correctly this
|
||||
way. If your exception refines an existing exception class, then you
|
||||
may also inherit from that instead of from the base class.
|
||||
|
||||
=head1 THROWING EXCEPTIONS
|
||||
|
||||
This is as simple as exemplified in the SYNOPSIS. In fact, there's
|
||||
nothing more to know. All you have to do is:
|
||||
|
||||
throw XML::SAX::Exception::MyException( Message => 'Something went wrong' );
|
||||
|
||||
and voila, you've thrown an exception which can be caught in an eval block.
|
||||
|
||||
=cut
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -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 Sytem 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;
|
||||
Reference in New Issue
Block a user