You are viewing a plain text version of this content. The canonical link for it is here.
Posted to commits@xerces.apache.org by ja...@apache.org on 2001/10/07 01:17:52 UTC
cvs commit: xml-xerces/perl postModule.pl
jasons 01/10/06 16:17:52
Modified: perl postModule.pl
Log:
* postModule.pl (Repository):
As of SWIG-1.3.10-pre1, got rid of operator handling
Added copy constructor list for DOM methods.
added use strict
We're only adding DESTROY() to classes we know are safe.
Joined I?DOMNodeList methods
Joined I?DOMNamedNodeMap methods
Joined I?DOMNode methods
Fix setAttributes() so that undefined values don't cause segfaults
Removed hard-coded DESTROY()'s
PerlErrorHandler::* now use warn() or die()
PerlXMLExceptionHandler -- bogus hack that needs to die, but at
least XMLExceptions are now caught.
remove_method(), fix_method(), and skipt_to_closing_brace() now in
SWIG.pm
Revision Changes Path
1.19 +226 -276 xml-xerces/perl/postModule.pl
Index: postModule.pl
===================================================================
RCS file: /home/cvs/xml-xerces/perl/postModule.pl,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- postModule.pl 2001/09/10 17:57:18 1.18
+++ postModule.pl 2001/10/06 23:17:52 1.19
@@ -1,54 +1,27 @@
#!/usr/bin/perl
+use lib '.';
+use strict;
+use SWIG qw(remove_method skip_to_closing_brace fix_method);
my($progname) = $0 =~ m"\/([^/]*)";
-%operator_symbols = (
- 'addition' => '+',
- 'addition_assignment' => '+=',
- 'subtraction' => '-',
- 'subtraction_assignment' => '-=',
- 'multiplication' => '*',
- 'multiplication_assignment' => '*=',
- 'division' => '/',
- 'division_assignment' => '/=',
- 'modulus' => '%',
- 'modulus_assignment' => '%=',
-
- 'left_shift' => '<<',
- 'left_shift_assignment' => '<<=',
- 'right_shift' => '>>',
- 'right_shift_assignment' => '>>=',
-
- 'assignment' => '=',
-
- 'bitwise_and' => '&',
- 'bitwise_or' => '|',
- 'bitwise_xor' => '^',
-
- 'less_than' => '<',
- 'less_than_or_equal_to' => '<=',
- 'greater_than' => '>',
- 'greater_than_or_equal_to' => '>=',
- 'equal_to' => '==',
- 'not_equal_to' => '!=',
-
- 'increment' => '++',
- 'decrement' => '--'
-);
-
-@idom_node_list_methods = qw(IDOM_Document::getElementsByTagName
- IDOM_Document::getElementsByTagNameNS
- IDOM_Element::getElementsByTagName
- IDOM_Element::getElementsByTagNameNS
- IDOM_Node::getChildNodes
+my @dom_node_list_methods = qw(IDOM_Document::getElementsByTagName
+ IDOM_Document::getElementsByTagNameNS
+ IDOM_Element::getElementsByTagName
+ IDOM_Element::getElementsByTagNameNS
+ IDOM_Node::getChildNodes
);
-@idom_node_map_methods = qw(IDOM_DocumentType::getEntities
+my @dom_node_map_methods = qw(IDOM_DocumentType::getEntities
IDOM_DocumentType::getNotations
IDOM_Node::getAttributes
);
-@idom_node_methods = qw(IDOM_Node::new
+my @dom_copy_methods = qw(IDOM_XMLDecl
+ IDOM_Attr
+ );
+
+my @dom_node_methods = qw(IDOM_Node::new
IDOM_Node::getParentNode
IDOM_Node::getFirstChild
IDOM_Node::getLastChild
@@ -90,7 +63,7 @@
my $num = 0;
++$num while -e "$progname.$num.tmp";
-for $file (@ARGV) {
+for my $file (@ARGV) {
next unless open FILE, $file;
open TEMP, ">$progname.$num.tmp";
@@ -112,22 +85,25 @@
}
}
-# for now I think we want to keep the DESTROY methods
-# if (/sub DESTROY/) {
-# while (<FILE>) {
-# next unless /^\}/;
-# $_ = <FILE>;
-# last;
-# }
-# }
+ # swig also grabs some static variables from PlatformUtils.hpp
+ # that don't work because we've ripped out the functionality
+ # of the primary XML::Xerces class
+ if (/VARIABLE STUBS/) {
+ while (<FILE>) {
+ next unless /\#\#\#\#\#\#\#\#\#\#\#\#\#/;
+ last;
+ }
+ }
+ # we're only keeping DESTROY for the parsers until we know better
+ # we get core dumps if it's defined on some classes
if (/sub DESTROY/) {
- if ($CURR_CLASS eq 'InputSource' ||
- $CURR_CLASS eq 'LocalFileInputSource' ||
- $CURR_CLASS eq 'DOM_Node'
- ) {
- remove_method(\*FILE,
- \*TEMP);
+ unless (grep {$_ eq $CURR_CLASS} qw(IDOMParser
+ DOMParser
+ SAXParser
+ SAX2XMLReader))
+ {
+ remove_method(\*FILE);
} else {
fix_method(\*FILE,
\*TEMP,
@@ -146,32 +122,6 @@
#######################################################################
#
- # ADDS IN "OVERLOAD" MODULE STATEMENTS
- #
- if (/\#\#\s+Class\b/) {
- if (@operators) {
- print TEMP "use Carp;\nuse overload\n";
- for $key (@operators) {
- my $operator_symbol = $operator_symbols{$key};
- print TEMP <<"EOT";
-'$operator_symbol' => sub {
-carp "operator '$operator_symbol' assumed to be commutative."
-if \$_[2];
- \$_[0]->$key(\$_[1])
-},
-EOT
- }
- print TEMP qq(\t'fallback' => 1\n;\n\n);
- @operators = ();
- }
- }
-
- for $key (keys %operator_symbols) {
- push @operators, $key if /\b$key\b/;
- }
-
- #######################################################################
- #
# MUNG MODULE for DOMString and XMLCh support
#
# CHANGE "$args[0] = tied(%{$args[0]})"
@@ -219,24 +169,17 @@
#
# Perl API specific changes
#
- # DOM_NodeList: automatically convert to perl list
- # if called in a list context
- if (/^(\s*)\$(XML::Xerces::)?DOM_NodeList::OWNER/) {
- print TEMP <<'EOT';
- # automatically convert to perl list if called in a list context
- return $result->to_list() if wantarray;
-EOT
- }
- # IDOM_NodeList: automatically convert to perl list
+ # I?DOM_NodeList: automatically convert to perl list
# if called in a list context
- if (grep {/$CURR_CLASS/} @idom_node_list_methods) {
+ if (grep {/$CURR_CLASS/} @dom_node_list_methods) {
if (my ($sub) = /^sub\s+([\w_]+)/) {
$sub = "$ {CURR_CLASS}::$sub";
- if (grep {/$sub$/} @idom_node_list_methods) {
- my $fix = <<'EOT';
- # automatically convert to perl list if called in a list context
- return $result->to_list() if wantarray;
+ my $dom = $CURR_CLASS =~ /IDOM/ ? 'IDOM' : 'DOM';
+ if (grep {/$sub$/} @dom_node_list_methods) {
+ my $fix = <<"EOT";
+ return \$result->to_list() if wantarray;
+ \$${dom}_NodeList::OWNER{\$result} = 1;
EOT
fix_method(\*FILE,
\*TEMP,
@@ -248,24 +191,16 @@
}
}
- # DOM_NamedNodeMap: automatically convert to perl hash
+ # I?DOM_NamedNodeMap: automatically convert to perl hash
# if called in a list context
- if (/^(\s*)\$(XML::Xerces::)?DOM_NamedNodeMap::OWNER/) {
- print TEMP <<'EOT';
- # automatically convert to perl hash if called in a list context
- return $result->to_hash() if wantarray;
-EOT
- }
-
- # IDOM_NamedNodeMap: automatically convert to perl hash
- # if called in a list context
- if (grep {/$CURR_CLASS/} @idom_node_map_methods) {
+ if (grep {/$CURR_CLASS/} @dom_node_map_methods) {
if (my ($sub) = /^sub\s+([\w_]+)/) {
$sub = "$ {CURR_CLASS}::$sub";
- if (grep {/$sub$/} @idom_node_map_methods) {
- my $fix = <<'EOT';
- # automatically convert to perl hash if called in a list context
- return $result->to_hash() if wantarray;
+ my $dom = $CURR_CLASS =~ /IDOM/ ? 'IDOM' : 'DOM';
+ if (grep {/$sub$/} @dom_node_map_methods) {
+ my $fix = <<"EOT";
+ return \$result->to_hash() if wantarray;
+ \$${dom}_NamedNodeMap::OWNER{\$result} = 1;
EOT
fix_method(\*FILE,
\*TEMP,
@@ -277,19 +212,11 @@
}
}
- # DOM_Node: automatically convert to base class
- if (/^(\s*)\$(XML::Xerces::)?DOM_Node::OWNER/) {
- print TEMP <<'EOT';
- # automatically convert to base class
- $result = $result->actual_cast();
-EOT
- }
-
- # IDOM_Node: automatically convert to base class
- if (grep {/$CURR_CLASS/} @idom_node_methods) {
+ # I?DOM_Node: automatically convert to base class
+ if (grep {/$CURR_CLASS/} @dom_node_methods) {
if (my ($sub) = /^sub\s+([\w_]+)/) {
$sub = "$ {CURR_CLASS}::$sub";
- if (grep {/$sub$/} @idom_node_methods) {
+ if (grep {/$sub$/} @dom_node_methods) {
my $fix = <<'EOT';
# automatically convert to base class
$result = $result->actual_cast();
@@ -303,31 +230,51 @@
}
}
}
-
- ######################################################################
- #
- # Method Overloads
+ # MemBufInputSource: new has *optional* SYSTEM ID
+ if ($CURR_CLASS eq 'MemBufInputSource') {
+ if (/^sub\s+new/) {
+ my $fix = <<'EOT';
+ # SYSTEM ID is *optional*
+ if (scalar @args == 1) {
+ push(@args,'FAKE_SYSTEM_ID');
+ }
+EOT
+ fix_method(\*FILE,
+ \*TEMP,
+ qr/my \@args/,
+ $fix,
+ 1);
+ next;
+ }
+ }
- if ($CURR_CLASS eq 'DOM_Element') {
- if (/XML::Xercesc::DOM_Element_setAttribute;/) {
- print TEMP <<'EOT';
+ # we need to fix setAttribute() so that undefined values don't
+ # cause a core dump
+ if ($CURR_CLASS =~ /(I?DOM)_Element/) {
+ my $dom = $1;
+ if (/XML::Xercesc::${dom}_Element_setAttribute;/) {
+ print TEMP <<"EOT";
sub setAttribute {
- my ($self,$attr,$val) = @_;
- return unless defined $attr and defined $val;
- my $result = XML::Xercesc::DOM_Element_setAttribute(@_);
- return $result unless ref($result) =~ m[XML::Xerces];
- $XML::Xerces::DOM_Attr::OWNER{$result} = 1;
+ my (\$self,\$attr,\$val) = \@_;
+ return unless defined \$attr and defined \$val;
+ my \$result = XML::Xercesc::${dom}_Element_setAttribute(\@_);
+ return \$result unless ref(\$result) =~ m[XML::Xerces];
+ \$XML::Xerces::${dom}_Attr::OWNER{\$result} = 1;
my %resulthash;
- tie %resulthash, ref($result), $result;
- return bless \%resulthash, ref($result);
+ tie %resulthash, ref(\$result), \$result;
+ return bless \\\%resulthash, ref(\$result);
}
EOT
next;
}
}
- if ($CURR_CLASS =~ /(I?DOM)Parser/) {
+ ######################################################################
+ #
+ # Method Overloads
+
+ if ($CURR_CLASS =~ /(I?DOM|SAX)Parser/) {
my $dom = $1;
next if /__overload__/;
if (/XML::Xercesc::${dom}Parser_parse;/) {
@@ -335,9 +282,9 @@
sub parse {
my \@args = \@_;
if (ref \$args[1]) {
- XML::Xercesc::${dom}Parser_parse(\@args);
+ XML::Xercesc::${dom}Parser_parse__overload__is(\@args);
} else {
- XML::Xercesc::${dom}Parser_parse__overload__1(\@args);
+ XML::Xercesc::${dom}Parser_parse(\@args);
}
}
EOT
@@ -347,9 +294,9 @@
sub parseFirst {
my \@args = \@_;
if (ref \$args[1]) {
- XML::Xercesc::${dom}Parser_parseFirst(\@args);
+ XML::Xercesc::${dom}Parser_parseFirst__overload__is(\@args);
} else {
- XML::Xercesc::${dom}Parser_parseFirst__overload__1(\@args);
+ XML::Xercesc::${dom}Parser_parseFirst(\@args);
}
}
EOT
@@ -357,21 +304,94 @@
}
}
- if ($CURR_CLASS eq 'DOM_Attr') {
+ if ($CURR_CLASS =~ /URLInputSource/) {
if (/^sub.*__constructor__/) {
- remove_method(\*FILE,\*TEMP);
+ remove_method(\*FILE);
next;
} elsif (/^sub\s+new/) {
+ my $subst_func = sub {$_[0] = '' if $_[0] =~ /tied/;};
my $new = <<'EOT';
- if (scalar @args == 0) {
- $self = XML::Xercesc::new_DOM_Attr();
- } else {
- $self = XML::Xercesc::DOM_Attr_DOM_Attr__constructor__1(@args);
+ if (ref $args[0]) {
+ $args[0] = tied(%{$args[0]});
+ $self = XML::Xercesc::new_URLInputSource(@args);
+ } elsif (scalar @args == 2) {
+ $self = XML::Xercesc::new_URLInputSource__constructor__sys(@args);
+ } else {
+ $self = XML::Xercesc::new_URLInputSource__constructor__pub(@args);
+ }
+EOT
+ fix_method(\*FILE,
+ \*TEMP,
+ qr/\$self = XML::Xercesc::new_/,
+ $new,
+ 0,
+ $subst_func,
+ );
+ next;
+ }
+ }
+
+ if ($CURR_CLASS =~ /XMLURL/) {
+ if (/^sub.*__constructor__/) {
+ remove_method(\*FILE);
+ next;
+ } elsif (/^sub\s+new/) {
+ my $new = <<'EOT';
+ if (! scalar @args) {
+ $self = XML::Xercesc::new_XMLURL();
+ } elsif (scalar @args == 1) {
+ $self = XML::Xercesc::new_XMLURL__constructor__text(@args);
+ } else {
+ $self = XML::Xercesc::new_XMLURL__constructor__base(@args);
+ }
+EOT
+ fix_method(\*FILE,
+ \*TEMP,
+ qr/\$self = XML::Xercesc::new_/,
+ $new,
+ 0,
+ );
+ next;
}
+ }
+
+ if (grep {/$CURR_CLASS/} @dom_copy_methods) {
+ if (/^sub.*__constructor__/) {
+ remove_method(\*FILE);
+ next;
+ } elsif (/^sub\s+new/) {
+ my $new = <<"EOT";
+ if (ref \$pkg) {
+ \$self = XML::Xercesc::new_${CURR_CLASS}__constructor__copy(\$pkg);
+ \$pkg = ref \$pkg;
+ } else {
+ \$self = XML::Xercesc::new_${CURR_CLASS}();
+ }
+EOT
+ fix_method(\*FILE,
+ \*TEMP,
+ qr/\$self = XML::Xercesc::new_/,
+ $new);
+ next;
+ }
+ }
+
+ if ($CURR_CLASS =~ /LocalFileInputSource/) {
+ # this line assumed the first constructor, so we remove it
+ if (/^sub.*__constructor__/) {
+ remove_method(\*FILE);
+ next;
+ } elsif (/^sub\s+new/) {
+ my $new = <<'EOT';
+ if (scalar @args == 1) {
+ $self = XML::Xercesc::new_LocalFileInputSource(@args);
+ } else {
+ $self = XML::Xercesc::new_LocalFileInputSource__constructor__base(@args);
+ }
EOT
fix_method(\*FILE,
\*TEMP,
- qr/\$self = XML::Xercesc::new_DOM_Attr/,
+ qr/\$self = XML::Xercesc::new_/,
$new);
next;
}
@@ -416,58 +436,6 @@
\$self{__ERROR_HANDLER} = \$callback;
}
EOT
-
-# if ($class =~ /IDOMParser/) {
-# print TEMP <<'EOT';
-# sub DESTROY {
-# return unless $_[0]->isa('HASH');
-# my $self = tied(%{$_[0]});
-# delete $ITERATORS{$self};
-# if (exists $OWNER{$self}) {
-# XML::Xercesc::delete_IDOMParser($self);
-# delete $OWNER{$self};
-# }
-# }
-# EOT
-# } elsif ($class eq 'DOMParser') {
-# print TEMP <<'EOT';
-# sub DESTROY {
-# return unless $_[0]->isa('HASH');
-# my $self = tied(%{$_[0]});
-# delete $ITERATORS{$self};
-# if (exists $OWNER{$self}) {
-# XML::Xercesc::delete_DOMParser($self);
-# delete $OWNER{$self};
-# }
-# }
-# EOT
-# } elsif ($class eq 'SAXParser') {
-# print TEMP <<'EOT';
-# sub DESTROY {
-# return unless $_[0]->isa('HASH');
-# my $self = tied(%{$_[0]});
-# delete $ITERATORS{$self};
-# if (exists $OWNER{$self}) {
-# XML::Xercesc::delete_SAXParser($self);
-# delete $OWNER{$self};
-# }
-# }
-# EOT
-# } elsif ($class eq 'SAX2XMLReader') {
-# print TEMP <<'EOT';
-# sub DESTROY {
-# return unless $_[0]->isa('HASH');
-# my $self = tied(%{$_[0]});
-# delete $ITERATORS{$self};
-# if (exists $OWNER{$self}) {
-# XML::Xercesc::delete_SAX2XMLReader($self);
-# delete $OWNER{$self};
-# }
-# }
-# EOT
-# } else {
-# warn("unexpected class: $class, when creating setErrorHandler");
-# }
# we don't print out the function
next;
}
@@ -522,7 +490,7 @@
print TEMP;
}
-my $extra = <<'EOT';
+my $extra = <<'EXTRA';
############# Class : XML::Xerces::PerlContentHandler ##############
package XML::Xerces::PerlContentHandler;
@ISA = qw();
@@ -586,36 +554,74 @@
}
sub warning {
- print STDERR "WARNING:\n";
- print STDERR "FILE: ", $_[1]->getSystemId, "\n";
- print STDERR "LINE: ", $_[1]->getLineNumber, "\n";
- print STDERR "COLUMN: ", $_[1]->getColumnNumber, "\n";
- print STDERR "MESSAGE: ", $_[1]->getMessage, "\n";
- exit 1;
+ my $system_id = $_[1]->getSystemId;
+ my $line_num = $_[1]->getLineNumber;
+ my $col_num = $_[1]->getColumnNumber;
+ my $msg = $_[1]->getMessage;
+ warn(<<EOT);
+WARNING:
+FILE: $system_id
+LINE: $line_num
+COLUMN: $col_num
+MESSAGE: $msg
+EOT
}
sub error {
- print STDERR "ERROR:\n";
- print STDERR "FILE: ", $_[1]->getSystemId, "\n";
- print STDERR "LINE: ", $_[1]->getLineNumber, "\n";
- print STDERR "COLUMN: ", $_[1]->getColumnNumber, "\n";
- print STDERR "MESSAGE: ", $_[1]->getMessage, "\n";
- exit 1;
+ my $system_id = $_[1]->getSystemId;
+ my $line_num = $_[1]->getLineNumber;
+ my $col_num = $_[1]->getColumnNumber;
+ my $msg = $_[1]->getMessage;
+ die(<<EOT);
+ERROR:
+FILE: $system_id
+LINE: $line_num
+COLUMN: $col_num
+MESSAGE: $msg
+EOT
}
sub fatal_error {
- print STDERR "FATAL ERROR:\n";
- print STDERR "FILE: ", $_[1]->getSystemId, "\n";
- print STDERR "LINE: ", $_[1]->getLineNumber, "\n";
- print STDERR "COLUMN: ", $_[1]->getColumnNumber, "\n";
- print STDERR "MESSAGE: ", $_[1]->getMessage, "\n";
- exit 1;
+ my $system_id = $_[1]->getSystemId;
+ my $line_num = $_[1]->getLineNumber;
+ my $col_num = $_[1]->getColumnNumber;
+ my $msg = $_[1]->getMessage;
+ die(<<EOT);
+FATAL ERROR:
+FILE: $system_id
+LINE: $line_num
+COLUMN: $col_num
+MESSAGE: $msg
+EOT
}
sub reset_errors {}
+############# Class : XML::Xerces::PerlXMLExceptionHandler ##############
+package XML::Xerces::PerlXMLExceptionHandler;
+@ISA = qw();
+sub new {
+ my $class = shift;
+ return bless {}, $class;
+}
+
+sub catch {
+ my ($exception) = shift;
+ my $file = $exception->getSrcFile;
+ my $line_num = $exception->getSrcLine;
+ my $code = $exception->getCode;
+ my $msg = $exception->getMessage;
+ die(<<EOT);
+XMLException:
+FILE: $file
+LINE: $line_num
+CODE: $code
+MESSAGE: $msg
+EOT
+}
+
package XML::Xerces::DOM_NodeList;
# convert the NodeList to a perl list
sub to_list {
@@ -1122,67 +1128,11 @@
XML::Xerces::XMLPlatformUtils::Initialize();
1;
-EOT
+EXTRA
close(FILE);
print TEMP $extra;
close(TEMP);
rename "$progname.$num.tmp", $file;
}
-
-sub remove_method {
- my ($in_fh,$out_fh) = @_;
- skip_to_closing_brace(@_,0);
-}
-
-sub skip_to_closing_brace {
- my ($in_fh,$out_fh,$print) = @_;
- $print = 0 unless defined $print;
- my $braces = 1;
- while ($braces && ! eof($in_fh)) {
- $_ = <$in_fh>;
- if (/\}/ and /\{/) {
- my $tmp = $_;
- $tmp =~ s/\{[^\}]*\}//g;
- $braces-- if $tmp =~ /\}/;
- $braces++ if $tmp =~ /\{/;
- } else {
- $braces-- if /\}/;
- $braces++ if /\{/;
- }
- if ($print) {
- substitute_line($_);
- print TEMP;
- }
- }
- if ($braces) {
- print STDERR "skip_to_closing_brace exited with positive brace count";
- }
-}
-
-sub fix_method {
- my ($in_fh,$out_fh,$match,$subst,$keep) = @_;
- $keep = 0 unless defined $keep;
- my $braces = 1;
- print TEMP;
- while ($braces && ! eof($in_fh)) {
- $_ = <$in_fh>;
- $braces-- if /\}/;
- $braces++ if /\{/;
-# substitute_line($_);
- if (/$match/) {
- if ($keep) {
- $_ .= $subst;
- } else {
- s/^.*\n/$subst\n/;
- }
- }
- print TEMP;
- }
- if ($braces) {
- print STDERR "fix_method exited with positive brace count";
- }
-}
-
-
---------------------------------------------------------------------
To unsubscribe, e-mail: xerces-cvs-unsubscribe@xml.apache.org
For additional commands, e-mail: xerces-cvs-help@xml.apache.org