The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.

NAME

  XML::GDOME::$perl_class - Interface $class implementation.

SYNOPSIS

END my @synopsis = values %synopsis; alignEquals(\@synopsis); for (@synopsis) { print POD " $_\n"; } my $parent_class = $perl_class; my @class_hierarchy; while ($parent_class = $parent_class{$parent_class}) { unshift @class_hierarchy, $parent_class; } if (@class_hierarchy) { print POD <<END;

CLASS INHERITANCE

END for my $class (@class_hierarchy) { print POD "XML::GDOME::$class > "; } print POD "XML::GDOME::$perl_class\n\n"; } # print POD <<END; # #=head1 DESCRIPTION # #$class_description{$class} # #END

    print POD <<END;

METHODS

    END

        while (my ($method, $synopsis) = each %synopsis) {
          my $hash_ref = $docs->{$class}->{$method};
          if ($hash_ref) {
            print POD "\n=item $synopsis{$method}\n\n";
            print POD "$hash_ref->{desc}\n\n" if exists $hash_ref->{desc};
            while (my ($k, $v) = each %{$hash_ref->{vars}}) {
              print POD "I<C<$k>>: $v\n\n";
            }
            print POD "I<Returns>: $hash_ref->{return}\n\n" if exists $hash_ref->{return};
            while (my ($k, $v) = each %{$hash_ref->{exc}}) {
              print POD "C<$k>: $v\n\n";
            }
          }
        }
    
        print POD <<END;

END

    close POD;
  }

}

print PM q{@EXPORT = qw( } . join(" ", keys %constants) . qq{ encodeToUTF8 decodeFromUTF8 );\n\n};

while (my ($k, $v) = each %constants) { if ($k !~ m!_NODE$! || $k eq 'READONLY_NODE' || $k eq 'READWRITE_NODE' || $k eq 'XPATH_NAMESPACE_NODE' ) { print PM "sub $k(){$v;}\n"; } } print PM "\n";

alignEquals(\@isa_strings); print PM join("\n",@isa_strings);

