[libinline-java-perl] 140/398: Initial revision
Jonas Smedegaard
dr at jones.dk
Thu Feb 26 11:42:57 UTC 2015
This is an automated email from the git hooks/post-receive script.
js pushed a commit to tag 0.55
in repository libinline-java-perl.
commit 07b1377227b5124245e60dbdcc9818069960468a
Author: Patrick LeBoutillier <patl at cpan.org>
Date: Mon Jan 14 17:34:30 2002 +0000
Initial revision
---
bug/croak_bug.pl | 581 +++++++++++++++++++++++++++++++++++++++++++++++++++++
bug/gcj_test.class | Bin 0 -> 1843 bytes
bug/gcj_test.java | 56 ++++++
gcj/java | 3 +
gcj/javac | 3 +
5 files changed, 643 insertions(+)
diff --git a/bug/croak_bug.pl b/bug/croak_bug.pl
new file mode 100644
index 0000000..f7ef525
--- /dev/null
+++ b/bug/croak_bug.pl
@@ -0,0 +1,581 @@
+#!/usr/local/perl56/bin/perl -w
+
+use strict ;
+
+package class ;
+ at class::ISA = qw(Inline::Java::Object) ;
+
+use Carp ;
+
+
+$SIG{__DIE__} = sub {
+ $Inline::Java::DONE = 1 ;
+ die @_ ;
+} ;
+
+
+sub new {
+ my $class = shift ;
+ my @args = @_ ;
+
+ my $o = $Inline::Java::INLINE->{'$modfname'} ;
+
+ my $ret = undef ;
+ eval {
+ $ret = $class->__new() ;
+ } ;
+ croak $@ if $@ ;
+
+ return $ret ;
+}
+
+
+
+package Inline::Java::Object ;
+ at Inline::Java::Object::ISA = qw(Inline::Java::Object::Tie) ;
+
+use strict ;
+
+$Inline::Java::Object::VERSION = '0.10' ;
+
+use Carp ;
+
+
+# Here we store as keys the knots and as values our blessed private objects
+my $PRIVATES = {} ;
+
+
+# Bogus constructor. We fall here if no public constructor is defined
+# in the Java class.
+sub new {
+ my $class = shift ;
+
+ croak "No public constructor defined for class $class" ;
+}
+
+
+# Constructor. Here we create a new object that will be linked
+# to a real Java object.
+sub __new {
+ my $class = shift ;
+ my $java_class = shift ;
+ my $inline = shift ;
+ my $objid = shift ;
+ my $proto = shift ;
+ my $args = shift ;
+
+ my %this = () ;
+
+ my $knot = tie %this, $class ;
+ my $this = bless(\%this, $class) ;
+
+ my $priv = Inline::Java::Object::Private->new($java_class, $inline) ;
+ $PRIVATES->{$knot} = $priv ;
+
+ croak "frog" ;
+}
+
+
+sub __get_private {
+ my $this = shift ;
+
+ my $knot = tied(%{$this}) || $this ;
+
+ my $priv = $PRIVATES->{$knot} ;
+ if (! defined($priv)){
+ croak "Unknown Java object reference" ;
+ }
+
+ return $priv ;
+}
+
+
+# Here an object in destroyed. this function seems to be called twice
+# for each object. I think it's because the $this reference is both blessed
+# and tied to the same package.
+sub DESTROY {
+ my $this = shift ;
+
+ print STDERR "DESTROY\n" ;
+ if (! $Inline::Java::DONE){
+ if (! $this->__get_private()->{deleted}){
+ $this->__get_private()->{deleted} = 1 ;
+ eval {
+ $this->__get_private()->{proto}->DeleteJavaObject($this) ;
+ } ;
+ croak "In method DESTROY of class $this->__get_private()->{class}: $@" if $@ ;
+ }
+ else{
+ # Inline::Java::debug("Object destructor called more than once for $this !") ;
+ }
+ }
+
+ untie %{$this} ;
+}
+
+
+
+######################## Hash Methods ########################
+package Inline::Java::Object::Tie ;
+ at Inline::Java::Object::Tie::ISA = qw(Tie::StdHash) ;
+
+
+use Tie::Hash ;
+use Carp ;
+
+
+sub TIEHASH {
+ my $class = shift ;
+
+ return $class->SUPER::TIEHASH(@_) ;
+}
+
+
+sub STORE {
+ my $this = shift ;
+ my $key = shift ;
+ my $value = shift ;
+
+ return $this->__set_member($key, $value) ;
+}
+
+
+sub FETCH {
+ my $this = shift ;
+ my $key = shift ;
+
+ return $this->__get_member($key) ;
+}
+
+
+sub FIRSTKEY {
+ my $this = shift ;
+
+ return $this->SUPER::FIRSTKEY() ;
+}
+
+
+sub NEXTKEY {
+ my $this = shift ;
+
+ return $this->SUPER::NEXTKEY() ;
+}
+
+
+sub EXISTS {
+ my $this = shift ;
+ my $key = shift ;
+
+ my $inline = $Inline::Java::INLINE->{$this->__get_private()->{module}} ;
+ my $fields = $inline->get_fields($this->__get_private()->{java_class}) ;
+
+ if ($fields->{$key}){
+ return 1 ;
+ }
+
+ return 0 ;
+}
+
+
+sub DELETE {
+ my $this = shift ;
+ my $key = shift ;
+
+ croak "Operation DELETE not supported on Java object" ;
+}
+
+
+sub CLEAR {
+ my $this = shift ;
+
+ croak "Operation CLEAR not supported on Java object" ;
+}
+
+
+sub DESTROY {
+ my $this = shift ;
+
+ $PRIVATES->{$this} = undef ;
+}
+
+
+
+
+######################## Private Object ########################
+package Inline::Java::Object::Private ;
+
+sub new {
+ my $class = shift ;
+ my $java_class = shift ;
+ my $inline = shift ;
+
+ my $this = {} ;
+ $this->{class} = $class ;
+ $this->{java_class} = $java_class ;
+ $this->{module} = $inline->{modfname} ;
+ $this->{known_to_perl} = 1 ;
+ $this->{proto} = new Inline::Java::Protocol($this, $inline) ;
+
+ bless($this, $class) ;
+
+ return $this ;
+}
+
+
+package Inline::Java::Protocol ;
+
+
+use strict ;
+
+$Inline::Java::Protocol::VERSION = '0.10' ;
+
+use Carp ;
+
+
+sub new {
+ my $class = shift ;
+ my $obj = shift ;
+ my $inline = shift ;
+
+ my $this = {} ;
+ $this->{obj_priv} = $obj || {} ;
+ $this->{module} = $inline->{modfname} ;
+
+ bless($this, $class) ;
+ return $this ;
+}
+
+
+sub ISA {
+ my $this = shift ;
+ my $proto = shift ;
+
+ Inline::Java::debug("checking if $this is a $proto") ;
+
+ my $id = $this->{obj_priv}->{id} ;
+ my $class = $this->{obj_priv}->{java_class} ;
+ my $data = join(" ",
+ "isa",
+ $id,
+ Inline::Java::Class::ValidateClass($class),
+ Inline::Java::Class::ValidateClass($proto),
+ ) ;
+
+ Inline::Java::debug(" packet sent is $data") ;
+
+ return $this->Send($data, 1) ;
+}
+
+
+# Called to create a Java object
+sub CreateJavaObject {
+ my $this = shift ;
+ my $class = shift ;
+ my $proto = shift ;
+ my $args = shift ;
+
+ Inline::Java::debug("creating object new $class" . $this->CreateSignature($args)) ;
+
+ my $data = join(" ",
+ "create_object",
+ Inline::Java::Class::ValidateClass($class),
+ $this->CreateSignature($proto, ","),
+ $this->ValidateArgs($args),
+ ) ;
+
+ Inline::Java::debug(" packet sent is $data") ;
+
+ return $this->Send($data, 1) ;
+}
+
+
+# Called to call a static Java method
+sub CallStaticJavaMethod {
+ my $this = shift ;
+ my $class = shift ;
+ my $method = shift ;
+ my $proto = shift ;
+ my $args = shift ;
+
+ Inline::Java::debug("calling $class.$method" . $this->CreateSignature($args)) ;
+
+ my $data = join(" ",
+ "call_static_method",
+ Inline::Java::Class::ValidateClass($class),
+ $this->ValidateMethod($method),
+ $this->CreateSignature($proto, ","),
+ $this->ValidateArgs($args),
+ ) ;
+
+ Inline::Java::debug(" packet sent is $data") ;
+
+ return $this->Send($data) ;
+}
+
+
+# Calls a regular Java method.
+sub CallJavaMethod {
+ my $this = shift ;
+ my $method = shift ;
+ my $proto = shift ;
+ my $args = shift ;
+
+ my $id = $this->{obj_priv}->{id} ;
+ my $class = $this->{obj_priv}->{java_class} ;
+ Inline::Java::debug("calling object($id).$method" . $this->CreateSignature($args)) ;
+
+ my $data = join(" ",
+ "call_method",
+ $id,
+ Inline::Java::Class::ValidateClass($class),
+ $this->ValidateMethod($method),
+ $this->CreateSignature($proto, ","),
+ $this->ValidateArgs($args),
+ ) ;
+
+ Inline::Java::debug(" packet sent is $data") ;
+
+ return $this->Send($data) ;
+}
+
+
+# Sets a member variable.
+sub SetJavaMember {
+ my $this = shift ;
+ my $member = shift ;
+ my $proto = shift ;
+ my $arg = shift ;
+
+ my $id = $this->{obj_priv}->{id} ;
+ my $class = $this->{obj_priv}->{java_class} ;
+ Inline::Java::debug("setting object($id)->{$member} = $arg->[0]") ;
+ my $data = join(" ",
+ "set_member",
+ $id,
+ Inline::Java::Class::ValidateClass($class),
+ $this->ValidateMember($member),
+ Inline::Java::Class::ValidateClass($proto->[0]),
+ $this->ValidateArgs($arg),
+ ) ;
+
+ Inline::Java::debug(" packet sent is $data") ;
+
+ return $this->Send($data) ;
+}
+
+
+# Gets a member variable.
+sub GetJavaMember {
+ my $this = shift ;
+ my $member = shift ;
+ my $proto = shift ;
+
+ my $id = $this->{obj_priv}->{id} ;
+ my $class = $this->{obj_priv}->{java_class} ;
+ Inline::Java::debug("getting object($id)->{$member}") ;
+
+ my $data = join(" ",
+ "get_member",
+ $id,
+ Inline::Java::Class::ValidateClass($class),
+ $this->ValidateMember($member),
+ Inline::Java::Class::ValidateClass($proto->[0]),
+ "undef:",
+ ) ;
+
+ Inline::Java::debug(" packet sent is $data") ;
+
+ return $this->Send($data) ;
+}
+
+
+# Deletes a Java object
+sub DeleteJavaObject {
+ my $this = shift ;
+ my $obj = shift ;
+
+ if (defined($this->{obj_priv}->{id})){
+ my $id = $this->{obj_priv}->{id} ;
+ my $class = $this->{obj_priv}->{java_class} ;
+
+ Inline::Java::debug("deleting object $obj $id ($class)") ;
+
+ my $data = join(" ",
+ "delete_object",
+ $id,
+ ) ;
+
+ Inline::Java::debug(" packet sent is $data") ;
+
+ $this->Send($data) ;
+ }
+}
+
+
+# This method makes sure that the method we are asking for
+# has the correct form for a Java method.
+sub ValidateMethod {
+ my $this = shift ;
+ my $method = shift ;
+
+ if ($method !~ /^(\w+)$/){
+ croak "Invalid Java method name $method" ;
+ }
+
+ return $method ;
+}
+
+
+# This method makes sure that the member we are asking for
+# has the correct form for a Java member.
+sub ValidateMember {
+ my $this = shift ;
+ my $member = shift ;
+
+ if ($member !~ /^(\w+)$/){
+ croak "Invalid Java member name $member" ;
+ }
+
+ return $member ;
+}
+
+
+# Validates the arguments to be used in a method call.
+sub ValidateArgs {
+ my $this = shift ;
+ my $args = shift ;
+
+ my @ret = () ;
+ foreach my $arg (@{$args}){
+ if (! defined($arg)){
+ push @ret, "undef:" ;
+ }
+ elsif (ref($arg)){
+ if ((! UNIVERSAL::isa($arg, "Inline::Java::Object"))&&(! UNIVERSAL::isa($arg, "Inline::Java::Array"))){
+ croak "A Java method or member can only have Java objects, Java arrays or scalars as arguments" ;
+ }
+
+ if (UNIVERSAL::isa($arg, "Inline::Java::Array")){
+ $arg = $arg->__get_object() ;
+ }
+ my $class = $arg->__get_private()->{java_class} ;
+ my $id = $arg->__get_private()->{id} ;
+ push @ret, "object:$class:$id" ;
+ }
+ else{
+ push @ret, "scalar:" . join(".", unpack("C*", $arg)) ;
+ }
+ }
+
+ return @ret ;
+}
+
+
+sub CreateSignature {
+ my $this = shift ;
+ my $proto = shift ;
+ my $del = shift || ", " ;
+
+ return "(" . join($del, @{$proto}) . ")" ;
+}
+
+
+# This actually sends the request to the Java program. It also takes
+# care of registering the returned object (if any)
+sub Send {
+ my $this = shift ;
+ my $data = shift ;
+ my $const = shift ;
+
+ my $resp = undef ;
+ my $inline = $Inline::Java::INLINE->{$this->{module}} ;
+ if (! $inline->{Java}->{JNI}){
+ my $sock = $inline->{Java}->{socket} ;
+ print $sock $data . "\n" or
+ croak "Can't send packet over socket: $!" ;
+
+ $resp = <$sock> ;
+ }
+ else{
+ $resp = $inline->{Java}->{JNI}->process_command($data) ;
+ }
+
+ Inline::Java::debug(" packet recv is $resp") ;
+
+ if (! $resp){
+ croak "Can't receive packet over socket: $!" ;
+ }
+ elsif ($resp =~ /^error scalar:([\d.]*)$/){
+ my $msg = pack("C*", split(/\./, $1)) ;
+ Inline::Java::debug(" packet recv error: $msg") ;
+ croak $msg ;
+ }
+ elsif ($resp =~ /^ok scalar:([\d.]*)$/){
+ return pack("C*", split(/\./, $1)) ;
+ }
+ elsif ($resp =~ /^ok undef:$/){
+ return undef ;
+ }
+ elsif ($resp =~ /^ok object:(\d+):(.*)$/){
+ # Create the Perl object wrapper and return it.
+ my $id = $1 ;
+ my $class = $2 ;
+
+ if ($const){
+ $this->{obj_priv}->{java_class} = $class ;
+ $this->{obj_priv}->{id} = $id ;
+
+ return undef ;
+ }
+ else{
+ my $perl_class = $class ;
+ $perl_class =~ s/[.\$]/::/g ;
+ my $pkg = $inline->{pkg} ;
+ $perl_class = $pkg . "::" . $perl_class ;
+ Inline::Java::debug($perl_class) ;
+
+ my $known = 0 ;
+ {
+ no strict 'refs' ;
+ if (defined(${$perl_class . "::" . "EXISTS"})){
+ Inline::Java::debug(" returned class exists!") ;
+ $known = 1 ;
+ }
+ else{
+ Inline::Java::debug(" returned class doesn't exist!") ;
+ }
+ }
+
+ my $obj = undef ;
+ if ($known){
+ Inline::Java::debug("creating stub for known object...") ;
+ $obj = $perl_class->__new($class, $inline, $id) ;
+ Inline::Java::debug("stub created ($obj)...") ;
+ }
+ else{
+ Inline::Java::debug("creating stub for unknown object...") ;
+ $obj = Inline::Java::Object->__new($class, $inline, $id) ;
+ Inline::Java::debug("stub created ($obj)...") ;
+ $obj->__get_private()->{known_to_perl} = 0 ;
+ }
+
+ Inline::Java::debug("checking if stub is array...") ;
+ if (Inline::Java::Class::ClassIsArray($class)){
+ Inline::Java::debug("creating array object...") ;
+ $obj = new Inline::Java::Array($obj) ;
+ Inline::Java::debug("array object created...") ;
+ }
+
+ Inline::Java::debug("returning stub...") ;
+
+ return $obj ;
+ }
+ }
+}
+
+
+
+package main ;
+
+my $o = new class() ;
+
diff --git a/bug/gcj_test.class b/bug/gcj_test.class
new file mode 100644
index 0000000..fad3e96
Binary files /dev/null and b/bug/gcj_test.class differ
diff --git a/bug/gcj_test.java b/bug/gcj_test.java
new file mode 100644
index 0000000..5c265b3
--- /dev/null
+++ b/bug/gcj_test.java
@@ -0,0 +1,56 @@
+import java.lang.reflect.* ;
+
+
+public class gcj_test {
+ public static void main(String[] args){
+ try {
+ obj o = new obj() ;
+ Class c = Class.forName("obj") ;
+
+ Method methods[] = c.getMethods() ;
+ Field fields[] = c.getFields() ;
+ Method m = null ;
+ Field f = null ;
+ for (int i = 0 ; i < methods.length ; i++){
+ if (methods[i].getName().equals("f")){
+ m = methods[i] ;
+ break ;
+ }
+ }
+ for (int i = 0 ; i < fields.length ; i++){
+ if (fields[i].getName().equals("s")){
+ f = fields[i] ;
+ break ;
+ }
+ }
+
+
+ Object a[] = {"test"} ;
+ m.invoke(o, a) ;
+ f.set(o, "test") ;
+ System.out.println("s set to 'test'") ;
+ System.out.println("s = " + (String)f.get(o)) ;
+ a[0] = null ;
+ m.invoke(o, a) ;
+ f.set(o, null) ;
+ System.out.println("s set to null") ;
+ System.out.println("s = " + (String)f.get(o)) ;
+ f.get(o) ;
+ }
+ catch (Exception e){
+ System.err.println(e.getClass().getName() + ": " + e.getMessage()) ;
+ System.exit(1) ;
+ }
+
+ System.out.println("Done") ;
+ }
+}
+
+
+class obj {
+ public String s = null ;
+
+ public void f(String s){
+ System.out.println("f invoked with param " + s) ;
+ }
+}
\ No newline at end of file
diff --git a/gcj/java b/gcj/java
new file mode 100755
index 0000000..920bfed
--- /dev/null
+++ b/gcj/java
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+/home/patrickl/apps/gcc-3.0.1/bin/gij $@
diff --git a/gcj/javac b/gcj/javac
new file mode 100755
index 0000000..36ae053
--- /dev/null
+++ b/gcj/javac
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+/home/patrickl/apps/gcc-3.0.1/bin/gcj -C $@
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libinline-java-perl.git
More information about the Pkg-perl-cvs-commits
mailing list