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;
}