print PM q{

sub createDocFromString { my $class = shift; my $str = shift; my $mode = shift || 0; return $di->createDocFromMemory($str, $mode); }

sub createDocFromURI { my $class = shift; my $uri = shift; my $mode = shift || 0; return $di->createDocFromURI($uri, $mode); }

sub createDocument { my $class = shift; return $di->createDocument(@_); }

sub createDocumentType { my $class = shift; return $di->createDocumentType(@_); }

sub hasFeature { my $class = shift; return $di->hasFeature(@_); }

sub new { my $class = shift; my %options = @_; my $self = bless \%options, $class;

  return $self;
}

sub parse_fh { my ($self, $fh) = @_; local $/ = undef; my $str = <$fh>; $self->init_parser(); my $doc = __PACKAGE__->createDocFromString($str); if ( $self->{XML_GDOME_EXPAND_XINCLUDE} ) { $doc->process_xinclude(); } return $doc; }

sub parse_string { my ($self, $str) = @_; $self->init_parser(); my $doc =__PACKAGE__->createDocFromString($str); if ( $self->{XML_GDOME_EXPAND_XINCLUDE} ) { $doc->process_xinclude(); } return $doc; }

sub parse_file { my ($self, $uri) = @_; $self->init_parser(); my $doc = __PACKAGE__->createDocFromURI($uri); if ( $self->{XML_GDOME_EXPAND_XINCLUDE} ) { $doc->process_xinclude(); } return $doc; }

sub match_callback { my $self = shift; return $self->{XML_GDOME_MATCH_CB} = shift; }

sub read_callback { my $self = shift; return $self->{XML_GDOME_READ_CB} = shift; }

sub close_callback { my $self = shift; return $self->{XML_GDOME_CLOSE_CB} = shift; }

sub open_callback { my $self = shift; return $self->{XML_GDOME_OPEN_CB} = shift; }

sub callbacks { my $self = shift; if (@_) { my ($match, $open, $read, $close) = @_; @{$self}{qw(XML_GDOME_MATCH_CB XML_GDOME_OPEN_CB XML_GDOME_READ_CB XML_GDOME_CLOSE_CB)} = ($match, $open, $read, $close); } else { return @{$self}{qw(XML_GDOME_MATCH_CB XML_GDOME_OPEN_CB XML_GDOME_READ_CB XML_GDOME_CLOSE_CB)}; } }

sub expand_xinclude { my $self = shift; $self->{XML_GDOME_EXPAND_XINCLUDE} = shift if scalar @_; return $self->{XML_GDOME_EXPAND_XINCLUDE}; }

sub init_parser { my $self = shift; $self->_match_callback( $self->{XML_GDOME_MATCH_CB} ) if $self->{XML_GDOME_MATCH_CB}; $self->_read_callback( $self->{XML_GDOME_READ_CB} ) if $self->{XML_GDOME_READ_CB}; $self->_open_callback( $self->{XML_GDOME_OPEN_CB} ) if $self->{XML_GDOME_OPEN_CB}; $self->_close_callback( $self->{XML_GDOME_CLOSE_CB} ) if $self->{XML_GDOME_CLOSE_CB}; }

package XML::GDOME::Document;

sub toString { my $doc = shift; my $mode = shift || 0; return $di->saveDocToString($doc,$mode); }

sub toStringEnc { my $doc = shift; my $encoding = shift; my $mode = shift || 0; return $di->saveDocToStringEnc($doc,$encoding,$mode); }

package XML::GDOME::Node;

sub attributes { getAttributes(@_); }

sub getAttributes { my ($elem) = @_; my $nnm = $elem->_attributes; if (wantarray) { return () if !$nnm; my @attrs; for my $i (0 .. $nnm->getLength - 1) { push @attrs, $nnm->item("$i"); } return @attrs; } else { return $nnm; } }

sub xpath_evaluate { my ($contextNode, $expression, $resolver, $type) = @_; $XML::GDOME::XPath::xpeval ||= XML::GDOME::XPath::Evaluator::mkref(); no warnings; return $XML::GDOME::XPath::xpeval->evaluate($expression, $contextNode, $resolver, $type, undef); }

sub findnodes { my $res = xpath_evaluate(@_);

  my @nodes;
  while (my $node = $res->iterateNext) {
    push @nodes, $node;
  }
  return @nodes;
}

sub xpath_createNSResolver { my ($node) = @_; $XML::GDOME::XPath::xpeval ||= XML::GDOME::XPath::Evaluator::mkref(); return $XML::GDOME::XPath::xpeval->createNSResolver($node); }

sub childNodes { getChildNodes(@_); }

sub getChildNodes { my ($elem) = @_; my $nl = $elem->_childNodes; if (wantarray) { return () if !$nl; my @nodes; for my $i (0 .. $nl->getLength - 1) { push @nodes, $nl->item("$i"); } return @nodes; } else { return $nl; } }

sub iterator { my $self = shift; my $funcref = shift; my $child = undef;

  my $rv = $funcref->( $self );
  foreach $child ( $self->getChildNodes() ){
    $rv = $child->iterator( $funcref );
  }
  return $rv;
}

sub getAttributesNS { my ($self, $nsuri) = @_; my @attr; for my $attr ($self->getAttributes()) { push @attr, $attr if $attr->getNamespaceURI() eq $nsuri; } return @attr; }

sub findvalue { my $res = xpath_evaluate(@_);

  my $val = '';
  while (my $node = $res->iterateNext) {
    $val .= $node->to_literal;
  }
  return $val;
}

sub find { my $res = xpath_evaluate(@_);

  my $type = $res->resultType;
  if ($type == XML::GDOME::UNORDERED_NODE_ITERATOR_TYPE ||
      $type == XML::GDOME::ORDERED_NODE_ITERATOR_TYPE) {
    my @nodes;
    while (my $node = $res->iterateNext) {
      push @nodes, $node;
    }
    return @nodes;
  }
  elsif ($type == XML::GDOME::NUMBER_TYPE()) {
    return $res->numberValue;
  }
  elsif ($type == XML::GDOME::STRING_TYPE()) {
    return $res->stringValue;
  }
  elsif ($type == XML::GDOME::BOOLEAN_TYPE()) {
    return $res->booleanValue;
  }
  else {
    croak("Unknown result type");
  }
}

sub insertAfter { my ($parent, $newChild, $refChild) = @_;

  if (!$refChild) {
    return $parent->appendChild($newChild);
  }
  my $nextChild = $refChild->getNextSibling();
  if ($nextChild) {
    $parent->insertBefore($newChild, $nextChild);
  } else {
    $parent->appendChild($newChild);
  }
}

sub getChildrenByTagName { my ($self, $tagname) = @_; my @nodes; for my $node ($self->getChildNodes()) { if ($node->getNodeName() eq $tagname) { push @nodes, $node; } } return @nodes; }

sub getChildrenByTagNameNS { my ($self, $nsURI, $tagname) = @_; my @nodes; for my $node ($self->getChildNodes()) { if ($node->getLocalName() eq $tagname && $node->getNamespaceURI eq $nsURI) { push @nodes, $node; } } return @nodes; }

sub getElementsByLocalName { my ($self, $localname) = @_; # FIXME must fetch all descendants of node with local name my @elem; for my $elem ($self->getChildNodes()) { push @elem, $elem if $elem->getLocalName() eq $localname; } return @elem; }

sub getName { getNodeName(@_); }

sub getData { getNodeValue(@_); }

sub getType { getNodeType(@_); }

sub getOwner { getOwnerDocument(@_); }

sub getChildnodes { getChildNodes(@_); }

sub localname { getLocalName(@_); }

package XML::GDOME::Element;

sub appendTextNode { appendText(@_); }

sub appendText { my ($node, $xmlString) = @_; if ($xmlString != '') { my $text = $node->getOwnerDocument->createTextNode($xmlString); $node->appendChild($text); } return; }

sub getElementsByTagName { my $elem = shift; my $nl = $elem->_getElementsByTagName(@_); if (wantarray) { return () if !$nl; my @nodes; for my $i (0 .. $nl->getLength - 1) { push @nodes, $nl->item("$i"); } return @nodes; } else { return $nl; } }

sub getElementsByTagNameNS { my $elem = shift; my $nl = $elem->_getElementsByTagNameNS(@_); if (wantarray) { return () if !$nl; my @nodes; for my $i (0 .. $nl->getLength - 1) { push @nodes, $nl->item("$i"); } return @nodes; } else { return $nl; } }

sub appendTextChild { my ($node, $tagName, $xmlString) = @_; my $dom = $node->getOwnerDocument(); my $child = $node->appendChild($dom->createElement($tagName)); return $child->appendChild($dom->createTextNode($xmlString)); return $child; }

sub appendWellBalancedChunk { my ($self, $chunk) = @_; my $dom0 = $self->getOwnerDocument(); my $dom1 = XML::GDOME->createDocFromString("<gdome>".$chunk."</gdome>"); for my $child ($dom1->getDocumentElement()->getChildNodes()) { my $copy = $dom0->importNode($child, 1); $self->appendChild($copy); } }

package XML::GDOME::Document;

sub getElementsByTagName { my $elem = shift; my $nl = $elem->_getElementsByTagName(@_); if (wantarray) { return () if !$nl; my @nodes; for my $i (0 .. $nl->getLength - 1) { push @nodes, $nl->item("$i"); } return @nodes; } else { return $nl; } }

sub getElementsByTagNameNS { my $elem = shift; my $nl = $elem->_getElementsByTagNameNS(@_); if (wantarray) { return () if !$nl; my @nodes; for my $i (0 .. $nl->getLength - 1) { push @nodes, $nl->item("$i"); } return @nodes; } else { return $nl; } }

sub createAttribute { my ($elem, $name, $value) = @_; my $attr = $elem->_createAttribute($name); if ($value) { $attr->setValue($value); } return $attr; }

sub createPI { createProcessingInstruction(@_); }

1; };

print XS qq{

MODULE = XML::GDOME PACKAGE = XML::GDOME

SV * _match_callback(self, ...) SV * self CODE: if (items > 1) { SET_CB(GDOMEPerl_match_cb, ST(1)); } else { RETVAL = GDOMEPerl_match_cb ? sv_2mortal(GDOMEPerl_match_cb) : &PL_sv_undef; } OUTPUT: RETVAL

SV * _open_callback(self, ...) SV * self CODE: if (items > 1) { SET_CB(GDOMEPerl_open_cb, ST(1)); } else { RETVAL = GDOMEPerl_open_cb ? sv_2mortal(GDOMEPerl_open_cb) : &PL_sv_undef; } OUTPUT: RETVAL

SV * _read_callback(self, ...) SV * self CODE: if (items > 1) { SET_CB(GDOMEPerl_read_cb, ST(1)); } else { RETVAL = GDOMEPerl_read_cb ? sv_2mortal(GDOMEPerl_read_cb) : &PL_sv_undef; } OUTPUT: RETVAL

SV * _close_callback(self, ...) SV * self CODE: if (items > 1) { SET_CB(GDOMEPerl_close_cb, ST(1)); } else { RETVAL = GDOMEPerl_close_cb ? sv_2mortal(GDOMEPerl_close_cb) : &PL_sv_undef; } OUTPUT: RETVAL

};

close XS; close PM;

sub perlEscape { my $str = shift; $str =~ s!^(XPath)!$1::!; if ($str =~ m!^Node(Filter|Iterator)$!) { $str = 'Traversal::' . $str; } return $str; }

sub getBless { my ($struct) = @_; if ($struct =~ m!^Gdome(.*) \*$!) { my $perl_class = perlEscape($1); unless ($struct eq 'GdomeDOMString *') { return "XML::GDOME::$perl_class"; } return; } }

sub alignEquals { my $lines = shift; my $max_indent = 0; for (@$lines) { if (m!=!g) { my $indent = pos; pos = 0; if ($indent > $max_indent) { $max_indent = $indent; } } } for (@$lines) { if (m!=!g) { my $indent = pos; my $spacing = " " x ($max_indent - $indent); $_ =~ s!=!$spacing=!; } else { $_ = (' ' x ($max_indent + 1)) . $_; } } }

sub parseHeader { my $file = shift; open HEADER, "$file"; while (<HEADER>) { if (my ($k, $v) = m!(GDOME_[A-Z_]*) = (\d+)!) { if ($k =~ m!_NODE$! || $k =~ m!_ERR$! || $k =~ m!_TYPE$!) { unless ($k eq 'GDOME_NOEXCEPTION_ERR' || $k eq 'GDOME_NULL_POINTER_ERR' || $k eq 'GDOME_READONLY_NODE' || $k eq 'GDOME_READWRITE_NODE' ) { $k =~ s!GDOME_!!g; } } $constants{$k} = $v; } } close HEADER; }

sub filterDoc { my $text = shift; $$text =~ s!\@(\w+)!$1!g; $$text =~ s!\%NULL!undef!g; $$text =~ s!NULL!undef!g; $$text =~ s!\%TRUE!1!g; $$text =~ s!\%FALSE!0!g; $$text =~ s!\%0!0!g; $$text =~ s!\%GDOME_(\w+)_NODE!$1!g; $$text =~ s!16-bit unit!character!g; }

sub parseDocs { my $file = shift; my ($method_doc, $class, $in_return_section, $in_exc_section); open DOC, "$file"; while (<DOC>) { chomp; if ($_ eq '/**') { $method_doc = <DOC>; $method_doc =~ s!^ \* !!; $method_doc =~ s!:\n$!!;

      $method_doc =~ m!^gdome_(\w+)_(.+)!;
      $class = $abbrv_lookup{$1};
      $method_doc = $2;

      # get variables
      my $var;
      tie %{$docs->{$class}->{$method_doc}->{vars}}, "Tie::IxHash";
      while (<DOC>) {
        last unless m!^ \* (\@(\w+):  )?(.+)\n!;
        $var = $2 if $2;
        my $desc = $3;
        next if ($var eq 'self' || $var eq 'exc');
        filterDoc(\$desc);
        $docs->{$class}->{$method_doc}->{vars}->{$var} .= $desc;
      }
    }
    if ($method_doc) {
      my $text = $_;
      if ($_ eq ' */') {
        $method_doc = undef;
        $in_return_section = 0;
        $in_exc_section = undef;
        next;
      } elsif ($_ =~ m!^ \*\s*$!) {
        next;
      } elsif (m!^ \* Returns: !) {
        $in_return_section = 1;
        $in_exc_section = undef;
        $text = $';
      } elsif (m!^ \* \%(GDOME.*): !) {
        $in_exc_section = $1;
        $in_return_section = 0;
        $text = $';
      } else {
        $text =~ s!^ \*!!;
      }
      filterDoc(\$text);

      if ($in_return_section) {
        $docs->{$class}->{$method_doc}->{return} .= $text;
      } elsif ($in_exc_section) {
        $docs->{$class}->{$method_doc}->{exc}->{$in_exc_section} .= $text;
      } else {
        $docs->{$class}->{$method_doc}->{desc} .= $text;
      }
    }
    $docs->{$class}->{$method_doc}->{desc} =~ s!^\s+!!g;
  }
  close DOC;
}