local-lib5/lib/perl5/i486-linux-gnu-thread-multi/XML/LibXML/SAX/Parser.pm

   1 # $Id: Parser.pm 785 2009-07-16 14:17:46Z pajas $
   2 #
   3 # This is free software, you may use it and distribute it under the same terms as
   4 # Perl itself.
   5 #
   6 # Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas
   7 #
   8 #
   9
  10 package XML::LibXML::SAX::Parser;
  11
  12 use strict;
  13 use vars qw($VERSION @ISA);
  14
  15 use XML::LibXML;
  16 use XML::LibXML::Common qw(:libxml);
  17 use XML::SAX::Base;
  18 use XML::SAX::DocumentLocator;
  19
  20 $VERSION = "1.70"; # VERSION TEMPLATE: DO NOT CHANGE
  21 @ISA = ('XML::SAX::Base');
  22
  23 sub CLONE_SKIP {
  24   return $XML::LibXML::__threads_shared ? 0 : 1;
  25 }
  26
  27 sub _parse_characterstream {
  28     my ($self, $fh, $options) = @_;
  29     die "parsing a characterstream is not supported at this time";
  30 }
  31
  32 sub _parse_bytestream {
  33     my ($self, $fh, $options) = @_;
  34     my $parser = XML::LibXML->new();
  35     my $doc = exists($options->{Source}{SystemId}) ? $parser->parse_fh($fh, $options->{Source}{SystemId}) : $parser->parse_fh($fh);
  36     $self->generate($doc);
  37 }
  38
  39 sub _parse_string {
  40     my ($self, $str, $options) = @_;
  41     my $parser = XML::LibXML->new();
  42     my $doc = exists($options->{Source}{SystemId}) ? $parser->parse_string($str, $options->{Source}{SystemId}) : $parser->parse_string($str);
  43     $self->generate($doc);
  44 }
  45
  46 sub _parse_systemid {
  47     my ($self, $sysid, $options) = @_;
  48     my $parser = XML::LibXML->new();
  49     my $doc = $parser->parse_file($sysid);
  50     $self->generate($doc);
  51 }
  52
  53 sub generate {
  54     my $self = shift;
  55     my ($node) = @_;
  56
  57     my $doc = $node->ownerDocument();
  58     {
  59       # precompute some DocumentLocator values
  60       my %locator = (
  61         PublicId => undef,
  62         SystemId => undef,
  63         Encoding => undef,
  64         XMLVersion => undef,
  65        );
  66       my $dtd = defined $doc ? $doc->externalSubset() : undef;
  67       if (defined $dtd) {
  68         $locator{PublicId} = $dtd->publicId();
  69         $locator{SystemId} = $dtd->systemId();
  70       }
  71       if (defined $doc) {
  72         $locator{Encoding} = $doc->encoding();
  73         $locator{XMLVersion} = $doc->version();
  74       }
  75       $self->set_document_locator(
  76         XML::SAX::DocumentLocator->new(
  77           sub { $locator{PublicId} },
  78           sub { $locator{SystemId} },
  79           sub { defined($self->{current_node}) ? $self->{current_node}->line_number() : undef },
  80           sub { 1 },
  81           sub { $locator{Encoding} },
  82           sub { $locator{XMLVersion} },
  83          ),
  84        );
  85     }
  86
  87     if ( $node->nodeType() == XML_DOCUMENT_NODE
  88          || $node->nodeType == XML_HTML_DOCUMENT_NODE ) {
  89         $self->start_document({});
  90         $self->xml_decl({Version => $node->getVersion, Encoding => $node->getEncoding});
  91         $self->process_node($node);
  92         $self->end_document({});
  93     }
  94 }
  95
  96 sub process_node {
  97     my ($self, $node) = @_;
  98
  99     local $self->{current_node} = $node;
 100
 101     my $node_type = $node->nodeType();
 102     if ($node_type == XML_COMMENT_NODE) {
 103         $self->comment( { Data => $node->getData } );
 104     }
 105     elsif ($node_type == XML_TEXT_NODE
 106            || $node_type == XML_CDATA_SECTION_NODE) {
 107         # warn($node->getData . "\n");
 108         $self->characters( { Data => $node->nodeValue } );
 109     }
 110     elsif ($node_type == XML_ELEMENT_NODE) {
 111         # warn("<" . $node->getName . ">\n");
 112         $self->process_element($node);
 113         # warn("</" . $node->getName . ">\n");
 114     }
 115     elsif ($node_type == XML_ENTITY_REF_NODE) {
 116         foreach my $kid ($node->childNodes) {
 117             # warn("child of entity ref: " . $kid->getType() . " called: " . $kid->getName . "\n");
 118             $self->process_node($kid);
 119         }
 120     }
 121     elsif ($node_type == XML_DOCUMENT_NODE
 122            || $node_type == XML_HTML_DOCUMENT_NODE
 123            || $node_type == XML_DOCUMENT_FRAG_NODE) {
 124         # some times it is just usefull to generate SAX events from
 125         # a document fragment (very good with filters).
 126         foreach my $kid ($node->childNodes) {
 127             $self->process_node($kid);
 128         }
 129     }
 130     elsif ($node_type == XML_PI_NODE) {
 131         $self->processing_instruction( { Target =>  $node->getName, Data => $node->getData } );
 132     }
 133     elsif ($node_type == XML_COMMENT_NODE) {
 134         $self->comment( { Data => $node->getData } );
 135     }
 136     elsif ( $node_type == XML_XINCLUDE_START
 137             || $node_type == XML_XINCLUDE_END ) {
 138         # ignore!
 139         # i may want to handle this one day, dunno yet
 140     }
 141     elsif ($node_type == XML_DTD_NODE ) {
 142         # ignore!
 143         # i will support DTDs, but had no time yet.
 144     }
 145     else {
 146         # warn("unsupported node type: $node_type");
 147     }
 148
 149 }
 150
 151 sub process_element {
 152     my ($self, $element) = @_;
 153
 154     my $attribs = {};
 155     my @ns_maps = $element->getNamespaces;
 156
 157     foreach my $ns (@ns_maps) {
 158         $self->start_prefix_mapping(
 159             {
 160                 NamespaceURI => $ns->href,
 161                 Prefix       => ( defined $ns->localname  ? $ns->localname : ''),
 162             }
 163         );
 164     }
 165
 166     foreach my $attr ($element->attributes) {
 167         my $key;
 168         # warn("Attr: $attr -> ", $attr->getName, " = ", $attr->getData, "\n");
 169         # this isa dump thing...
 170         if ($attr->isa('XML::LibXML::Namespace')) {
 171             # TODO This needs fixing modulo agreeing on what
 172             # is the right thing to do here.
 173             unless ( defined $attr->name ) {
 174                 ## It's an atter like "xmlns='foo'"
 175                 $attribs->{"{}xmlns"} =
 176                   {
 177                    Name         => "xmlns",
 178                    LocalName    => "xmlns",
 179                    Prefix       => "",
 180                    Value        => $attr->href,
 181                    NamespaceURI => "",
 182                   };
 183             }
 184             else {
 185                 my $prefix = "xmlns";
 186                 my $localname = $attr->localname;
 187                 my $key = "{http://www.w3.org/2000/xmlns/}";
 188                 my $name = "xmlns";
 189
 190                 if ( defined $localname ) {
 191                     $key .= $localname;
 192                     $name.= ":".$localname;
 193                 }
 194
 195                 $attribs->{$key} =
 196                   {
 197                    Name         => $name,
 198                    Value        => $attr->href,
 199                    NamespaceURI => "http://www.w3.org/2000/xmlns/",
 200                    Prefix       => $prefix,
 201                    LocalName    => $localname,
 202                   };
 203             }
 204         }
 205         else {
 206             my $ns = $attr->namespaceURI;
 207
 208             $ns = '' unless defined $ns;
 209             $key = "{$ns}".$attr->localname;
 210             ## Not sure why, but $attr->name is coming through stripped
 211             ## of its prefix, so we need to hand-assemble a real name.
 212             my $name = $attr->name;
 213             $name = "" unless defined $name;
 214
 215             my $prefix = $attr->prefix;
 216             $prefix = "" unless defined $prefix;
 217             $name = "$prefix:$name"
 218               if index( $name, ":" ) < 0 && length $prefix;
 219
 220             $attribs->{$key} =
 221                 {
 222                     Name => $name,
 223                     Value => $attr->value,
 224                     NamespaceURI => $ns,
 225                     Prefix => $prefix,
 226                     LocalName => $attr->localname,
 227                 };
 228         }
 229         # use Data::Dumper;
 230         # warn("Attr made: ", Dumper($attribs->{$key}), "\n");
 231     }
 232
 233     my $node = {
 234         Name => $element->nodeName,
 235         Attributes => $attribs,
 236         NamespaceURI => $element->namespaceURI,
 237         Prefix => $element->prefix || "",
 238         LocalName => $element->localname,
 239     };
 240
 241     $self->start_element($node);
 242
 243     foreach my $child ($element->childNodes) {
 244         $self->process_node($child);
 245     }
 246
 247     my $end_node = { %$node };
 248
 249     delete $end_node->{Attributes};
 250
 251     $self->end_element($end_node);
 252
 253     foreach my $ns (@ns_maps) {
 254         $self->end_prefix_mapping(
 255             {
 256                 NamespaceURI => $ns->href,
 257                 Prefix       => ( defined $ns->localname  ? $ns->localname : ''),
 258             }
 259         );
 260     }
 261 }
 262
 263 1;
 264
 265 __END__