diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/XML/LibXML.pm')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/XML/LibXML.pm | 2238 |
1 files changed, 2238 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/XML/LibXML.pm b/Master/tlpkg/tlperl0/lib/XML/LibXML.pm new file mode 100755 index 00000000000..37600cdaf93 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/XML/LibXML.pm @@ -0,0 +1,2238 @@ +# $Id: LibXML.pm 809 2009-10-04 21:17:41Z pajas $ +# +# +# This is free software, you may use it and distribute it under the same terms as +# Perl itself. +# +# Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas +# +# + +package XML::LibXML; + +use strict; +use vars qw($VERSION $ABI_VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS + $skipDTD $skipXMLDeclaration $setTagCompression + $MatchCB $ReadCB $OpenCB $CloseCB %PARSER_FLAGS + ); +use Carp; + +use constant XML_XMLNS_NS => 'http://www.w3.org/2000/xmlns/'; +use constant XML_XML_NS => 'http://www.w3.org/XML/1998/namespace'; + +use XML::LibXML::Error; +use XML::LibXML::NodeList; +use XML::LibXML::XPathContext; +use IO::Handle; # for FH reads called as methods + +BEGIN { +$VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE +$ABI_VERSION = 2; +require Exporter; +require DynaLoader; +@ISA = qw(DynaLoader Exporter); + +use vars qw($__PROXY_NODE_REGISTRY $__threads_shared $__PROXY_NODE_REGISTRY_MUTEX $__loaded); + +sub VERSION { + my $class = shift; + my ($caller) = caller; + my $req_abi = $ABI_VERSION; + if (UNIVERSAL::can($caller,'REQUIRE_XML_LIBXML_ABI_VERSION')) { + $req_abi = $caller->REQUIRE_XML_LIBXML_ABI_VERSION(); + } elsif ($caller eq 'XML::LibXSLT') { + # XML::LibXSLT without REQUIRE_XML_LIBXML_ABI_VERSION is an old and incompatible version + $req_abi = 1; + } + unless ($req_abi == $ABI_VERSION) { + my $ver = @_ ? ' '.$_[0] : ''; + die ("This version of $caller requires XML::LibXML$ver (ABI $req_abi), which is incompatible with currently installed XML::LibXML $VERSION (ABI $ABI_VERSION). Please upgrade $caller, XML::LibXML, or both!"); + } + return $class->UNIVERSAL::VERSION(@_) +} + +#-------------------------------------------------------------------------# +# export information # +#-------------------------------------------------------------------------# +%EXPORT_TAGS = ( + all => [qw( + XML_ELEMENT_NODE + XML_ATTRIBUTE_NODE + XML_TEXT_NODE + XML_CDATA_SECTION_NODE + XML_ENTITY_REF_NODE + XML_ENTITY_NODE + XML_PI_NODE + XML_COMMENT_NODE + XML_DOCUMENT_NODE + XML_DOCUMENT_TYPE_NODE + XML_DOCUMENT_FRAG_NODE + XML_NOTATION_NODE + XML_HTML_DOCUMENT_NODE + XML_DTD_NODE + XML_ELEMENT_DECL + XML_ATTRIBUTE_DECL + XML_ENTITY_DECL + XML_NAMESPACE_DECL + XML_XINCLUDE_END + XML_XINCLUDE_START + encodeToUTF8 + decodeFromUTF8 + XML_XMLNS_NS + XML_XML_NS + )], + libxml => [qw( + XML_ELEMENT_NODE + XML_ATTRIBUTE_NODE + XML_TEXT_NODE + XML_CDATA_SECTION_NODE + XML_ENTITY_REF_NODE + XML_ENTITY_NODE + XML_PI_NODE + XML_COMMENT_NODE + XML_DOCUMENT_NODE + XML_DOCUMENT_TYPE_NODE + XML_DOCUMENT_FRAG_NODE + XML_NOTATION_NODE + XML_HTML_DOCUMENT_NODE + XML_DTD_NODE + XML_ELEMENT_DECL + XML_ATTRIBUTE_DECL + XML_ENTITY_DECL + XML_NAMESPACE_DECL + XML_XINCLUDE_END + XML_XINCLUDE_START + )], + encoding => [qw( + encodeToUTF8 + decodeFromUTF8 + )], + ns => [qw( + XML_XMLNS_NS + XML_XML_NS + )], + ); + +@EXPORT_OK = ( + @{$EXPORT_TAGS{all}}, + ); + +@EXPORT = ( + @{$EXPORT_TAGS{all}}, + ); + +#-------------------------------------------------------------------------# +# initialization of the global variables # +#-------------------------------------------------------------------------# +$skipDTD = 0; +$skipXMLDeclaration = 0; +$setTagCompression = 0; + +$MatchCB = undef; +$ReadCB = undef; +$OpenCB = undef; +$CloseCB = undef; + +# if ($threads::threads) { +# our $__THREADS_TID = 0; +# eval q{ +# use threads::shared; +# our $__PROXY_NODE_REGISTRY_MUTEX :shared = 0; +# }; +# die $@ if $@; +# } +#-------------------------------------------------------------------------# +# bootstrapping # +#-------------------------------------------------------------------------# +bootstrap XML::LibXML $VERSION; +undef &AUTOLOAD; + +*encodeToUTF8 = \&XML::LibXML::Common::encodeToUTF8; +*decodeFromUTF8 = \&XML::LibXML::Common::decodeFromUTF8; + +} # BEGIN + + +#-------------------------------------------------------------------------# +# libxml2 node names (see also XML::LibXML::Common # +#-------------------------------------------------------------------------# +use constant XML_ELEMENT_NODE => 1; +use constant XML_ATTRIBUTE_NODE => 2; +use constant XML_TEXT_NODE => 3; +use constant XML_CDATA_SECTION_NODE => 4; +use constant XML_ENTITY_REF_NODE => 5; +use constant XML_ENTITY_NODE => 6; +use constant XML_PI_NODE => 7; +use constant XML_COMMENT_NODE => 8; +use constant XML_DOCUMENT_NODE => 9; +use constant XML_DOCUMENT_TYPE_NODE => 10; +use constant XML_DOCUMENT_FRAG_NODE => 11; +use constant XML_NOTATION_NODE => 12; +use constant XML_HTML_DOCUMENT_NODE => 13; +use constant XML_DTD_NODE => 14; +use constant XML_ELEMENT_DECL => 15; +use constant XML_ATTRIBUTE_DECL => 16; +use constant XML_ENTITY_DECL => 17; +use constant XML_NAMESPACE_DECL => 18; +use constant XML_XINCLUDE_START => 19; +use constant XML_XINCLUDE_END => 20; + + +sub import { + my $package=shift; + if (grep /^:threads_shared$/, @_) { + require threads; + if (!defined($__threads_shared)) { + if (INIT_THREAD_SUPPORT()) { + eval q{ + use threads::shared; + share($__PROXY_NODE_REGISTRY_MUTEX); + }; + if ($@) { # something went wrong + DISABLE_THREAD_SUPPORT(); # leave the library in a usable state + die $@; # and die + } + $__PROXY_NODE_REGISTRY = XML::LibXML::HashTable->new(); + $__threads_shared=1; + } else { + croak("XML::LibXML or Perl compiled without ithread support!"); + } + } elsif (!$__threads_shared) { + croak("XML::LibXML already loaded without thread support. Too late to enable thread support!"); + } + } elsif (defined $XML::LibXML::__loaded) { + $__threads_shared=0 if not defined $__threads_shared; + } + __PACKAGE__->export_to_level(1,$package,grep !/^:threads(_shared)?$/,@_); +} + +sub threads_shared_enabled { + return $__threads_shared ? 1 : 0; +} + +# if ($threads::threads) { +# our $__PROXY_NODE_REGISTRY = XML::LibXML::HashTable->new(); +# } + +#-------------------------------------------------------------------------# +# test exact version (up to patch-level) # +#-------------------------------------------------------------------------# +{ + my ($runtime_version) = LIBXML_RUNTIME_VERSION() =~ /^(\d+)/; + if ( $runtime_version < LIBXML_VERSION ) { + warn "Warning: XML::LibXML compiled against libxml2 ".LIBXML_VERSION. + ", but runtime libxml2 is older $runtime_version\n"; + } +} + + +#-------------------------------------------------------------------------# +# parser flags # +#-------------------------------------------------------------------------# + +# Copied directly from http://xmlsoft.org/html/libxml-parser.html#xmlParserOption +use constant { + XML_PARSE_RECOVER => 1, # recover on errors + XML_PARSE_NOENT => 2, # substitute entities + XML_PARSE_DTDLOAD => 4, # load the external subset + XML_PARSE_DTDATTR => 8, # default DTD attributes + XML_PARSE_DTDVALID => 16, # validate with the DTD + XML_PARSE_NOERROR => 32, # suppress error reports + XML_PARSE_NOWARNING => 64, # suppress warning reports + XML_PARSE_PEDANTIC => 128, # pedantic error reporting + XML_PARSE_NOBLANKS => 256, # remove blank nodes + XML_PARSE_SAX1 => 512, # use the SAX1 interface internally + XML_PARSE_XINCLUDE => 1024, # Implement XInclude substitition + XML_PARSE_NONET => 2048, # Forbid network access + XML_PARSE_NODICT => 4096, # Do not reuse the context dictionnary + XML_PARSE_NSCLEAN => 8192, # remove redundant namespaces declarations + XML_PARSE_NOCDATA => 16384, # merge CDATA as text nodes + XML_PARSE_NOXINCNODE => 32768, # do not generate XINCLUDE START/END nodes + XML_PARSE_COMPACT => 65536, # compact small text nodes; no modification of the tree allowed afterwards + # (will possibly crash if you try to modify the tree) + XML_PARSE_OLD10 => 131072, # parse using XML-1.0 before update 5 + XML_PARSE_NOBASEFIX => 262144, # do not fixup XINCLUDE xml#base uris + XML_PARSE_HUGE => 524288, # relax any hardcoded limit from the parser + XML_PARSE_OLDSAX => 1048576, # parse using SAX2 interface from before 2.7.0 +}; + +use constant XML_LIBXML_PARSE_DEFAULTS => ( XML_PARSE_NODICT | XML_PARSE_HUGE | XML_PARSE_DTDLOAD | XML_PARSE_NOENT ); + +# this hash is made global so that applications can add names for new +# libxml2 parser flags as temporary workaround + +%PARSER_FLAGS = ( + recover => XML_PARSE_RECOVER, + expand_entities => XML_PARSE_NOENT, + load_ext_dtd => XML_PARSE_DTDLOAD, + complete_attributes => XML_PARSE_DTDATTR, + validation => XML_PARSE_DTDVALID, + suppress_errors => XML_PARSE_NOERROR, + suppress_warnings => XML_PARSE_NOWARNING, + pedantic_parser => XML_PARSE_PEDANTIC, + no_blanks => XML_PARSE_NOBLANKS, + expand_xinclude => XML_PARSE_XINCLUDE, + xinclude => XML_PARSE_XINCLUDE, + no_network => XML_PARSE_NONET, + clean_namespaces => XML_PARSE_NSCLEAN, + no_cdata => XML_PARSE_NOCDATA, + no_xinclude_nodes => XML_PARSE_NOXINCNODE, + old10 => XML_PARSE_OLD10, + no_base_fix => XML_PARSE_NOBASEFIX, + huge => XML_PARSE_HUGE, + oldsax => XML_PARSE_OLDSAX, +); + +my %OUR_FLAGS = ( + recover => 'XML_LIBXML_RECOVER', + line_numbers => 'XML_LIBXML_LINENUMBERS', + URI => 'XML_LIBXML_BASE_URI', + base_uri => 'XML_LIBXML_BASE_URI', + gdome => 'XML_LIBXML_GDOME', + ext_ent_handler => 'ext_ent_handler', +); + +sub _parser_options { + my ($self, $opts) = @_; + + # currently dictionaries break XML::LibXML memory management + + my $flags; + + if (ref($self)) { + $flags = ($self->{XML_LIBXML_PARSER_OPTIONS}||0); + } else { + $flags = XML_LIBXML_PARSE_DEFAULTS; # safety precaution + } + + my ($key, $value); + while (($key,$value) = each %$opts) { + my $f = $PARSER_FLAGS{ $key }; + if (defined $f) { + if ($value) { + $flags |= $f + } else { + $flags &= ~$f; + } + } elsif ($key eq 'set_parser_flags') { # this can be used to pass flags XML::LibXML does not yet know about + $flags |= $value; + } elsif ($key eq 'unset_parser_flags') { + $flags &= ~$value; + } + + } + return $flags; +} + +my %compatibility_flags = ( + XML_LIBXML_VALIDATION => 'validation', + XML_LIBXML_EXPAND_ENTITIES => 'expand_entities', + XML_LIBXML_PEDANTIC => 'pedantic_parser', + XML_LIBXML_NONET => 'no_network', + XML_LIBXML_EXT_DTD => 'load_ext_dtd', + XML_LIBXML_COMPLETE_ATTR => 'complete_attributes', + XML_LIBXML_EXPAND_XINCLUDE => 'expand_xinclude', + XML_LIBXML_NSCLEAN => 'clean_namespaces', + XML_LIBXML_KEEP_BLANKS => 'keep_blanks', + XML_LIBXML_LINENUMBERS => 'line_numbers', +); + +#-------------------------------------------------------------------------# +# parser constructor # +#-------------------------------------------------------------------------# + + +sub new { + my $class = shift; + my $self = bless { + }, $class; + if (@_) { + my %opts = (); + if (ref($_[0]) eq 'HASH') { + %opts = %{$_[0]}; + } else { + # old interface + my %args = @_; + %opts=( + map { + (($compatibility_flags{ $_ }||$_) => $args{ $_ }) + } keys %args + ); + } + # parser flags + $opts{no_blanks} = !$opts{keep_blanks} if exists($opts{keep_blanks}) and !exists($opts{no_blanks}); + + for (keys %OUR_FLAGS) { + $self->{$OUR_FLAGS{$_}} = delete $opts{$_}; + } + $class->load_catalog(delete($opts{catalog})) if $opts{catalog}; + + $self->{XML_LIBXML_PARSER_OPTIONS} = XML::LibXML->_parser_options(\%opts); + + # store remaining unknown options directly in $self + for (keys %opts) { + $self->{$_}=$opts{$_} unless exists $PARSER_FLAGS{$_}; + } + } else { + $self->{XML_LIBXML_PARSER_OPTIONS} = XML_LIBXML_PARSE_DEFAULTS; + } + if ( defined $self->{Handler} ) { + $self->set_handler( $self->{Handler} ); + } + + $self->{_State_} = 0; + return $self; +} + +sub _clone { + my ($self)=@_; + my $new = ref($self)->new({ + recover => $self->{XML_LIBXML_RECOVER}, + line_nubers => $self->{XML_LIBXML_LINENUMBERS}, + base_uri => $self->{XML_LIBXML_BASE_URI}, + gdome => $self->{XML_LIBXML_GDOME}, + set_parser_flags => $self->{XML_LIBXML_PARSER_OPTIONS}, + }); + return $new; +} + +#-------------------------------------------------------------------------# +# Threads support methods # +#-------------------------------------------------------------------------# + +# threads doc says CLONE's API may change in future, which would break +# an XS method prototype +sub CLONE { + if ($XML::LibXML::__threads_shared) { + XML::LibXML::_CLONE( $_[0] ); + } +} + +sub CLONE_SKIP { + return $XML::LibXML::__threads_shared ? 0 : 1; +} + +sub __proxy_registry { + my ($class)=caller; + die "This version of $class uses API of XML::LibXML 1.66 which is not compatible with XML::LibXML $VERSION. Please upgrade $class!\n"; +} + +#-------------------------------------------------------------------------# +# DOM Level 2 document constructor # +#-------------------------------------------------------------------------# + +sub createDocument { + my $self = shift; + if (!@_ or $_[0] =~ m/^\d\.\d$/) { + # for backward compatibility + return XML::LibXML::Document->new(@_); + } + else { + # DOM API: createDocument(namespaceURI, qualifiedName, doctype?) + my $doc = XML::LibXML::Document-> new; + my $el = $doc->createElementNS(shift, shift); + $doc->setDocumentElement($el); + $doc->setExternalSubset(shift) if @_; + return $doc; + } +} + +#-------------------------------------------------------------------------# +# callback functions # +#-------------------------------------------------------------------------# + +sub input_callbacks { + my $self = shift; + my $icbclass = shift; + + if ( defined $icbclass ) { + $self->{XML_LIBXML_CALLBACK_STACK} = $icbclass; + } + return $self->{XML_LIBXML_CALLBACK_STACK}; +} + +sub match_callback { + my $self = shift; + if ( ref $self ) { + if ( scalar @_ ) { + $self->{XML_LIBXML_MATCH_CB} = shift; + $self->{XML_LIBXML_CALLBACK_STACK} = undef; + } + return $self->{XML_LIBXML_MATCH_CB}; + } + else { + $MatchCB = shift if scalar @_; + return $MatchCB; + } +} + +sub read_callback { + my $self = shift; + if ( ref $self ) { + if ( scalar @_ ) { + $self->{XML_LIBXML_READ_CB} = shift; + $self->{XML_LIBXML_CALLBACK_STACK} = undef; + } + return $self->{XML_LIBXML_READ_CB}; + } + else { + $ReadCB = shift if scalar @_; + return $ReadCB; + } +} + +sub close_callback { + my $self = shift; + if ( ref $self ) { + if ( scalar @_ ) { + $self->{XML_LIBXML_CLOSE_CB} = shift; + $self->{XML_LIBXML_CALLBACK_STACK} = undef; + } + return $self->{XML_LIBXML_CLOSE_CB}; + } + else { + $CloseCB = shift if scalar @_; + return $CloseCB; + } +} + +sub open_callback { + my $self = shift; + if ( ref $self ) { + if ( scalar @_ ) { + $self->{XML_LIBXML_OPEN_CB} = shift; + $self->{XML_LIBXML_CALLBACK_STACK} = undef; + } + return $self->{XML_LIBXML_OPEN_CB}; + } + else { + $OpenCB = shift if scalar @_; + return $OpenCB; + } +} + +sub callbacks { + my $self = shift; + if ( ref $self ) { + if (@_) { + my ($match, $open, $read, $close) = @_; + @{$self}{qw(XML_LIBXML_MATCH_CB XML_LIBXML_OPEN_CB XML_LIBXML_READ_CB XML_LIBXML_CLOSE_CB)} = ($match, $open, $read, $close); + $self->{XML_LIBXML_CALLBACK_STACK} = undef; + } + else { + return @{$self}{qw(XML_LIBXML_MATCH_CB XML_LIBXML_OPEN_CB XML_LIBXML_READ_CB XML_LIBXML_CLOSE_CB)}; + } + } + else { + if (@_) { + ( $MatchCB, $OpenCB, $ReadCB, $CloseCB ) = @_; + } + else { + return ( $MatchCB, $OpenCB, $ReadCB, $CloseCB ); + } + } +} + +#-------------------------------------------------------------------------# +# internal member variable manipulation # +#-------------------------------------------------------------------------# +sub __parser_option { + my ($self, $opt) = @_; + if (@_>2) { + if ($_[2]) { + $self->{XML_LIBXML_PARSER_OPTIONS} |= $opt; + return 1; + } else { + $self->{XML_LIBXML_PARSER_OPTIONS} &= ~$opt; + return 0; + } + } else { + return ($self->{XML_LIBXML_PARSER_OPTIONS} & $opt) ? 1 : 0; + } +} + +sub option_exists { + my ($self,$name)=@_; + return ($PARSER_FLAGS{$name} || $OUR_FLAGS{$name}) ? 1 : 0; +} +sub get_option { + my ($self,$name)=@_; + my $flag = $OUR_FLAGS{$name}; + return $self->{$flag} if $flag; + $flag = $PARSER_FLAGS{$name}; + return $self->__parser_option($flag) if $flag; + warn "XML::LibXML::get_option: unknown parser option $name\n"; + return undef; +} +sub set_option { + my ($self,$name,$value)=@_; + my $flag = $OUR_FLAGS{$name}; + return ($self->{$flag}=$value) if $flag; + $flag = $PARSER_FLAGS{$name}; + return $self->__parser_option($flag,$value) if $flag; + warn "XML::LibXML::get_option: unknown parser option $name\n"; + return undef; +} +sub set_options { + my $self=shift; + my $opts; + if (@_==1 and ref($_[0]) eq 'HASH') { + $opts = $_[0]; + } elsif (@_ % 2 == 0) { + $opts={@_}; + } else { + croak("Odd number of elements passed to set_options"); + } + $self->set_option($_=>$opts->{$_}) foreach keys %$opts; + return; +} + +sub validation { + my $self = shift; + return $self->__parser_option(XML_PARSE_DTDVALID,@_); +} + +sub recover { + my $self = shift; + if (scalar @_) { + $self->{XML_LIBXML_RECOVER} = $_[0]; + $self->__parser_option(XML_PARSE_RECOVER,@_); + } + return $self->{XML_LIBXML_RECOVER}; +} + +sub recover_silently { + my $self = shift; + my $arg = shift; + (($arg == 1) ? $self->recover(2) : $self->recover($arg)) if defined($arg); + return (($self->recover()||0) == 2) ? 1 : 0; +} + +sub expand_entities { + my $self = shift; + if (scalar(@_) and $_[0]) { + return $self->__parser_option(XML_PARSE_NOENT | XML_PARSE_DTDLOAD,1); + } + return $self->__parser_option(XML_PARSE_NOENT,@_); +} + +sub keep_blanks { + my $self = shift; + my @args; # we have to negate the argument and return negated value, since + # the actual flag is no_blanks + if (scalar @_) { + @args=($_[0] ? 0 : 1); + } + return $self->__parser_option(XML_PARSE_NOBLANKS,@args) ? 0 : 1; +} + +sub pedantic_parser { + my $self = shift; + return $self->__parser_option(XML_PARSE_PEDANTIC,@_); +} + +sub line_numbers { + my $self = shift; + $self->{XML_LIBXML_LINENUMBERS} = shift if scalar @_; + return $self->{XML_LIBXML_LINENUMBERS}; +} + +sub no_network { + my $self = shift; + return $self->__parser_option(XML_PARSE_NONET,@_); +} + +sub load_ext_dtd { + my $self = shift; + return $self->__parser_option(XML_PARSE_DTDLOAD,@_); +} + +sub complete_attributes { + my $self = shift; + return $self->__parser_option(XML_PARSE_DTDATTR,@_); +} + +sub expand_xinclude { + my $self = shift; + return $self->__parser_option(XML_PARSE_XINCLUDE,@_); +} + +sub base_uri { + my $self = shift; + $self->{XML_LIBXML_BASE_URI} = shift if scalar @_; + return $self->{XML_LIBXML_BASE_URI}; +} + +sub gdome_dom { + my $self = shift; + $self->{XML_LIBXML_GDOME} = shift if scalar @_; + return $self->{XML_LIBXML_GDOME}; +} + +sub clean_namespaces { + my $self = shift; + return $self->__parser_option(XML_PARSE_NSCLEAN,@_); +} + +#-------------------------------------------------------------------------# +# set the optional SAX(2) handler # +#-------------------------------------------------------------------------# +sub set_handler { + my $self = shift; + if ( defined $_[0] ) { + $self->{HANDLER} = $_[0]; + + $self->{SAX_ELSTACK} = []; + $self->{SAX} = {State => 0}; + } + else { + # undef SAX handling + $self->{SAX_ELSTACK} = []; + delete $self->{HANDLER}; + delete $self->{SAX}; + } +} + +#-------------------------------------------------------------------------# +# helper functions # +#-------------------------------------------------------------------------# +sub _auto_expand { + my ( $self, $result, $uri ) = @_; + + $result->setBaseURI( $uri ) if defined $uri; + + if ( $self->expand_xinclude ) { + $self->{_State_} = 1; + eval { $self->processXIncludes($result); }; + my $err = $@; + $self->{_State_} = 0; + if ($err) { + $self->_cleanup_callbacks(); + $result = undef; + croak $err; + } + } + return $result; +} + +sub _init_callbacks { + my $self = shift; + my $icb = $self->{XML_LIBXML_CALLBACK_STACK}; + unless ( defined $icb ) { + $self->{XML_LIBXML_CALLBACK_STACK} = XML::LibXML::InputCallback->new(); + $icb = $self->{XML_LIBXML_CALLBACK_STACK}; + } + + my $mcb = $self->match_callback(); + my $ocb = $self->open_callback(); + my $rcb = $self->read_callback(); + my $ccb = $self->close_callback(); + + if ( defined $mcb and defined $ocb and defined $rcb and defined $ccb ) { + $icb->register_callbacks( [$mcb, $ocb, $rcb, $ccb] ); + } + $icb->init_callbacks(); +} + +sub _cleanup_callbacks { + my $self = shift; + $self->{XML_LIBXML_CALLBACK_STACK}->cleanup_callbacks(); + my $mcb = $self->match_callback(); + $self->{XML_LIBXML_CALLBACK_STACK}->unregister_callbacks( [$mcb] ); +} + +sub __read { + read($_[0], $_[1], $_[2]); +} + +sub __write { + if ( ref( $_[0] ) ) { + $_[0]->write( $_[1], $_[2] ); + } + else { + $_[0]->write( $_[1] ); + } +} + +sub load_xml { + my ($class_or_self) = shift; + my %args = map { ref($_) eq 'HASH' ? (%$_) : $_ } @_; + my $URI = delete($args{URI}); + $URI = "$URI" if defined $URI; # stringify in case it is an URI object + my $parser; + if (ref($class_or_self)) { + $parser = $class_or_self->_clone(); + $parser->{XML_LIBXML_PARSER_OPTIONS} = $parser->_parser_options(\%args); + } else { + $parser = $class_or_self->new(\%args); + } + my $dom; + if ( defined $args{location} ) { + $dom = $parser->parse_file( "$args{location}" ); + } + elsif ( defined $args{string} ) { + $dom = $parser->parse_string( $args{string}, $URI ); + } + elsif ( defined $args{IO} ) { + $dom = $parser->parse_fh( $args{IO}, $URI ); + } + else { + croak("XML::LibXML->load: specify location, string, or IO"); + } + return $dom; +} + +sub load_html { + my ($class_or_self) = shift; + my %args = map { ref($_) eq 'HASH' ? (%$_) : $_ } @_; + my $URI = delete($args{URI}); + $URI = "$URI" if defined $URI; # stringify in case it is an URI object + my $parser; + if (ref($class_or_self)) { + $parser = $class_or_self->_clone(); + } else { + $parser = $class_or_self->new(); + } + my $dom; + if ( defined $args{location} ) { + $dom = $parser->parse_html_file( "$args{location}", \%args ); + } + elsif ( defined $args{string} ) { + $dom = $parser->parse_html_string( $args{string}, \%args ); + } + elsif ( defined $args{IO} ) { + $dom = $parser->parse_html_fh( $args{IO}, \%args ); + } + else { + croak("XML::LibXML->load: specify location, string, or IO"); + } + return $dom; +} + +#-------------------------------------------------------------------------# +# parsing functions # +#-------------------------------------------------------------------------# +# all parsing functions handle normal as SAX parsing at the same time. +# note that SAX parsing is handled incomplete! use XML::LibXML::SAX for +# complete parsing sequences +#-------------------------------------------------------------------------# +sub parse_string { + my $self = shift; + croak("parse_string is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self; + croak("parse already in progress") if $self->{_State_}; + + unless ( defined $_[0] and length $_[0] ) { + croak("Empty String"); + } + + $self->{_State_} = 1; + my $result; + + $self->_init_callbacks(); + + if ( defined $self->{SAX} ) { + my $string = shift; + $self->{SAX_ELSTACK} = []; + eval { $result = $self->_parse_sax_string($string); }; + my $err = $@; + $self->{_State_} = 0; + if ($err) { + chomp $err unless ref $err; + $self->_cleanup_callbacks(); + croak $err; + } + } + else { + eval { $result = $self->_parse_string( @_ ); }; + + my $err = $@; + $self->{_State_} = 0; + if ($err) { + chomp $err unless ref $err; + $self->_cleanup_callbacks(); + croak $err; + } + + $result = $self->_auto_expand( $result, $self->{XML_LIBXML_BASE_URI} ); + } + $self->_cleanup_callbacks(); + + return $result; +} + +sub parse_fh { + my $self = shift; + croak("parse_fh is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self; + croak("parse already in progress") if $self->{_State_}; + $self->{_State_} = 1; + my $result; + + $self->_init_callbacks(); + + if ( defined $self->{SAX} ) { + $self->{SAX_ELSTACK} = []; + eval { $self->_parse_sax_fh( @_ ); }; + my $err = $@; + $self->{_State_} = 0; + if ($err) { + chomp $err unless ref $err; + $self->_cleanup_callbacks(); + croak $err; + } + } + else { + eval { $result = $self->_parse_fh( @_ ); }; + my $err = $@; + $self->{_State_} = 0; + if ($err) { + chomp $err unless ref $err; + $self->_cleanup_callbacks(); + croak $err; + } + + $result = $self->_auto_expand( $result, $self->{XML_LIBXML_BASE_URI} ); + } + + $self->_cleanup_callbacks(); + + return $result; +} + +sub parse_file { + my $self = shift; + croak("parse_file is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self; + croak("parse already in progress") if $self->{_State_}; + + $self->{_State_} = 1; + my $result; + + $self->_init_callbacks(); + + if ( defined $self->{SAX} ) { + $self->{SAX_ELSTACK} = []; + eval { $self->_parse_sax_file( @_ ); }; + my $err = $@; + $self->{_State_} = 0; + if ($err) { + chomp $err unless ref $err; + $self->_cleanup_callbacks(); + croak $err; + } + } + else { + eval { $result = $self->_parse_file(@_); }; + my $err = $@; + $self->{_State_} = 0; + if ($err) { + chomp $err unless ref $err; + $self->_cleanup_callbacks(); + croak $err; + } + + $result = $self->_auto_expand( $result ); + } + $self->_cleanup_callbacks(); + + return $result; +} + +sub parse_xml_chunk { + my $self = shift; + # max 2 parameter: + # 1: the chunk + # 2: the encoding of the string + croak("parse_xml_chunk is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self; + croak("parse already in progress") if $self->{_State_}; my $result; + + unless ( defined $_[0] and length $_[0] ) { + croak("Empty String"); + } + + $self->{_State_} = 1; + + $self->_init_callbacks(); + + if ( defined $self->{SAX} ) { + eval { + $self->_parse_sax_xml_chunk( @_ ); + + # this is required for XML::GenericChunk. + # in normal case is_filter is not defined, an thus the parsing + # will be terminated. in case of a SAX filter the parsing is not + # finished at that state. therefore we must not reset the parsing + unless ( $self->{IS_FILTER} ) { + $result = $self->{HANDLER}->end_document(); + } + }; + } + else { + eval { $result = $self->_parse_xml_chunk( @_ ); }; + } + + $self->_cleanup_callbacks(); + + my $err = $@; + $self->{_State_} = 0; + if ($err) { + chomp $err unless ref $err; + croak $err; + } + + return $result; +} + +sub parse_balanced_chunk { + my $self = shift; + $self->_init_callbacks(); + my $rv; + eval { + $rv = $self->parse_xml_chunk( @_ ); + }; + my $err = $@; + $self->_cleanup_callbacks(); + if ( $err ) { + chomp $err unless ref $err; + croak $err; + } + return $rv +} + +# java style +sub processXIncludes { + my $self = shift; + my $doc = shift; + my $opts = shift; + my $options = $self->_parser_options($opts); + if ( $self->{_State_} != 1 ) { + $self->_init_callbacks(); + } + my $rv; + eval { + $rv = $self->_processXIncludes($doc || " ", $options); + }; + my $err = $@; + if ( $self->{_State_} != 1 ) { + $self->_cleanup_callbacks(); + } + + if ( $err ) { + chomp $err unless ref $err; + croak $err; + } + return $rv; +} + +# perl style +sub process_xincludes { + my $self = shift; + my $doc = shift; + my $opts = shift; + my $options = $self->_parser_options($opts); + + my $rv; + $self->_init_callbacks(); + eval { + $rv = $self->_processXIncludes($doc || " ", $options); + }; + my $err = $@; + $self->_cleanup_callbacks(); + if ( $err ) { + chomp $err unless ref $err; + croak $@; + } + return $rv; +} + +#-------------------------------------------------------------------------# +# HTML parsing functions # +#-------------------------------------------------------------------------# + +sub _html_options { + my ($self,$opts)=@_; + $opts = {} unless ref $opts; + # return (undef,undef) unless ref $opts; + my $flags = 0; + $flags |= 1 if exists $opts->{recover} ? $opts->{recover} : $self->recover; + $flags |= 32 if $opts->{suppress_errors}; + $flags |= 64 if $opts->{suppress_warnings}; + $flags |= 128 if exists $opts->{pedantic_parser} ? $opts->{pedantic_parser} : $self->pedantic_parser; + $flags |= 256 if exists $opts->{no_blanks} ? $opts->{no_blanks} : !$self->keep_blanks; + $flags |= 2048 if exists $opts->{no_network} ? $opts->{no_network} : !$self->no_network; + $flags |= 16384 if $opts->{no_cdata}; + $flags |= 65536 if $opts->{compact}; # compact small text nodes; no modification + # of the tree allowed afterwards + # (WILL possibly CRASH IF YOU try to MODIFY THE TREE) + $flags |= 524288 if $opts->{huge}; # relax any hardcoded limit from the parser + $flags |= 1048576 if $opts->{oldsax}; # parse using SAX2 interface from before 2.7.0 + + return ($opts->{URI},$opts->{encoding},$flags); +} + +sub parse_html_string { + my ($self,$str,$opts) = @_; + croak("parse_html_string is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self; + croak("parse already in progress") if $self->{_State_}; + + unless ( defined $str and length $str ) { + croak("Empty String"); + } + $self->{_State_} = 1; + my $result; + + $self->_init_callbacks(); + eval { + $result = $self->_parse_html_string( $str, + $self->_html_options($opts) + ); + }; + my $err = $@; + $self->{_State_} = 0; + if ($err) { + chomp $err unless ref $err; + $self->_cleanup_callbacks(); + croak $err; + } + + $self->_cleanup_callbacks(); + + return $result; +} + +sub parse_html_file { + my ($self,$file,$opts) = @_; + croak("parse_html_file is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self; + croak("parse already in progress") if $self->{_State_}; + $self->{_State_} = 1; + my $result; + + $self->_init_callbacks(); + eval { $result = $self->_parse_html_file($file, + $self->_html_options($opts) + ); }; + my $err = $@; + $self->{_State_} = 0; + if ($err) { + chomp $err unless ref $err; + $self->_cleanup_callbacks(); + croak $err; + } + + $self->_cleanup_callbacks(); + + return $result; +} + +sub parse_html_fh { + my ($self,$fh,$opts) = @_; + croak("parse_html_fh is not a class method! Create a parser object with XML::LibXML->new first!") unless ref $self; + croak("parse already in progress") if $self->{_State_}; + $self->{_State_} = 1; + + my $result; + $self->_init_callbacks(); + eval { $result = $self->_parse_html_fh( $fh, + $self->_html_options($opts) + ); }; + my $err = $@; + $self->{_State_} = 0; + if ($err) { + chomp $err unless ref $err; + $self->_cleanup_callbacks(); + croak $err; + } + $self->_cleanup_callbacks(); + + return $result; +} + +#-------------------------------------------------------------------------# +# push parser interface # +#-------------------------------------------------------------------------# +sub init_push { + my $self = shift; + + if ( defined $self->{CONTEXT} ) { + delete $self->{CONTEXT}; + } + + if ( defined $self->{SAX} ) { + $self->{CONTEXT} = $self->_start_push(1); + } + else { + $self->{CONTEXT} = $self->_start_push(0); + } +} + +sub push { + my $self = shift; + + $self->_init_callbacks(); + + if ( not defined $self->{CONTEXT} ) { + $self->init_push(); + } + + eval { + foreach ( @_ ) { + $self->_push( $self->{CONTEXT}, $_ ); + } + }; + my $err = $@; + $self->_cleanup_callbacks(); + if ( $err ) { + chomp $err unless ref $err; + croak $err; + } +} + +# this function should be promoted! +# the reason is because libxml2 uses xmlParseChunk() for this purpose! +sub parse_chunk { + my $self = shift; + my $chunk = shift; + my $terminate = shift; + + if ( not defined $self->{CONTEXT} ) { + $self->init_push(); + } + + if ( defined $chunk and length $chunk ) { + $self->_push( $self->{CONTEXT}, $chunk ); + } + + if ( $terminate ) { + return $self->finish_push(); + } +} + + +sub finish_push { + my $self = shift; + my $restore = shift || 0; + return undef unless defined $self->{CONTEXT}; + + my $retval; + + if ( defined $self->{SAX} ) { + eval { + $self->_end_sax_push( $self->{CONTEXT} ); + $retval = $self->{HANDLER}->end_document( {} ); + }; + } + else { + eval { $retval = $self->_end_push( $self->{CONTEXT}, $restore ); }; + } + my $err = $@; + delete $self->{CONTEXT}; + if ( $err ) { + chomp $err unless ref $err; + croak( $err ); + } + return $retval; +} + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::Node Interface # +#-------------------------------------------------------------------------# +package XML::LibXML::Node; + +sub CLONE_SKIP { + return $XML::LibXML::__threads_shared ? 0 : 1; +} + +sub isSupported { + my $self = shift; + my $feature = shift; + return $self->can($feature) ? 1 : 0; +} + +sub getChildNodes { my $self = shift; return $self->childNodes(); } + +sub childNodes { + my $self = shift; + my @children = $self->_childNodes(0); + return wantarray ? @children : XML::LibXML::NodeList->new_from_ref(\@children , 1); +} + +sub nonBlankChildNodes { + my $self = shift; + my @children = $self->_childNodes(1); + return wantarray ? @children : XML::LibXML::NodeList->new_from_ref(\@children , 1); +} + +sub attributes { + my $self = shift; + my @attr = $self->_attributes(); + return wantarray ? @attr : XML::LibXML::NamedNodeMap->new( @attr ); +} + + +sub findnodes { + my ($node, $xpath) = @_; + my @nodes = $node->_findnodes($xpath); + if (wantarray) { + return @nodes; + } + else { + return XML::LibXML::NodeList->new_from_ref(\@nodes, 1); + } +} + +sub exists { + my ($node, $xpath) = @_; + my (undef, $value) = $node->_find($xpath,1); + return $value; +} + +sub findvalue { + my ($node, $xpath) = @_; + my $res; + $res = $node->find($xpath); + return $res->to_literal->value; +} + +sub findbool { + my ($node, $xpath) = @_; + my ($type, @params) = $node->_find($xpath,1); + if ($type) { + return $type->new(@params); + } + return undef; +} + +sub find { + my ($node, $xpath) = @_; + my ($type, @params) = $node->_find($xpath,0); + if ($type) { + return $type->new(@params); + } + return undef; +} + +sub setOwnerDocument { + my ( $self, $doc ) = @_; + $doc->adoptNode( $self ); +} + +sub toStringC14N { + my ($self, $comments, $xpath, $xpc) = @_; + return $self->_toStringC14N( $comments || 0, + (defined $xpath ? $xpath : undef), + 0, + undef, + (defined $xpc ? $xpc : undef) + ); +} +sub toStringEC14N { + my ($self, $comments, $xpath, $xpc, $inc_prefix_list) = @_; + unless (UNIVERSAL::isa($xpc,'XML::LibXML::XPathContext')) { + if ($inc_prefix_list) { + croak("toStringEC14N: 3rd argument is not an XML::LibXML::XPathContext"); + } else { + $inc_prefix_list=$xpc; + $xpc=undef; + } + } + if (defined($inc_prefix_list) and !UNIVERSAL::isa($inc_prefix_list,'ARRAY')) { + croak("toStringEC14N: inclusive_prefix_list must be undefined or ARRAY"); + } + return $self->_toStringC14N( $comments || 0, + (defined $xpath ? $xpath : undef), + 1, + (defined $inc_prefix_list ? $inc_prefix_list : undef), + (defined $xpc ? $xpc : undef) + ); +} + +*serialize_c14n = \&toStringC14N; +*serialize_exc_c14n = \&toStringEC14N; + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::Document Interface # +#-------------------------------------------------------------------------# +package XML::LibXML::Document; + +use vars qw(@ISA); +@ISA = ('XML::LibXML::Node'); + +sub actualEncoding { + my $doc = shift; + my $enc = $doc->encoding; + return (defined $enc and length $enc) ? $enc : 'UTF-8'; +} + +sub setDocumentElement { + my $doc = shift; + my $element = shift; + + my $oldelem = $doc->documentElement; + if ( defined $oldelem ) { + $doc->removeChild($oldelem); + } + + $doc->_setDocumentElement($element); +} + +sub toString { + my $self = shift; + my $flag = shift; + + my $retval = ""; + + if ( defined $XML::LibXML::skipXMLDeclaration + and $XML::LibXML::skipXMLDeclaration == 1 ) { + foreach ( $self->childNodes ){ + next if $_->nodeType == XML::LibXML::XML_DTD_NODE() + and $XML::LibXML::skipDTD; + $retval .= $_->toString; + } + } + else { + $flag ||= 0 unless defined $flag; + $retval = $self->_toString($flag); + } + + return $retval; +} + +sub serialize { + my $self = shift; + return $self->toString( @_ ); +} + +#-------------------------------------------------------------------------# +# bad style xinclude processing # +#-------------------------------------------------------------------------# +sub process_xinclude { + my $self = shift; + my $opts = shift; + XML::LibXML->new->processXIncludes( $self, $opts ); +} + +sub insertProcessingInstruction { + my $self = shift; + my $target = shift; + my $data = shift; + + my $pi = $self->createPI( $target, $data ); + my $root = $self->documentElement; + + if ( defined $root ) { + # this is actually not correct, but i guess it's what the user + # intends + $self->insertBefore( $pi, $root ); + } + else { + # if no documentElement was found we just append the PI + $self->appendChild( $pi ); + } +} + +sub insertPI { + my $self = shift; + $self->insertProcessingInstruction( @_ ); +} + +#-------------------------------------------------------------------------# +# DOM L3 Document functions. +# added after robins implicit feature requst +#-------------------------------------------------------------------------# +*getElementsByTagName = \&XML::LibXML::Element::getElementsByTagName; +*getElementsByTagNameNS = \&XML::LibXML::Element::getElementsByTagNameNS; +*getElementsByLocalName = \&XML::LibXML::Element::getElementsByLocalName; + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::DocumentFragment Interface # +#-------------------------------------------------------------------------# +package XML::LibXML::DocumentFragment; + +use vars qw(@ISA); +@ISA = ('XML::LibXML::Node'); + +sub toString { + my $self = shift; + my $retval = ""; + if ( $self->hasChildNodes() ) { + foreach my $n ( $self->childNodes() ) { + $retval .= $n->toString(@_); + } + } + return $retval; +} + +*serialize = \&toString; + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::Element Interface # +#-------------------------------------------------------------------------# +package XML::LibXML::Element; + +use vars qw(@ISA); +@ISA = ('XML::LibXML::Node'); +use XML::LibXML qw(:ns :libxml); +use Carp; + +sub setNamespace { + my $self = shift; + my $n = $self->nodeName; + if ( $self->_setNamespace(@_) ){ + if ( scalar @_ < 3 || $_[2] == 1 ){ + $self->setNodeName( $n ); + } + return 1; + } + return 0; +} + +sub getAttribute { + my $self = shift; + my $name = $_[0]; + if ( $name =~ /^xmlns(?::|$)/ ) { + # user wants to get a namespace ... + (my $prefix = $name )=~s/^xmlns:?//; + $self->_getNamespaceDeclURI($prefix); + } + else { + $self->_getAttribute(@_); + } +} + +sub setAttribute { + my ( $self, $name, $value ) = @_; + if ( $name =~ /^xmlns(?::|$)/ ) { + # user wants to set the special attribute for declaring XML namespace ... + + # this is fine but not exactly DOM conformant behavior, btw (according to DOM we should + # probably declare an attribute which looks like XML namespace declaration + # but isn't) + (my $nsprefix = $name )=~s/^xmlns:?//; + my $nn = $self->nodeName; + if ( $nn =~ /^\Q${nsprefix}\E:/ ) { + # the element has the same prefix + $self->setNamespaceDeclURI($nsprefix,$value) || + $self->setNamespace($value,$nsprefix,1); + ## + ## We set the namespace here. + ## This is helpful, as in: + ## + ## | $e = XML::LibXML::Element->new('foo:bar'); + ## | $e->setAttribute('xmlns:foo','http://yoyodine') + ## + } + else { + # just modify the namespace + $self->setNamespaceDeclURI($nsprefix, $value) || + $self->setNamespace($value,$nsprefix,0); + } + } + else { + $self->_setAttribute($name, $value); + } +} + +sub getAttributeNS { + my $self = shift; + my ($nsURI, $name) = @_; + croak("invalid attribute name") if !defined($name) or $name eq q{}; + if ( defined($nsURI) and $nsURI eq XML_XMLNS_NS ) { + $self->_getNamespaceDeclURI($name eq 'xmlns' ? undef : $name); + } + else { + $self->_getAttributeNS(@_); + } +} + +sub setAttributeNS { + my ($self, $nsURI, $qname, $value)=@_; + unless (defined $qname and length $qname) { + croak("bad name"); + } + if (defined($nsURI) and $nsURI eq XML_XMLNS_NS) { + if ($qname !~ /^xmlns(?::|$)/) { + croak("NAMESPACE ERROR: Namespace declartions must have the prefix 'xmlns'"); + } + $self->setAttribute($qname,$value); # see implementation above + return; + } + if ($qname=~/:/ and not (defined($nsURI) and length($nsURI))) { + croak("NAMESPACE ERROR: Attribute without a prefix cannot be in a namespace"); + } + if ($qname=~/^xmlns(?:$|:)/) { + croak("NAMESPACE ERROR: 'xmlns' prefix and qualified-name are reserved for the namespace ".XML_XMLNS_NS); + } + if ($qname=~/^xml:/ and not (defined $nsURI and $nsURI eq XML_XML_NS)) { + croak("NAMESPACE ERROR: 'xml' prefix is reserved for the namespace ".XML_XML_NS); + } + $self->_setAttributeNS( defined $nsURI ? $nsURI : undef, $qname, $value ); +} + +sub getElementsByTagName { + my ( $node , $name ) = @_; + my $xpath = $name eq '*' ? "descendant::*" : "descendant::*[name()='$name']"; + my @nodes = $node->_findnodes($xpath); + return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1); +} + +sub getElementsByTagNameNS { + my ( $node, $nsURI, $name ) = @_; + my $xpath; + if ( $name eq '*' ) { + if ( $nsURI eq '*' ) { + $xpath = "descendant::*"; + } else { + $xpath = "descendant::*[namespace-uri()='$nsURI']"; + } + } elsif ( $nsURI eq '*' ) { + $xpath = "descendant::*[local-name()='$name']"; + } else { + $xpath = "descendant::*[local-name()='$name' and namespace-uri()='$nsURI']"; + } + my @nodes = $node->_findnodes($xpath); + return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1); +} + +sub getElementsByLocalName { + my ( $node,$name ) = @_; + my $xpath; + if ($name eq '*') { + $xpath = "descendant::*"; + } else { + $xpath = "descendant::*[local-name()='$name']"; + } + my @nodes = $node->_findnodes($xpath); + return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1); +} + +sub getChildrenByTagName { + my ( $node, $name ) = @_; + my @nodes; + if ($name eq '*') { + @nodes = grep { $_->nodeType == XML_ELEMENT_NODE() } + $node->childNodes(); + } else { + @nodes = grep { $_->nodeName eq $name } $node->childNodes(); + } + return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1); +} + +sub getChildrenByLocalName { + my ( $node, $name ) = @_; + # my @nodes; + # if ($name eq '*') { + # @nodes = grep { $_->nodeType == XML_ELEMENT_NODE() } + # $node->childNodes(); + # } else { + # @nodes = grep { $_->nodeType == XML_ELEMENT_NODE() and + # $_->localName eq $name } $node->childNodes(); + # } + # return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1); + my @nodes = $node->_getChildrenByTagNameNS('*',$name); + return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1); +} + +sub getChildrenByTagNameNS { + my ( $node, $nsURI, $name ) = @_; + my @nodes = $node->_getChildrenByTagNameNS($nsURI,$name); + return wantarray ? @nodes : XML::LibXML::NodeList->new_from_ref(\@nodes, 1); +} + +sub appendWellBalancedChunk { + my ( $self, $chunk ) = @_; + + my $local_parser = XML::LibXML->new(); + my $frag = $local_parser->parse_xml_chunk( $chunk ); + + $self->appendChild( $frag ); +} + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::Text Interface # +#-------------------------------------------------------------------------# +package XML::LibXML::Text; + +use vars qw(@ISA); +@ISA = ('XML::LibXML::Node'); + +sub attributes { return undef; } + +sub deleteDataString { + my $node = shift; + my $string = shift; + my $all = shift; + my $data = $node->nodeValue(); + $string =~ s/([\\\*\+\^\{\}\&\?\[\]\(\)\$\%\@])/\\$1/g; + if ( $all ) { + $data =~ s/$string//g; + } + else { + $data =~ s/$string//; + } + $node->setData( $data ); +} + +sub replaceDataString { + my ( $node, $left, $right,$all ) = @_; + + #ashure we exchange the strings and not expressions! + $left =~ s/([\\\*\+\^\{\}\&\?\[\]\(\)\$\%\@])/\\$1/g; + my $datastr = $node->nodeValue(); + if ( $all ) { + $datastr =~ s/$left/$right/g; + } + else{ + $datastr =~ s/$left/$right/; + } + $node->setData( $datastr ); +} + +sub replaceDataRegEx { + my ( $node, $leftre, $rightre, $flags ) = @_; + return unless defined $leftre; + $rightre ||= ""; + + my $datastr = $node->nodeValue(); + my $restr = "s/" . $leftre . "/" . $rightre . "/"; + $restr .= $flags if defined $flags; + + eval '$datastr =~ '. $restr; + + $node->setData( $datastr ); +} + +1; + +package XML::LibXML::Comment; + +use vars qw(@ISA); +@ISA = ('XML::LibXML::Text'); + +1; + +package XML::LibXML::CDATASection; + +use vars qw(@ISA); +@ISA = ('XML::LibXML::Text'); + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::Attribute Interface # +#-------------------------------------------------------------------------# +package XML::LibXML::Attr; +use vars qw( @ISA ) ; +@ISA = ('XML::LibXML::Node') ; + +sub setNamespace { + my ($self,$href,$prefix) = @_; + my $n = $self->nodeName; + if ( $self->_setNamespace($href,$prefix) ) { + $self->setNodeName($n); + return 1; + } + + return 0; +} + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::Dtd Interface # +#-------------------------------------------------------------------------# +# this is still under construction +# +package XML::LibXML::Dtd; +use vars qw( @ISA ); +@ISA = ('XML::LibXML::Node'); + +# at least DESTROY and CLONE_SKIP must be inherited + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::PI Interface # +#-------------------------------------------------------------------------# +package XML::LibXML::PI; +use vars qw( @ISA ); +@ISA = ('XML::LibXML::Node'); + +sub setData { + my $pi = shift; + + my $string = ""; + if ( scalar @_ == 1 ) { + $string = shift; + } + else { + my %h = @_; + $string = join " ", map {$_.'="'.$h{$_}.'"'} keys %h; + } + + # the spec says any char but "?>" [17] + $pi->_setData( $string ) unless $string =~ /\?>/; +} + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::Namespace Interface # +#-------------------------------------------------------------------------# +package XML::LibXML::Namespace; + +sub CLONE_SKIP { 1 } + +# this is infact not a node! +sub prefix { return "xmlns"; } +sub getPrefix { return "xmlns"; } +sub getNamespaceURI { return "http://www.w3.org/2000/xmlns/" }; + +sub getNamespaces { return (); } + +sub nodeName { + my $self = shift; + my $nsP = $self->localname; + return ( defined($nsP) && length($nsP) ) ? "xmlns:$nsP" : "xmlns"; +} +sub name { goto &nodeName } +sub getName { goto &nodeName } + +sub isEqualNode { + my ( $self, $ref ) = @_; + if ( ref($ref) eq "XML::LibXML::Namespace" ) { + return $self->_isEqual($ref); + } + return 0; +} + +sub isSameNode { + my ( $self, $ref ) = @_; + if ( $$self == $$ref ){ + return 1; + } + return 0; +} + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::NamedNodeMap Interface # +#-------------------------------------------------------------------------# +package XML::LibXML::NamedNodeMap; + +use XML::LibXML qw(:libxml); + +sub CLONE_SKIP { + return $XML::LibXML::__threads_shared ? 0 : 1; +} + +sub new { + my $class = shift; + my $self = bless { Nodes => [@_] }, $class; + $self->{NodeMap} = { map { $_->nodeName => $_ } @_ }; + return $self; +} + +sub length { return scalar( @{$_[0]->{Nodes}} ); } +sub nodes { return $_[0]->{Nodes}; } +sub item { $_[0]->{Nodes}->[$_[1]]; } + +sub getNamedItem { + my $self = shift; + my $name = shift; + + return $self->{NodeMap}->{$name}; +} + +sub setNamedItem { + my $self = shift; + my $node = shift; + + my $retval; + if ( defined $node ) { + if ( scalar @{$self->{Nodes}} ) { + my $name = $node->nodeName(); + if ( $node->nodeType() == XML_NAMESPACE_DECL ) { + return; + } + if ( defined $self->{NodeMap}->{$name} ) { + if ( $node->isSameNode( $self->{NodeMap}->{$name} ) ) { + return; + } + $retval = $self->{NodeMap}->{$name}->replaceNode( $node ); + } + else { + $self->{Nodes}->[0]->addSibling($node); + } + + $self->{NodeMap}->{$name} = $node; + push @{$self->{Nodes}}, $node; + } + else { + # not done yet + # can this be properly be done??? + warn "not done yet\n"; + } + } + return $retval; +} + +sub removeNamedItem { + my $self = shift; + my $name = shift; + my $retval; + if ( $name =~ /^xmlns/ ) { + warn "not done yet\n"; + } + elsif ( exists $self->{NodeMap}->{$name} ) { + $retval = $self->{NodeMap}->{$name}; + $retval->unbindNode; + delete $self->{NodeMap}->{$name}; + $self->{Nodes} = [grep {not($retval->isSameNode($_))} @{$self->{Nodes}}]; + } + + return $retval; +} + +sub getNamedItemNS { + my $self = shift; + my $nsURI = shift; + my $name = shift; + return undef; +} + +sub setNamedItemNS { + my $self = shift; + my $nsURI = shift; + my $node = shift; + return undef; +} + +sub removeNamedItemNS { + my $self = shift; + my $nsURI = shift; + my $name = shift; + return undef; +} + +1; + +package XML::LibXML::_SAXParser; + +# this is pseudo class!!! and it will be removed as soon all functions +# moved to XS level + +use XML::SAX::Exception; + +sub CLONE_SKIP { + return $XML::LibXML::__threads_shared ? 0 : 1; +} + +# these functions will use SAX exceptions as soon i know how things really work +sub warning { + my ( $parser, $message, $line, $col ) = @_; + my $error = XML::SAX::Exception::Parse->new( LineNumber => $line, + ColumnNumber => $col, + Message => $message, ); + $parser->{HANDLER}->warning( $error ); +} + +sub error { + my ( $parser, $message, $line, $col ) = @_; + + my $error = XML::SAX::Exception::Parse->new( LineNumber => $line, + ColumnNumber => $col, + Message => $message, ); + $parser->{HANDLER}->error( $error ); +} + +sub fatal_error { + my ( $parser, $message, $line, $col ) = @_; + my $error = XML::SAX::Exception::Parse->new( LineNumber => $line, + ColumnNumber => $col, + Message => $message, ); + $parser->{HANDLER}->fatal_error( $error ); +} + +1; + +package XML::LibXML::RelaxNG; + +sub CLONE_SKIP { 1 } + +sub new { + my $class = shift; + my %args = @_; + + my $self = undef; + if ( defined $args{location} ) { + $self = $class->parse_location( $args{location} ); + } + elsif ( defined $args{string} ) { + $self = $class->parse_buffer( $args{string} ); + } + elsif ( defined $args{DOM} ) { + $self = $class->parse_document( $args{DOM} ); + } + + return $self; +} + +1; + +package XML::LibXML::Schema; + +sub CLONE_SKIP { 1 } + +sub new { + my $class = shift; + my %args = @_; + + my $self = undef; + if ( defined $args{location} ) { + $self = $class->parse_location( $args{location} ); + } + elsif ( defined $args{string} ) { + $self = $class->parse_buffer( $args{string} ); + } + + return $self; +} + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::Pattern Interface # +#-------------------------------------------------------------------------# + +package XML::LibXML::Pattern; + +sub CLONE_SKIP { 1 } + +sub new { + my $class = shift; + my ($pattern,$ns_map)=@_; + my $self = undef; + + unless (UNIVERSAL::can($class,'_compilePattern')) { + croak("Cannot create XML::LibXML::Pattern - ". + "your libxml2 is compiled without pattern support!"); + } + + if (ref($ns_map) eq 'HASH') { + # translate prefix=>URL hash to a (URL,prefix) list + $self = $class->_compilePattern($pattern,0,[reverse %$ns_map]); + } else { + $self = $class->_compilePattern($pattern,0); + } + return $self; +} + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::RegExp Interface # +#-------------------------------------------------------------------------# + +package XML::LibXML::RegExp; + +sub CLONE_SKIP { 1 } + +sub new { + my $class = shift; + my ($regexp)=@_; + unless (UNIVERSAL::can($class,'_compile')) { + croak("Cannot create XML::LibXML::RegExp - ". + "your libxml2 is compiled without regexp support!"); + } + return $class->_compile($regexp); +} + +1; + +#-------------------------------------------------------------------------# +# XML::LibXML::XPathExpression Interface # +#-------------------------------------------------------------------------# + +package XML::LibXML::XPathExpression; + +sub CLONE_SKIP { 1 } + +1; + + +#-------------------------------------------------------------------------# +# XML::LibXML::InputCallback Interface # +#-------------------------------------------------------------------------# +package XML::LibXML::InputCallback; + +use vars qw($_CUR_CB @_GLOBAL_CALLBACKS @_CB_STACK); + +BEGIN { + $_CUR_CB = undef; + @_GLOBAL_CALLBACKS = (); + @_CB_STACK = (); +} + +sub CLONE_SKIP { + return $XML::LibXML::__threads_shared ? 0 : 1; +} + +#-------------------------------------------------------------------------# +# global callbacks # +#-------------------------------------------------------------------------# +sub _callback_match { + my $uri = shift; + my $retval = 0; + + # loop through the callbacks and and find the first matching + # The callbacks are stored in execution order (reverse stack order) + # any new global callbacks are shifted to the callback stack. + foreach my $cb ( @_GLOBAL_CALLBACKS ) { + + # callbacks have to return 1, 0 or undef, while 0 and undef + # are handled the same way. + # in fact, if callbacks return other values, the global match + # assumes silently that the callback failed. + + $retval = $cb->[0]->($uri); + + if ( defined $retval and $retval == 1 ) { + # make the other callbacks use this callback + $_CUR_CB = $cb; + unshift @_CB_STACK, $cb; + last; + } + } + + return $retval; +} + +sub _callback_open { + my $uri = shift; + my $retval = undef; + + # the open callback has to return a defined value. + # if one works on files this can be a file handle. But + # depending on the needs of the callback it also can be a + # database handle or a integer labeling a certain dataset. + + if ( defined $_CUR_CB ) { + $retval = $_CUR_CB->[1]->( $uri ); + + # reset the callbacks, if one callback cannot open an uri + if ( not defined $retval or $retval == 0 ) { + shift @_CB_STACK; + $_CUR_CB = $_CB_STACK[0]; + } + } + + return $retval; +} + +sub _callback_read { + my $fh = shift; + my $buflen = shift; + + my $retval = undef; + + if ( defined $_CUR_CB ) { + $retval = $_CUR_CB->[2]->( $fh, $buflen ); + } + + return $retval; +} + +sub _callback_close { + my $fh = shift; + my $retval = 0; + + if ( defined $_CUR_CB ) { + $retval = $_CUR_CB->[3]->( $fh ); + shift @_CB_STACK; + $_CUR_CB = $_CB_STACK[0]; + } + + return $retval; +} + +#-------------------------------------------------------------------------# +# member functions and methods # +#-------------------------------------------------------------------------# + +sub new { + my $CLASS = shift; + return bless {'_CALLBACKS' => []}, $CLASS; +} + +# add a callback set to the callback stack +# synopsis: $icb->register_callbacks( [$match_cb, $open_cb, $read_cb, $close_cb] ); +sub register_callbacks { + my $self = shift; + my $cbset = shift; + + # test if callback set is complete + if ( ref $cbset eq "ARRAY" and scalar( @$cbset ) == 4 ) { + unshift @{$self->{_CALLBACKS}}, $cbset; + } +} + +# remove a callback set to the callback stack +# if a callback set is passed, this function will check for the match function +sub unregister_callbacks { + my $self = shift; + my $cbset = shift; + if ( ref $cbset eq "ARRAY" and scalar( @$cbset ) == 4 ) { + $self->{_CALLBACKS} = [grep { $_->[0] != $cbset->[0] } @{$self->{_CALLBACKS}}]; + } + else { + shift @{$self->{_CALLBACKS}}; + } +} + +# make libxml2 use the callbacks +sub init_callbacks { + my $self = shift; + + $_CUR_CB = undef; + @_CB_STACK = (); + + @_GLOBAL_CALLBACKS = @{ $self->{_CALLBACKS} }; + + if ( defined $XML::LibXML::match_cb and + defined $XML::LibXML::open_cb and + defined $XML::LibXML::read_cb and + defined $XML::LibXML::close_cb ) { + push @_GLOBAL_CALLBACKS, [$XML::LibXML::match_cb, + $XML::LibXML::open_cb, + $XML::LibXML::read_cb, + $XML::LibXML::close_cb]; + } + + $self->lib_init_callbacks(); +} + +# reset libxml2's callbacks +sub cleanup_callbacks { + my $self = shift; + + $_CUR_CB = undef; + @_GLOBAL_CALLBACKS = (); + @_CB_STACK = (); + + $self->lib_cleanup_callbacks(); +} + +$XML::LibXML::__loaded=1; + +1; + +__END__ |