lib/XML/LibXML/SAX/Parser.pm

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