home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / LibXML.pm < prev    next >
Encoding:
Perl POD Document  |  2003-08-22  |  29.9 KB  |  1,165 lines
  1. # $Id: LibXML.pm,v 1.94 2003/08/23 00:07:06 phish Exp $
  2.  
  3. package XML::LibXML;
  4.  
  5. use strict;
  6. use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS
  7.             $skipDTD $skipXMLDeclaration $setTagCompression
  8.             $MatchCB $ReadCB $OpenCB $CloseCB );
  9. use Carp;
  10.  
  11. use XML::LibXML::Common qw(:encoding :libxml);
  12.  
  13. use XML::LibXML::NodeList;
  14. use IO::Handle; # for FH reads called as methods
  15.  
  16.  
  17. $VERSION = "1.56";
  18. require Exporter;
  19. require DynaLoader;
  20.  
  21. @ISA = qw(DynaLoader Exporter);
  22.  
  23. #-------------------------------------------------------------------------#
  24. # export information                                                      #
  25. #-------------------------------------------------------------------------#
  26. %EXPORT_TAGS = (
  27.                 all => [qw(
  28.                            XML_ELEMENT_NODE
  29.                            XML_ATTRIBUTE_NODE
  30.                            XML_TEXT_NODE
  31.                            XML_CDATA_SECTION_NODE
  32.                            XML_ENTITY_REF_NODE
  33.                            XML_ENTITY_NODE
  34.                            XML_PI_NODE
  35.                            XML_COMMENT_NODE
  36.                            XML_DOCUMENT_NODE
  37.                            XML_DOCUMENT_TYPE_NODE
  38.                            XML_DOCUMENT_FRAG_NODE
  39.                            XML_NOTATION_NODE
  40.                            XML_HTML_DOCUMENT_NODE
  41.                            XML_DTD_NODE
  42.                            XML_ELEMENT_DECL
  43.                            XML_ATTRIBUTE_DECL
  44.                            XML_ENTITY_DECL
  45.                            XML_NAMESPACE_DECL
  46.                            XML_XINCLUDE_END
  47.                            XML_XINCLUDE_START
  48.                            encodeToUTF8
  49.                            decodeFromUTF8
  50.                           )],
  51.                 libxml => [qw(
  52.                            XML_ELEMENT_NODE
  53.                            XML_ATTRIBUTE_NODE
  54.                            XML_TEXT_NODE
  55.                            XML_CDATA_SECTION_NODE
  56.                            XML_ENTITY_REF_NODE
  57.                            XML_ENTITY_NODE
  58.                            XML_PI_NODE
  59.                            XML_COMMENT_NODE
  60.                            XML_DOCUMENT_NODE
  61.                            XML_DOCUMENT_TYPE_NODE
  62.                            XML_DOCUMENT_FRAG_NODE
  63.                            XML_NOTATION_NODE
  64.                            XML_HTML_DOCUMENT_NODE
  65.                            XML_DTD_NODE
  66.                            XML_ELEMENT_DECL
  67.                            XML_ATTRIBUTE_DECL
  68.                            XML_ENTITY_DECL
  69.                            XML_NAMESPACE_DECL
  70.                            XML_XINCLUDE_END
  71.                            XML_XINCLUDE_START
  72.                           )],
  73.                 encoding => [qw(
  74.                                 encodeToUTF8
  75.                                 decodeFromUTF8
  76.                                )],
  77.                );
  78.  
  79. @EXPORT_OK = (
  80.               @{$EXPORT_TAGS{all}},
  81.              );
  82.  
  83. @EXPORT = (
  84.            @{$EXPORT_TAGS{all}},
  85.           );
  86.  
  87. #-------------------------------------------------------------------------#
  88. # initialization of the global variables                                  #
  89. #-------------------------------------------------------------------------#
  90. $skipDTD            = 0;
  91. $skipXMLDeclaration = 0;
  92. $setTagCompression  = 0;
  93.  
  94. $MatchCB = undef;
  95. $ReadCB  = undef;
  96. $OpenCB  = undef;
  97. $CloseCB = undef;
  98.  
  99. #-------------------------------------------------------------------------#
  100. # bootstrapping                                                           #
  101. #-------------------------------------------------------------------------#
  102. bootstrap XML::LibXML $VERSION;
  103.  
  104. #-------------------------------------------------------------------------#
  105. # parser constructor                                                      #
  106. #-------------------------------------------------------------------------#
  107. sub new {
  108.     my $class = shift;
  109.     my %options = @_;
  110.     if ( not exists $options{XML_LIBXML_KEEP_BLANKS} ) {
  111.         $options{XML_LIBXML_KEEP_BLANKS} = 1;
  112.     }
  113.  
  114.     if ( defined $options{catalog} ) {
  115.         $class->load_catalog( $options{catalog} );
  116.         delete $options{catalog};
  117.     }
  118.  
  119.     my $self = bless \%options, $class;
  120.     if ( defined $options{Handler} ) {
  121.         $self->set_handler( $options{Handler} );
  122.     }
  123.  
  124.     return $self;
  125. }
  126.  
  127. #-------------------------------------------------------------------------#
  128. # callback functions                                                      #
  129. #-------------------------------------------------------------------------#
  130. sub match_callback {
  131.     my $self = shift;
  132.     if ( ref $self ) {
  133.         $self->{XML_LIBXML_MATCH_CB} = shift if scalar @_;
  134.         return $self->{XML_LIBXML_MATCH_CB};
  135.     }
  136.     else {
  137.         $MatchCB = shift if scalar @_;
  138.         return $MatchCB;
  139.     }
  140. }
  141.  
  142. sub read_callback {
  143.     my $self = shift;
  144.     if ( ref $self ) {
  145.         $self->{XML_LIBXML_READ_CB} = shift if scalar @_;
  146.         return $self->{XML_LIBXML_READ_CB};
  147.     }
  148.     else {
  149.         $ReadCB = shift if scalar @_;
  150.         return $ReadCB;
  151.     }
  152. }
  153.  
  154. sub close_callback {
  155.     my $self = shift;
  156.     if ( ref $self ) {
  157.         $self->{XML_LIBXML_CLOSE_CB} = shift if scalar @_;
  158.         return $self->{XML_LIBXML_CLOSE_CB};
  159.     }
  160.     else {
  161.         $CloseCB = shift if scalar @_;
  162.         return $CloseCB;
  163.     }
  164. }
  165.  
  166. sub open_callback {
  167.     my $self = shift;
  168.     if ( ref $self ) {
  169.         $self->{XML_LIBXML_OPEN_CB} = shift if scalar @_;
  170.         return $self->{XML_LIBXML_OPEN_CB};
  171.     }
  172.     else {
  173.         $OpenCB = shift if scalar @_;
  174.         return $OpenCB;
  175.     }
  176. }
  177.  
  178. sub callbacks {
  179.     my $self = shift;
  180.     if ( ref $self ) {
  181.         if (@_) {
  182.             my ($match, $open, $read, $close) = @_;
  183.             @{$self}{qw(XML_LIBXML_MATCH_CB XML_LIBXML_OPEN_CB XML_LIBXML_READ_CB XML_LIBXML_CLOSE_CB)} = ($match, $open, $read, $close);
  184.         }
  185.         else {
  186.             return @{$self}{qw(XML_LIBXML_MATCH_CB XML_LIBXML_OPEN_CB XML_LIBXML_READ_CB XML_LIBXML_CLOSE_CB)};
  187.         }
  188.     }
  189.     else {
  190.         if (@_) {
  191.            ( $MatchCB, $OpenCB, $ReadCB, $CloseCB ) = @_;
  192.         }
  193.         else {
  194.             return ( $MatchCB, $OpenCB, $ReadCB, $CloseCB );
  195.         }
  196.     }
  197. }
  198.  
  199. #-------------------------------------------------------------------------#
  200. # member variable manipulation                                            #
  201. #-------------------------------------------------------------------------#
  202. sub validation {
  203.     my $self = shift;
  204.     $self->{XML_LIBXML_VALIDATION} = shift if scalar @_;
  205.     return $self->{XML_LIBXML_VALIDATION};
  206. }
  207.  
  208. sub recover {
  209.     my $self = shift;
  210.     $self->{XML_LIBXML_RECOVER} = shift if scalar @_;
  211.     return $self->{XML_LIBXML_RECOVER};
  212. }
  213.  
  214. sub expand_entities {
  215.     my $self = shift;
  216.     $self->{XML_LIBXML_EXPAND_ENTITIES} = shift if scalar @_;
  217.     return $self->{XML_LIBXML_EXPAND_ENTITIES};
  218. }
  219.  
  220. sub keep_blanks {
  221.     my $self = shift;
  222.     $self->{XML_LIBXML_KEEP_BLANKS} = shift if scalar @_;
  223.     return $self->{XML_LIBXML_KEEP_BLANKS};
  224. }
  225.  
  226. sub pedantic_parser {
  227.     my $self = shift;
  228.     $self->{XML_LIBXML_PEDANTIC} = shift if scalar @_;
  229.     return $self->{XML_LIBXML_PEDANTIC};
  230. }
  231.  
  232. sub line_numbers {
  233.     my $self = shift;
  234.     $self->{XML_LIBXML_LINENUMBERS} = shift if scalar @_;
  235.     return $self->{XML_LIBXML_LINENUMBERS};
  236. }
  237.  
  238. sub load_ext_dtd {
  239.     my $self = shift;
  240.     $self->{XML_LIBXML_EXT_DTD} = shift if scalar @_;
  241.     return $self->{XML_LIBXML_EXT_DTD};
  242. }
  243.  
  244. sub complete_attributes {
  245.     my $self = shift;
  246.     $self->{XML_LIBXML_COMPLETE_ATTR} = shift if scalar @_;
  247.     return $self->{XML_LIBXML_COMPLETE_ATTR};
  248. }
  249.  
  250. sub expand_xinclude  {
  251.     my $self = shift;
  252.     $self->{XML_LIBXML_EXPAND_XINCLUDE} = shift if scalar @_;
  253.     return $self->{XML_LIBXML_EXPAND_XINCLUDE};
  254. }
  255.  
  256. sub base_uri {
  257.     my $self = shift;
  258.     $self->{XML_LIBXML_BASE_URI} = shift if scalar @_;
  259.     return $self->{XML_LIBXML_BASE_URI};
  260. }
  261.  
  262. sub gdome_dom {
  263.     my $self = shift;
  264.     $self->{XML_LIBXML_GDOME} = shift if scalar @_;
  265.     return $self->{XML_LIBXML_GDOME};
  266. }
  267.  
  268.  
  269. #-------------------------------------------------------------------------#
  270. # set the optional SAX(2) handler                                         #
  271. #-------------------------------------------------------------------------#
  272. sub set_handler {
  273.     my $self = shift;
  274.     if ( defined $_[0] ) {
  275.         $self->{HANDLER} = $_[0];
  276.  
  277.         $self->{SAX_ELSTACK} = [];
  278.         $self->{SAX} = {State => 0};
  279.     }
  280.     else {
  281.         # undef SAX handling
  282.         $self->{SAX_ELSTACK} = [];
  283.         delete $self->{HANDLER};
  284.         delete $self->{SAX};
  285.     }
  286. }
  287.  
  288. #-------------------------------------------------------------------------#
  289. # helper functions                                                        #
  290. #-------------------------------------------------------------------------#
  291. sub _auto_expand {
  292.     my ( $self, $result, $uri ) = @_;
  293.  
  294.     $result->setBaseURI( $uri ) if defined $uri;
  295.  
  296.     if ( defined $self->{XML_LIBXML_EXPAND_XINCLUDE}
  297.          and  $self->{XML_LIBXML_EXPAND_XINCLUDE} == 1 ) {
  298.         $self->{_State_} = 1;
  299.         eval { $self->processXIncludes($result); };
  300.             my $err = $@;
  301.         $self->{_State_} = 0;
  302.         if ($err) {
  303.             $result = undef;
  304.             croak $err;
  305.         }
  306.     }
  307.     return $result;
  308. }
  309.  
  310. sub __read {
  311.     read($_[0], $_[1], $_[2]);
  312. }
  313.  
  314. sub __write {
  315.     if ( ref( $_[0] ) ) {
  316.         $_[0]->write( $_[1], $_[2] );
  317.     }
  318.     else {
  319.         $_[0]->write( $_[1] );
  320.     }
  321. }
  322.  
  323. #-------------------------------------------------------------------------#
  324. # parsing functions                                                       #
  325. #-------------------------------------------------------------------------#
  326. # all parsing functions handle normal as SAX parsing at the same time.
  327. # note that SAX parsing is handled incomplete! use XML::LibXML::SAX for
  328. # complete parsing sequences
  329. #-------------------------------------------------------------------------#
  330. sub parse_string {
  331.     my $self = shift;
  332.     croak("parse already in progress") if $self->{_State_};
  333.  
  334.     unless ( defined $_[0] and length $_[0] ) {
  335.         croak("Empty String");
  336.     }
  337.  
  338.     $self->{_State_} = 1;
  339.     my $result;
  340.  
  341.     if ( defined $self->{SAX} ) {
  342.         my $string = shift;
  343.         $self->{SAX_ELSTACK} = [];
  344.         eval {
  345.             $self->_parse_sax_string($string);
  346.         };
  347.         my $err = $@;
  348.         $self->{_State_} = 0;
  349.         if ($err) {
  350.             croak $err;
  351.         }
  352.     }
  353.     else {
  354.         eval { $result = $self->_parse_string( @_ ); };
  355.  
  356.         my $err = $@;
  357.         $self->{_State_} = 0;
  358.         if ($err) {
  359.             croak $err;
  360.         }
  361.  
  362.         $result = $self->_auto_expand( $result, $self->{XML_LIBXML_BASE_URI} );
  363.     }
  364.  
  365.     return $result;
  366. }
  367.  
  368. sub parse_fh {
  369.     my $self = shift;
  370.     croak("parse already in progress") if $self->{_State_};
  371.     $self->{_State_} = 1;
  372.     my $result;
  373.     if ( defined $self->{SAX} ) {
  374.         $self->{SAX_ELSTACK} = [];
  375.         eval { $self->_parse_sax_fh( @_ );  };
  376.         my $err = $@;
  377.         $self->{_State_} = 0;
  378.         if ($err) {
  379.             croak $err;
  380.         }
  381.     }
  382.     else {
  383.         eval { $result = $self->_parse_fh( @_ ); };
  384.         my $err = $@;
  385.         $self->{_State_} = 0;
  386.         if ($err) {
  387.             croak $err;
  388.         }
  389.  
  390.         $result = $self->_auto_expand( $result,, $self->{XML_LIBXML_BASE_URI} );
  391.     }
  392.  
  393.     return $result;
  394. }
  395.  
  396. sub parse_file {
  397.     my $self = shift;
  398.     croak("parse already in progress") if $self->{_State_};
  399.     $self->{_State_} = 1;
  400.     my $result;
  401.     if ( defined $self->{SAX} ) {
  402.         $self->{SAX_ELSTACK} = [];
  403.         eval { $self->_parse_sax_file( @_ );  };
  404.         my $err = $@;
  405.         $self->{_State_} = 0;
  406.         if ($err) {
  407.             croak $err;
  408.         }
  409.     }
  410.     else {
  411.         eval { $result = $self->_parse_file(@_); };
  412.         my $err = $@;
  413.         $self->{_State_} = 0;
  414.         if ($err) {
  415.             croak $err;
  416.         }
  417.  
  418.         $result = $self->_auto_expand( $result );
  419.     }
  420.  
  421.     return $result;
  422. }
  423.  
  424. sub parse_xml_chunk {
  425.     my $self = shift;
  426.     # max 2 parameter:
  427.     # 1: the chunk
  428.     # 2: the encoding of the string
  429.     croak("parse already in progress") if $self->{_State_};    my $result;
  430.  
  431.     unless ( defined $_[0] and length $_[0] ) {
  432.         croak("Empty String");
  433.     }
  434.  
  435.     $self->{_State_} = 1;
  436.     if ( defined $self->{SAX} ) {
  437.         eval {
  438.             $self->_parse_sax_xml_chunk( @_ );
  439.  
  440.             # this is required for XML::GenericChunk.
  441.             # in normal case is_filter is not defined, an thus the parsing
  442.             # will be terminated. in case of a SAX filter the parsing is not
  443.             # finished at that state. therefore we must not reset the parsing
  444.             unless ( $self->{IS_FILTER} ) {
  445.                 $result = $self->{HANDLER}->end_document();
  446.             }
  447.         };
  448.     }
  449.     else {
  450.         eval { $result = $self->_parse_xml_chunk( @_ ); };
  451.     }
  452.  
  453.     my $err = $@;
  454.     $self->{_State_} = 0;
  455.     if ($err) {
  456.         croak $err;
  457.     }
  458.  
  459.     return $result;
  460. }
  461.  
  462. sub parse_balanced_chunk {
  463.     my $self = shift;
  464.     return $self->parse_xml_chunk( @_ );
  465. }
  466.  
  467. # java style
  468. sub processXIncludes {
  469.     my $self = shift;
  470.     my $doc = shift;
  471.     return $self->_processXIncludes($doc || " ");
  472. }
  473.  
  474. # perl style
  475. sub process_xincludes {
  476.     my $self = shift;
  477.     my $doc = shift;
  478.     return $self->_processXIncludes($doc || " ");
  479. }
  480.  
  481.  
  482. #-------------------------------------------------------------------------#
  483. # push parser interface                                                   #
  484. #-------------------------------------------------------------------------#
  485. sub init_push {
  486.     my $self = shift;
  487.  
  488.     if ( defined $self->{CONTEXT} ) {
  489.         delete $self->{CONTEXT};
  490.     }
  491.  
  492.     if ( defined $self->{SAX} ) {
  493.         $self->{CONTEXT} = $self->_start_push(1);
  494.     }
  495.     else {
  496.         $self->{CONTEXT} = $self->_start_push(0);
  497.     }
  498. }
  499.  
  500. sub push {
  501.     my $self = shift;
  502.  
  503.     if ( not defined $self->{CONTEXT} ) {
  504.         $self->init_push();
  505.     }
  506.  
  507.     foreach ( @_ ) {
  508.         $self->_push( $self->{CONTEXT}, $_ );
  509.     }
  510. }
  511.  
  512. # this function should be promoted!
  513. # the reason is because libxml2 uses xmlParseChunk() for this purpose!
  514. sub parse_chunk {
  515.     my $self = shift;
  516.     my $chunk = shift;
  517.     my $terminate = shift;
  518.  
  519.     if ( not defined $self->{CONTEXT} ) {
  520.         $self->init_push();
  521.     }
  522.  
  523.     if ( defined $chunk and length $chunk ) {
  524.         $self->_push( $self->{CONTEXT}, $chunk );
  525.     }
  526.  
  527.     if ( $terminate ) {
  528.         return $self->finish_push();
  529.     }
  530. }
  531.  
  532.  
  533. sub finish_push {
  534.     my $self = shift;
  535.     my $restore = shift || 0;
  536.     return undef unless defined $self->{CONTEXT};
  537.  
  538.     my $retval;
  539.  
  540.     if ( defined $self->{SAX} ) {
  541.         eval {
  542.             $self->_end_sax_push( $self->{CONTEXT} );
  543.             $retval = $self->{HANDLER}->end_document( {} );
  544.         };
  545.     }
  546.     else {
  547.         eval { $retval = $self->_end_push( $self->{CONTEXT}, $restore ); };
  548.     }
  549.  
  550.     delete $self->{CONTEXT};
  551.  
  552.     if ( $@ ) {
  553.         croak( $@ );
  554.     }
  555.     return $retval;
  556. }
  557.  
  558. 1;
  559.  
  560. #-------------------------------------------------------------------------#
  561. # XML::LibXML::Node Interface                                             #
  562. #-------------------------------------------------------------------------#
  563. package XML::LibXML::Node;
  564.  
  565. sub isSupported {
  566.     my $self    = shift;
  567.     my $feature = shift;
  568.     return $self->can($feature) ? 1 : 0;
  569. }
  570.  
  571. sub getChildNodes { my $self = shift; return $self->childNodes(); }
  572.  
  573. sub childNodes {
  574.     my $self = shift;
  575.     my @children = $self->_childNodes();
  576.     return wantarray ? @children : XML::LibXML::NodeList->new( @children );
  577. }
  578.  
  579. sub attributes {
  580.     my $self = shift;
  581.     my @attr = $self->_attributes();
  582.     return wantarray ? @attr : XML::LibXML::NamedNodeMap->new( @attr );
  583. }
  584.  
  585. sub iterator {
  586.     warn "this function is obsolete!\nIt was disabled in version 1.54\n";
  587.     return undef;
  588. }
  589.  
  590.  
  591. sub findnodes {
  592.     my ($node, $xpath) = @_;
  593.     my @nodes = $node->_findnodes($xpath);
  594.     if (wantarray) {
  595.         return @nodes;
  596.     }
  597.     else {
  598.         return XML::LibXML::NodeList->new(@nodes);
  599.     }
  600. }
  601.  
  602. sub findvalue {
  603.     my ($node, $xpath) = @_;
  604.     my $res;
  605.     eval {
  606.         $res = $node->find($xpath);
  607.     };
  608.     if  ( $@ ) {
  609.         die $@;
  610.     }
  611.     return $res->to_literal->value;
  612. }
  613.  
  614. sub find {
  615.     my ($node, $xpath) = @_;
  616.     my ($type, @params) = $node->_find($xpath);
  617.     if ($type) {
  618.         return $type->new(@params);
  619.     }
  620.     return undef;
  621. }
  622.  
  623. sub setOwnerDocument {
  624.     my ( $self, $doc ) = @_;
  625.     $doc->adoptNode( $self );
  626. }
  627.  
  628. sub toStringC14N {
  629.     my $self = shift;
  630.     my ($comments, $xpath) = @_;
  631.  
  632.     $comments = 0 unless defined $comments;
  633.     return $self->_toStringC14N( $comments, $xpath );
  634. }
  635.  
  636. sub serialize_c14n {
  637.     my $self = shift;
  638.     return $self->toStringC14N( @_ );
  639. }
  640.  
  641. 1;
  642.  
  643. #-------------------------------------------------------------------------#
  644. # XML::LibXML::Document Interface                                         #
  645. #-------------------------------------------------------------------------#
  646. package XML::LibXML::Document;
  647.  
  648. use vars qw(@ISA);
  649. @ISA = ('XML::LibXML::Node');
  650.  
  651. sub setDocumentElement {
  652.     my $doc = shift;
  653.     my $element = shift;
  654.  
  655.     my $oldelem = $doc->documentElement;
  656.     if ( defined $oldelem ) {
  657.         $doc->removeChild($oldelem);
  658.     }
  659.  
  660.     $doc->_setDocumentElement($element);
  661. }
  662.  
  663. sub toString {
  664.     my $self = shift;
  665.     my $flag = shift;
  666.  
  667.     my $retval = "";
  668.  
  669.     if ( defined $XML::LibXML::skipXMLDeclaration
  670.          and $XML::LibXML::skipXMLDeclaration == 1 ) {
  671.         foreach ( $self->childNodes ){
  672.             next if $_->nodeType == XML::LibXML::XML_DTD_NODE()
  673.                     and $XML::LibXML::skipDTD;
  674.             $retval .= $_->toString;
  675.         }
  676.     }
  677.     else {
  678.         $flag ||= 0 unless defined $flag;
  679.         $retval =  $self->_toString($flag);
  680.     }
  681.  
  682.     return $retval;
  683. }
  684.  
  685. sub serialize {
  686.     my $self = shift;
  687.     return $self->toString( @_ );
  688. }
  689.  
  690. #-------------------------------------------------------------------------#
  691. # bad style xinclude processing                                           #
  692. #-------------------------------------------------------------------------#
  693. sub process_xinclude {
  694.     my $self = shift;
  695.     XML::LibXML->new->processXIncludes( $self );
  696. }
  697.  
  698. sub insertProcessingInstruction {
  699.     my $self   = shift;
  700.     my $target = shift;
  701.     my $data   = shift;
  702.  
  703.     my $pi     = $self->createPI( $target, $data );
  704.     my $root   = $self->documentElement;
  705.  
  706.     if ( defined $root ) {
  707.         # this is actually not correct, but i guess it's what the user
  708.         # intends
  709.         $self->insertBefore( $pi, $root );
  710.     }
  711.     else {
  712.         # if no documentElement was found we just append the PI
  713.         $self->appendChild( $pi );
  714.     }
  715. }
  716.  
  717. sub insertPI {
  718.     my $self = shift;
  719.     $self->insertProcessingInstruction( @_ );
  720. }
  721.  
  722. #-------------------------------------------------------------------------#
  723. # DOM L3 Document functions.
  724. # added after robins implicit feature requst
  725. #-------------------------------------------------------------------------#
  726. sub getElementsByTagName {
  727.     my ( $doc , $name ) = @_;
  728.     my $xpath = "descendant-or-self::node()/$name";
  729.     my @nodes = $doc->_findnodes($xpath);
  730.     return wantarray ? @nodes : XML::LibXML::NodeList->new(@nodes);
  731. }
  732.  
  733. sub  getElementsByTagNameNS {
  734.     my ( $doc, $nsURI, $name ) = @_;
  735.     my $xpath = "descendant-or-self::*[local-name()='$name' and namespace-uri()='$nsURI']";
  736.     my @nodes = $doc->_findnodes($xpath);
  737.     return wantarray ? @nodes : XML::LibXML::NodeList->new(@nodes);
  738. }
  739.  
  740. sub getElementsByLocalName {
  741.     my ( $doc,$name ) = @_;
  742.     my $xpath = "descendant-or-self::*[local-name()='$name']";
  743.     my @nodes = $doc->_findnodes($xpath);
  744.     return wantarray ? @nodes : XML::LibXML::NodeList->new(@nodes);
  745. }
  746.  
  747. sub getElementsById {
  748.     my ( $doc, $id ) = @_;
  749.     return ($doc->findnodes( "id('$id')" ))[0];
  750. }
  751.  
  752. 1;
  753.  
  754. #-------------------------------------------------------------------------#
  755. # XML::LibXML::DocumentFragment Interface                                 #
  756. #-------------------------------------------------------------------------#
  757. package XML::LibXML::DocumentFragment;
  758.  
  759. use vars qw(@ISA);
  760. @ISA = ('XML::LibXML::Node');
  761.  
  762. sub toString {
  763.     my $self = shift;
  764.     my $retval = "";
  765.     if ( $self->hasChildNodes() ) {
  766.         foreach my $n ( $self->childNodes() ) {
  767.             $retval .= $n->toString(@_);
  768.         }
  769.     }
  770.     return $retval;
  771. }
  772.  
  773.  
  774. sub serialize {
  775.     my $self = shift;
  776.     return $self->toString(@_);
  777. }
  778.  
  779. 1;
  780.  
  781. #-------------------------------------------------------------------------#
  782. # XML::LibXML::Element Interface                                          #
  783. #-------------------------------------------------------------------------#
  784. package XML::LibXML::Element;
  785.  
  786. use vars qw(@ISA);
  787. @ISA = ('XML::LibXML::Node');
  788.  
  789. sub setNamespace {
  790.     my $self = shift;
  791.     my $n = $self->nodeName;
  792.     if ( $self->_setNamespace(@_) ){
  793.         if ( scalar @_ < 3 || $_[2] == 1 ){
  794.             $self->setNodeName( $n );
  795.         }
  796.         return 1;
  797.     }
  798.     return 0;
  799. }
  800.  
  801. sub setAttribute {
  802.     my ( $self, $name, $value ) = @_;
  803.     if ( $name =~ /^xmlns/ ) {
  804.         # user wants to set a namespace ...
  805.  
  806.         (my $lname = $name )=~s/^xmlns://;
  807.         my $nn = $self->nodeName;
  808.         if ( $nn =~ /^$lname\:/ ) {
  809.             $self->setNamespace($value, $lname);
  810.         }
  811.         else {
  812.             # use a ($active = 0) namespace
  813.             $self->setNamespace($value, $lname, 0);
  814.         }
  815.     }
  816.     else {
  817.         $self->_setAttribute($name, $value);
  818.     }
  819. }
  820.  
  821. sub getElementsByTagName {
  822.     my ( $node , $name ) = @_;
  823.     my $xpath = "descendant::$name";
  824.     my @nodes = $node->_findnodes($xpath);
  825.     return wantarray ? @nodes : XML::LibXML::NodeList->new(@nodes);
  826. }
  827.  
  828. sub  getElementsByTagNameNS {
  829.     my ( $node, $nsURI, $name ) = @_;
  830.     my $xpath = "descendant::*[local-name()='$name' and namespace-uri()='$nsURI']";
  831.     my @nodes = $node->_findnodes($xpath);
  832.     return wantarray ? @nodes : XML::LibXML::NodeList->new(@nodes);
  833. }
  834.  
  835. sub getElementsByLocalName {
  836.     my ( $node,$name ) = @_;
  837.     my $xpath = "descendant::*[local-name()='$name']";
  838.         my @nodes = $node->_findnodes($xpath);
  839.     return wantarray ? @nodes : XML::LibXML::NodeList->new(@nodes);
  840. }
  841.  
  842. sub getChildrenByTagName {
  843.     my ( $node, $name ) = @_;
  844.     my @nodes = grep { $_->nodeName eq $name } $node->childNodes();
  845.     return wantarray ? @nodes : XML::LibXML::NodeList->new(@nodes);
  846. }
  847.  
  848. sub getChildrenByTagNameNS {
  849.     my ( $node, $nsURI, $name ) = @_;
  850.     my $xpath = "*[local-name()='$name' and namespace-uri()='$nsURI']";
  851.     my @nodes = $node->_findnodes($xpath);
  852.     return wantarray ? @nodes : XML::LibXML::NodeList->new(@nodes);
  853. }
  854.  
  855. sub appendWellBalancedChunk {
  856.     my ( $self, $chunk ) = @_;
  857.  
  858.     my $local_parser = XML::LibXML->new();
  859.     my $frag = $local_parser->parse_xml_chunk( $chunk );
  860.  
  861.     $self->appendChild( $frag );
  862. }
  863.  
  864. 1;
  865.  
  866. #-------------------------------------------------------------------------#
  867. # XML::LibXML::Text Interface                                             #
  868. #-------------------------------------------------------------------------#
  869. package XML::LibXML::Text;
  870.  
  871. use vars qw(@ISA);
  872. @ISA = ('XML::LibXML::Node');
  873.  
  874. sub attributes { return undef; }
  875.  
  876. sub deleteDataString {
  877.     my $node = shift;
  878.     my $string = shift;
  879.     my $all    = shift;
  880.     my $data = $node->nodeValue();
  881.     $string =~ s/([\\\*\+\^\{\}\&\?\[\]\(\)\$\%\@])/\\$1/g;
  882.     if ( $all ) {
  883.         $data =~ s/$string//g;
  884.     }
  885.     else {
  886.         $data =~ s/$string//;
  887.     }
  888.     $node->setData( $data );
  889. }
  890.  
  891. sub replaceDataString {
  892.     my ( $node, $left, $right,$all ) = @_;
  893.  
  894.     #ashure we exchange the strings and not expressions!
  895.     $left  =~ s/([\\\*\+\^\{\}\&\?\[\]\(\)\$\%\@])/\\$1/g;
  896.     my $datastr = $node->nodeValue();
  897.     if ( $all ) {
  898.         $datastr =~ s/$left/$right/g;
  899.     }
  900.     else{
  901.         $datastr =~ s/$left/$right/;
  902.     }
  903.     $node->setData( $datastr );
  904. }
  905.  
  906. sub replaceDataRegEx {
  907.     my ( $node, $leftre, $rightre, $flags ) = @_;
  908.     return unless defined $leftre;
  909.     $rightre ||= "";
  910.  
  911.     my $datastr = $node->nodeValue();
  912.     my $restr   = "s/" . $leftre . "/" . $rightre . "/";
  913.     $restr .= $flags if defined $flags;
  914.  
  915.     eval '$datastr =~ '. $restr;
  916.  
  917.     $node->setData( $datastr );
  918. }
  919.  
  920. 1;
  921.  
  922. package XML::LibXML::Comment;
  923.  
  924. use vars qw(@ISA);
  925. @ISA = ('XML::LibXML::Text');
  926.  
  927. 1;
  928.  
  929. package XML::LibXML::CDATASection;
  930.  
  931. use vars qw(@ISA);
  932. @ISA     = ('XML::LibXML::Text');
  933.  
  934. 1;
  935.  
  936. #-------------------------------------------------------------------------#
  937. # XML::LibXML::Attribute Interface                                        #
  938. #-------------------------------------------------------------------------#
  939. package XML::LibXML::Attr;
  940. use vars qw( @ISA ) ;
  941. @ISA = ('XML::LibXML::Node') ;
  942.  
  943. sub setNamespace {
  944.     my ($self,$href,$prefix) = @_;
  945.     my $n = $self->nodeName;
  946.     if ( $self->_setNamespace($href,$prefix) ) {
  947.         $self->setNodeName($n);
  948.         return 1;
  949.     }
  950.  
  951.     return 0;
  952. }
  953.  
  954. 1;
  955.  
  956. #-------------------------------------------------------------------------#
  957. # XML::LibXML::Dtd Interface                                              #
  958. #-------------------------------------------------------------------------#
  959. # this is still under construction
  960. #
  961. package XML::LibXML::Dtd;
  962. use vars qw( @ISA );
  963. @ISA = ('XML::LibXML::Node');
  964.  
  965. 1;
  966.  
  967. #-------------------------------------------------------------------------#
  968. # XML::LibXML::PI Interface                                               #
  969. #-------------------------------------------------------------------------#
  970. package XML::LibXML::PI;
  971. use vars qw( @ISA );
  972. @ISA = ('XML::LibXML::Node');
  973.  
  974. sub setData {
  975.     my $pi = shift;
  976.  
  977.     my $string = "";
  978.     if ( scalar @_ == 1 ) {
  979.         $string = shift;
  980.     }
  981.     else {
  982.         my %h = @_;
  983.         $string = join " ", map {$_.'="'.$h{$_}.'"'} keys %h;
  984.     }
  985.  
  986.     # the spec says any char but "?>" [17]
  987.     $pi->_setData( $string ) unless  $string =~ /\?>/;
  988. }
  989.  
  990. 1;
  991.  
  992. #-------------------------------------------------------------------------#
  993. # XML::LibXML::Namespace Interface                                        #
  994. #-------------------------------------------------------------------------#
  995. package XML::LibXML::Namespace;
  996.  
  997. # this is infact not a node!
  998. sub prefix { return "xmlns"; }
  999.  
  1000. sub getNamespaces { return (); }
  1001.  
  1002. sub nodeName {
  1003.     my $self = shift;
  1004.     my $nsP  = $self->name;
  1005.     return ( defined($nsP) && length($nsP) ) ? "xmlns:$nsP" : "xmlns";
  1006. }
  1007.  
  1008. sub getNodeName { my $self = shift; return $self->nodeName; }
  1009.  
  1010. sub isEqualNode {
  1011.     my ( $self, $ref ) = @_;
  1012.     if ( ref($ref) eq "XML::LibXML::Namespace" ) {
  1013.         return $self->_isEqual($ref);
  1014.     }
  1015.     return 0;
  1016. }
  1017.  
  1018. sub isSameNode {
  1019.     my ( $self, $ref ) = @_;
  1020.     if ( $$self == $$ref ){
  1021.         return 1;
  1022.     }
  1023.     return 0;
  1024. }
  1025.  
  1026. 1;
  1027.  
  1028. #-------------------------------------------------------------------------#
  1029. # XML::LibXML::NamedNodeMap Interface                                     #
  1030. #-------------------------------------------------------------------------#
  1031. package XML::LibXML::NamedNodeMap;
  1032.  
  1033. use XML::LibXML::Common qw(:libxml);
  1034.  
  1035. sub new {
  1036.     my $class = shift;
  1037.     my $self = bless { Nodes => [@_] }, $class;
  1038.     $self->{NodeMap} = { map { $_->nodeName => $_ } @_ };
  1039.     return $self;
  1040. }
  1041.  
  1042. sub length     { return scalar( @{$_[0]->{Nodes}} ); }
  1043. sub nodes      { return $_[0]->{Nodes}; }
  1044. sub item       { $_[0]->{Nodes}->[$_[1]]; }
  1045.  
  1046. sub getNamedItem {
  1047.     my $self = shift;
  1048.     my $name = shift;
  1049.  
  1050.     return $self->{NodeMap}->{$name};
  1051. }
  1052.  
  1053. sub setNamedItem {
  1054.     my $self = shift;
  1055.     my $node = shift;
  1056.  
  1057.     my $retval;
  1058.     if ( defined $node ) {
  1059.         if ( scalar @{$self->{Nodes}} ) {
  1060.             my $name = $node->nodeName();
  1061.             if ( $node->nodeType() == XML_NAMESPACE_DECL ) {
  1062.                 return;
  1063.             }
  1064.             if ( defined $self->{NodeMap}->{$name} ) {
  1065.                 if ( $node->isSameNode( $self->{NodeMap}->{$name} ) ) {
  1066.                     return;
  1067.                 }
  1068.                 $retval = $self->{NodeMap}->{$name}->replaceNode( $node );
  1069.             }
  1070.             else {
  1071.                 $self->{Nodes}->[0]->addSibling($node);
  1072.             }
  1073.  
  1074.             $self->{NodeMap}->{$name} = $node;
  1075.             push @{$self->{Nodes}}, $node;
  1076.         }
  1077.         else {
  1078.             # not done yet
  1079.             # can this be properly be done???
  1080.             warn "not done yet\n";
  1081.         }
  1082.     }
  1083.     return $retval;
  1084. }
  1085.  
  1086. sub removeNamedItem {
  1087.     my $self = shift;
  1088.     my $name = shift;
  1089.     my $retval;
  1090.     if ( $name =~ /^xmlns/ ) {
  1091.         warn "not done yet\n";
  1092.     }
  1093.     elsif ( exists $self->{NodeMap}->{$name} ) {
  1094.         $retval = $self->{NodeMap}->{$name};
  1095.         $retval->unbindNode;
  1096.         delete $self->{NodeMap}->{$name};
  1097.         $self->{Nodes} = [grep {not($retval->isSameNode($_))} @{$self->{Nodes}}];
  1098.     }
  1099.  
  1100.     return $retval;
  1101. }
  1102.  
  1103. sub getNamedItemNS {
  1104.     my $self = shift;
  1105.     my $nsURI = shift;
  1106.     my $name = shift;
  1107.     return undef;
  1108. }
  1109.  
  1110. sub setNamedItemNS {
  1111.     my $self = shift;
  1112.     my $nsURI = shift;
  1113.     my $node = shift;
  1114.     return undef;
  1115. }
  1116.  
  1117. sub removeNamedItemNS {
  1118.     my $self = shift;
  1119.     my $nsURI = shift;
  1120.     my $name = shift;
  1121.     return undef;
  1122. }
  1123.  
  1124. 1;
  1125.  
  1126. package XML::LibXML::_SAXParser;
  1127.  
  1128. # this is pseudo class!!! and it will be removed as soon all functions
  1129. # moved to XS level
  1130.  
  1131. use XML::SAX::Exception;
  1132.  
  1133. # these functions will use SAX exceptions as soon i know how things really work
  1134. sub warning {
  1135.     my ( $parser, $message, $line, $col ) = @_;
  1136.     my $error = XML::SAX::Exception::Parse->new( LineNumber   => $line,
  1137.                                                  ColumnNumber => $col,
  1138.                                                  Message      => $message, );
  1139.     $parser->{HANDLER}->warning( $error );
  1140. }
  1141.  
  1142. sub error {
  1143.     my ( $parser, $message, $line, $col ) = @_;
  1144.  
  1145.     my $error = XML::SAX::Exception::Parse->new( LineNumber   => $line,
  1146.                                                  ColumnNumber => $col,
  1147.                                                  Message      => $message, );
  1148.     $parser->{HANDLER}->error( $error );
  1149. }
  1150.  
  1151. sub fatal_error {
  1152.     my ( $parser, $message, $line, $col ) = @_;
  1153.     my $error = XML::SAX::Exception::Parse->new( LineNumber   => $line,
  1154.                                                  ColumnNumber => $col,
  1155.                                                  Message      => $message, );
  1156.     $parser->{HANDLER}->fatal_error( $error );
  1157. }
  1158.  
  1159. 1;
  1160.  
  1161. #-------------------------------------------------------------------------#
  1162. # XML::LibXML Parser documentation                                        #
  1163. #-------------------------------------------------------------------------#
  1164. __END__
  1165.