Revision history for Perl extension XML::Parser.
+2.46 2019-09-24 (by Todd Rinaldo)
+ - use foreach not for for loops
+ - produce README.md so travis will show up on github
+ - remove use vars and switch to our.
+ - travis-ci testing from 5.8..5.28
+ - Convert XML::Parser to use 3 arg opens with no barewords.
+ - Migrate tracker to github
+ - Switch to XSLoader
+ - Fix a buffer overwrite in parse_stream()
+
2.44 2015-01-12 (by Todd Rinaldo)
- RT 99098 - Revert "Add more useful error message on parse to Expat". It breaks
XML::Twig. Calling code will need to do this if it's needed.
package XML::Parser::Expat;
-require 5.004;
-
use strict;
-use vars qw($VERSION @ISA %Handler_Setters %Encoding_Table @Encoding_Path
- $have_File_Spec);
+
+#use warnings; No warnings numeric??
+
+use XSLoader;
use Carp;
-require DynaLoader;
+our $VERSION = '2.46';
-@ISA = qw(DynaLoader);
-$VERSION = "2.44";
+our ( %Encoding_Table, @Encoding_Path, $have_File_Spec );
-$have_File_Spec = $INC{'File/Spec.pm'} || do 'File/Spec.pm';
+use File::Spec ();
%Encoding_Table = ();
if ($have_File_Spec) {
- @Encoding_Path = (grep(-d $_,
- map(File::Spec->catdir($_, qw(XML Parser Encodings)),
- @INC)),
- File::Spec->curdir);
+ @Encoding_Path = (
+ grep( -d $_,
+ map( File::Spec->catdir( $_, qw(XML Parser Encodings) ),
+ @INC ) ),
+ File::Spec->curdir
+ );
}
else {
- @Encoding_Path = (grep(-d $_, map($_ . '/XML/Parser/Encodings', @INC)), '.');
+ @Encoding_Path = ( grep( -d $_, map( $_ . '/XML/Parser/Encodings', @INC ) ), '.' );
}
-
-
-bootstrap XML::Parser::Expat $VERSION;
-
-%Handler_Setters = (
- Start => \&SetStartElementHandler,
- End => \&SetEndElementHandler,
- Char => \&SetCharacterDataHandler,
- Proc => \&SetProcessingInstructionHandler,
- Comment => \&SetCommentHandler,
- CdataStart => \&SetStartCdataHandler,
- CdataEnd => \&SetEndCdataHandler,
- Default => \&SetDefaultHandler,
- Unparsed => \&SetUnparsedEntityDeclHandler,
- Notation => \&SetNotationDeclHandler,
- ExternEnt => \&SetExternalEntityRefHandler,
- ExternEntFin => \&SetExtEntFinishHandler,
- Entity => \&SetEntityDeclHandler,
- Element => \&SetElementDeclHandler,
- Attlist => \&SetAttListDeclHandler,
- Doctype => \&SetDoctypeHandler,
- DoctypeFin => \&SetEndDoctypeHandler,
- XMLDecl => \&SetXMLDeclHandler
- );
+
+XSLoader::load( 'XML::Parser::Expat', $VERSION );
+
+our %Handler_Setters = (
+ Start => \&SetStartElementHandler,
+ End => \&SetEndElementHandler,
+ Char => \&SetCharacterDataHandler,
+ Proc => \&SetProcessingInstructionHandler,
+ Comment => \&SetCommentHandler,
+ CdataStart => \&SetStartCdataHandler,
+ CdataEnd => \&SetEndCdataHandler,
+ Default => \&SetDefaultHandler,
+ Unparsed => \&SetUnparsedEntityDeclHandler,
+ Notation => \&SetNotationDeclHandler,
+ ExternEnt => \&SetExternalEntityRefHandler,
+ ExternEntFin => \&SetExtEntFinishHandler,
+ Entity => \&SetEntityDeclHandler,
+ Element => \&SetElementDeclHandler,
+ Attlist => \&SetAttListDeclHandler,
+ Doctype => \&SetDoctypeHandler,
+ DoctypeFin => \&SetEndDoctypeHandler,
+ XMLDecl => \&SetXMLDeclHandler
+);
sub new {
- my ($class, %args) = @_;
- my $self = bless \%args, $_[0];
- $args{_State_} = 0;
- $args{Context} = [];
- $args{Namespaces} ||= 0;
- $args{ErrorMessage} ||= '';
- if ($args{Namespaces}) {
- $args{Namespace_Table} = {};
- $args{Namespace_List} = [undef];
- $args{Prefix_Table} = {};
- $args{New_Prefixes} = [];
- }
- $args{_Setters} = \%Handler_Setters;
- $args{Parser} = ParserCreate($self, $args{ProtocolEncoding},
- $args{Namespaces});
- $self;
+ my ( $class, %args ) = @_;
+ my $self = bless \%args, $_[0];
+ $args{_State_} = 0;
+ $args{Context} = [];
+ $args{Namespaces} ||= 0;
+ $args{ErrorMessage} ||= '';
+ if ( $args{Namespaces} ) {
+ $args{Namespace_Table} = {};
+ $args{Namespace_List} = [undef];
+ $args{Prefix_Table} = {};
+ $args{New_Prefixes} = [];
+ }
+ $args{_Setters} = \%Handler_Setters;
+ $args{Parser} = ParserCreate(
+ $self, $args{ProtocolEncoding},
+ $args{Namespaces}
+ );
+ $self;
}
sub load_encoding {
- my ($file) = @_;
-
- $file =~ s!([^/]+)$!\L$1\E!;
- $file .= '.enc' unless $file =~ /\.enc$/;
- unless ($file =~ m!^/!) {
- foreach (@Encoding_Path) {
- my $tmp = ($have_File_Spec
- ? File::Spec->catfile($_, $file)
- : "$_/$file");
- if (-e $tmp) {
- $file = $tmp;
- last;
- }
+ my ($file) = @_;
+
+ $file =~ s!([^/]+)$!\L$1\E!;
+ $file .= '.enc' unless $file =~ /\.enc$/;
+ unless ( $file =~ m!^/! ) {
+ foreach (@Encoding_Path) {
+ my $tmp = (
+ $have_File_Spec
+ ? File::Spec->catfile( $_, $file )
+ : "$_/$file"
+ );
+ if ( -e $tmp ) {
+ $file = $tmp;
+ last;
+ }
+ }
}
- }
- local(*ENC);
- open(ENC, $file) or croak("Couldn't open encmap $file:\n$!\n");
- binmode(ENC);
- my $data;
- my $br = sysread(ENC, $data, -s $file);
- croak("Trouble reading $file:\n$!\n")
- unless defined($br);
- close(ENC);
+ open( my $fh, '<', $file ) or croak("Couldn't open encmap $file:\n$!\n");
+ binmode($fh);
+ my $data;
+ my $br = sysread( $fh, $data, -s $file );
+ croak("Trouble reading $file:\n$!\n")
+ unless defined($br);
+ close($fh);
- my $name = LoadEncoding($data, $br);
- croak("$file isn't an encmap file")
- unless defined($name);
+ my $name = LoadEncoding( $data, $br );
+ croak("$file isn't an encmap file")
+ unless defined($name);
- $name;
-} # End load_encoding
+ $name;
+} # End load_encoding
sub setHandlers {
- my ($self, @handler_pairs) = @_;
+ my ( $self, @handler_pairs ) = @_;
- croak("Uneven number of arguments to setHandlers method")
- if (int(@handler_pairs) & 1);
+ croak("Uneven number of arguments to setHandlers method")
+ if ( int(@handler_pairs) & 1 );
- my @ret;
+ my @ret;
- while (@handler_pairs) {
- my $type = shift @handler_pairs;
- my $handler = shift @handler_pairs;
- croak "Handler for $type not a Code ref"
- unless (! defined($handler) or ! $handler or ref($handler) eq 'CODE');
+ while (@handler_pairs) {
+ my $type = shift @handler_pairs;
+ my $handler = shift @handler_pairs;
+ croak 'Handler for $type not a Code ref'
+ unless ( !defined($handler) or !$handler or ref($handler) eq 'CODE' );
- my $hndl = $self->{_Setters}->{$type};
+ my $hndl = $self->{_Setters}->{$type};
- unless (defined($hndl)) {
- my @types = sort keys %{$self->{_Setters}};
- croak("Unknown Expat handler type: $type\n Valid types: @types");
- }
+ unless ( defined($hndl) ) {
+ my @types = sort keys %{ $self->{_Setters} };
+ croak("Unknown Expat handler type: $type\n Valid types: @types");
+ }
- my $old = &$hndl($self->{Parser}, $handler);
- push (@ret, $type, $old);
- }
+ my $old = &$hndl( $self->{Parser}, $handler );
+ push( @ret, $type, $old );
+ }
- return @ret;
+ return @ret;
}
-sub xpcroak
- {
- my ($self, $message) = @_;
-
- my $eclines = $self->{ErrorContext};
- my $line = GetCurrentLineNumber($_[0]->{Parser});
- $message .= " at line $line";
- $message .= ":\n" . $self->position_in_context($eclines)
- if defined($eclines);
- croak $message;
+sub xpcroak {
+ my ( $self, $message ) = @_;
+
+ my $eclines = $self->{ErrorContext};
+ my $line = GetCurrentLineNumber( $_[0]->{Parser} );
+ $message .= " at line $line";
+ $message .= ":\n" . $self->position_in_context($eclines)
+ if defined($eclines);
+ croak $message;
}
sub xpcarp {
- my ($self, $message) = @_;
-
- my $eclines = $self->{ErrorContext};
- my $line = GetCurrentLineNumber($_[0]->{Parser});
- $message .= " at line $line";
- $message .= ":\n" . $self->position_in_context($eclines)
- if defined($eclines);
- carp $message;
+ my ( $self, $message ) = @_;
+
+ my $eclines = $self->{ErrorContext};
+ my $line = GetCurrentLineNumber( $_[0]->{Parser} );
+ $message .= ' at line $line';
+ $message .= ":\n" . $self->position_in_context($eclines)
+ if defined($eclines);
+ carp $message;
}
sub default_current {
- my $self = shift;
- if ($self->{_State_} == 1) {
- return DefaultCurrent($self->{Parser});
- }
+ my $self = shift;
+ if ( $self->{_State_} == 1 ) {
+ return DefaultCurrent( $self->{Parser} );
+ }
}
sub recognized_string {
- my $self = shift;
- if ($self->{_State_} == 1) {
- return RecognizedString($self->{Parser});
- }
+ my $self = shift;
+ if ( $self->{_State_} == 1 ) {
+ return RecognizedString( $self->{Parser} );
+ }
}
sub original_string {
- my $self = shift;
- if ($self->{_State_} == 1) {
- return OriginalString($self->{Parser});
- }
+ my $self = shift;
+ if ( $self->{_State_} == 1 ) {
+ return OriginalString( $self->{Parser} );
+ }
}
sub current_line {
- my $self = shift;
- if ($self->{_State_} == 1) {
- return GetCurrentLineNumber($self->{Parser});
- }
+ my $self = shift;
+ if ( $self->{_State_} == 1 ) {
+ return GetCurrentLineNumber( $self->{Parser} );
+ }
}
sub current_column {
- my $self = shift;
- if ($self->{_State_} == 1) {
- return GetCurrentColumnNumber($self->{Parser});
- }
+ my $self = shift;
+ if ( $self->{_State_} == 1 ) {
+ return GetCurrentColumnNumber( $self->{Parser} );
+ }
}
sub current_byte {
- my $self = shift;
- if ($self->{_State_} == 1) {
- return GetCurrentByteIndex($self->{Parser});
- }
+ my $self = shift;
+ if ( $self->{_State_} == 1 ) {
+ return GetCurrentByteIndex( $self->{Parser} );
+ }
}
sub base {
- my ($self, $newbase) = @_;
- my $p = $self->{Parser};
- my $oldbase = GetBase($p);
- SetBase($p, $newbase) if @_ > 1;
- return $oldbase;
+ my ( $self, $newbase ) = @_;
+ my $p = $self->{Parser};
+ my $oldbase = GetBase($p);
+ SetBase( $p, $newbase ) if @_ > 1;
+ return $oldbase;
}
sub context {
- my $ctx = $_[0]->{Context};
- @$ctx;
+ my $ctx = $_[0]->{Context};
+ @$ctx;
}
sub current_element {
- my ($self) = @_;
- @{$self->{Context}} ? $self->{Context}->[-1] : undef;
+ my ($self) = @_;
+ @{ $self->{Context} } ? $self->{Context}->[-1] : undef;
}
sub in_element {
- my ($self, $element) = @_;
- @{$self->{Context}} ? $self->eq_name($self->{Context}->[-1], $element)
- : undef;
+ my ( $self, $element ) = @_;
+ @{ $self->{Context} }
+ ? $self->eq_name( $self->{Context}->[-1], $element )
+ : undef;
}
sub within_element {
- my ($self, $element) = @_;
- my $cnt = 0;
- foreach (@{$self->{Context}}) {
- $cnt++ if $self->eq_name($_, $element);
- }
- return $cnt;
+ my ( $self, $element ) = @_;
+ my $cnt = 0;
+ foreach ( @{ $self->{Context} } ) {
+ $cnt++ if $self->eq_name( $_, $element );
+ }
+ return $cnt;
}
sub depth {
- my ($self) = @_;
- int(@{$self->{Context}});
+ my ($self) = @_;
+ int( @{ $self->{Context} } );
}
sub element_index {
- my ($self) = @_;
+ my ($self) = @_;
- if ($self->{_State_} == 1) {
- return ElementIndex($self->{Parser});
- }
+ if ( $self->{_State_} == 1 ) {
+ return ElementIndex( $self->{Parser} );
+ }
}
################
# Namespace methods
sub namespace {
- my ($self, $name) = @_;
- local($^W) = 0;
- $self->{Namespace_List}->[int($name)];
+ my ( $self, $name ) = @_;
+ local ($^W) = 0;
+ $self->{Namespace_List}->[ int($name) ];
}
sub eq_name {
- my ($self, $nm1, $nm2) = @_;
- local($^W) = 0;
+ my ( $self, $nm1, $nm2 ) = @_;
+ local ($^W) = 0;
- int($nm1) == int($nm2) and $nm1 eq $nm2;
+ int($nm1) == int($nm2) and $nm1 eq $nm2;
}
sub generate_ns_name {
- my ($self, $name, $namespace) = @_;
+ my ( $self, $name, $namespace ) = @_;
- $namespace ?
- GenerateNSName($name, $namespace, $self->{Namespace_Table},
- $self->{Namespace_List})
+ $namespace
+ ? GenerateNSName(
+ $name, $namespace, $self->{Namespace_Table},
+ $self->{Namespace_List}
+ )
: $name;
}
sub new_ns_prefixes {
- my ($self) = @_;
- if ($self->{Namespaces}) {
- return @{$self->{New_Prefixes}};
- }
- return ();
+ my ($self) = @_;
+ if ( $self->{Namespaces} ) {
+ return @{ $self->{New_Prefixes} };
+ }
+ return ();
}
sub expand_ns_prefix {
- my ($self, $prefix) = @_;
+ my ( $self, $prefix ) = @_;
- if ($self->{Namespaces}) {
- my $stack = $self->{Prefix_Table}->{$prefix};
- return (defined($stack) and @$stack) ? $stack->[-1] : undef;
- }
+ if ( $self->{Namespaces} ) {
+ my $stack = $self->{Prefix_Table}->{$prefix};
+ return ( defined($stack) and @$stack ) ? $stack->[-1] : undef;
+ }
- return undef;
+ return undef;
}
sub current_ns_prefixes {
- my ($self) = @_;
+ my ($self) = @_;
- if ($self->{Namespaces}) {
- my %set = %{$self->{Prefix_Table}};
+ if ( $self->{Namespaces} ) {
+ my %set = %{ $self->{Prefix_Table} };
- if (exists $set{'#default'} and not defined($set{'#default'}->[-1])) {
- delete $set{'#default'};
- }
+ if ( exists $set{'#default'} and not defined( $set{'#default'}->[-1] ) ) {
+ delete $set{'#default'};
+ }
- return keys %set;
- }
+ return keys %set;
+ }
- return ();
+ return ();
}
-
################################################################
# Namespace declaration handlers
#
sub NamespaceStart {
- my ($self, $prefix, $uri) = @_;
+ my ( $self, $prefix, $uri ) = @_;
- $prefix = '#default' unless defined $prefix;
- my $stack = $self->{Prefix_Table}->{$prefix};
+ $prefix = '#default' unless defined $prefix;
+ my $stack = $self->{Prefix_Table}->{$prefix};
- if (defined $stack) {
- push(@$stack, $uri);
- }
- else {
- $self->{Prefix_Table}->{$prefix} = [$uri];
- }
+ if ( defined $stack ) {
+ push( @$stack, $uri );
+ }
+ else {
+ $self->{Prefix_Table}->{$prefix} = [$uri];
+ }
- # The New_Prefixes list gets emptied at end of startElement function
- # in Expat.xs
+ # The New_Prefixes list gets emptied at end of startElement function
+ # in Expat.xs
- push(@{$self->{New_Prefixes}}, $prefix);
+ push( @{ $self->{New_Prefixes} }, $prefix );
}
sub NamespaceEnd {
- my ($self, $prefix) = @_;
+ my ( $self, $prefix ) = @_;
- $prefix = '#default' unless defined $prefix;
+ $prefix = '#default' unless defined $prefix;
- my $stack = $self->{Prefix_Table}->{$prefix};
- if (@$stack > 1) {
- pop(@$stack);
- }
- else {
- delete $self->{Prefix_Table}->{$prefix};
- }
+ my $stack = $self->{Prefix_Table}->{$prefix};
+ if ( @$stack > 1 ) {
+ pop(@$stack);
+ }
+ else {
+ delete $self->{Prefix_Table}->{$prefix};
+ }
}
################
sub specified_attr {
- my $self = shift;
-
- if ($self->{_State_} == 1) {
- return GetSpecifiedAttributeCount($self->{Parser});
- }
+ my $self = shift;
+
+ if ( $self->{_State_} == 1 ) {
+ return GetSpecifiedAttributeCount( $self->{Parser} );
+ }
}
sub finish {
- my ($self) = @_;
- if ($self->{_State_} == 1) {
- my $parser = $self->{Parser};
- UnsetAllHandlers($parser);
- }
+ my ($self) = @_;
+ if ( $self->{_State_} == 1 ) {
+ my $parser = $self->{Parser};
+ UnsetAllHandlers($parser);
+ }
}
sub position_in_context {
- my ($self, $lines) = @_;
- if ($self->{_State_} == 1) {
- my $parser = $self->{Parser};
- my ($string, $linepos) = PositionContext($parser, $lines);
+ my ( $self, $lines ) = @_;
+ if ( $self->{_State_} == 1 ) {
+ my $parser = $self->{Parser};
+ my ( $string, $linepos ) = PositionContext( $parser, $lines );
- return '' unless defined($string);
+ return '' unless defined($string);
- my $col = GetCurrentColumnNumber($parser);
- my $ptr = ('=' x ($col - 1)) . '^' . "\n";
- my $ret;
- my $dosplit = $linepos < length($string);
-
- $string .= "\n" unless $string =~ /\n$/;
-
- if ($dosplit) {
- $ret = substr($string, 0, $linepos) . $ptr
- . substr($string, $linepos);
- } else {
- $ret = $string . $ptr;
- }
-
- return $ret;
- }
-}
+ my $col = GetCurrentColumnNumber($parser);
+ my $ptr = ( '=' x ( $col - 1 ) ) . '^' . "\n";
+ my $ret;
+ my $dosplit = $linepos < length($string);
-sub xml_escape {
- my $self = shift;
- my $text = shift;
+ $string .= "\n" unless $string =~ /\n$/;
- study $text;
- $text =~ s/\&/\&/g;
- $text =~ s/</\</g;
- foreach (@_) {
- croak "xml_escape: '$_' isn't a single character" if length($_) > 1;
+ if ($dosplit) {
+ $ret = substr( $string, 0, $linepos ) . $ptr . substr( $string, $linepos );
+ }
+ else {
+ $ret = $string . $ptr;
+ }
- if ($_ eq '>') {
- $text =~ s/>/\>/g;
+ return $ret;
}
- elsif ($_ eq '"') {
- $text =~ s/\"/\"/;
- }
- elsif ($_ eq "'") {
- $text =~ s/\'/\'/;
- }
- else {
- my $rep = '&#' . sprintf('x%X', ord($_)) . ';';
- if (/\W/) {
- my $ptrn = "\\$_";
- $text =~ s/$ptrn/$rep/g;
- }
- else {
- $text =~ s/$_/$rep/g;
- }
+}
+
+sub xml_escape {
+ my $self = shift;
+ my $text = shift;
+
+ study $text;
+ $text =~ s/\&/\&/g;
+ $text =~ s/</\</g;
+ foreach (@_) {
+ croak "xml_escape: '$_' isn't a single character" if length($_) > 1;
+
+ if ( $_ eq '>' ) {
+ $text =~ s/>/\>/g;
+ }
+ elsif ( $_ eq '"' ) {
+ $text =~ s/\"/\"/;
+ }
+ elsif ( $_ eq "'" ) {
+ $text =~ s/\'/\'/;
+ }
+ else {
+ my $rep = '&#' . sprintf( 'x%X', ord($_) ) . ';';
+ if (/\W/) {
+ my $ptrn = "\\$_";
+ $text =~ s/$ptrn/$rep/g;
+ }
+ else {
+ $text =~ s/$_/$rep/g;
+ }
+ }
}
- }
- $text;
+ $text;
}
sub skip_until {
- my $self = shift;
- if ($self->{_State_} <= 1) {
- SkipUntil($self->{Parser}, $_[0]);
- }
+ my $self = shift;
+ if ( $self->{_State_} <= 1 ) {
+ SkipUntil( $self->{Parser}, $_[0] );
+ }
}
sub release {
- my $self = shift;
- ParserRelease($self->{Parser});
+ my $self = shift;
+ ParserRelease( $self->{Parser} );
}
sub DESTROY {
- my $self = shift;
- ParserFree($self->{Parser});
+ my $self = shift;
+ ParserFree( $self->{Parser} );
}
sub parse {
- my $self = shift;
- my $arg = shift;
- croak "Parse already in progress (Expat)" if $self->{_State_};
- $self->{_State_} = 1;
- my $parser = $self->{Parser};
- my $ioref;
- my $result = 0;
-
- if (defined $arg) {
- local *@;
- if (ref($arg) and UNIVERSAL::isa($arg, 'IO::Handle')) {
- $ioref = $arg;
- } elsif ($] < 5.008 and defined tied($arg)) {
- require IO::Handle;
- $ioref = $arg;
+ my $self = shift;
+ my $arg = shift;
+ croak 'Parse already in progress (Expat)' if $self->{_State_};
+ $self->{_State_} = 1;
+ my $parser = $self->{Parser};
+ my $ioref;
+ my $result = 0;
+
+ if ( defined $arg ) {
+ local *@;
+ if ( ref($arg) and UNIVERSAL::isa( $arg, 'IO::Handle' ) ) {
+ $ioref = $arg;
+ }
+ elsif ( $] < 5.008 and defined tied($arg) ) {
+ require IO::Handle;
+ $ioref = $arg;
+ }
+ else {
+ require IO::Handle;
+ eval {
+ no strict 'refs';
+ $ioref = *{$arg}{IO} if defined *{$arg};
+ };
+ if ( ref($ioref) eq 'FileHandle' ) {
+
+ #for perl 5.10.x and possibly earlier, see t/file_open_scalar.t
+ require FileHandle;
+ }
+ }
+ }
+
+ if ( defined($ioref) ) {
+ my $delim = $self->{Stream_Delimiter};
+ my $prev_rs;
+ my $ioclass = ref $ioref;
+ $ioclass = 'IO::Handle' if !length $ioclass;
+
+ $prev_rs = $ioclass->input_record_separator("\n$delim\n")
+ if defined($delim);
+
+ $result = ParseStream( $parser, $ioref, $delim );
+
+ $ioclass->input_record_separator($prev_rs)
+ if defined($delim);
}
else {
- require IO::Handle;
- eval {
- no strict 'refs';
- $ioref = *{$arg}{IO} if defined *{$arg};
- };
- if (ref($ioref) eq 'FileHandle') {
- #for perl 5.10.x and possibly earlier, see t/file_open_scalar.t
- require FileHandle;
- }
+ $result = ParseString( $parser, $arg );
}
- }
-
- if (defined($ioref)) {
- my $delim = $self->{Stream_Delimiter};
- my $prev_rs;
- my $ioclass = ref $ioref;
- $ioclass = "IO::Handle" if !length $ioclass;
-
- $prev_rs = $ioclass->input_record_separator("\n$delim\n")
- if defined($delim);
-
- $result = ParseStream($parser, $ioref, $delim);
-
- $ioclass->input_record_separator($prev_rs)
- if defined($delim);
- } else {
- $result = ParseString($parser, $arg);
- }
-
- $self->{_State_} = 2;
- $result or croak $self->{ErrorMessage};
+
+ $self->{_State_} = 2;
+ $result or croak $self->{ErrorMessage};
}
sub parsestring {
- my $self = shift;
- $self->parse(@_);
+ my $self = shift;
+ $self->parse(@_);
}
sub parsefile {
- my $self = shift;
- croak "Parser has already been used" if $self->{_State_};
- local(*FILE);
- open(FILE, $_[0]) or croak "Couldn't open $_[0]:\n$!";
- binmode(FILE);
- my $ret = $self->parse(*FILE);
- close(FILE);
- $ret;
+ my $self = shift;
+ croak 'Parser has already been used' if $self->{_State_};
+
+ open( my $fh, '<', $_[0] ) or croak "Couldn't open $_[0]:\n$!";
+ binmode($fh);
+ my $ret = $self->parse($fh);
+ close($fh);
+ $ret;
}
################################################################
-package #hide from PAUSE
- XML::Parser::ContentModel;
+package #hide from PAUSE
+ XML::Parser::ContentModel;
use overload '""' => \&asString, 'eq' => \&thiseq;
-sub EMPTY () {1}
-sub ANY () {2}
-sub MIXED () {3}
-sub NAME () {4}
-sub CHOICE () {5}
-sub SEQ () {6}
-
+sub EMPTY () { 1 }
+sub ANY () { 2 }
+sub MIXED () { 3 }
+sub NAME () { 4 }
+sub CHOICE () { 5 }
+sub SEQ () { 6 }
sub isempty {
- return $_[0]->{Type} == EMPTY;
+ return $_[0]->{Type} == EMPTY;
}
sub isany {
- return $_[0]->{Type} == ANY;
+ return $_[0]->{Type} == ANY;
}
sub ismixed {
- return $_[0]->{Type} == MIXED;
+ return $_[0]->{Type} == MIXED;
}
sub isname {
- return $_[0]->{Type} == NAME;
+ return $_[0]->{Type} == NAME;
}
sub name {
- return $_[0]->{Tag};
+ return $_[0]->{Tag};
}
sub ischoice {
- return $_[0]->{Type} == CHOICE;
+ return $_[0]->{Type} == CHOICE;
}
sub isseq {
- return $_[0]->{Type} == SEQ;
+ return $_[0]->{Type} == SEQ;
}
sub quant {
- return $_[0]->{Quant};
+ return $_[0]->{Quant};
}
sub children {
- my $children = $_[0]->{Children};
- if (defined $children) {
- return @$children;
- }
- return undef;
+ my $children = $_[0]->{Children};
+ if ( defined $children ) {
+ return @$children;
+ }
+ return undef;
}
sub asString {
- my ($self) = @_;
- my $ret;
-
- if ($self->{Type} == NAME) {
- $ret = $self->{Tag};
- }
- elsif ($self->{Type} == EMPTY) {
- return "EMPTY";
- }
- elsif ($self->{Type} == ANY) {
- return "ANY";
- }
- elsif ($self->{Type} == MIXED) {
- $ret = '(#PCDATA';
- foreach (@{$self->{Children}}) {
- $ret .= '|' . $_;
+ my ($self) = @_;
+ my $ret;
+
+ if ( $self->{Type} == NAME ) {
+ $ret = $self->{Tag};
+ }
+ elsif ( $self->{Type} == EMPTY ) {
+ return 'EMPTY';
+ }
+ elsif ( $self->{Type} == ANY ) {
+ return 'ANY';
+ }
+ elsif ( $self->{Type} == MIXED ) {
+ $ret = '(#PCDATA';
+ foreach ( @{ $self->{Children} } ) {
+ $ret .= '|' . $_;
+ }
+ $ret .= ')';
+ }
+ else {
+ my $sep = $self->{Type} == CHOICE ? '|' : ',';
+ $ret = '(' . join( $sep, map { $_->asString } @{ $self->{Children} } ) . ')';
}
- $ret .= ')';
- }
- else {
- my $sep = $self->{Type} == CHOICE ? '|' : ',';
- $ret = '(' . join($sep, map { $_->asString } @{$self->{Children}}) . ')';
- }
-
- $ret .= $self->{Quant} if $self->{Quant};
- return $ret;
+
+ $ret .= $self->{Quant} if $self->{Quant};
+ return $ret;
}
sub thiseq {
- my $self = shift;
+ my $self = shift;
- return $self->asString eq $_[0];
+ return $self->asString eq $_[0];
}
################################################################
-package #hide from PAUSE
- XML::Parser::ExpatNB;
+package #hide from PAUSE
+ XML::Parser::ExpatNB;
-use vars qw(@ISA);
use Carp;
-@ISA = qw(XML::Parser::Expat);
+our @ISA = qw(XML::Parser::Expat);
sub parse {
- my $self = shift;
- my $class = ref($self);
- croak "parse method not supported in $class";
+ my $self = shift;
+ my $class = ref($self);
+ croak "parse method not supported in $class";
}
sub parsestring {
- my $self = shift;
- my $class = ref($self);
- croak "parsestring method not supported in $class";
+ my $self = shift;
+ my $class = ref($self);
+ croak "parsestring method not supported in $class";
}
sub parsefile {
- my $self = shift;
- my $class = ref($self);
- croak "parsefile method not supported in $class";
+ my $self = shift;
+ my $class = ref($self);
+ croak "parsefile method not supported in $class";
}
sub parse_more {
- my ($self, $data) = @_;
+ my ( $self, $data ) = @_;
- $self->{_State_} = 1;
- my $ret = XML::Parser::Expat::ParsePartial($self->{Parser}, $data);
+ $self->{_State_} = 1;
+ my $ret = XML::Parser::Expat::ParsePartial( $self->{Parser}, $data );
- croak $self->{ErrorMessage} unless $ret;
+ croak $self->{ErrorMessage} unless $ret;
}
sub parse_done {
- my $self = shift;
-
- my $ret = XML::Parser::Expat::ParseDone($self->{Parser});
- unless ($ret) {
- my $msg = $self->{ErrorMessage};
- $self->release;
- croak $msg;
- }
+ my $self = shift;
- $self->{_State_} = 2;
-
- my $result = $ret;
- my @result = ();
- my $final = $self->{FinalHandler};
- if (defined $final) {
- if (wantarray) {
- @result = &$final($self);
+ my $ret = XML::Parser::Expat::ParseDone( $self->{Parser} );
+ unless ($ret) {
+ my $msg = $self->{ErrorMessage};
+ $self->release;
+ croak $msg;
}
- else {
- $result = &$final($self);
+
+ $self->{_State_} = 2;
+
+ my $result = $ret;
+ my @result = ();
+ my $final = $self->{FinalHandler};
+ if ( defined $final ) {
+ if (wantarray) {
+ @result = &$final($self);
+ }
+ else {
+ $result = &$final($self);
+ }
}
- }
- $self->release;
+ $self->release;
- return unless defined wantarray;
- return wantarray ? @result : $result;
+ return unless defined wantarray;
+ return wantarray ? @result : $result;
}
################################################################
-package #hide from PAUSE
- XML::Parser::Encinfo;
+package #hide from PAUSE
+ XML::Parser::Encinfo;
sub DESTROY {
- my $self = shift;
- XML::Parser::Expat::FreeEncoding($self);
+ my $self = shift;
+ XML::Parser::Expat::FreeEncoding($self);
}
1;
$parser->setHandlers('Start' => \&sh,
'End' => \&eh,
'Char' => \&ch);
- open(FOO, '<', 'info.xml') or die "Couldn't open";
- $parser->parse(*FOO);
- close(FOO);
+ open(my $fh, '<', 'info.xml') or die "Couldn't open";
+ $parser->parse($fh);
+ close($fh);
# $parser->parse('<foo id="me"> here <em>we</em> go </foo>');
sub sh
(long)XML_GetCurrentColumnNumber(parser),
(long)XML_GetCurrentByteIndex(parser),
dopos ? ":\n" : "");
- // See https://rt.cpan.org/Ticket/Display.html?id=92030
- // It explains why type conversion is used.
+ /* See https://rt.cpan.org/Ticket/Display.html?id=92030
+ It explains why type conversion is used. */
if (dopos)
{
}
else {
tbuff = newSV(0);
- tsiz = newSViv(BUFSIZE);
- buffsize = BUFSIZE;
+ tsiz = newSViv(BUFSIZE); /* in UTF-8 characters */
+ buffsize = BUFSIZE * 6; /* in bytes that encode an UTF-8 string */
}
while (! done)
croak("read error");
tb = SvPV(tbuff, br);
- if (br > 0)
+ if (br > 0) {
+ if (br > buffsize)
+ croak("The input buffer is not large enough for read UTF-8 decoded string");
Copy(tb, buffer, br, char);
- else
+ } else
done = 1;
PUTBACK ;
Parser/Encodings/iso-8859-7.enc ISO-8859-7 binary encoding map
Parser/Encodings/iso-8859-8.enc ISO-8859-8 binary encoding map
Parser/Encodings/iso-8859-9.enc ISO-8859-9 binary encoding map
+Parser/Encodings/iso-8859-15.enc ISO-8859-15 binary encoding map
Parser/Encodings/windows-1250.enc cp1250-WinLatin2 binary encoding map
Parser/Encodings/windows-1251.enc cp1251-Russian binary encoding map
Parser/Encodings/windows-1252.enc cp1252-WinLatin1 binary encoding map
"Clark Cooper (coopercc@netheaven.com)"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.143240",
+ "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
- "version" : "2"
+ "version" : 2
},
"name" : "XML-Parser",
"no_index" : {
"prereqs" : {
"build" : {
"requires" : {
- "Test::More" : "0"
+ "ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"LWP::UserAgent" : "0",
"perl" : "5.00405"
}
+ },
+ "test" : {
+ "requires" : {
+ "Test::More" : "0",
+ "warnings" : "0"
+ }
}
},
"release_status" : "stable",
"resources" : {
+ "bugtracker" : {
+ "web" : "https://github.com/toddr/XML-Parser/issues"
+ },
"repository" : {
"url" : "http://github.com/toddr/XML-Parser"
}
},
- "version" : "2.44"
+ "version" : "2.46",
+ "x_serialization_backend" : "JSON::PP version 2.97001"
}
author:
- 'Clark Cooper (coopercc@netheaven.com)'
build_requires:
+ ExtUtils::MakeMaker: '0'
Test::More: '0'
+ warnings: '0'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.143240'
+generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
LWP::UserAgent: '0'
perl: '5.00405'
resources:
+ bugtracker: https://github.com/toddr/XML-Parser/issues
repository: http://github.com/toddr/XML-Parser
-version: '2.44'
+version: '2.46'
+x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
-use 5.004005; #Devel::CheckLib
+use 5.004005; #Devel::CheckLib
use ExtUtils::MakeMaker;
use lib qw(inc);
use Devel::CheckLib;
use Config;
-$expat_libpath = '';
-$expat_incpath = '';
+$expat_libpath = $ENV{EXPATLIBPATH} || '';
+$expat_incpath = $ENV{EXPATINCPATH} || '';
my @replacement_args;
foreach (@ARGV) {
- if (/^EXPAT(LIB|INC)PATH=(.+)/) {
- if ($1 eq 'LIB') {
- $expat_libpath = $2;
+ if (/^EXPAT(LIB|INC)PATH=(.+)/) {
+ if ( $1 eq 'LIB' ) {
+ $expat_libpath = $2;
+ }
+ else {
+ $expat_incpath = $2;
+ }
+
+ #push(@replacement_args, "$1=$2");
}
else {
- $expat_incpath = $2;
+ push( @replacement_args, $_ );
}
- #push(@replacement_args, "$1=$2");
- }
- else {
- push(@replacement_args, $_);
- }
}
@ARGV = @replacement_args;
unless (
- check_lib( # fill in what you prompted the user for here
- lib => [qw(expat)],
- header => ['expat.h'],
- incpath => $expat_incpath,
- ($expat_libpath?
- (libpath => $expat_libpath):()),
- )) {
+ check_lib( # fill in what you prompted the user for here
+ lib => [qw(expat)],
+ header => ['expat.h'],
+ incpath => $expat_incpath,
+ ( $expat_libpath ? ( libpath => $expat_libpath ) : () ),
+ )
+) {
warn <<'Expat_Not_Installed;';
Expat must be installed prior to building XML::Parser and I can't find
variable at run time for perl to find the library.
Expat_Not_Installed;
- #exit;
-}
-if (not $expat_libpath and $] >= 5.006001 and $^O ne 'MSWin32') {
- require ExtUtils::Liblist; # Buggy before this
- ($expat_libpath) = ExtUtils::Liblist->ext('-lexpat');
+ # exiting before Makefile generation silences CPANTesters reports
+ # when expat is not available.
+ exit 0;
}
-=for cmt
-
-unless ($expat_libpath) {
- # Test for existence of libexpat
- my $found = 0;
- foreach (split(/\s+/, $Config{libpth})) {
- if (-f "$_/libexpat." . $Config{so}) {
- $expat_libpath=$_;
- $found = 1;
- last;
- }
- }
-
- if (!$found and $^O eq 'MSWin32') {
- if (-f 'C:/lib/Expat-2.0.0/Libs/libexpat.dll') {
- $expat_libpath = 'C:/lib/Expat-2.0.0/Libs';
- $expat_incpath = 'C:/lib/Expat-2.0.0/Source/lib';
- $found = 1;
- }
-
- }
- if ($found) {
- print "libexpat found in $expat_libpath\n";
- }
-
- unless ($found) {
- warn <<'Expat_Not_Installed;';
-
-Expat must be installed prior to building XML::Parser and I can't find
-it in the standard library directories. Install 'expat-devel' (or
-'libexpat1-dev') package with your OS package manager.
-
-Or you can download expat from:
-
-http://sourceforge.net/projects/expat/
-
-If expat is installed, but in a non-standard directory, then use the
-following options to Makefile.PL:
-
- EXPATLIBPATH=... To set the directory in which to find libexpat
-
- EXPATINCPATH=... To set the directory in which to find expat.h
-
-For example:
-
- perl Makefile.PL EXPATLIBPATH=/home/me/lib EXPATINCPATH=/home/me/include
-
-Note that if you build against a shareable library in a non-standard location
-you may (on some platforms) also have to set your LD_LIBRARY_PATH environment
-variable at run time for perl to find the library.
-
-Expat_Not_Installed;
- exit 0;
- }
+if ( not $expat_libpath and $] >= 5.006001 and $^O ne 'MSWin32' ) {
+ require ExtUtils::Liblist; # Buggy before this
+ ($expat_libpath) = ExtUtils::Liblist->ext('-lexpat');
}
-=cut
# Don't try to descend into Expat directory for testing
-sub MY::test
-{
- my $self = shift;
+sub MY::test {
+ my $self = shift;
- my $hold = delete $self->{DIR};
- my $ret = $self->MM::test(@_);
- $self->{DIR} = $hold if defined($hold);
- $ret;
+ my $hold = delete $self->{DIR};
+ my $ret = $self->MM::test(@_);
+ $self->{DIR} = $hold if defined($hold);
+ $ret;
}
my @extras = ();
-push(@extras,
- CAPI => 'TRUE')
- if ($PERL_VERSION >= 5.005 and $OSNAME eq 'MSWin32'
- and $Config{archname} =~ /-object\b/i);
+push(
+ @extras,
+ CAPI => 'TRUE'
+ )
+ if ( $PERL_VERSION >= 5.005
+ and $OSNAME eq 'MSWin32'
+ and $Config{archname} =~ /-object\b/i );
WriteMakefile1(
- ABSTRACT_FROM => 'Parser.pm',
- AUTHOR => 'Clark Cooper (coopercc@netheaven.com)',
- LICENSE => 'perl',
- MIN_PERL_VERSION => '5.00405',
- META_MERGE => {
- resources => {
- repository => 'http://github.com/toddr/XML-Parser',
+ ABSTRACT_FROM => 'Parser.pm',
+ AUTHOR => 'Clark Cooper (coopercc@netheaven.com)',
+ LICENSE => 'perl',
+ MIN_PERL_VERSION => '5.00405',
+ META_MERGE => {
+ resources => {
+ bugtracker => 'https://github.com/toddr/XML-Parser/issues',
+ repository => 'http://github.com/toddr/XML-Parser',
+ },
+ },
+ TEST_REQUIRES => {
+ 'Test::More' => 0,
+ 'warnings' => 0,
+ },
+
+ NAME => 'XML::Parser',
+ DIR => [qw(Expat)],
+ dist => { COMPRESS => 'gzip', SUFFIX => '.gz' },
+ VERSION_FROM => 'Parser.pm',
+ PREREQ_PM => {
+ 'LWP::UserAgent' => 0, #for tests
},
- },
- BUILD_REQUIRES => {
- 'Test::More' => 0,
- },
-
- NAME => 'XML::Parser',
- DIR => [qw(Expat)],
- dist => {COMPRESS => 'gzip', SUFFIX => '.gz'},
- VERSION_FROM => 'Parser.pm',
- PREREQ_PM => {
- 'LWP::UserAgent' => 0, #for tests
- },
- $^O =~/win/i ? (
+ $^O =~ /win/i
+ ? (
dist => {
TAR => 'ptar',
TARFLAGS => '-c -C -f',
},
- ) : (),
- @extras
+ )
+ : (),
+ @extras
);
+sub WriteMakefile1 { #Compatibility code for old versions of EU::MM. Written by Alexandr Ciornii, version 0.23. Added by eumm-upgrade.
+ my %params = @_;
+ my $eumm_version = $ExtUtils::MakeMaker::VERSION;
+ $eumm_version = eval $eumm_version;
+ die "EXTRA_META is deprecated" if exists $params{EXTRA_META};
+ die "License not specified" if not exists $params{LICENSE};
+ if ( $params{AUTHOR} and ref( $params{AUTHOR} ) eq 'ARRAY' and $eumm_version < 6.5705 ) {
+ $params{META_ADD}->{author} = $params{AUTHOR};
+ $params{AUTHOR} = join( ', ', @{ $params{AUTHOR} } );
+ }
+ if ( $params{TEST_REQUIRES} and $eumm_version < 6.64 ) {
+ $params{BUILD_REQUIRES} = { %{ $params{BUILD_REQUIRES} || {} }, %{ $params{TEST_REQUIRES} } };
+ delete $params{TEST_REQUIRES};
+ }
+ if ( $params{BUILD_REQUIRES} and $eumm_version < 6.5503 ) {
+
+ #EUMM 6.5502 has problems with BUILD_REQUIRES
+ $params{PREREQ_PM} = { %{ $params{PREREQ_PM} || {} }, %{ $params{BUILD_REQUIRES} } };
+ delete $params{BUILD_REQUIRES};
+ }
+ delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52;
+ delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48;
+ delete $params{META_MERGE} if $eumm_version < 6.46;
+ delete $params{META_ADD} if $eumm_version < 6.46;
+ delete $params{LICENSE} if $eumm_version < 6.31;
-sub WriteMakefile1 { #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade.
- my %params=@_;
- my $eumm_version=$ExtUtils::MakeMaker::VERSION;
- $eumm_version=eval $eumm_version;
- die "EXTRA_META is deprecated" if exists $params{EXTRA_META};
- die "License not specified" if not exists $params{LICENSE};
- if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) {
- #EUMM 6.5502 has problems with BUILD_REQUIRES
- $params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} };
- delete $params{BUILD_REQUIRES};
- }
- delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52;
- delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48;
- delete $params{META_MERGE} if $eumm_version < 6.46;
- delete $params{META_ADD} if $eumm_version < 6.46;
- delete $params{LICENSE} if $eumm_version < 6.31;
- delete $params{AUTHOR} if $] < 5.005;
- delete $params{ABSTRACT_FROM} if $] < 5.005;
- delete $params{BINARY_LOCATION} if $] < 5.005;
-
- WriteMakefile(%params);
+ WriteMakefile(%params);
}
use strict;
-use vars qw($VERSION $LWP_load_failed);
+our ( $VERSION, $LWP_load_failed );
use Carp;
BEGIN {
- require XML::Parser::Expat;
- $VERSION = '2.44';
- die "Parser.pm and Expat.pm versions don't match"
- unless $VERSION eq $XML::Parser::Expat::VERSION;
+ require XML::Parser::Expat;
+ $VERSION = '2.46';
+ die "Parser.pm and Expat.pm versions don't match"
+ unless $VERSION eq $XML::Parser::Expat::VERSION;
}
$LWP_load_failed = 0;
sub new {
- my ($class, %args) = @_;
- my $style = $args{Style};
-
- my $nonexopt = $args{Non_Expat_Options} ||= {};
-
- $nonexopt->{Style} = 1;
- $nonexopt->{Non_Expat_Options} = 1;
- $nonexopt->{Handlers} = 1;
- $nonexopt->{_HNDL_TYPES} = 1;
- $nonexopt->{NoLWP} = 1;
-
- $args{_HNDL_TYPES} = {%XML::Parser::Expat::Handler_Setters};
- $args{_HNDL_TYPES}->{Init} = 1;
- $args{_HNDL_TYPES}->{Final} = 1;
-
- $args{Handlers} ||= {};
- my $handlers = $args{Handlers};
-
- if (defined($style)) {
- my $stylepkg = $style;
-
- if ($stylepkg !~ /::/) {
- $stylepkg = "\u$style";
-
- eval {
- my $fullpkg = 'XML::Parser::Style::' . $stylepkg;
- my $stylefile = $fullpkg;
- $stylefile =~ s/::/\//g;
- require "$stylefile.pm";
- $stylepkg = $fullpkg;
- };
- if ($@) {
- # fallback to old behaviour
- $stylepkg = 'XML::Parser::' . $stylepkg;
- }
- }
-
- my $htype;
- foreach $htype (keys %{$args{_HNDL_TYPES}}) {
- # Handlers explicitly given override
- # handlers from the Style package
- unless (defined($handlers->{$htype})) {
-
- # A handler in the style package must either have
- # exactly the right case as the type name or a
- # completely lower case version of it.
-
- my $hname = "${stylepkg}::$htype";
- if (defined(&$hname)) {
- $handlers->{$htype} = \&$hname;
- next;
+ my ( $class, %args ) = @_;
+ my $style = $args{Style};
+
+ my $nonexopt = $args{Non_Expat_Options} ||= {};
+
+ $nonexopt->{Style} = 1;
+ $nonexopt->{Non_Expat_Options} = 1;
+ $nonexopt->{Handlers} = 1;
+ $nonexopt->{_HNDL_TYPES} = 1;
+ $nonexopt->{NoLWP} = 1;
+
+ $args{_HNDL_TYPES} = {%XML::Parser::Expat::Handler_Setters};
+ $args{_HNDL_TYPES}->{Init} = 1;
+ $args{_HNDL_TYPES}->{Final} = 1;
+
+ $args{Handlers} ||= {};
+ my $handlers = $args{Handlers};
+
+ if ( defined($style) ) {
+ my $stylepkg = $style;
+
+ if ( $stylepkg !~ /::/ ) {
+ $stylepkg = "\u$style";
+
+ eval {
+ my $fullpkg = "XML::Parser::Style::$stylepkg";
+ my $stylefile = $fullpkg;
+ $stylefile =~ s/::/\//g;
+ require "$stylefile.pm";
+ $stylepkg = $fullpkg;
+ };
+ if ($@) {
+
+ # fallback to old behaviour
+ $stylepkg = "XML::Parser::$stylepkg";
+ }
}
-
- $hname = "${stylepkg}::\L$htype";
- if (defined(&$hname)) {
- $handlers->{$htype} = \&$hname;
- next;
+
+ foreach my $htype ( keys %{ $args{_HNDL_TYPES} } ) {
+
+ # Handlers explicitly given override
+ # handlers from the Style package
+ unless ( defined( $handlers->{$htype} ) ) {
+
+ # A handler in the style package must either have
+ # exactly the right case as the type name or a
+ # completely lower case version of it.
+
+ my $hname = "${stylepkg}::$htype";
+ if ( defined(&$hname) ) {
+ $handlers->{$htype} = \&$hname;
+ next;
+ }
+
+ $hname = "${stylepkg}::\L$htype";
+ if ( defined(&$hname) ) {
+ $handlers->{$htype} = \&$hname;
+ next;
+ }
+ }
}
- }
- }
- }
-
- unless (defined($handlers->{ExternEnt})
- or defined ($handlers->{ExternEntFin})) {
-
- if ($args{NoLWP} or $LWP_load_failed) {
- $handlers->{ExternEnt} = \&file_ext_ent_handler;
- $handlers->{ExternEntFin} = \&file_ext_ent_cleanup;
}
- else {
- # The following just bootstraps the real LWP external entity
- # handler
- $handlers->{ExternEnt} = \&initial_ext_ent_handler;
+ unless ( defined( $handlers->{ExternEnt} )
+ or defined( $handlers->{ExternEntFin} ) ) {
+
+ if ( $args{NoLWP} or $LWP_load_failed ) {
+ $handlers->{ExternEnt} = \&file_ext_ent_handler;
+ $handlers->{ExternEntFin} = \&file_ext_ent_cleanup;
+ }
+ else {
+ # The following just bootstraps the real LWP external entity
+ # handler
+
+ $handlers->{ExternEnt} = \&initial_ext_ent_handler;
- # No cleanup function available until LWPExternEnt.pl loaded
+ # No cleanup function available until LWPExternEnt.pl loaded
+ }
}
- }
- $args{Pkg} ||= caller;
- bless \%args, $class;
-} # End of new
+ $args{Pkg} ||= caller;
+ bless \%args, $class;
+} # End of new
sub setHandlers {
- my ($self, @handler_pairs) = @_;
-
- croak("Uneven number of arguments to setHandlers method")
- if (int(@handler_pairs) & 1);
-
- my @ret;
- while (@handler_pairs) {
- my $type = shift @handler_pairs;
- my $handler = shift @handler_pairs;
- unless (defined($self->{_HNDL_TYPES}->{$type})) {
- my @types = sort keys %{$self->{_HNDL_TYPES}};
-
- croak("Unknown Parser handler type: $type\n Valid types: @types");
+ my ( $self, @handler_pairs ) = @_;
+
+ croak('Uneven number of arguments to setHandlers method')
+ if ( int(@handler_pairs) & 1 );
+
+ my @ret;
+ while (@handler_pairs) {
+ my $type = shift @handler_pairs;
+ my $handler = shift @handler_pairs;
+ unless ( defined( $self->{_HNDL_TYPES}->{$type} ) ) {
+ my @types = sort keys %{ $self->{_HNDL_TYPES} };
+
+ croak("Unknown Parser handler type: $type\n Valid types: @types");
+ }
+ push( @ret, $type, $self->{Handlers}->{$type} );
+ $self->{Handlers}->{$type} = $handler;
}
- push(@ret, $type, $self->{Handlers}->{$type});
- $self->{Handlers}->{$type} = $handler;
- }
- return @ret;
+ return @ret;
}
sub parse_start {
- my $self = shift;
- my @expat_options = ();
+ my $self = shift;
+ my @expat_options = ();
- my ($key, $val);
- while (($key, $val) = each %{$self}) {
- push (@expat_options, $key, $val)
- unless exists $self->{Non_Expat_Options}->{$key};
- }
+ my ( $key, $val );
+ while ( ( $key, $val ) = each %{$self} ) {
+ push( @expat_options, $key, $val )
+ unless exists $self->{Non_Expat_Options}->{$key};
+ }
- my %handlers = %{$self->{Handlers}};
- my $init = delete $handlers{Init};
- my $final = delete $handlers{Final};
+ my %handlers = %{ $self->{Handlers} };
+ my $init = delete $handlers{Init};
+ my $final = delete $handlers{Final};
- my $expatnb = XML::Parser::ExpatNB->new(@expat_options, @_);
- $expatnb->setHandlers(%handlers);
+ my $expatnb = XML::Parser::ExpatNB->new( @expat_options, @_ );
+ $expatnb->setHandlers(%handlers);
- &$init($expatnb)
- if defined($init);
+ &$init($expatnb)
+ if defined($init);
- $expatnb->{_State_} = 1;
+ $expatnb->{_State_} = 1;
- $expatnb->{FinalHandler} = $final
- if defined($final);
+ $expatnb->{FinalHandler} = $final
+ if defined($final);
- return $expatnb;
+ return $expatnb;
}
sub parse {
- my $self = shift;
- my $arg = shift;
- my @expat_options = ();
- my ($key, $val);
- while (($key, $val) = each %{$self}) {
- push(@expat_options, $key, $val)
- unless exists $self->{Non_Expat_Options}->{$key};
- }
-
- my $expat = XML::Parser::Expat->new(@expat_options, @_);
- my %handlers = %{$self->{Handlers}};
- my $init = delete $handlers{Init};
- my $final = delete $handlers{Final};
-
- $expat->setHandlers(%handlers);
-
- if ($self->{Base}) {
- $expat->base($self->{Base});
- }
-
- &$init($expat)
- if defined($init);
-
- my @result = ();
- my $result;
- eval {
- $result = $expat->parse($arg);
- };
- my $err = $@;
- if ($err) {
- $expat->release;
- die $err;
- }
-
- if ($result and defined($final)) {
- if (wantarray) {
- @result = &$final($expat);
+ my $self = shift;
+ my $arg = shift;
+ my @expat_options = ();
+ my ( $key, $val );
+ while ( ( $key, $val ) = each %{$self} ) {
+ push( @expat_options, $key, $val )
+ unless exists $self->{Non_Expat_Options}->{$key};
}
- else {
- $result = &$final($expat);
+
+ my $expat = XML::Parser::Expat->new( @expat_options, @_ );
+ my %handlers = %{ $self->{Handlers} };
+ my $init = delete $handlers{Init};
+ my $final = delete $handlers{Final};
+
+ $expat->setHandlers(%handlers);
+
+ if ( $self->{Base} ) {
+ $expat->base( $self->{Base} );
}
- }
-
- $expat->release;
- return unless defined wantarray;
- return wantarray ? @result : $result;
+ &$init($expat)
+ if defined($init);
+
+ my @result = ();
+ my $result;
+ eval { $result = $expat->parse($arg); };
+ my $err = $@;
+ if ($err) {
+ $expat->release;
+ die $err;
+ }
+
+ if ( $result and defined($final) ) {
+ if (wantarray) {
+ @result = &$final($expat);
+ }
+ else {
+ $result = &$final($expat);
+ }
+ }
+
+ $expat->release;
+
+ return unless defined wantarray;
+ return wantarray ? @result : $result;
}
sub parsestring {
- my $self = shift;
- $self->parse(@_);
+ my $self = shift;
+ $self->parse(@_);
}
sub parsefile {
- my $self = shift;
- my $file = shift;
- local(*FILE);
- open(FILE, $file) or croak "Couldn't open $file:\n$!";
- binmode(FILE);
- my @ret;
- my $ret;
-
- $self->{Base} = $file;
-
- if (wantarray) {
- eval {
- @ret = $self->parse(*FILE, @_);
- };
- }
- else {
- eval {
- $ret = $self->parse(*FILE, @_);
- };
- }
- my $err = $@;
- close(FILE);
- die $err if $err;
-
- return unless defined wantarray;
- return wantarray ? @ret : $ret;
+ my $self = shift;
+ my $file = shift;
+
+ open( my $fh, '<', $file ) or croak "Couldn't open $file:\n$!";
+ binmode($fh);
+ my @ret;
+ my $ret;
+
+ $self->{Base} = $file;
+
+ if (wantarray) {
+ eval { @ret = $self->parse( $fh, @_ ); };
+ }
+ else {
+ eval { $ret = $self->parse( $fh, @_ ); };
+ }
+ my $err = $@;
+ close($fh);
+ die $err if $err;
+
+ return unless defined wantarray;
+ return wantarray ? @ret : $ret;
}
sub initial_ext_ent_handler {
- # This just bootstraps in the real lwp_ext_ent_handler which
- # also loads the URI and LWP modules.
-
- unless ($LWP_load_failed) {
- local($^W) = 0;
-
- my $stat =
- eval {
- require('XML/Parser/LWPExternEnt.pl');
- };
-
- if ($stat) {
- $_[0]->setHandlers(ExternEnt => \&lwp_ext_ent_handler,
- ExternEntFin => \&lwp_ext_ent_cleanup);
-
- goto &lwp_ext_ent_handler;
- }
- # Failed to load lwp handler, act as if NoLWP
+ # This just bootstraps in the real lwp_ext_ent_handler which
+ # also loads the URI and LWP modules.
- $LWP_load_failed = 1;
+ unless ($LWP_load_failed) {
+ local ($^W) = 0;
- my $cmsg = "Couldn't load LWP based external entity handler\n";
- $cmsg .= "Switching to file-based external entity handler\n";
- $cmsg .= " (To avoid this message, use NoLWP option to XML::Parser)\n";
- warn($cmsg);
- }
+ my $stat = eval { require('XML/Parser/LWPExternEnt.pl'); };
- $_[0]->setHandlers(ExternEnt => \&file_ext_ent_handler,
- ExternEntFin => \&file_ext_ent_cleanup);
- goto &file_ext_ent_handler;
+ if ($stat) {
+ $_[0]->setHandlers(
+ ExternEnt => \&lwp_ext_ent_handler,
+ ExternEntFin => \&lwp_ext_ent_cleanup
+ );
+
+ goto &lwp_ext_ent_handler;
+ }
+
+ # Failed to load lwp handler, act as if NoLWP
+
+ $LWP_load_failed = 1;
+
+ my $cmsg = "Couldn't load LWP based external entity handler\n" . "Switching to file-based external entity handler\n" . " (To avoid this message, use NoLWP option to XML::Parser)\n";
+ warn($cmsg);
+ }
+
+ $_[0]->setHandlers(
+ ExternEnt => \&file_ext_ent_handler,
+ ExternEntFin => \&file_ext_ent_cleanup
+ );
+ goto &file_ext_ent_handler;
}
sub file_ext_ent_handler {
- my ($xp, $base, $path) = @_;
+ my ( $xp, $base, $path ) = @_;
- # Prepend base only for relative paths
+ # Prepend base only for relative paths
- if (defined($base)
- and not ($path =~ m!^(?:[\\/]|\w+:)!))
- {
- my $newpath = $base;
- $newpath =~ s![^\\/:]*$!$path!;
- $path = $newpath;
+ if ( defined($base)
+ and not( $path =~ m!^(?:[\\/]|\w+:)! ) ) {
+ my $newpath = $base;
+ $newpath =~ s![^\\/:]*$!$path!;
+ $path = $newpath;
}
- if ($path =~ /^\s*[|>+]/
- or $path =~ /\|\s*$/) {
- $xp->{ErrorMessage}
- .= "System ID ($path) contains Perl IO control characters";
- return undef;
- }
-
- require IO::File;
- my $fh = IO::File->new($path);
- unless (defined $fh) {
- $xp->{ErrorMessage}
- .= "Failed to open $path:\n$!";
- return undef;
- }
-
- $xp->{_BaseStack} ||= [];
- $xp->{_FhStack} ||= [];
-
- push(@{$xp->{_BaseStack}}, $base);
- push(@{$xp->{_FhStack}}, $fh);
-
- $xp->base($path);
-
- return $fh;
+ if ( $path =~ /^\s*[|>+]/
+ or $path =~ /\|\s*$/ ) {
+ $xp->{ErrorMessage} .= "System ID ($path) contains Perl IO control characters";
+ return undef;
+ }
+
+ require IO::File;
+ my $fh = IO::File->new($path);
+ unless ( defined $fh ) {
+ $xp->{ErrorMessage} .= "Failed to open $path:\n$!";
+ return undef;
+ }
+
+ $xp->{_BaseStack} ||= [];
+ $xp->{_FhStack} ||= [];
+
+ push( @{ $xp->{_BaseStack} }, $base );
+ push( @{ $xp->{_FhStack} }, $fh );
+
+ $xp->base($path);
+
+ return $fh;
}
sub file_ext_ent_cleanup {
- my ($xp) = @_;
+ my ($xp) = @_;
- my $fh = pop(@{$xp->{_FhStack}});
- $fh->close;
+ my $fh = pop( @{ $xp->{_FhStack} } );
+ $fh->close;
- my $base = pop(@{$xp->{_BaseStack}});
- $xp->base($base);
+ my $base = pop( @{ $xp->{_BaseStack} } );
+ $xp->base($base);
}
1;
$p3->setHandlers(Char => \&text,
Default => \&other);
- open(FOO, 'xmlgenerator |');
- $p3->parse(*FOO, ProtocolEncoding => 'ISO-8859-1');
- close(FOO);
+ open(my $fh, 'xmlgenerator |');
+ $p3->parse($foo, ProtocolEncoding => 'ISO-8859-1');
+ close($foo);
$p3->parsefile('junk.xml', ErrorContext => 3);
directly set. Otherwise, if true, it forces the use of a file based external
entity handler.
-=item * Non-Expat-Options
+=item * Non_Expat_Options
If provided, this should be an anonymous hash whose keys are options that
shouldn't be passed to Expat. This should only be of concern to those
use strict;
sub Start {
- my $expat = shift;
- my $tag = shift;
- print STDERR "@{$expat->{Context}} \\\\ (@_)\n";
+ my $expat = shift;
+ my $tag = shift;
+ print STDERR "@{$expat->{Context}} \\\\ (@_)\n";
}
sub End {
- my $expat = shift;
- my $tag = shift;
- print STDERR "@{$expat->{Context}} //\n";
+ my $expat = shift;
+ my $tag = shift;
+ print STDERR "@{$expat->{Context}} //\n";
}
sub Char {
- my $expat = shift;
- my $text = shift;
- $text =~ s/([\x80-\xff])/sprintf "#x%X;", ord $1/eg;
- $text =~ s/([\t\n])/sprintf "#%d;", ord $1/eg;
- print STDERR "@{$expat->{Context}} || $text\n";
+ my $expat = shift;
+ my $text = shift;
+ $text =~ s/([\x80-\xff])/sprintf "#x%X;", ord $1/eg;
+ $text =~ s/([\t\n])/sprintf "#%d;", ord $1/eg;
+ print STDERR "@{$expat->{Context}} || $text\n";
}
sub Proc {
- my $expat = shift;
- my $target = shift;
- my $text = shift;
- my @foo = @{$expat->{Context}};
- print STDERR "@foo $target($text)\n";
+ my $expat = shift;
+ my $target = shift;
+ my $text = shift;
+ my @foo = @{ $expat->{Context} };
+ print STDERR "@foo $target($text)\n";
}
1;
This just prints out the document in outline form to STDERR. Nothing special is
returned by parse.
-=cut
\ No newline at end of file
+=cut
use strict;
sub Init {
- my $expat = shift;
- $expat->{Lists} = [];
- $expat->{Curlist} = $expat->{Tree} = [];
+ my $expat = shift;
+ $expat->{Lists} = [];
+ $expat->{Curlist} = $expat->{Tree} = [];
}
sub Start {
- my $expat = shift;
- my $tag = shift;
- my $newlist = [ ];
- my $class = "${$expat}{Pkg}::$tag";
- my $newobj = bless { @_, Kids => $newlist }, $class;
- push @{ $expat->{Lists} }, $expat->{Curlist};
- push @{ $expat->{Curlist} }, $newobj;
- $expat->{Curlist} = $newlist;
+ my $expat = shift;
+ my $tag = shift;
+ my $newlist = [];
+ my $class = "${$expat}{Pkg}::$tag";
+ my $newobj = bless { @_, Kids => $newlist }, $class;
+ push @{ $expat->{Lists} }, $expat->{Curlist};
+ push @{ $expat->{Curlist} }, $newobj;
+ $expat->{Curlist} = $newlist;
}
sub End {
- my $expat = shift;
- my $tag = shift;
- $expat->{Curlist} = pop @{ $expat->{Lists} };
+ my $expat = shift;
+ my $tag = shift;
+ $expat->{Curlist} = pop @{ $expat->{Lists} };
}
sub Char {
- my $expat = shift;
- my $text = shift;
- my $class = "${$expat}{Pkg}::Characters";
- my $clist = $expat->{Curlist};
- my $pos = $#$clist;
-
- if ($pos >= 0 and ref($clist->[$pos]) eq $class) {
- $clist->[$pos]->{Text} .= $text;
- } else {
- push @$clist, bless { Text => $text }, $class;
- }
+ my $expat = shift;
+ my $text = shift;
+ my $class = "${$expat}{Pkg}::Characters";
+ my $clist = $expat->{Curlist};
+ my $pos = $#$clist;
+
+ if ( $pos >= 0 and ref( $clist->[$pos] ) eq $class ) {
+ $clist->[$pos]->{Text} .= $text;
+ }
+ else {
+ push @$clist, bless { Text => $text }, $class;
+ }
}
sub Final {
- my $expat = shift;
- delete $expat->{Curlist};
- delete $expat->{Lists};
- $expat->{Tree};
+ my $expat = shift;
+ delete $expat->{Curlist};
+ delete $expat->{Lists};
+ $expat->{Tree};
}
1;
# This style invented by Tim Bray <tbray@textuality.com>
sub Init {
- no strict 'refs';
- my $expat = shift;
- $expat->{Text} = '';
- my $sub = $expat->{Pkg} ."::StartDocument";
- &$sub($expat)
- if defined(&$sub);
+ no strict 'refs';
+ my $expat = shift;
+ $expat->{Text} = '';
+ my $sub = $expat->{Pkg} . "::StartDocument";
+ &$sub($expat)
+ if defined(&$sub);
}
sub Start {
- no strict 'refs';
- my $expat = shift;
- my $type = shift;
-
- doText($expat);
- $_ = "<$type";
-
- %_ = @_;
- while (@_) {
- $_ .= ' ' . shift() . '="' . shift() . '"';
- }
- $_ .= '>';
-
- my $sub = $expat->{Pkg} . "::StartTag";
- if (defined(&$sub)) {
- &$sub($expat, $type);
- } else {
- print;
- }
+ no strict 'refs';
+ my $expat = shift;
+ my $type = shift;
+
+ doText($expat);
+ $_ = "<$type";
+
+ %_ = @_;
+ while (@_) {
+ $_ .= ' ' . shift() . '="' . shift() . '"';
+ }
+ $_ .= '>';
+
+ my $sub = $expat->{Pkg} . "::StartTag";
+ if ( defined(&$sub) ) {
+ &$sub( $expat, $type );
+ }
+ else {
+ print;
+ }
}
sub End {
- no strict 'refs';
- my $expat = shift;
- my $type = shift;
-
- # Set right context for Text handler
- push(@{$expat->{Context}}, $type);
- doText($expat);
- pop(@{$expat->{Context}});
-
- $_ = "</$type>";
-
- my $sub = $expat->{Pkg} . "::EndTag";
- if (defined(&$sub)) {
- &$sub($expat, $type);
- } else {
- print;
- }
+ no strict 'refs';
+ my $expat = shift;
+ my $type = shift;
+
+ # Set right context for Text handler
+ push( @{ $expat->{Context} }, $type );
+ doText($expat);
+ pop( @{ $expat->{Context} } );
+
+ $_ = "</$type>";
+
+ my $sub = $expat->{Pkg} . "::EndTag";
+ if ( defined(&$sub) ) {
+ &$sub( $expat, $type );
+ }
+ else {
+ print;
+ }
}
sub Char {
- my $expat = shift;
- $expat->{Text} .= shift;
+ my $expat = shift;
+ $expat->{Text} .= shift;
}
sub Proc {
- no strict 'refs';
- my $expat = shift;
- my $target = shift;
- my $text = shift;
-
- doText($expat);
+ no strict 'refs';
+ my $expat = shift;
+ my $target = shift;
+ my $text = shift;
- $_ = "<?$target $text?>";
-
- my $sub = $expat->{Pkg} . "::PI";
- if (defined(&$sub)) {
- &$sub($expat, $target, $text);
- } else {
- print;
- }
+ doText($expat);
+
+ $_ = "<?$target $text?>";
+
+ my $sub = $expat->{Pkg} . "::PI";
+ if ( defined(&$sub) ) {
+ &$sub( $expat, $target, $text );
+ }
+ else {
+ print;
+ }
}
sub Final {
- no strict 'refs';
- my $expat = shift;
- my $sub = $expat->{Pkg} . "::EndDocument";
- &$sub($expat)
- if defined(&$sub);
+ no strict 'refs';
+ my $expat = shift;
+ my $sub = $expat->{Pkg} . "::EndDocument";
+ &$sub($expat)
+ if defined(&$sub);
}
sub doText {
- no strict 'refs';
- my $expat = shift;
- $_ = $expat->{Text};
-
- if (length($_)) {
- my $sub = $expat->{Pkg} . "::Text";
- if (defined(&$sub)) {
- &$sub($expat);
- } else {
- print;
+ no strict 'refs';
+ my $expat = shift;
+ $_ = $expat->{Text};
+
+ if ( length($_) ) {
+ my $sub = $expat->{Pkg} . "::Text";
+ if ( defined(&$sub) ) {
+ &$sub($expat);
+ }
+ else {
+ print;
+ }
+
+ $expat->{Text} = '';
}
-
- $expat->{Text} = '';
- }
}
1;
=back
-=cut
\ No newline at end of file
+=cut
package XML::Parser::Style::Subs;
sub Start {
- no strict 'refs';
- my $expat = shift;
- my $tag = shift;
- my $sub = $expat->{Pkg} . "::$tag";
- eval { &$sub($expat, $tag, @_) };
+ no strict 'refs';
+ my $expat = shift;
+ my $tag = shift;
+ my $sub = $expat->{Pkg} . "::$tag";
+ eval { &$sub( $expat, $tag, @_ ) };
}
sub End {
- no strict 'refs';
- my $expat = shift;
- my $tag = shift;
- my $sub = $expat->{Pkg} . "::${tag}_";
- eval { &$sub($expat, $tag) };
+ no strict 'refs';
+ my $expat = shift;
+ my $tag = shift;
+ my $sub = $expat->{Pkg} . "::${tag}_";
+ eval { &$sub( $expat, $tag ) };
}
1;
$XML::Parser::Built_In_Styles{Tree} = 1;
sub Init {
- my $expat = shift;
- $expat->{Lists} = [];
- $expat->{Curlist} = $expat->{Tree} = [];
+ my $expat = shift;
+ $expat->{Lists} = [];
+ $expat->{Curlist} = $expat->{Tree} = [];
}
sub Start {
- my $expat = shift;
- my $tag = shift;
- my $newlist = [ { @_ } ];
- push @{ $expat->{Lists} }, $expat->{Curlist};
- push @{ $expat->{Curlist} }, $tag => $newlist;
- $expat->{Curlist} = $newlist;
+ my $expat = shift;
+ my $tag = shift;
+ my $newlist = [ {@_} ];
+ push @{ $expat->{Lists} }, $expat->{Curlist};
+ push @{ $expat->{Curlist} }, $tag => $newlist;
+ $expat->{Curlist} = $newlist;
}
sub End {
- my $expat = shift;
- my $tag = shift;
- $expat->{Curlist} = pop @{ $expat->{Lists} };
+ my $expat = shift;
+ my $tag = shift;
+ $expat->{Curlist} = pop @{ $expat->{Lists} };
}
sub Char {
- my $expat = shift;
- my $text = shift;
- my $clist = $expat->{Curlist};
- my $pos = $#$clist;
-
- if ($pos > 0 and $clist->[$pos - 1] eq '0') {
- $clist->[$pos] .= $text;
- } else {
- push @$clist, 0 => $text;
- }
+ my $expat = shift;
+ my $text = shift;
+ my $clist = $expat->{Curlist};
+ my $pos = $#$clist;
+
+ if ( $pos > 0 and $clist->[ $pos - 1 ] eq '0' ) {
+ $clist->[$pos] .= $text;
+ }
+ else {
+ push @$clist, 0 => $text;
+ }
}
sub Final {
- my $expat = shift;
- delete $expat->{Curlist};
- delete $expat->{Lists};
- $expat->{Tree};
+ my $expat = shift;
+ delete $expat->{Curlist};
+ delete $expat->{Lists};
+ $expat->{Tree};
}
1;
- XML::Parser Version 2.40
+NAME
+ XML::Parser - A perl module for parsing XML documents
-Copyright (c) 1998-2000 Larry Wall and Clark Cooper.
-All rights reserved.
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
+SYNOPSIS
+ use XML::Parser;
-This is a Perl extension interface to James Clark's XML parser, expat.
-It requires at least version 5.004 of perl and it requires that you have
-release 1.95.0 or greater of expat installed. You can download expat
-from http://sourceforge.net/projects/expat/
+ $p1 = XML::Parser->new(Style => 'Debug');
+ $p1->parsefile('REC-xml-19980210.xml');
+ $p1->parse('<foo id="me">Hello World</foo>');
+
+ # Alternative
+ $p2 = XML::Parser->new(Handlers => {Start => \&handle_start,
+ End => \&handle_end,
+ Char => \&handle_char});
+ $p2->parse($socket);
+
+ # Another alternative
+ $p3 = XML::Parser->new(ErrorContext => 2);
+
+ $p3->setHandlers(Char => \&text,
+ Default => \&other);
+
+ open(my $fh, 'xmlgenerator |');
+ $p3->parse($foo, ProtocolEncoding => 'ISO-8859-1');
+ close($foo);
+
+ $p3->parsefile('junk.xml', ErrorContext => 3);
+
+DESCRIPTION
+ This module provides ways to parse XML documents. It is built on top of
+ XML::Parser::Expat, which is a lower level interface to James Clark's
+ expat library. Each call to one of the parsing methods creates a new
+ instance of XML::Parser::Expat which is then used to parse the document.
+ Expat options may be provided when the XML::Parser object is created.
+ These options are then passed on to the Expat object on each parse call.
+ They can also be given as extra arguments to the parse methods, in which
+ case they override options given at XML::Parser creation time.
-Best way is to install expat development package with your OS package manager.
-Debian/Ubuntu/similar: libexpat1-dev (old versions: expat-dev)
+ The behavior of the parser is controlled either by "STYLES" and/or
+ "HANDLERS" options, or by "setHandlers" method. These all provide
+ mechanisms for XML::Parser to set the handlers needed by
+ XML::Parser::Expat. If neither "Style" nor "Handlers" are specified,
+ then parsing just checks the document for being well-formed.
+
+ When underlying handlers get called, they receive as their first
+ parameter the *Expat* object, not the Parser object.
+
+METHODS
+ new This is a class method, the constructor for XML::Parser. Options are
+ passed as keyword value pairs. Recognized options are:
+
+ * Style
+
+ This option provides an easy way to create a given style of
+ parser. The built in styles are: "Debug", "Subs", "Tree",
+ "Objects", and "Stream". These are all defined in separate
+ packages under "XML::Parser::Style::*", and you can find further
+ documentation for each style both below, and in those packages.
+
+ Custom styles can be provided by giving a full package name
+ containing at least one '::'. This package should then have subs
+ defined for each handler it wishes to have installed. See
+ "STYLES" below for a discussion of each built in style.
+
+ * Handlers
+
+ When provided, this option should be an anonymous hash
+ containing as keys the type of handler and as values a sub
+ reference to handle that type of event. All the handlers get
+ passed as their 1st parameter the instance of expat that is
+ parsing the document. Further details on handlers can be found
+ in "HANDLERS". Any handler set here overrides the corresponding
+ handler set with the Style option.
+
+ * Pkg
+
+ Some styles will refer to subs defined in this package. If not
+ provided, it defaults to the package which called the
+ constructor.
+
+ * ErrorContext
+
+ This is an Expat option. When this option is defined, errors are
+ reported in context. The value should be the number of lines to
+ show on either side of the line in which the error occurred.
+
+ * ProtocolEncoding
+
+ This is an Expat option. This sets the protocol encoding name.
+ It defaults to none. The built-in encodings are: "UTF-8",
+ "ISO-8859-1", "UTF-16", and "US-ASCII". Other encodings may be
+ used if they have encoding maps in one of the directories in the
+ @Encoding_Path list. Check "ENCODINGS" for more information on
+ encoding maps. Setting the protocol encoding overrides any
+ encoding in the XML declaration.
+
+ * Namespaces
+
+ This is an Expat option. If this is set to a true value, then
+ namespace processing is done during the parse. See "Namespaces"
+ in XML::Parser::Expat for further discussion of namespace
+ processing.
+
+ * NoExpand
+
+ This is an Expat option. Normally, the parser will try to expand
+ references to entities defined in the internal subset. If this
+ option is set to a true value, and a default handler is also
+ set, then the default handler will be called when an entity
+ reference is seen in text. This has no effect if a default
+ handler has not been registered, and it has no effect on the
+ expansion of entity references inside attribute values.
+
+ * Stream_Delimiter
+
+ This is an Expat option. It takes a string value. When this
+ string is found alone on a line while parsing from a stream,
+ then the parse is ended as if it saw an end of file. The
+ intended use is with a stream of xml documents in a MIME
+ multipart format. The string should not contain a trailing
+ newline.
+
+ * ParseParamEnt
+
+ This is an Expat option. Unless standalone is set to "yes" in
+ the XML declaration, setting this to a true value allows the
+ external DTD to be read, and parameter entities to be parsed and
+ expanded.
+
+ * NoLWP
+
+ This option has no effect if the ExternEnt or ExternEntFin
+ handlers are directly set. Otherwise, if true, it forces the use
+ of a file based external entity handler.
+
+ * Non_Expat_Options
+
+ If provided, this should be an anonymous hash whose keys are
+ options that shouldn't be passed to Expat. This should only be
+ of concern to those subclassing XML::Parser.
+
+ setHandlers(TYPE, HANDLER [, TYPE, HANDLER [...]])
+ This method registers handlers for various parser events. It
+ overrides any previous handlers registered through the Style or
+ Handler options or through earlier calls to setHandlers. By
+ providing a false or undefined value as the handler, the existing
+ handler can be unset.
+
+ This method returns a list of type, handler pairs corresponding to
+ the input. The handlers returned are the ones that were in effect
+ prior to the call.
+
+ See a description of the handler types in "HANDLERS".
+
+ parse(SOURCE [, OPT => OPT_VALUE [...]])
+ The SOURCE parameter should either be a string containing the whole
+ XML document, or it should be an open IO::Handle. Constructor
+ options to XML::Parser::Expat given as keyword-value pairs may
+ follow the SOURCE parameter. These override, for this call, any
+ options or attributes passed through from the XML::Parser instance.
+
+ A die call is thrown if a parse error occurs. Otherwise it will
+ return 1 or whatever is returned from the Final handler, if one is
+ installed. In other words, what parse may return depends on the
+ style.
+
+ parsestring
+ This is just an alias for parse for backwards compatibility.
+
+ parsefile(FILE [, OPT => OPT_VALUE [...]])
+ Open FILE for reading, then call parse with the open handle. The
+ file is closed no matter how parse returns. Returns what parse
+ returns.
+
+ parse_start([ OPT => OPT_VALUE [...]])
+ Create and return a new instance of XML::Parser::ExpatNB.
+ Constructor options may be provided. If an init handler has been
+ provided, it is called before returning the ExpatNB object.
+ Documents are parsed by making incremental calls to the parse_more
+ method of this object, which takes a string. A single call to the
+ parse_done method of this object, which takes no arguments,
+ indicates that the document is finished.
+
+ If there is a final handler installed, it is executed by the
+ parse_done method before returning and the parse_done method returns
+ whatever is returned by the final handler.
+
+HANDLERS
+ Expat is an event based parser. As the parser recognizes parts of the
+ document (say the start or end tag for an XML element), then any
+ handlers registered for that type of an event are called with suitable
+ parameters. All handlers receive an instance of XML::Parser::Expat as
+ their first argument. See "METHODS" in XML::Parser::Expat for a
+ discussion of the methods that can be called on this object.
+
+ Init (Expat)
+ This is called just before the parsing of the document starts.
+
+ Final (Expat)
+ This is called just after parsing has finished, but only if no errors
+ occurred during the parse. Parse returns what this returns.
+
+ Start (Expat, Element [, Attr, Val [,...]])
+ This event is generated when an XML start tag is recognized. Element is
+ the name of the XML element type that is opened with the start tag. The
+ Attr & Val pairs are generated for each attribute in the start tag.
+
+ End (Expat, Element)
+ This event is generated when an XML end tag is recognized. Note that an
+ XML empty tag (<foo/>) generates both a start and an end event.
+
+ Char (Expat, String)
+ This event is generated when non-markup is recognized. The non-markup
+ sequence of characters is in String. A single non-markup sequence of
+ characters may generate multiple calls to this handler. Whatever the
+ encoding of the string in the original document, this is given to the
+ handler in UTF-8.
+
+ Proc (Expat, Target, Data)
+ This event is generated when a processing instruction is recognized.
+
+ Comment (Expat, Data)
+ This event is generated when a comment is recognized.
+
+ CdataStart (Expat)
+ This is called at the start of a CDATA section.
+
+ CdataEnd (Expat)
+ This is called at the end of a CDATA section.
+
+ Default (Expat, String)
+ This is called for any characters that don't have a registered handler.
+ This includes both characters that are part of markup for which no
+ events are generated (markup declarations) and characters that could
+ generate events, but for which no handler has been registered.
+
+ Whatever the encoding in the original document, the string is returned
+ to the handler in UTF-8.
+
+ Unparsed (Expat, Entity, Base, Sysid, Pubid, Notation)
+ This is called for a declaration of an unparsed entity. Entity is the
+ name of the entity. Base is the base to be used for resolving a relative
+ URI. Sysid is the system id. Pubid is the public id. Notation is the
+ notation name. Base and Pubid may be undefined.
+
+ Notation (Expat, Notation, Base, Sysid, Pubid)
+ This is called for a declaration of notation. Notation is the notation
+ name. Base is the base to be used for resolving a relative URI. Sysid is
+ the system id. Pubid is the public id. Base, Sysid, and Pubid may all be
+ undefined.
+
+ ExternEnt (Expat, Base, Sysid, Pubid)
+ This is called when an external entity is referenced. Base is the base
+ to be used for resolving a relative URI. Sysid is the system id. Pubid
+ is the public id. Base, and Pubid may be undefined.
+
+ This handler should either return a string, which represents the
+ contents of the external entity, or return an open filehandle that can
+ be read to obtain the contents of the external entity, or return undef,
+ which indicates the external entity couldn't be found and will generate
+ a parse error.
+
+ If an open filehandle is returned, it must be returned as either a glob
+ (*FOO) or as a reference to a glob (e.g. an instance of IO::Handle).
+
+ A default handler is installed for this event. The default handler is
+ XML::Parser::lwp_ext_ent_handler unless the NoLWP option was provided
+ with a true value, otherwise XML::Parser::file_ext_ent_handler is the
+ default handler for external entities. Even without the NoLWP option, if
+ the URI or LWP modules are missing, the file based handler ends up being
+ used after giving a warning on the first external entity reference.
+
+ The LWP external entity handler will use proxies defined in the
+ environment (http_proxy, ftp_proxy, etc.).
+
+ Please note that the LWP external entity handler reads the entire entity
+ into a string and returns it, where as the file handler opens a
+ filehandle.
+
+ Also note that the file external entity handler will likely choke on
+ absolute URIs or file names that don't fit the conventions of the local
+ operating system.
+
+ The expat base method can be used to set a basename for relative
+ pathnames. If no basename is given, or if the basename is itself a
+ relative name, then it is relative to the current working directory.
+
+ ExternEntFin (Expat)
+ This is called after parsing an external entity. It's not called unless
+ an ExternEnt handler is also set. There is a default handler installed
+ that pairs with the default ExternEnt handler.
+
+ If you're going to install your own ExternEnt handler, then you should
+ set (or unset) this handler too.
+
+ Entity (Expat, Name, Val, Sysid, Pubid, Ndata, IsParam)
+ This is called when an entity is declared. For internal entities, the
+ Val parameter will contain the value and the remaining three parameters
+ will be undefined. For external entities, the Val parameter will be
+ undefined, the Sysid parameter will have the system id, the Pubid
+ parameter will have the public id if it was provided (it will be
+ undefined otherwise), the Ndata parameter will contain the notation for
+ unparsed entities. If this is a parameter entity declaration, then the
+ IsParam parameter is true.
+
+ Note that this handler and the Unparsed handler above overlap. If both
+ are set, then this handler will not be called for unparsed entities.
+
+ Element (Expat, Name, Model)
+ The element handler is called when an element declaration is found. Name
+ is the element name, and Model is the content model as an
+ XML::Parser::Content object. See "XML::Parser::ContentModel Methods" in
+ XML::Parser::Expat for methods available for this class.
+
+ Attlist (Expat, Elname, Attname, Type, Default, Fixed)
+ This handler is called for each attribute in an ATTLIST declaration. So
+ an ATTLIST declaration that has multiple attributes will generate
+ multiple calls to this handler. The Elname parameter is the name of the
+ element with which the attribute is being associated. The Attname
+ parameter is the name of the attribute. Type is the attribute type,
+ given as a string. Default is the default value, which will either be
+ "#REQUIRED", "#IMPLIED" or a quoted string (i.e. the returned string
+ will begin and end with a quote character). If Fixed is true, then this
+ is a fixed attribute.
+
+ Doctype (Expat, Name, Sysid, Pubid, Internal)
+ This handler is called for DOCTYPE declarations. Name is the document
+ type name. Sysid is the system id of the document type, if it was
+ provided, otherwise it's undefined. Pubid is the public id of the
+ document type, which will be undefined if no public id was given.
+ Internal is the internal subset, given as a string. If there was no
+ internal subset, it will be undefined. Internal will contain all
+ whitespace, comments, processing instructions, and declarations seen in
+ the internal subset. The declarations will be there whether or not they
+ have been processed by another handler (except for unparsed entities
+ processed by the Unparsed handler). However, comments and processing
+ instructions will not appear if they've been processed by their
+ respective handlers.
+
+ * DoctypeFin (Parser)
+ This handler is called after parsing of the DOCTYPE declaration has
+ finished, including any internal or external DTD declarations.
+
+ XMLDecl (Expat, Version, Encoding, Standalone)
+ This handler is called for xml declarations. Version is a string
+ containing the version. Encoding is either undefined or contains an
+ encoding string. Standalone will be either true, false, or undefined if
+ the standalone attribute is yes, no, or not made respectively.
+
+STYLES
+ Debug
+ This just prints out the document in outline form. Nothing special is
+ returned by parse.
+
+ Subs
+ Each time an element starts, a sub by that name in the package specified
+ by the Pkg option is called with the same parameters that the Start
+ handler gets called with.
+
+ Each time an element ends, a sub with that name appended with an
+ underscore ("_"), is called with the same parameters that the End
+ handler gets called with.
+
+ Nothing special is returned by parse.
+
+ Tree
+ Parse will return a parse tree for the document. Each node in the tree
+ takes the form of a tag, content pair. Text nodes are represented with a
+ pseudo-tag of "0" and the string that is their content. For elements,
+ the content is an array reference. The first item in the array is a
+ (possibly empty) hash reference containing attributes. The remainder of
+ the array is a sequence of tag-content pairs representing the content of
+ the element.
+
+ So for example the result of parsing:
+
+ <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
+
+ would be:
+
+ Tag Content
+ ==================================================================
+ [foo, [{}, head, [{id => "a"}, 0, "Hello ", em, [{}, 0, "there"]],
+ bar, [ {}, 0, "Howdy", ref, [{}]],
+ 0, "do"
+ ]
+ ]
+
+ The root document "foo", has 3 children: a "head" element, a "bar"
+ element and the text "do". After the empty attribute hash, these are
+ represented in it's contents by 3 tag-content pairs.
+
+ Objects
+ This is similar to the Tree style, except that a hash object is created
+ for each element. The corresponding object will be in the class whose
+ name is created by appending "::" and the element name to the package
+ set with the Pkg option. Non-markup text will be in the ::Characters
+ class. The contents of the corresponding object will be in an anonymous
+ array that is the value of the Kids property for that object.
+
+ Stream
+ This style also uses the Pkg package. If none of the subs that this
+ style looks for is there, then the effect of parsing with this style is
+ to print a canonical copy of the document without comments or
+ declarations. All the subs receive as their 1st parameter the Expat
+ instance for the document they're parsing.
+
+ It looks for the following routines:
+
+ * StartDocument
+
+ Called at the start of the parse .
+
+ * StartTag
+
+ Called for every start tag with a second parameter of the element
+ type. The $_ variable will contain a copy of the tag and the %_
+ variable will contain attribute values supplied for that element.
+
+ * EndTag
+
+ Called for every end tag with a second parameter of the element
+ type. The $_ variable will contain a copy of the end tag.
-After that run `cpan XML::Parser`.
+ * Text
-You can install this module from OS package too, but CPAN has most fresh version.
-CentOS/RHEL/Fedora: perl-XML-Parser
-Debian/Ubuntu/similar: should be already installed
+ Called just before start or end tags with accumulated non-markup
+ text in the $_ variable.
-XML::Parser installation requires gcc, so on MacOS X you need to download and run
-Xcode from Mac app store (~1.5 GB)
+ * PI
+ Called for processing instructions. The $_ variable will contain a
+ copy of the PI and the target and data are sent as 2nd and 3rd
+ parameters respectively.
-The documentation for this extension can be found in pod format at the end
-of the files Parser.pm and Expat/Expat.pm. The perldoc program, provided with
-the perl distribution, can be used to view this documentation.
+ * EndDocument
-This was modified from the original XML::Parser created by Larry Wall.
+ Called at conclusion of the parse.
--------------
+ENCODINGS
+ XML documents may be encoded in character sets other than Unicode as
+ long as they may be mapped into the Unicode character set. Expat has
+ further restrictions on encodings. Read the xmlparse.h header file in
+ the expat distribution to see details on these restrictions.
-To manually install this module, cd to the directory that contains this README file
-and type the following:
+ Expat has built-in encodings for: "UTF-8", "ISO-8859-1", "UTF-16", and
+ "US-ASCII". Encodings are set either through the XML declaration
+ encoding attribute or through the ProtocolEncoding option to XML::Parser
+ or XML::Parser::Expat.
- perl Makefile.PL
+ For encodings other than the built-ins, expat calls the function
+ load_encoding in the Expat package with the encoding name. This function
+ looks for a file in the path list @XML::Parser::Expat::Encoding_Path,
+ that matches the lower-cased name with a '.enc' extension. The first one
+ it finds, it loads.
-Alternatively, if you plan to install XML::Parser somewhere other than
-your system's perl library directory. You can type something like this:
+ If you wish to build your own encoding maps, check out the XML::Encoding
+ module from CPAN.
- perl Makefile.PL PREFIX=/home/me/perl INSTALLDIRS=perl
+AUTHORS
+ Larry Wall <larry@wall.org> wrote version 1.0.
-Then to build you run make.
+ Clark Cooper <coopercc@netheaven.com> picked up support, changed the API
+ for this version (2.x), provided documentation, and added some standard
+ package features.
- make
+ Matt Sergeant <matt@sergeant.org> is now maintaining XML::Parser
-You can then test the module by typing:
-
- make test
-
-There are some sample utilities in the samples directory along with an
-xml form of the XML specification to test them on. You may need to change
-the '#!' line at the top of these utilities to what is appropriate for
-your system. If you're going to play around with them prior to installing
-the module, you would need to add the blib paths to your perl search
-path, like this (assuming your current directory is samples):
-
- perl -I../blib/lib -I../blib/arch xmlcomments REC-xml-19980210.xml
-
-or set your PERLLIB environment variable.
-
-If you have write access to the installation directories, you may then
-install by typing:
-
- make install
-
-Discussion on features and bugs of this software and general discussion
-on topics relating to perl and XML takes place on the perl-xml mailing
-list, to which you can subscribe by sending mail to:
-
- subscribe-perl-xml@lyris.activestate.com
-
-
-
-
-Differences from Version 2.30
-=============================
-
-Version 2.31 is a minor bugfix release to allow XML::Parser to
-work under the forthcoming Perl 5.8.0 release. There are no functional
-changes.
-
-Differences from Version 2.29
-=============================
-
-Expat is no longer included with this package. It must now be already
-installed on your system as a library. You may download the library
-version of expat from http://sourceforge.net/projects/expat/. After
-downloading, expat must be configured (an automatic script does this),
-built and installed.
-
-A workaround has been provided for those people who couldn't compile
-Expat.xs with a perl 5.6.0 with USE_5005THREADS on.
-
-A bug that prevented IO::Handler from being read by the parse method
-has been fixed.
-
-Fixed a bug in reading external entities with incremental parsing.
-
-Clark Cooper
- coopercc@netheaven.com
package Devel::CheckLib;
-use 5.00405; #postfix foreach
+use 5.00405; #postfix foreach
use strict;
use vars qw($VERSION @ISA @EXPORT);
$VERSION = '0.99';
use File::Temp;
require Exporter;
-@ISA = qw(Exporter);
+@ISA = qw(Exporter);
@EXPORT = qw(assert_lib check_lib_or_exit check_lib);
# localising prevents the warningness leaking out of this module
local $^W = 1; # use warnings is a 5.6-ism
-_findcc(); # bomb out early if there's no compiler
+_findcc(); # bomb out early if there's no compiler
=head1 NAME
sub check_lib_or_exit {
eval 'assert_lib(@_)';
- if($@) {
+ if ($@) {
warn $@;
exit;
}
sub assert_lib {
my %args = @_;
- my (@libs, @libpaths, @headers, @incpaths);
+ my ( @libs, @libpaths, @headers, @incpaths );
# FIXME: these four just SCREAM "refactor" at me
- @libs = (ref($args{lib}) ? @{$args{lib}} : $args{lib})
- if $args{lib};
- @libpaths = (ref($args{libpath}) ? @{$args{libpath}} : $args{libpath})
- if $args{libpath};
- @headers = (ref($args{header}) ? @{$args{header}} : $args{header})
- if $args{header};
- @incpaths = (ref($args{incpath}) ? @{$args{incpath}} : $args{incpath})
- if $args{incpath};
+ @libs = ( ref( $args{lib} ) ? @{ $args{lib} } : $args{lib} )
+ if $args{lib};
+ @libpaths = ( ref( $args{libpath} ) ? @{ $args{libpath} } : $args{libpath} )
+ if $args{libpath};
+ @headers = ( ref( $args{header} ) ? @{ $args{header} } : $args{header} )
+ if $args{header};
+ @incpaths = ( ref( $args{incpath} ) ? @{ $args{incpath} } : $args{incpath} )
+ if $args{incpath};
# work-a-like for Makefile.PL's LIBS and INC arguments
# if given as command-line argument, append to %args
for my $arg (@ARGV) {
for my $mm_attr_key (qw(LIBS INC)) {
- if (my ($mm_attr_value) = $arg =~ /\A $mm_attr_key = (.*)/x) {
- # it is tempting to put some \s* into the expression, but the
- # MM command-line parser only accepts LIBS etc. followed by =,
- # so we should not be any more lenient with whitespace than that
+ if ( my ($mm_attr_value) = $arg =~ /\A $mm_attr_key = (.*)/x ) {
+
+ # it is tempting to put some \s* into the expression, but the
+ # MM command-line parser only accepts LIBS etc. followed by =,
+ # so we should not be any more lenient with whitespace than that
$args{$mm_attr_key} .= " $mm_attr_value";
}
}
}
# using special form of split to trim whitespace
- if(defined($args{LIBS})) {
- foreach my $arg (split(' ', $args{LIBS})) {
- die("LIBS argument badly-formed: $arg\n") unless($arg =~ /^-[lLR]/);
- push @{$arg =~ /^-l/ ? \@libs : \@libpaths}, substr($arg, 2);
+ if ( defined( $args{LIBS} ) ) {
+ foreach my $arg ( split( ' ', $args{LIBS} ) ) {
+ die("LIBS argument badly-formed: $arg\n") unless ( $arg =~ /^-[lLR]/ );
+ push @{ $arg =~ /^-l/ ? \@libs : \@libpaths }, substr( $arg, 2 );
}
}
- if(defined($args{INC})) {
- foreach my $arg (split(' ', $args{INC})) {
- die("INC argument badly-formed: $arg\n") unless($arg =~ /^-I/);
- push @incpaths, substr($arg, 2);
+ if ( defined( $args{INC} ) ) {
+ foreach my $arg ( split( ' ', $args{INC} ) ) {
+ die("INC argument badly-formed: $arg\n") unless ( $arg =~ /^-I/ );
+ push @incpaths, substr( $arg, 2 );
}
}
- my ($cc, $ld) = _findcc();
+ my ( $cc, $ld ) = _findcc();
my @missing;
my @wrongresult;
my @use_headers;
# first figure out which headers we can't find ...
for my $header (@headers) {
push @use_headers, $header;
- my($ch, $cfile) = File::Temp::tempfile(
- 'assertlibXXXXXXXX', SUFFIX => '.c'
- );
+ my ( $ch, $cfile ) = File::Temp::tempfile( 'assertlibXXXXXXXX', SUFFIX => '.c' );
my $ofile = $cfile;
$ofile =~ s/\.c$/$Config{_o}/;
print $ch qq{#include <$_>\n} for @use_headers;
print $ch qq{int main(void) { return 0; }\n};
close($ch);
- my $exefile = File::Temp::mktemp( 'assertlibXXXXXXXX' ) . $Config{_exe};
+ my $exefile = File::Temp::mktemp('assertlibXXXXXXXX') . $Config{_exe};
my @sys_cmd;
+
# FIXME: re-factor - almost identical code later when linking
- if ( $Config{cc} eq 'cl' ) { # Microsoft compiler
+ if ( $Config{cc} eq 'cl' ) { # Microsoft compiler
require Win32;
@sys_cmd = (
@$cc,
$cfile,
"/Fe$exefile",
- (map { '/I'.Win32::GetShortPathName($_) } @incpaths),
- "/link",
- @$ld
+ ( map { '/I' . Win32::GetShortPathName($_) } @incpaths ),
+ "/link",
+ @$ld
);
- } elsif($Config{cc} =~ /bcc32(\.exe)?/) { # Borland
+ }
+ elsif ( $Config{cc} =~ /bcc32(\.exe)?/ ) { # Borland
@sys_cmd = (
@$cc,
@$ld,
- (map { "-I$_" } @incpaths),
+ ( map { "-I$_" } @incpaths ),
"-o$exefile",
$cfile
);
- } else { # Unix-ish: gcc, Sun, AIX (gcc, cc), ...
+ }
+ else { # Unix-ish: gcc, Sun, AIX (gcc, cc), ...
@sys_cmd = (
@$cc,
@$ld,
$cfile,
- (map { "-I$_" } @incpaths),
+ ( map { "-I$_" } @incpaths ),
"-o", "$exefile"
);
}
warn "# @sys_cmd\n" if $args{debug};
my $rv = $args{debug} ? system(@sys_cmd) : _quiet_system(@sys_cmd);
- push @missing, $header if $rv != 0 || ! -x $exefile;
+ push @missing, $header if $rv != 0 || !-x $exefile;
_cleanup_exe($exefile);
unlink $ofile if -e $ofile;
unlink $cfile;
- }
+ }
# now do each library in turn with headers
- my($ch, $cfile) = File::Temp::tempfile(
- 'assertlibXXXXXXXX', SUFFIX => '.c'
- );
+ my ( $ch, $cfile ) = File::Temp::tempfile( 'assertlibXXXXXXXX', SUFFIX => '.c' );
my $ofile = $cfile;
$ofile =~ s/\.c$/$Config{_o}/;
print $ch qq{#include <$_>\n} foreach (@headers);
- print $ch "int main(void) { ".($args{function} || 'return 0;')." }\n";
+ print $ch "int main(void) { " . ( $args{function} || 'return 0;' ) . " }\n";
close($ch);
- for my $lib ( @libs ) {
- my $exefile = File::Temp::mktemp( 'assertlibXXXXXXXX' ) . $Config{_exe};
+ for my $lib (@libs) {
+ my $exefile = File::Temp::mktemp('assertlibXXXXXXXX') . $Config{_exe};
my @sys_cmd;
- if ( $Config{cc} eq 'cl' ) { # Microsoft compiler
+ if ( $Config{cc} eq 'cl' ) { # Microsoft compiler
require Win32;
- my @libpath = map {
- q{/libpath:} . Win32::GetShortPathName($_)
- } @libpaths;
+ my @libpath = map { q{/libpath:} . Win32::GetShortPathName($_) } @libpaths;
+
# this is horribly sensitive to the order of arguments
@sys_cmd = (
@$cc,
$cfile,
"${lib}.lib",
- "/Fe$exefile",
- (map { '/I'.Win32::GetShortPathName($_) } @incpaths),
+ "/Fe$exefile",
+ ( map { '/I' . Win32::GetShortPathName($_) } @incpaths ),
"/link",
@$ld,
- (map {'/libpath:'.Win32::GetShortPathName($_)} @libpaths),
+ ( map { '/libpath:' . Win32::GetShortPathName($_) } @libpaths ),
);
- } elsif($Config{cc} eq 'CC/DECC') { # VMS
- } elsif($Config{cc} =~ /bcc32(\.exe)?/) { # Borland
+ }
+ elsif ( $Config{cc} eq 'CC/DECC' ) { # VMS
+ }
+ elsif ( $Config{cc} =~ /bcc32(\.exe)?/ ) { # Borland
@sys_cmd = (
@$cc,
@$ld,
"-o$exefile",
- (map { "-I$_" } @incpaths),
- (map { "-L$_" } @libpaths),
+ ( map { "-I$_" } @incpaths ),
+ ( map { "-L$_" } @libpaths ),
"-l$lib",
- $cfile);
- } else { # Unix-ish
- # gcc, Sun, AIX (gcc, cc)
+ $cfile
+ );
+ }
+ else { # Unix-ish
+ # gcc, Sun, AIX (gcc, cc)
@sys_cmd = (
@$cc,
@$ld,
$cfile,
"-o", "$exefile",
- (map { "-I$_" } @incpaths),
- (map { "-L$_" } @libpaths),
+ ( map { "-I$_" } @incpaths ),
+ ( map { "-L$_" } @libpaths ),
"-l$lib",
);
}
warn "# @sys_cmd\n" if $args{debug};
my $rv = $args{debug} ? system(@sys_cmd) : _quiet_system(@sys_cmd);
- push @missing, $lib if $rv != 0 || ! -x $exefile;
+ push @missing, $lib if $rv != 0 || !-x $exefile;
my $absexefile = File::Spec->rel2abs($exefile);
- $absexefile = '"'.$absexefile.'"' if $absexefile =~ m/\s/;
+ $absexefile = '"' . $absexefile . '"' if $absexefile =~ m/\s/;
push @wrongresult, $lib if $rv == 0 && -x $exefile && system($absexefile) != 0;
unlink $ofile if -e $ofile;
_cleanup_exe($exefile);
- }
+ }
unlink $cfile;
my $miss_string = join( q{, }, map { qq{'$_'} } @missing );
die("Can't link/include C library $miss_string, aborting.\n") if @missing;
- my $wrong_string = join( q{, }, map { qq{'$_'} } @wrongresult);
+ my $wrong_string = join( q{, }, map { qq{'$_'} } @wrongresult );
die("wrong result: $wrong_string\n") if @wrongresult;
}
my ($exefile) = @_;
my $ofile = $exefile;
$ofile =~ s/$Config{_exe}$/$Config{_o}/;
- unlink $exefile if -f $exefile;
- unlink $ofile if -f $ofile;
+ unlink $exefile if -f $exefile;
+ unlink $ofile if -f $ofile;
unlink "$exefile\.manifest" if -f "$exefile\.manifest";
if ( $Config{cc} eq 'cl' ) {
+
# MSVC also creates foo.ilk and foo.pdb
my $ilkfile = $exefile;
$ilkfile =~ s/$Config{_exe}$/.ilk/;
unlink $ilkfile if -f $ilkfile;
unlink $pdbfile if -f $pdbfile;
}
- return
+ return;
}
-
+
# return ($cc, $ld)
# where $cc is an array ref of compiler name, compiler flags
# where $ld is an array ref of linker flags
sub _findcc {
+
# Need to use $keep=1 to work with MSWin32 backslashes and quotes
- my $Config_ccflags = $Config{ccflags}; # use copy so ASPerl will compile
+ my $Config_ccflags = $Config{ccflags}; # use copy so ASPerl will compile
my @Config_ldflags = ();
- for my $config_val ( @Config{qw(ldflags perllibs)} ){
+ for my $config_val ( @Config{qw(ldflags perllibs)} ) {
push @Config_ldflags, $config_val if ( $config_val =~ /\S/ );
}
- my @ccflags = grep { length } quotewords('\s+', 1, $Config_ccflags||'');
- my @ldflags = grep { length } quotewords('\s+', 1, @Config_ldflags);
- my @paths = split(/$Config{path_sep}/, $ENV{PATH});
- my @cc = split(/\s+/, $Config{cc});
+ my @ccflags = grep { length } quotewords( '\s+', 1, $Config_ccflags || '' );
+ my @ldflags = grep { length } quotewords( '\s+', 1, @Config_ldflags );
+ my @paths = split( /$Config{path_sep}/, $ENV{PATH} );
+ my @cc = split( /\s+/, $Config{cc} );
return ( [ @cc, @ccflags ], \@ldflags ) if -x $cc[0];
foreach my $path (@paths) {
- my $compiler = File::Spec->catfile($path, $cc[0]) . $Config{_exe};
- return ([ $compiler, @cc[1 .. $#cc], @ccflags ], \@ldflags)
- if -x $compiler;
+ my $compiler = File::Spec->catfile( $path, $cc[0] ) . $Config{_exe};
+ return ( [ $compiler, @cc[ 1 .. $#cc ], @ccflags ], \@ldflags )
+ if -x $compiler;
}
die("Couldn't find your C compiler\n");
}
local *STDERR_SAVE;
open STDOUT_SAVE, ">&STDOUT" or die "CheckLib: $! saving STDOUT";
open STDERR_SAVE, ">&STDERR" or die "CheckLib: $! saving STDERR";
-
+
# redirect to nowhere
local *DEV_NULL;
- open DEV_NULL, ">" . File::Spec->devnull
- or die "CheckLib: $! opening handle to null device";
+ open DEV_NULL, ">" . File::Spec->devnull
+ or die "CheckLib: $! opening handle to null device";
open STDOUT, ">&" . fileno DEV_NULL
- or die "CheckLib: $! redirecting STDOUT to null handle";
+ or die "CheckLib: $! redirecting STDOUT to null handle";
open STDERR, ">&" . fileno DEV_NULL
- or die "CheckLib: $! redirecting STDERR to null handle";
+ or die "CheckLib: $! redirecting STDERR to null handle";
# run system command
my $rv = system(@cmd);
# restore handles
open STDOUT, ">&" . fileno STDOUT_SAVE
- or die "CheckLib: $! restoring STDOUT handle";
+ or die "CheckLib: $! restoring STDOUT handle";
open STDERR, ">&" . fileno STDERR_SAVE
- or die "CheckLib: $! restoring STDERR handle";
+ or die "CheckLib: $! restoring STDERR handle";
return $rv;
}
use XML::Parser;
my $indoctype = 0;
-my $inroot = 0;
-my $p = new XML::Parser(ErrorContext => 2,
- Namespaces => 1,
- ParseParamEnt => 1,
- Handlers => {Start => \&sthndl,
- End => \&endhndl,
- Char => \&chrhndl,
- Proc => \&proc,
- Doctype => sub {$indoctype = 1},
- DoctypeFin => sub {$indoctype = 0}
- }
- );
+my $inroot = 0;
+my $p = new XML::Parser(
+ ErrorContext => 2,
+ Namespaces => 1,
+ ParseParamEnt => 1,
+ Handlers => {
+ Start => \&sthndl,
+ End => \&endhndl,
+ Char => \&chrhndl,
+ Proc => \&proc,
+ Doctype => sub { $indoctype = 1 },
+ DoctypeFin => sub { $indoctype = 0 }
+ }
+);
my $file = shift;
-if (defined $file) {
- $p->parsefile($file);
+if ( defined $file ) {
+ $p->parsefile($file);
}
else {
- $p->parse(*STDIN);
+ $p->parse(*STDIN);
}
################
################
sub sthndl {
- my $xp = shift;
- my $el = shift;
-
- $inroot = 1 unless $inroot;
- my $ns_index = 1;
-
- my $elns = $xp->namespace($el);
- if (defined $elns) {
- my $pfx = 'n' . $ns_index++;
- print "<$pfx:$el xmlns:$pfx=\"$elns\"";
- }
- else {
- print "<$el";
- }
-
- if (@_) {
- for (my $i = 0; $i < @_; $i += 2) {
- my $nm = $_[$i];
- my $ns = $xp->namespace($nm);
- $_[$i] = defined($ns) ? "$ns\01$nm" : "\01$nm";
+ my $xp = shift;
+ my $el = shift;
+
+ $inroot = 1 unless $inroot;
+ my $ns_index = 1;
+
+ my $elns = $xp->namespace($el);
+ if ( defined $elns ) {
+ my $pfx = 'n' . $ns_index++;
+ print "<$pfx:$el xmlns:$pfx=\"$elns\"";
+ }
+ else {
+ print "<$el";
}
- my %atts = @_;
- my @ids = sort keys %atts;
- foreach my $id (@ids) {
- my ($ns, $nm) = split(/\01/, $id);
- my $val = $xp->xml_escape($atts{$id}, '"', "\x9", "\xA", "\xD");
- if (length($ns)) {
- my $pfx = 'n' . $ns_index++;
- print " $pfx:$nm=\"$val\" xmlns:$pfx=\"$ns\"";
- }
- else {
- print " $nm=\"$val\"";
- }
+ if (@_) {
+ for ( my $i = 0; $i < @_; $i += 2 ) {
+ my $nm = $_[$i];
+ my $ns = $xp->namespace($nm);
+ $_[$i] = defined($ns) ? "$ns\01$nm" : "\01$nm";
+ }
+
+ my %atts = @_;
+ my @ids = sort keys %atts;
+ foreach my $id (@ids) {
+ my ( $ns, $nm ) = split( /\01/, $id );
+ my $val = $xp->xml_escape( $atts{$id}, '"', "\x9", "\xA", "\xD" );
+ if ( length($ns) ) {
+ my $pfx = 'n' . $ns_index++;
+ print " $pfx:$nm=\"$val\" xmlns:$pfx=\"$ns\"";
+ }
+ else {
+ print " $nm=\"$val\"";
+ }
+ }
}
- }
- print '>';
-} # End sthndl
+ print '>';
+} # End sthndl
sub endhndl {
- my ($xp, $el) = @_;
+ my ( $xp, $el ) = @_;
- my $nm = $xp->namespace($el) ? "n1:$el" : $el;
- print "</$nm>";
- if ($xp->depth == 0) {
- $inroot = 0;
- print "\n";
- }
-} # End endhndl
+ my $nm = $xp->namespace($el) ? "n1:$el" : $el;
+ print "</$nm>";
+ if ( $xp->depth == 0 ) {
+ $inroot = 0;
+ print "\n";
+ }
+} # End endhndl
sub chrhndl {
- my ($xp, $data) = @_;
+ my ( $xp, $data ) = @_;
- print $xp->xml_escape($data, '>', "\xD");
-} # End chrhndl
+ print $xp->xml_escape( $data, '>', "\xD" );
+} # End chrhndl
sub proc {
- my ($xp, $target, $data) = @_;
+ my ( $xp, $target, $data ) = @_;
- unless ($indoctype) {
- print "<?$target $data?>";
- print "\n" unless $inroot;
- }
+ unless ($indoctype) {
+ print "<?$target $data?>";
+ print "\n" unless $inroot;
+ }
}
# Tell emacs that this is really a perl script
die "Can't find file \"$file\""
unless -f $file;
-
+
my $count = 0;
-my $parser = new XML::Parser(ErrorContext => 2,
- ParseParamEnt => 0
- );
+my $parser = new XML::Parser(
+ ErrorContext => 2,
+ ParseParamEnt => 0
+);
-$parser->setHandlers(Comment => \&comments);
+$parser->setHandlers( Comment => \&comments );
$parser->parsefile($file);
## End of main
################
-sub comments
-{
- my ($p, $data) = @_;
+sub comments {
+ my ( $p, $data ) = @_;
my $line = $p->current_line;
$data =~ s/\n/\n\t/g;
print "$line:\t<!--$data-->\n";
$count++;
-} # End comments
+} # End comments
# Tell Emacs that this is really a perl script
# Local Variables:
use XML::Parser;
-my $Usage =<<'End_of_Usage;';
+my $Usage = <<'End_of_Usage;';
Usage is:
xmlfilter [-h] [-nl] [{-+}root] [{-+}el=elname] [{-+}el:elnamepat]
[{-+}att:attname] [{-+}att:attname:attvalpat] xmlfile
and for which the attribute value matches attvalpat.
End_of_Usage;
-my $pass = 1;
+my $pass = 1;
my $do_newline = 0;
my $attcheck = 0;
my %drop_att;
my %keep_att;
-my $always_true = sub {1;};
+my $always_true = sub { 1; };
my $root_element = '';
my $in_cdata = 0;
# Process options
-while (defined($ARGV[0]) and $ARGV[0] =~ /^[-+]/)
-{
+while ( defined( $ARGV[0] ) and $ARGV[0] =~ /^[-+]/ ) {
my $opt = shift;
- if ($opt eq '-root')
- {
- $pass = 0;
+ if ( $opt eq '-root' ) {
+ $pass = 0;
}
- elsif ($opt eq '+root')
- {
- $pass = 1;
+ elsif ( $opt eq '+root' ) {
+ $pass = 1;
}
- elsif ($opt eq '-h')
- {
- print $Usage;
- exit;
+ elsif ( $opt eq '-h' ) {
+ print $Usage;
+ exit;
}
- elsif ($opt eq '-nl')
- {
- $do_newline = 1;
+ elsif ( $opt eq '-nl' ) {
+ $do_newline = 1;
}
- elsif ($opt =~ /^([-+])el([:=])(\S*)/)
- {
- my ($disp, $kind, $pattern) = ($1, $2, $3);
- my ($hashref, $aref);
-
- if ($disp eq '-')
- {
- $hashref = \%drop_el;
- $aref = \@drop_elpat;
- }
- else
- {
- $hashref = \%keep_el;
- $aref = \@keep_elpat;
- }
-
- if ($kind eq '=')
- {
- $hashref->{$pattern} = 1;
- }
- else
- {
- push(@$aref, $pattern);
- }
+ elsif ( $opt =~ /^([-+])el([:=])(\S*)/ ) {
+ my ( $disp, $kind, $pattern ) = ( $1, $2, $3 );
+ my ( $hashref, $aref );
+
+ if ( $disp eq '-' ) {
+ $hashref = \%drop_el;
+ $aref = \@drop_elpat;
+ }
+ else {
+ $hashref = \%keep_el;
+ $aref = \@keep_elpat;
+ }
+
+ if ( $kind eq '=' ) {
+ $hashref->{$pattern} = 1;
+ }
+ else {
+ push( @$aref, $pattern );
+ }
}
- elsif ($opt =~ /^([-+])att:(\w+)(?::(\S*))?/)
- {
- my ($disp, $id, $pattern) = ($1, $2, $3);
- my $ref = ($disp eq '-') ? \%drop_att : \%keep_att;
-
- if (defined($pattern))
- {
- $pattern =~ s!/!\\/!g;
- my $sub;
- eval "\$sub = sub {\$_[0] =~ /$pattern/;};";
-
- $ref->{$id} = $sub;
- }
- else
- {
- $ref->{$id} = $always_true;
- }
-
- $attcheck = 1;
+ elsif ( $opt =~ /^([-+])att:(\w+)(?::(\S*))?/ ) {
+ my ( $disp, $id, $pattern ) = ( $1, $2, $3 );
+ my $ref = ( $disp eq '-' ) ? \%drop_att : \%keep_att;
+
+ if ( defined($pattern) ) {
+ $pattern =~ s!/!\\/!g;
+ my $sub;
+ eval "\$sub = sub {\$_[0] =~ /$pattern/;};";
+
+ $ref->{$id} = $sub;
+ }
+ else {
+ $ref->{$id} = $always_true;
+ }
+
+ $attcheck = 1;
}
- else
- {
- die "Unknown option: $opt\n$Usage";
+ else {
+ die "Unknown option: $opt\n$Usage";
}
}
-my $drop_el_pattern = join('|', @drop_elpat);
-my $keep_el_pattern = join('|', @keep_elpat);
+my $drop_el_pattern = join( '|', @drop_elpat );
+my $keep_el_pattern = join( '|', @keep_elpat );
my $drop_sub;
-if ($drop_el_pattern)
-{
+if ($drop_el_pattern) {
eval "\$drop_sub = sub {\$_[0] =~ /$drop_el_pattern/;}";
}
-else
-{
- $drop_sub = sub {};
+else {
+ $drop_sub = sub { };
}
my $keep_sub;
-if ($keep_el_pattern)
-{
+if ($keep_el_pattern) {
eval "\$keep_sub = sub {\$_[0] =~ /$keep_el_pattern/;}";
}
-else
-{
- $keep_sub = sub {};
+else {
+ $keep_sub = sub { };
}
my $doc = shift;
my @togglestack = ();
-my $p = new XML::Parser(ErrorContext => 2,
- Handlers => {Start => \&start_handler,
- End => \&end_handler
- }
- );
+my $p = new XML::Parser(
+ ErrorContext => 2,
+ Handlers => {
+ Start => \&start_handler,
+ End => \&end_handler
+ }
+);
if ($pass) {
- $p->setHandlers(Char => \&char_handler,
- CdataStart => \&cdata_start,
- CdataEnd => \&cdata_end);
+ $p->setHandlers(
+ Char => \&char_handler,
+ CdataStart => \&cdata_start,
+ CdataEnd => \&cdata_end
+ );
}
$p->parsefile($doc);
print "</$root_element>\n"
- unless $pass;
+ unless $pass;
################
## End of main
################
-sub start_handler
-{
+sub start_handler {
my $xp = shift;
my $el = shift;
- unless ($root_element)
- {
- $root_element = $el;
- print "<$el>\n"
- unless $pass;
+ unless ($root_element) {
+ $root_element = $el;
+ print "<$el>\n"
+ unless $pass;
}
- my ($elref, $attref, $sub);
+ my ( $elref, $attref, $sub );
- if ($pass)
- {
- $elref = \%drop_el;
- $attref = \%drop_att;
- $sub = $drop_sub;
+ if ($pass) {
+ $elref = \%drop_el;
+ $attref = \%drop_att;
+ $sub = $drop_sub;
}
- else
- {
- $elref = \%keep_el;
- $attref = \%keep_att;
- $sub = $keep_sub;
+ else {
+ $elref = \%keep_el;
+ $attref = \%keep_att;
+ $sub = $keep_sub;
}
- if (defined($elref->{$el})
- or &$sub($el)
- or check_atts($attref, @_))
- {
- $pass = ! $pass;
- if ($pass) {
- $xp->setHandlers(Char => \&char_handler,
- CdataStart => \&cdata_start,
- CdataEnd => \&cdata_end);
- }
- else {
- $xp->setHandlers(Char => 0,
- CdataStart => 0,
- CdataEnd => 0);
- }
- push(@togglestack, $xp->depth);
+ if ( defined( $elref->{$el} )
+ or &$sub($el)
+ or check_atts( $attref, @_ ) ) {
+ $pass = !$pass;
+ if ($pass) {
+ $xp->setHandlers(
+ Char => \&char_handler,
+ CdataStart => \&cdata_start,
+ CdataEnd => \&cdata_end
+ );
+ }
+ else {
+ $xp->setHandlers(
+ Char => 0,
+ CdataStart => 0,
+ CdataEnd => 0
+ );
+ }
+ push( @togglestack, $xp->depth );
}
- if ($pass)
- {
- print "\n" if $do_newline;
- print "<$el";
- while (@_)
- {
- my $id = shift;
- my $val = shift;
-
- $val = $xp->xml_escape($val, "'");
- print " $id='$val'";
- }
- print ">";
+ if ($pass) {
+ print "\n" if $do_newline;
+ print "<$el";
+ while (@_) {
+ my $id = shift;
+ my $val = shift;
+
+ $val = $xp->xml_escape( $val, "'" );
+ print " $id='$val'";
+ }
+ print ">";
}
-} # End start_handler
+} # End start_handler
-sub end_handler
-{
+sub end_handler {
my $xp = shift;
my $el = shift;
- if ($pass)
- {
- print "</$el>";
+ if ($pass) {
+ print "</$el>";
}
- if (@togglestack and $togglestack[-1] == $xp->depth)
- {
- $pass = ! $pass;
- if ($pass) {
- $xp->setHandlers(Char => \&char_handler,
- CdataStart => \&cdata_start,
- CdataEnd => \&cdata_end);
- }
- else {
- $xp->setHandlers(Char => 0,
- CdataStart => 0,
- CdataEnd => 0);
- }
-
- pop(@togglestack);
+ if ( @togglestack and $togglestack[-1] == $xp->depth ) {
+ $pass = !$pass;
+ if ($pass) {
+ $xp->setHandlers(
+ Char => \&char_handler,
+ CdataStart => \&cdata_start,
+ CdataEnd => \&cdata_end
+ );
+ }
+ else {
+ $xp->setHandlers(
+ Char => 0,
+ CdataStart => 0,
+ CdataEnd => 0
+ );
+ }
+
+ pop(@togglestack);
}
-} # End end_handler
-
+} # End end_handler
-sub char_handler
-{
- my ($xp, $text) = @_;
+sub char_handler {
+ my ( $xp, $text ) = @_;
- if (length($text)) {
+ if ( length($text) ) {
- $text = $xp->xml_escape($text, '>')
- unless $in_cdata;
+ $text = $xp->xml_escape( $text, '>' )
+ unless $in_cdata;
- print $text;
+ print $text;
}
-} # End char_handler
+} # End char_handler
sub cdata_start {
- my $xp = shift;
+ my $xp = shift;
- print '<![CDATA[';
- $in_cdata = 1;
+ print '<![CDATA[';
+ $in_cdata = 1;
}
sub cdata_end {
- my $xp = shift;
+ my $xp = shift;
- print ']]>';
- $in_cdata = 0;
+ print ']]>';
+ $in_cdata = 0;
}
-sub check_atts
-{
+sub check_atts {
return $attcheck unless $attcheck;
my $ref = shift;
- while (@_)
- {
- my $id = shift;
- my $val = shift;
+ while (@_) {
+ my $id = shift;
+ my $val = shift;
- if (defined($ref->{$id}))
- {
- my $ret = &{$ref->{$id}}($val);
- return $ret if $ret;
- }
+ if ( defined( $ref->{$id} ) ) {
+ my $ret = &{ $ref->{$id} }($val);
+ return $ret if $ret;
+ }
}
return 0;
-} # End check_atts
+} # End check_atts
# Tell Emacs that this is really a perl script
# Local Variables:
package Elinfo;
sub new {
- bless { COUNT => 0,
- MINLEV => undef,
- SEEN => 0,
- CHARS => 0,
- EMPTY => 1,
- PTAB => {},
- KTAB => {},
- ATAB => {} }, shift;
+ bless {
+ COUNT => 0,
+ MINLEV => undef,
+ SEEN => 0,
+ CHARS => 0,
+ EMPTY => 1,
+ PTAB => {},
+ KTAB => {},
+ ATAB => {}
+ },
+ shift;
}
-
package main;
use English;
my $file = shift;
-my $subform =
- ' @<<<<<<<<<<<<<<< @>>>>';
+my $subform = ' @<<<<<<<<<<<<<<< @>>>>';
die "Can't find file \"$file\""
unless -f $file;
-
-my $parser = new XML::Parser(ErrorContext => 2);
-$parser->setHandlers(Start => \&start_handler,
- Char => \&char_handler);
+
+my $parser = new XML::Parser( ErrorContext => 2 );
+$parser->setHandlers(
+ Start => \&start_handler,
+ Char => \&char_handler
+);
$parser->parsefile($file);
-set_minlev($root, 0);
+set_minlev( $root, 0 );
my $el;
-foreach $el (sort bystruct keys %elements)
-{
+foreach $el ( sort bystruct keys %elements ) {
my $ref = $elements{$el};
print "\n================\n$el: ", $ref->{COUNT}, "\n";
- print "Had ", $ref->{CHARS}, " bytes of character data\n"
- if $ref->{CHARS};
+ print "Had ", $ref->{CHARS}, " bytes of character data\n"
+ if $ref->{CHARS};
print "Always empty\n"
- if $ref->{EMPTY};
+ if $ref->{EMPTY};
- showtab('Parents', $ref->{PTAB}, 0);
- showtab('Children', $ref->{KTAB}, 1);
- showtab('Attributes', $ref->{ATAB}, 0);
+ showtab( 'Parents', $ref->{PTAB}, 0 );
+ showtab( 'Children', $ref->{KTAB}, 1 );
+ showtab( 'Attributes', $ref->{ATAB}, 0 );
}
-
################
## End of main
################
-sub start_handler
-{
- my $p = shift;
+sub start_handler {
+ my $p = shift;
my $el = shift;
my $elinf = $elements{$el};
- if (not defined($elinf))
- {
- $elements{$el} = $elinf = new Elinfo;
- $elinf->{SEEN} = $seen++;
+ if ( not defined($elinf) ) {
+ $elements{$el} = $elinf = new Elinfo;
+ $elinf->{SEEN} = $seen++;
}
$elinf->{COUNT}++;
my $partab = $elinf->{PTAB};
my $parent = $p->current_element;
- if (defined($parent))
- {
- $partab->{$parent}++;
- my $pinf = $elements{$parent};
-
- # Increment our slot in parent's child table
- $pinf->{KTAB}->{$el}++;
- $pinf->{EMPTY} = 0;
+ if ( defined($parent) ) {
+ $partab->{$parent}++;
+ my $pinf = $elements{$parent};
+
+ # Increment our slot in parent's child table
+ $pinf->{KTAB}->{$el}++;
+ $pinf->{EMPTY} = 0;
}
- else
- {
- $root = $el;
+ else {
+ $root = $el;
}
# Deal with attributes
my $atab = $elinf->{ATAB};
- while (@_)
- {
- my $att = shift;
-
- $atab->{$att}++;
- shift; # Throw away value
+ while (@_) {
+ my $att = shift;
+
+ $atab->{$att}++;
+ shift; # Throw away value
}
-} # End start_handler
+} # End start_handler
-sub char_handler
-{
- my ($p, $data) = @_;
- my $inf = $elements{$p->current_element};
+sub char_handler {
+ my ( $p, $data ) = @_;
+ my $inf = $elements{ $p->current_element };
$inf->{EMPTY} = 0;
- if ($data =~ /\S/)
- {
- $inf->{CHARS} += length($data);
+ if ( $data =~ /\S/ ) {
+ $inf->{CHARS} += length($data);
}
-} # End char_handler
+} # End char_handler
-sub set_minlev
-{
- my ($el, $lev) = @_;
+sub set_minlev {
+ my ( $el, $lev ) = @_;
my $elinfo = $elements{$el};
- if (! defined($elinfo->{MINLEV}) or $elinfo->{MINLEV} > $lev)
- {
- my $newlev = $lev + 1;
-
- $elinfo->{MINLEV} = $lev;
- foreach (keys %{$elinfo->{KTAB}})
- {
- set_minlev($_, $newlev);
- }
+ if ( !defined( $elinfo->{MINLEV} ) or $elinfo->{MINLEV} > $lev ) {
+ my $newlev = $lev + 1;
+
+ $elinfo->{MINLEV} = $lev;
+ foreach ( keys %{ $elinfo->{KTAB} } ) {
+ set_minlev( $_, $newlev );
+ }
}
-} # End set_minlev
+} # End set_minlev
-sub bystruct
-{
+sub bystruct {
my $refa = $elements{$a};
my $refb = $elements{$b};
$refa->{MINLEV} <=> $refb->{MINLEV}
- or $refa->{SEEN} <=> $refb->{SEEN};
-} # End bystruct
-
+ or $refa->{SEEN} <=> $refb->{SEEN};
+} # End bystruct
-sub showtab
-{
- my ($title, $table, $dosum) = @_;
+sub showtab {
+ my ( $title, $table, $dosum ) = @_;
my @list = sort keys %{$table};
- if (@list)
- {
- print "\n $title:\n";
-
- my $item;
- my $sum = 0;
- foreach $item (@list)
- {
- my $cnt = $table->{$item};
- $sum += $cnt;
- formline($subform, $item, $cnt);
- print $ACCUMULATOR, "\n";
- $ACCUMULATOR = '';
- }
-
- if ($dosum and @list > 1)
- {
- print " =====\n";
- formline($subform, '', $sum);
- print $ACCUMULATOR, "\n";
- $ACCUMULATOR = '';
- }
+ if (@list) {
+ print "\n $title:\n";
+
+ my $item;
+ my $sum = 0;
+ foreach $item (@list) {
+ my $cnt = $table->{$item};
+ $sum += $cnt;
+ formline( $subform, $item, $cnt );
+ print $ACCUMULATOR, "\n";
+ $ACCUMULATOR = '';
+ }
+
+ if ( $dosum and @list > 1 ) {
+ print " =====\n";
+ formline( $subform, '', $sum );
+ print $ACCUMULATOR, "\n";
+ $ACCUMULATOR = '';
+ }
}
-} # End showtab
+} # End showtab
# Tell Emacs that this is really a perl script
# Local Variables:
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
-BEGIN {print "1..27\n";}
-END {print "not ok 1\n" unless $loaded;}
+BEGIN { print "1..27\n"; }
+END { print "not ok 1\n" unless $loaded; }
use XML::Parser;
-use FileHandle; # Make 5.10.0 happy.
+use FileHandle; # Make 5.10.0 happy.
$loaded = 1;
print "ok 1\n";
# Test 2
-
-my $parser = new XML::Parser(ProtocolEncoding => 'ISO-8859-1');
-if ($parser)
-{
+my $parser = new XML::Parser( ProtocolEncoding => 'ISO-8859-1' );
+if ($parser) {
print "ok 2\n";
}
-else
-{
+else {
print "not ok 2\n";
exit;
}
# Need this external entity
-open(ZOE, '>zoe.ent');
+open( ZOE, '>zoe.ent' );
print ZOE "'cute'";
close(ZOE);
# XML string for tests
-my $xmlstring =<<"End_of_XML;";
+my $xmlstring = <<"End_of_XML;";
<!DOCTYPE foo
[
<!NOTATION bar PUBLIC "qrs">
# Handlers
my @tests;
-my $pos ='';
+my $pos = '';
-sub ch
-{
- my ($p, $str) = @_;
+sub ch {
+ my ( $p, $str ) = @_;
$tests[4]++;
- $tests[5]++ if ($str =~ /2nd line/ and $p->in_element('blah'));
- if ($p->in_element('boom'))
- {
- $tests[17]++ if $str =~ /pretty/;
- $tests[18]++ if $str =~ /cute/;
+ $tests[5]++ if ( $str =~ /2nd line/ and $p->in_element('blah') );
+ if ( $p->in_element('boom') ) {
+ $tests[17]++ if $str =~ /pretty/;
+ $tests[18]++ if $str =~ /cute/;
}
}
-sub st
-{
- my ($p, $el, %atts) = @_;
+sub st {
+ my ( $p, $el, %atts ) = @_;
- $ndxstack[$p->depth] = $p->element_index;
- $tests[6]++ if ($el eq 'bar' and $atts{stomp} eq 'jill');
- if ($el eq 'zap' and $atts{'ref'} eq 'zing')
- {
- $tests[7]++;
- $p->default_current;
+ $ndxstack[ $p->depth ] = $p->element_index;
+ $tests[6]++ if ( $el eq 'bar' and $atts{stomp} eq 'jill' );
+ if ( $el eq 'zap' and $atts{'ref'} eq 'zing' ) {
+ $tests[7]++;
+ $p->default_current;
}
- elsif ($el eq 'bar') {
- $tests[22]++ if $p->recognized_string eq '<bar id="jack" stomp="jill">';
+ elsif ( $el eq 'bar' ) {
+ $tests[22]++ if $p->recognized_string eq '<bar id="jack" stomp="jill">';
}
}
-sub eh
-{
- my ($p, $el) = @_;
- $indexok = 0 unless $p->element_index == $ndxstack[$p->depth];
- if ($el eq 'zap')
- {
- $tests[8]++;
- my @old = $p->setHandlers('Char', \&newch);
- $tests[19]++ if $p->current_line == 17;
- $tests[20]++ if $p->current_column == 20;
- $tests[23]++ if ($old[0] eq 'Char' and $old[1] == \&ch);
+sub eh {
+ my ( $p, $el ) = @_;
+ $indexok = 0 unless $p->element_index == $ndxstack[ $p->depth ];
+ if ( $el eq 'zap' ) {
+ $tests[8]++;
+ my @old = $p->setHandlers( 'Char', \&newch );
+ $tests[19]++ if $p->current_line == 17;
+ $tests[20]++ if $p->current_column == 20;
+ $tests[23]++ if ( $old[0] eq 'Char' and $old[1] == \&ch );
}
- if ($el eq 'boom')
- {
- $p->setHandlers('Default', \&dh);
+ if ( $el eq 'boom' ) {
+ $p->setHandlers( 'Default', \&dh );
}
}
-sub dh
-{
- my ($p, $str) = @_;
- if ($str =~ /doozy/)
- {
- $tests[9]++;
- $pos = $p->position_in_context(1);
+sub dh {
+ my ( $p, $str ) = @_;
+ if ( $str =~ /doozy/ ) {
+ $tests[9]++;
+ $pos = $p->position_in_context(1);
}
$tests[10]++ if $str =~ /^<zap/;
}
-sub pi
-{
- my ($p, $tar, $data) = @_;
+sub pi {
+ my ( $p, $tar, $data ) = @_;
- $tests[11]++ if ($tar eq 'line-noise' and $data =~ /&\^&<</);
+ $tests[11]++ if ( $tar eq 'line-noise' and $data =~ /&\^&<</ );
}
-sub note
-{
- my ($p, $name, $base, $sysid, $pubid) = @_;
+sub note {
+ my ( $p, $name, $base, $sysid, $pubid ) = @_;
- $tests[12]++ if ($name eq 'bar' and $pubid eq 'qrs');
+ $tests[12]++ if ( $name eq 'bar' and $pubid eq 'qrs' );
}
-sub unp
-{
- my ($p, $name, $base, $sysid, $pubid, $notation) = @_;
+sub unp {
+ my ( $p, $name, $base, $sysid, $pubid, $notation ) = @_;
- $tests[13]++ if ($name eq 'zinger' and $pubid eq 'xyz'
- and $sysid eq 'abc' and $notation eq 'bar');
+ $tests[13]++ if ( $name eq 'zinger'
+ and $pubid eq 'xyz'
+ and $sysid eq 'abc'
+ and $notation eq 'bar' );
}
-sub newch
-{
- my ($p, $str) = @_;
+sub newch {
+ my ( $p, $str ) = @_;
- if ($] < 5.007001) {
- $tests[14]++ if $str =~ /'\302\240'/;
+ if ( $] < 5.007001 ) {
+ $tests[14]++ if $str =~ /'\302\240'/;
}
else {
- $tests[14]++ if $str =~ /'\xa0'/;
+ $tests[14]++ if $str =~ /'\xa0'/;
}
}
-sub extent
-{
- my ($p, $base, $sys, $pub) = @_;
+sub extent {
+ my ( $p, $base, $sys, $pub ) = @_;
- if ($sys eq 'fran-def')
- {
- $tests[15]++;
- return 'pretty';
+ if ( $sys eq 'fran-def' ) {
+ $tests[15]++;
+ return 'pretty';
}
- elsif ($sys eq 'zoe.ent')
- {
- $tests[16]++;
+ elsif ( $sys eq 'zoe.ent' ) {
+ $tests[16]++;
- open(FOO, $sys) or die "Couldn't open $sys";
- return *FOO;
+ open( FOO, $sys ) or die "Couldn't open $sys";
+ return *FOO;
}
}
eval {
- $parser->setHandlers('Char' => \&ch,
- 'Start' => \&st,
- 'End' => \&eh,
- 'Proc' => \&pi,
- 'Notation' => \¬e,
- 'Unparsed' => \&unp,
- 'ExternEnt' => \&extent,
- 'ExternEntFin' => sub {close(FOO);}
- );
+ $parser->setHandlers(
+ 'Char' => \&ch,
+ 'Start' => \&st,
+ 'End' => \&eh,
+ 'Proc' => \&pi,
+ 'Notation' => \¬e,
+ 'Unparsed' => \&unp,
+ 'ExternEnt' => \&extent,
+ 'ExternEntFin' => sub { close(FOO); }
+ );
};
-if ($@)
-{
+if ($@) {
print "not ok 3\n";
exit;
}
print "ok 3\n";
# Test 4..20
-eval {
- $parser->parsestring($xmlstring);
-};
+eval { $parser->parsestring($xmlstring); };
-if ($@)
-{
+if ($@) {
print "Parse error:\n$@";
}
-else
-{
+else {
$tests[21]++;
}
-unlink('zoe.ent') if (-f 'zoe.ent');
+unlink('zoe.ent') if ( -f 'zoe.ent' );
-for (4 .. 23)
-{
+for ( 4 .. 23 ) {
print "not " unless $tests[$_];
print "ok $_\n";
}
-$cmpstr =<< 'End_of_Cmp;';
+$cmpstr = << 'End_of_Cmp;';
<blah> 2nd line in bar </blah>
3rd line in bar <!-- Isn't this a doozy -->
===================^
</bar>
End_of_Cmp;
-if ($cmpstr ne $pos)
-{
+if ( $cmpstr ne $pos ) {
print "not ";
}
print "ok 24\n";
print "not " unless $indexok;
print "ok 25\n";
-
# Test that memory leak through autovivifying symbol table entries is fixed.
my $count = 0;
$parser = new XML::Parser(
- Handlers => {
- Start => sub { $count++ }
- }
+ Handlers => {
+ Start => sub { $count++ }
+ }
);
$xmlstring = '<a><b>Sea</b></a>';
-eval {
- $parser->parsestring($xmlstring);
-};
+eval { $parser->parsestring($xmlstring); };
-if($count != 2) {
- print "not ";
+if ( $count != 2 ) {
+ print "not ";
}
print "ok 26\n";
-if(defined(*{$xmlstring})) {
- print "not ";
+if ( defined( *{$xmlstring} ) ) {
+ print "not ";
}
print "ok 27\n";
-BEGIN {print "1..2\n";}
-END {print "not ok 1\n" unless $loaded;}
+BEGIN { print "1..2\n"; }
+END { print "not ok 1\n" unless $loaded; }
use XML::Parser;
$loaded = 1;
print "ok 1\n";
my $acc = '';
sub ch {
- my ($xp, $data) = @_;
+ my ( $xp, $data ) = @_;
- $acc .= $data;
+ $acc .= $data;
}
sub stcd {
- my $xp = shift;
- $xp->setHandlers(Char => \&ch);
+ my $xp = shift;
+ $xp->setHandlers( Char => \&ch );
}
sub ecd {
- my $xp = shift;
- $xp->setHandlers(Char => 0);
+ my $xp = shift;
+ $xp->setHandlers( Char => 0 );
}
-$parser = new XML::Parser(ErrorContext => 2,
- Handlers => {CdataStart => \&stcd,
- CdataEnd => \&ecd});
+$parser = new XML::Parser(
+ ErrorContext => 2,
+ Handlers => {
+ CdataStart => \&stcd,
+ CdataEnd => \&ecd
+ }
+);
$parser->parse($doc);
print "not "
- unless ($acc eq $cdata_part);
+ unless ( $acc eq $cdata_part );
print "ok 2\n";
-BEGIN {print "1..4\n";}
-END {print "not ok 1\n" unless $loaded;}
+BEGIN { print "1..4\n"; }
+END { print "not ok 1\n" unless $loaded; }
use XML::Parser;
$loaded = 1;
print "ok 1\n";
-$doc =<<'End_of_Doc;';
+$doc = <<'End_of_Doc;';
<!DOCTYPE foo [
<!ATTLIST bar zz CDATA 'there'>
]>
End_of_Doc;
sub st {
- my $xp = shift;
- my $el = shift;
-
- if ($el eq 'bar') {
- my %atts = @_;
- my %isdflt;
- my $specified = $xp->specified_attr;
-
- for (my $i = $specified; $i < @_; $i += 2) {
- $isdflt{$_[$i]} = 1;
- }
-
- if (defined $atts{xx}) {
- print 'not '
- if $isdflt{'xx'};
- print "ok 2\n";
+ my $xp = shift;
+ my $el = shift;
+
+ if ( $el eq 'bar' ) {
+ my %atts = @_;
+ my %isdflt;
+ my $specified = $xp->specified_attr;
+
+ for ( my $i = $specified; $i < @_; $i += 2 ) {
+ $isdflt{ $_[$i] } = 1;
+ }
+
+ if ( defined $atts{xx} ) {
+ print 'not '
+ if $isdflt{'xx'};
+ print "ok 2\n";
+
+ print 'not '
+ unless $isdflt{'zz'};
+ print "ok 3\n";
+ }
+ else {
+ print 'not '
+ if $isdflt{'zz'};
+ print "ok 4\n";
+ }
- print 'not '
- unless $isdflt{'zz'};
- print "ok 3\n";
}
- else {
- print 'not '
- if $isdflt{'zz'};
- print "ok 4\n";
- }
-
- }
}
-$p = new XML::Parser(Handlers => {Start => \&st});
+$p = new XML::Parser( Handlers => { Start => \&st } );
$p->parse($doc);
-BEGIN {print "1..6\n";}
-END {print "not ok 1\n" unless $loaded;}
+BEGIN { print "1..6\n"; }
+END { print "not ok 1\n" unless $loaded; }
use XML::Parser;
$loaded = 1;
print "ok 1\n";
my $xmldec = "<?xml version='1.0' encoding='x-sjis-unicode' ?>\n";
-my $docstring=<<"End_of_doc;";
+my $docstring = <<"End_of_doc;";
<\x8e\x83>\x90\x46\x81\x41\x98\x61\x81\x41\x99\x44
</\x8e\x83>
End_of_doc;
my $lastel;
sub text {
- my ($xp, $data) = @_;
+ my ( $xp, $data ) = @_;
- push(@bytes, unpack('U0C*', $data)); # was fixed 5.10
+ push( @bytes, unpack( 'U0C*', $data ) ); # was fixed 5.10
}
sub start {
- my ($xp, $el) = @_;
+ my ( $xp, $el ) = @_;
- $lastel = $el;
+ $lastel = $el;
}
-my $p = XML::Parser->new(Handlers => {Start => \&start, Char => \&text});
+my $p = XML::Parser->new( Handlers => { Start => \&start, Char => \&text } );
$p->parse($doc);
-my $exptag = ($] < 5.006)
- ? "\xe7\xa5\x89" # U+7949 blessings 0x8e83
- : chr(0x7949);
-
-my @expected = (0xe8, 0x89, 0xb2, # U+8272 beauty 0x9046
- 0xe3, 0x80, 0x81, # U+3001 comma 0x8141
- 0xe5, 0x92, 0x8c, # U+548C peace 0x9861
- 0xe3, 0x80, 0x81, # U+3001 comma 0x8141
- 0xe5, 0x83, 0x96, # U+50D6 joy 0x9944
- 0x0a);
+my $exptag = ( $] < 5.006 )
+ ? "\xe7\xa5\x89" # U+7949 blessings 0x8e83
+ : chr(0x7949);
+
+my @expected = (
+ 0xe8, 0x89, 0xb2, # U+8272 beauty 0x9046
+ 0xe3, 0x80, 0x81, # U+3001 comma 0x8141
+ 0xe5, 0x92, 0x8c, # U+548C peace 0x9861
+ 0xe3, 0x80, 0x81, # U+3001 comma 0x8141
+ 0xe5, 0x83, 0x96, # U+50D6 joy 0x9944
+ 0x0a
+);
-if ($lastel eq $exptag) {
- print "ok 2\n";
+if ( $lastel eq $exptag ) {
+ print "ok 2\n";
}
else {
- print "not ok 2\n";
+ print "not ok 2\n";
}
-if (@bytes != @expected) {
- print "not ok 3\n";
+if ( @bytes != @expected ) {
+ print "not ok 3\n";
}
else {
- my $i;
- for ($i = 0; $i < @expected; $i++) {
- if ($bytes[$i] != $expected[$i]) {
- print "not ok 3\n";
- exit;
+ my $i;
+ for ( $i = 0; $i < @expected; $i++ ) {
+ if ( $bytes[$i] != $expected[$i] ) {
+ print "not ok 3\n";
+ exit;
+ }
}
- }
- print "ok 3\n";
+ print "ok 3\n";
}
$lastel = '';
-$p->parse($docstring, ProtocolEncoding => 'X-SJIS-UNICODE');
+$p->parse( $docstring, ProtocolEncoding => 'X-SJIS-UNICODE' );
-if ($lastel eq $exptag) {
- print "ok 4\n";
+if ( $lastel eq $exptag ) {
+ print "ok 4\n";
}
else {
- print "not ok 4\n";
+ print "not ok 4\n";
}
# Test the CP-1252 Win-Latin-1 mapping
my %attr;
sub get_attr {
- my ($xp, $el, @list) = @_;
- %attr = @list;
+ my ( $xp, $el, @list ) = @_;
+ %attr = @list;
}
-$p = XML::Parser->new(Handlers => {Start => \&get_attr});
+$p = XML::Parser->new( Handlers => { Start => \&get_attr } );
-eval{ $p->parse($docstring) };
+eval { $p->parse($docstring) };
-if($@) {
- print "not "; # couldn't load the map
+if ($@) {
+ print "not "; # couldn't load the map
}
print "ok 5\n";
-if( $attr{euro} ne ( $] < 5.006 ? "\xE2\x82\xAC" : chr(0x20AC) )
- or $attr{lsq} ne ( $] < 5.006 ? "\xE2\x80\x98" : chr(0x2018) )
- or $attr{rdq} ne ( $] < 5.006 ? "\xE2\x80\x9D" : chr(0x201D) )
-) {
- print "not ";
+if ( $attr{euro} ne ( $] < 5.006 ? "\xE2\x82\xAC" : chr(0x20AC) )
+ or $attr{lsq} ne ( $] < 5.006 ? "\xE2\x80\x98" : chr(0x2018) )
+ or $attr{rdq} ne ( $] < 5.006 ? "\xE2\x80\x9D" : chr(0x201D) ) ) {
+ print "not ";
}
print "ok 6\n";
-BEGIN {print "1..5\n";}
-END {print "not ok 1\n" unless $loaded;}
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
use XML::Parser;
-$loaded = 1;
-print "ok 1\n";
################################################################
# Check default external entity handler
-
my $txt = '';
sub txt {
- my ($xp, $data) = @_;
+ my ( $xp, $data ) = @_;
- $txt .= $data;
+ $txt .= $data;
}
-my $docstring =<<'End_of_XML;';
+my $docstring = <<'End_of_XML;';
<!DOCTYPE foo [
<!ENTITY a SYSTEM "a.ent">
<!ENTITY b SYSTEM "b.ent">
</foo>
End_of_XML;
-open(ENT, '>a.ent') or die "Couldn't open a.ent for writing";
-print ENT "This ('&c;') is a quote of c";
-close(ENT);
+my $ent_fh;
+open( $ent_fh, '>', 'a.ent' ) or die "Couldn't open a.ent for writing";
+print $ent_fh "This ('&c;') is a quote of c";
+close($ent_fh);
-open(ENT, '>b.ent') or die "Couldn't open b.ent for writing";
-print ENT "Hello, I'm B";
-close(ENT);
+open( $ent_fh, '>', 'b.ent' ) or die "Couldn't open b.ent for writing";
+print $ent_fh "Hello, I'm B";
+close($ent_fh);
-open(ENT, '>c.ent') or die "Couldn't open c.ent for writing";
-print ENT "Hurrah for C";
-close(ENT);
+open( $ent_fh, '>', 'c.ent' ) or die "Couldn't open c.ent for writing";
+print $ent_fh "Hurrah for C";
+close($ent_fh);
-my $p = new XML::Parser(Handlers => {Char => \&txt});
+my $p = new XML::Parser( Handlers => { Char => \&txt } );
$p->parse($docstring);
-my %check = (a => "This ('Hurrah for C') is a quote of c",
- b => "Hello, I'm B");
-
-my $tstcnt = 2;
+my %check = (
+ a => "This ('Hurrah for C') is a quote of c",
+ b => "Hello, I'm B"
+);
-while ($txt =~ /([ab]) = "(.*)"/g) {
- my ($k, $v) = ($1, $2);
+while ( $txt =~ /([ab]) = "(.*)"/g ) {
+ my ( $k, $v ) = ( $1, $2 );
- unless ($check{$k} eq $v) {
- print "not ";
- }
- print "ok $tstcnt\n";
- $tstcnt++;
+ is($check{$k}, $v);
}
unlink('a.ent');
my $count = 0;
-$parser = XML::Parser->new(ErrorContext => 2);
-$parser->setHandlers(Comment => sub {$count++;});
+$parser = XML::Parser->new( ErrorContext => 2 );
+$parser->setHandlers( Comment => sub { $count++; } );
$parser->parsefile('samples/REC-xml-19980210.xml');
-is($count, 37);
+is( $count, 37 );
#tests behaviour on perls 5.10? .. 5.10.1
package Some::Fake::Packege;
+
sub fake_sub {
- require FileHandle;
+ require FileHandle;
}
+
package main;
use Test::More tests => 1;
my $count = 0;
-my $parser = XML::Parser->new(ErrorContext => 2);
-$parser->setHandlers(Comment => sub {$count++;});
+my $parser = XML::Parser->new( ErrorContext => 2 );
+$parser->setHandlers( Comment => sub { $count++; } );
+
+open my $fh, '<', 'samples/REC-xml-19980210.xml' or die;
-open my $fh,'<','samples/REC-xml-19980210.xml' or die;
#on 5.10 $fh would be a FileHandle object without a real FileHandle class
$parser->parse($fh);
-is($count, 37);
+is( $count, 37 );
-BEGIN {print "1..3\n";}
-END {print "not ok 1\n" unless $loaded;}
+BEGIN { print "1..3\n"; }
+END { print "not ok 1\n" unless $loaded; }
use XML::Parser;
$loaded = 1;
print "ok 1\n";
my $encount = 0;
sub st {
- my ($exp, $el) = @_;
- $stcount++;
- $exp->finish if $el eq 'loc';
+ my ( $exp, $el ) = @_;
+ $stcount++;
+ $exp->finish if $el eq 'loc';
}
sub end {
- $encount++;
+ $encount++;
}
-$parser = new XML::Parser(Handlers => {Start => \&st,
- End => \&end
- },
- ErrorContext => 2);
-
+$parser = new XML::Parser(
+ Handlers => {
+ Start => \&st,
+ End => \&end
+ },
+ ErrorContext => 2
+);
$parser->parsefile('samples/REC-xml-19980210.xml');
-BEGIN {print "1..16\n";}
-END {print "not ok 1\n" unless $loaded;}
+BEGIN { print "1..16\n"; }
+END { print "not ok 1\n" unless $loaded; }
use XML::Parser;
$loaded = 1;
print "ok 1\n";
################################################################
# Check namespaces
-$docstring =<<'End_of_doc;';
+$docstring = <<'End_of_doc;';
<foo xmlns="urn:blazing-saddles"
xmlns:bar="urn:young-frankenstein"
bar:alpha="17">
my $gname;
sub init {
- my $xp = shift;
- $gname = $xp->generate_ns_name('alpha', 'urn:young-frankenstein');
+ my $xp = shift;
+ $gname = $xp->generate_ns_name( 'alpha', 'urn:young-frankenstein' );
}
-
+
sub start {
- my $xp = shift;
- my $el = shift;
-
- if ($el eq 'foo') {
- print "not " unless $xp->namespace($el) eq 'urn:blazing-saddles';
- print "ok 2\n";
-
- print "not " unless $xp->new_ns_prefixes == 2;
- print "ok 3\n";
-
- while (@_) {
- my $att = shift;
- my $val = shift;
- if ($att eq 'alpha') {
- print "not " unless $xp->eq_name($gname, $att);
- print "ok 4\n";
- last;
- }
+ my $xp = shift;
+ my $el = shift;
+
+ if ( $el eq 'foo' ) {
+ print "not " unless $xp->namespace($el) eq 'urn:blazing-saddles';
+ print "ok 2\n";
+
+ print "not " unless $xp->new_ns_prefixes == 2;
+ print "ok 3\n";
+
+ while (@_) {
+ my $att = shift;
+ my $val = shift;
+ if ( $att eq 'alpha' ) {
+ print "not " unless $xp->eq_name( $gname, $att );
+ print "ok 4\n";
+ last;
+ }
+ }
}
- }
- elsif ($el eq 'zebra') {
- print "not " unless $xp->new_ns_prefixes == 0;
- print "ok 5\n";
-
- print "not " unless $xp->namespace($el) eq 'urn:blazing-saddles';
- print "ok 6\n";
- }
- elsif ($el eq 'tango') {
- print "not " if $xp->namespace($_[0]);
- print "ok 8\n";
-
- print "not " unless $_[0] eq $_[2];
- print "ok 9\n";
-
- print "not " if $xp->eq_name($_[0], $_[2]);
- print "ok 10\n";
-
- my $cnt = 0;
- foreach ($xp->new_ns_prefixes) {
- $cnt++ if $_ eq '#default';
- $cnt++ if $_ eq 'zoo';
+ elsif ( $el eq 'zebra' ) {
+ print "not " unless $xp->new_ns_prefixes == 0;
+ print "ok 5\n";
+
+ print "not " unless $xp->namespace($el) eq 'urn:blazing-saddles';
+ print "ok 6\n";
}
+ elsif ( $el eq 'tango' ) {
+ print "not " if $xp->namespace( $_[0] );
+ print "ok 8\n";
+
+ print "not " unless $_[0] eq $_[2];
+ print "ok 9\n";
- print "not " unless $cnt == 2;
- print "ok 11\n";
- }
+ print "not " if $xp->eq_name( $_[0], $_[2] );
+ print "ok 10\n";
+
+ my $cnt = 0;
+ foreach ( $xp->new_ns_prefixes ) {
+ $cnt++ if $_ eq '#default';
+ $cnt++ if $_ eq 'zoo';
+ }
+
+ print "not " unless $cnt == 2;
+ print "ok 11\n";
+ }
}
sub end {
- my $xp = shift;
- my $el = shift;
-
- if ($el eq 'zebra') {
- print "not "
- unless $xp->expand_ns_prefix('#default') eq 'urn:blazing-saddles';
- print "ok 7\n";
- }
- elsif ($el eq 'everywhere') {
- print "not " unless $xp->namespace($el) eq 'urn:blazing-saddles';
- print "ok 16\n";
- }
+ my $xp = shift;
+ my $el = shift;
+
+ if ( $el eq 'zebra' ) {
+ print "not "
+ unless $xp->expand_ns_prefix('#default') eq 'urn:blazing-saddles';
+ print "ok 7\n";
+ }
+ elsif ( $el eq 'everywhere' ) {
+ print "not " unless $xp->namespace($el) eq 'urn:blazing-saddles';
+ print "ok 16\n";
+ }
}
sub proc {
- my $xp = shift;
- my $target = shift;
+ my $xp = shift;
+ my $target = shift;
- if ($target eq 'nscheck') {
- print "not " if $xp->new_ns_prefixes > 0;
- print "ok 12\n";
+ if ( $target eq 'nscheck' ) {
+ print "not " if $xp->new_ns_prefixes > 0;
+ print "ok 12\n";
- my $cnt = 0;
- foreach ($xp->current_ns_prefixes) {
- $cnt++ if $_ eq 'zoo';
- $cnt++ if $_ eq 'bar';
- }
+ my $cnt = 0;
+ foreach ( $xp->current_ns_prefixes ) {
+ $cnt++ if $_ eq 'zoo';
+ $cnt++ if $_ eq 'bar';
+ }
- print "not " unless $cnt == 2;
- print "ok 13\n";
+ print "not " unless $cnt == 2;
+ print "ok 13\n";
- print "not "
- unless $xp->expand_ns_prefix('bar') eq 'urn:young-frankenstein';
- print "ok 14\n";
+ print "not "
+ unless $xp->expand_ns_prefix('bar') eq 'urn:young-frankenstein';
+ print "ok 14\n";
- print "not "
- unless $xp->expand_ns_prefix('zoo') eq 'urn:high-anxiety';
- print "ok 15\n";
- }
+ print "not "
+ unless $xp->expand_ns_prefix('zoo') eq 'urn:high-anxiety';
+ print "ok 15\n";
+ }
}
-my $parser = new XML::Parser(ErrorContext => 2,
- Namespaces => 1,
- Handlers => {Start => \&start,
- End => \&end,
- Proc => \&proc,
- Init => \&init});
+my $parser = new XML::Parser(
+ ErrorContext => 2,
+ Namespaces => 1,
+ Handlers => {
+ Start => \&start,
+ End => \&end,
+ Proc => \&proc,
+ Init => \&init
+ }
+);
$parser->parse($docstring);
-BEGIN {print "1..3\n";}
-END {print "not ok 1\n" unless $loaded;}
+BEGIN { print "1..3\n"; }
+END { print "not ok 1\n" unless $loaded; }
use XML::Parser;
$loaded = 1;
print "ok 1\n";
my $str;
sub tmpchar {
- my ($xp, $data) = @_;
+ my ( $xp, $data ) = @_;
- if ($xp->current_element eq 'day') {
- $str = $xp->original_string;
- $xp->setHandlers(Char => 0);
- }
+ if ( $xp->current_element eq 'day' ) {
+ $str = $xp->original_string;
+ $xp->setHandlers( Char => 0 );
+ }
}
-
-my $p = new XML::Parser(Handlers => {Comment => sub {$cnt++;},
- Char => \&tmpchar
- });
+
+my $p = new XML::Parser(
+ Handlers => {
+ Comment => sub { $cnt++; },
+ Char => \&tmpchar
+ }
+);
my $xpnb = $p->parse_start;
-open(REC, 'samples/REC-xml-19980210.xml');
+open( my $rec, '<', 'samples/REC-xml-19980210.xml' );
-while (<REC>) {
- $xpnb->parse_more($_);
+while (<$rec>) {
+ $xpnb->parse_more($_);
}
-close(REC);
+close($rec);
$xpnb->parse_done;
-BEGIN {print "1..4\n";}
-END {print "not ok 1\n" unless $loaded;}
+BEGIN { print "1..4\n"; }
+END { print "not ok 1\n" unless $loaded; }
use XML::Parser;
$loaded = 1;
print "ok 1\n";
-my $cmnt_count = 0;
-my $pi_count = 0;
+my $cmnt_count = 0;
+my $pi_count = 0;
my $between_count = 0;
-my $authseen = 0;
+my $authseen = 0;
sub init {
- my $xp = shift;
- $xp->skip_until(1); # Skip through prolog
+ my $xp = shift;
+ $xp->skip_until(1); # Skip through prolog
}
sub proc {
- $pi_count++;
+ $pi_count++;
}
sub cmnt {
- $cmnt_count++;
+ $cmnt_count++;
}
sub start {
- my ($xp, $el) = @_;
- my $ndx = $xp->element_index;
- if (! $authseen and $el eq 'authlist') {
- $authseen = 1;
- $xp->skip_until(2000);
- }
- elsif ($authseen and $ndx < 2000) {
- $between_count++;
- }
+ my ( $xp, $el ) = @_;
+ my $ndx = $xp->element_index;
+ if ( !$authseen and $el eq 'authlist' ) {
+ $authseen = 1;
+ $xp->skip_until(2000);
+ }
+ elsif ( $authseen and $ndx < 2000 ) {
+ $between_count++;
+ }
}
-my $p = new XML::Parser(Handlers => {Init => \&init,
- Start => \&start,
- Comment => \&cmnt,
- Proc => \&proc
- });
+my $p = new XML::Parser(
+ Handlers => {
+ Init => \&init,
+ Start => \&start,
+ Comment => \&cmnt,
+ Proc => \&proc
+ }
+);
$p->parsefile('samples/REC-xml-19980210.xml');
-BEGIN {print "1..3\n";}
-END {print "not ok 1\n" unless $loaded;}
+BEGIN { print "1..3\n"; }
+END { print "not ok 1\n" unless $loaded; }
use XML::Parser;
$loaded = 1;
print "ok 1\n";
-my $delim = '------------123453As23lkjlklz877';
-my $file = 'samples/REC-xml-19980210.xml';
+my $delim = '------------123453As23lkjlklz877';
+my $file = 'samples/REC-xml-19980210.xml';
my $tmpfile = 'stream.tmp';
my $cnt = 0;
+open( my $out_fh, '>', $tmpfile ) or die "Couldn't open $tmpfile for output";
+open( my $in_fh, '<', $file ) or die "Couldn't open $file for input";
-open(OUT, ">$tmpfile") or die "Couldn't open $tmpfile for output";
-open(IN, $file) or die "Couldn't open $file for input";
-
-while (<IN>) {
- print OUT;
+while (<$in_fh>) {
+ print $out_fh $_;
}
-close(IN);
-print OUT "$delim\n";
+close($in_fh);
+print $out_fh "$delim\n";
-open(IN, $file);
-while (<IN>) {
- print OUT;
+open( $in_fh, $file );
+while (<$in_fh>) {
+ print $out_fh $_;
}
-close(IN);
-close(OUT);
+close($in_fh);
+close($out_fh);
-my $parser = new XML::Parser(Stream_Delimiter => $delim,
- Handlers => {Comment => sub {$cnt++;}});
+my $parser = new XML::Parser(
+ Stream_Delimiter => $delim,
+ Handlers => {
+ Comment => sub { $cnt++; }
+ }
+);
-open(FOO, $tmpfile);
+open( my $fh, $tmpfile );
-$parser->parse(*FOO);
+$parser->parse($fh);
-print "not " if ($cnt != 37);
+print "not " if ( $cnt != 37 );
print "ok 2\n";
$cnt = 0;
-$parser->parse(*FOO);
+$parser->parse($fh);
-print "not " if ($cnt != 37);
+print "not " if ( $cnt != 37 );
print "ok 3\n";
-close(FOO);
+close($fh);
unlink($tmpfile);
{
# Debug style
- my $parser = XML::Parser->new(Style => 'Debug');
+ my $parser = XML::Parser->new( Style => 'Debug' );
ok($parser);
-
+
my $tmpfile = IO::File->new_tmpfile();
- open(OLDERR, ">&STDERR");
- open(STDERR, ">&" . $tmpfile->fileno) || die "Cannot re-open STDERR : $!";
-
+ open( OLDERR, ">&STDERR" );
+ open( STDERR, ">&" . $tmpfile->fileno ) || die "Cannot re-open STDERR : $!";
+
$parser->parse($xmlstr);
-
+
close(STDERR);
- open(STDERR, ">&OLDERR");
+ open( STDERR, ">&OLDERR" );
close(OLDERR);
-
- seek($tmpfile, 0, 0);
+
+ seek( $tmpfile, 0, 0 );
my $warn = 0;
$warn++ while (<$tmpfile>);
- ok($warn, 3, "Check we got three warnings out");
+ ok( $warn, 3, "Check we got three warnings out" );
}
{
# Object style
- my $parser = XML::Parser->new(Style => 'Objects');
+ my $parser = XML::Parser->new( Style => 'Objects' );
ok($parser);
-
+
my $tree = $parser->parse($xmlstr);
ok($tree);
}
{
# Stream style
- my $parser = XML::Parser->new(Style => 'Stream');
+ my $parser = XML::Parser->new( Style => 'Stream' );
ok($parser);
}
{
# Subs style
- my $parser = XML::Parser->new(Style => 'Subs');
+ my $parser = XML::Parser->new( Style => 'Subs' );
ok($parser);
}
{
# Tree style
- my $parser = XML::Parser->new(Style => 'Tree');
+ my $parser = XML::Parser->new( Style => 'Tree' );
ok($parser);
my $tree = $parser->parse($xmlstr);
- ok(ref($tree), 'ARRAY');
- ok($tree->[0], 'foo');
- ok(ref($tree->[1]), 'ARRAY');
- ok(ref($tree->[1]->[0]), 'HASH');
- ok($tree->[1][1], '0');
- ok($tree->[1][2], 'bar');
+ ok( ref($tree), 'ARRAY' );
+ ok( $tree->[0], 'foo' );
+ ok( ref( $tree->[1] ), 'ARRAY' );
+ ok( ref( $tree->[1]->[0] ), 'HASH' );
+ ok( $tree->[1][1], '0' );
+ ok( $tree->[1][2], 'bar' );
}
projects / platform / upstream / perl-XML-Parser.git / commitdiff