1package Inline::Java ;
2@Inline::Java::ISA = qw(Inline Exporter) ;
3
4# Export the cast function if wanted
5@EXPORT_OK = qw(cast coerce study_classes caught jar j2sdk) ;
6
7
8use strict ;
9require 5.006 ;
10
11$Inline::Java::VERSION = '0.540' ;
12
13
14# DEBUG is set via the DEBUG config
15if (! defined($Inline::Java::DEBUG)){
16	$Inline::Java::DEBUG = 0 ;
17}
18
19# Set DEBUG stream
20*DEBUG_STREAM = *STDERR ;
21
22require Inline ;
23use Carp ;
24use Config ;
25use File::Copy ;
26use File::Spec ;
27use Cwd ;
28use Data::Dumper ;
29
30use Inline::Java::Portable ;
31use Inline::Java::Class ;
32use Inline::Java::Object ;
33use Inline::Java::Array ;
34use Inline::Java::Handle ;
35use Inline::Java::Protocol ;
36use Inline::Java::Callback ;
37# Must be last.
38use Inline::Java::JVM ;
39# Our default J2SK
40require Inline::Java->find_default_j2sdk() ;
41
42
43# This is set when the script is over.
44my $DONE = 0 ;
45
46# This is set when at least one JVM is loaded.
47my $JVM = undef ;
48
49# This list will store the $o objects...
50my @INLINES = () ;
51
52my $report_version = "V2" ;
53
54# This stuff is to control the termination of the Java Interpreter
55sub done {
56	my $signal = shift ;
57
58	# To preserve the passed exit code...
59	my $ec = $? ;
60
61	$DONE = 1 ;
62
63	if (! $signal){
64		Inline::Java::debug(1, "killed by natural death.") ;
65	}
66	else{
67		Inline::Java::debug(1, "killed by signal SIG$signal.") ;
68	}
69
70	shutdown_JVM() ;
71	Inline::Java::debug(1, "exiting with $ec") ;
72	CORE::exit($ec) ;
73	exit($ec) ;
74}
75
76
77END {
78	if ($DONE < 1){
79		done() ;
80	}
81}
82
83
84# To export the cast function and others.
85sub import {
86	my $class = shift ;
87
88	foreach my $a (@_){
89		if ($a eq 'jar'){
90			print Inline::Java::Portable::get_server_jar() ;
91			exit() ;
92		}
93		elsif ($a eq 'j2sdk'){
94			print Inline::Java->find_default_j2sdk() . " says '" .
95				Inline::Java::get_default_j2sdk() . "'\n" ;
96			exit() ;
97		}
98		elsif ($a eq 'so_dirs'){
99			print Inline::Java::Portable::portable('SO_LIB_PATH_VAR') . "=" .
100				join(Inline::Java::Portable::portable('ENV_VAR_PATH_SEP'),
101				Inline::Java::get_default_j2sdk_so_dirs()) ;
102			exit() ;
103		}
104	}
105    $class->export_to_level(1, $class, @_) ;
106}
107
108
109
110######################## Inline interface ########################
111
112
113
114# Register this module as an Inline language support module
115sub register {
116	return {
117		language => 'Java',
118		aliases => ['JAVA', 'java'],
119		type => 'interpreted',
120		suffix => 'jdat',
121	} ;
122}
123
124
125# Here validate is overridden because some of the config options are needed
126# at load as well.
127sub validate {
128	my $o = shift ;
129
130	# This might not print since debug is set further down...
131	Inline::Java::debug(1, "Starting validate.") ;
132
133	my $jdk = Inline::Java::get_default_j2sdk() ;
134	my $dbg = $Inline::Java::DEBUG ;
135	my %opts = @_ ;
136	$o->set_option('DEBUG',					$dbg,			'i', 1, \%opts) ;
137	$o->set_option('J2SDK',					$jdk,			's', 1, \%opts) ;
138	$o->set_option('CLASSPATH',				'',				's', 1, \%opts) ;
139
140	$o->set_option('BIND',					'localhost',	's', 1, \%opts) ;
141	$o->set_option('HOST',					'localhost',	's', 1, \%opts) ;
142	$o->set_option('PORT',					-1,				'i', 1, \%opts) ;
143	$o->set_option('STARTUP_DELAY',			15,				'i', 1, \%opts) ;
144	$o->set_option('SHARED_JVM',			0,				'b', 1, \%opts) ;
145	$o->set_option('START_JVM',				1,				'b', 1, \%opts) ;
146	$o->set_option('JNI',					0,				'b', 1, \%opts) ;
147	$o->set_option('EMBEDDED_JNI',			0,				'b', 1, \%opts) ;
148	$o->set_option('NATIVE_DOUBLES',		0,				'b', 1, \%opts) ;
149
150	$o->set_option('WARN_METHOD_SELECT',	0,				'b', 1, \%opts) ;
151	$o->set_option('STUDY',					undef,			'a', 0, \%opts) ;
152	$o->set_option('AUTOSTUDY',				0,				'b', 1, \%opts) ;
153
154	$o->set_option('EXTRA_JAVA_ARGS',		'',				's', 1, \%opts) ;
155	$o->set_option('EXTRA_JAVAC_ARGS',		'',				's', 1, \%opts) ;
156	$o->set_option('DEBUGGER',				0,				'b', 1, \%opts) ;
157
158	$o->set_option('PRIVATE',				'',				'b', 1, \%opts) ;
159	$o->set_option('PACKAGE',				'',				's', 1, \%opts) ;
160
161	my @left_overs = keys(%opts) ;
162	if (scalar(@left_overs)){
163		croak "'$left_overs[0]' is not a valid configuration option for Inline::Java" ;
164	}
165
166	# Now for the post processing
167	$Inline::Java::DEBUG = $o->get_java_config('DEBUG') ;
168
169	# Embedded JNI turns on regular JNI
170	if ($o->get_java_config('EMBEDDED_JNI')){
171		$o->set_java_config('JNI', 1) ;
172	}
173
174	if ($o->get_java_config('PORT') == -1){
175		if ($o->get_java_config('SHARED_JVM')){
176			$o->set_java_config('PORT', 7891) ;
177		}
178		else{
179			$o->set_java_config('PORT', -7890) ;
180		}
181	}
182
183	if (($o->get_java_config('JNI'))&&($o->get_java_config('SHARED_JVM'))){
184		croak("You can't use the 'SHARED_JVM' option in 'JNI' mode") ;
185	}
186	if (($o->get_java_config('JNI'))&&($o->get_java_config('DEBUGGER'))){
187		croak("You can't invoke the Java debugger ('DEBUGGER' option) in 'JNI' mode") ;
188	}
189	if ((! $o->get_java_config('SHARED_JVM'))&&(! $o->get_java_config('START_JVM'))){
190		croak("Disabling the 'START_JVM' option only makes sense in 'SHARED_JVM' mode") ;
191	}
192
193	if ($o->get_java_config('JNI')){
194		require Inline::Java::JNI ;
195	}
196
197	if ($o->get_java_config('DEBUGGER')){
198		# Here we want to tweak a few settings to help debugging...
199		Inline::Java::debug(1, "Debugger mode activated") ;
200		# Add the -g compile option
201		$o->set_java_config('EXTRA_JAVAC_ARGS', $o->get_java_config('EXTRA_JAVAC_ARGS') . " -g ") ;
202		# Add the -sourcepath runtime option
203		$o->set_java_config('EXTRA_JAVA_ARGS', $o->get_java_config('EXTRA_JAVA_ARGS') .
204			" -sourcepath " . $o->get_api('build_dir') .
205			Inline::Java::Portable::portable("ENV_VAR_PATH_SEP_CP") .
206			Inline::Java::Portable::get_source_dir()
207		) ;
208	}
209
210	my $study = $o->get_java_config('STUDY') ;
211	if ((defined($study))&&(ref($study) ne 'ARRAY')){
212		croak "Configuration option 'STUDY' must be an array of Java class names" ;
213	}
214
215	Inline::Java::debug(1, "validate done.") ;
216}
217
218
219sub set_option {
220	my $o = shift ;
221	my $name = shift ;
222	my $default = shift ;
223	my $type = shift ;
224	my $env_or = shift ;
225	my $opts = shift ;
226	my $desc = shift ;
227
228	if (! exists($o->{ILSM}->{$name})){
229		my $val = undef ;
230		if (($env_or)&&(exists($ENV{"PERL_INLINE_JAVA_$name"}))){
231			$val = $ENV{"PERL_INLINE_JAVA_$name"} ;
232		}
233		elsif (exists($opts->{$name})){
234			$val = $opts->{$name} ;
235		}
236		else{
237			$val = $default ;
238		}
239
240		if ($type eq 'b'){
241			if (! defined($val)){
242				$val = 0 ;
243			}
244			$val = ($val ? 1 : 0) ;
245		}
246		elsif ($type eq 'i'){
247			if ((! defined($val))||($val !~ /\d/)){
248				$val = 0 ;
249			}
250			$val = int($val) ;
251		}
252
253		$o->set_java_config($name, $val) ;
254	}
255
256	delete $opts->{$name} ;
257}
258
259
260sub get_java_config {
261	my $o = shift ;
262	my $param = shift ;
263
264	return $o->{ILSM}->{$param} ;
265}
266
267
268sub set_java_config {
269	my $o = shift ;
270	my $param = shift ;
271	my $value = shift ;
272
273	return $o->{ILSM}->{$param} = $value ;
274}
275
276
277# In theory we shouldn't need to use this, but it seems
278# it's not all accessible by the API yet.
279sub get_config {
280	my $o = shift ;
281	my $param = shift ;
282
283	return $o->{CONFIG}->{$param} ;
284}
285
286
287sub get_api {
288	my $o = shift ;
289	my $param = shift ;
290
291	# Allows us to force a specific package...
292	if (($param eq 'pkg')&&($o->get_config('PACKAGE'))){
293		return $o->get_config('PACKAGE') ;
294	}
295
296	return $o->{API}->{$param} ;
297}
298
299
300# Parse and compile Java code
301sub build {
302	my $o = shift ;
303
304	if ($o->get_java_config('built')){
305		return ;
306	}
307
308	Inline::Java::debug(1, "Starting build.") ;
309
310	# Grab and untaint the current directory
311	my $cwd = Cwd::cwd() ;
312	if ($o->get_config('UNTAINT')){
313		($cwd) = $cwd =~ /(.*)/ ;
314	}
315
316	# We must grab this before we change to the build dir because
317	# it could be relative...
318	my $server_jar = Inline::Java::Portable::get_server_jar() ;
319
320	# We need to add all the previous install dirs to the classpath because
321	# they can access each other.
322	my @prev_install_dirs = () ;
323	foreach my $in (@INLINES){
324		push @prev_install_dirs, File::Spec->catdir($in->get_api('install_lib'),
325			'auto', $in->get_api('modpname')) ;
326	}
327
328	my $cp = $ENV{CLASSPATH} || '' ;
329	$ENV{CLASSPATH} = Inline::Java::Portable::make_classpath($server_jar, @prev_install_dirs, $o->get_java_config('CLASSPATH')) ;
330	Inline::Java::debug(2, "classpath: $ENV{CLASSPATH}") ;
331
332	# Create the build dir and go there
333	my $build_dir = $o->get_api('build_dir') ;
334	$o->mkpath($build_dir) ;
335	chdir $build_dir ;
336
337	my $code = $o->get_api('code') ;
338	my $pcode = $code ;
339	my $study_only = ($code =~ /^(STUDY|SERVER)$/) ;
340	my $source = ($study_only ? '' : $o->get_api('modfname') . ".java") ;
341
342	# Parse code to check for public class
343	$pcode =~ s/\\\"//g ;
344	$pcode =~ s/\"(.*?)\"//g ;
345	$pcode =~ s/\/\*(.*?)\*\///gs ;
346	$pcode =~ s/\/\/(.*)$//gm ;
347	if ($pcode =~ /public\s+(abstract\s+)?class\s+(\w+)/){
348		$source = "$2.java" ;
349	}
350
351	my $install_dir = File::Spec->catdir($o->get_api('install_lib'),
352		'auto', $o->get_api('modpname')) ;
353	$o->mkpath($install_dir) ;
354
355	if ($source){
356		# Dump the source code...
357		open(Inline::Java::JAVA, ">$source") or
358			croak "Can't open $source: $!" ;
359		print Inline::Java::JAVA $code ;
360		close(Inline::Java::JAVA) ;
361
362		# ... and compile it.
363		my $javac = File::Spec->catfile($o->get_java_config('J2SDK'),
364			Inline::Java::Portable::portable("J2SDK_BIN"),
365			"javac" . Inline::Java::Portable::portable("EXE_EXTENSION")) ;
366		my $redir = Inline::Java::Portable::portable("IO_REDIR") ;
367
368		my $args = "-deprecation " . $o->get_java_config('EXTRA_JAVAC_ARGS') ;
369		my $pinstall_dir = Inline::Java::Portable::portable("SUB_FIX_JAVA_PATH", $install_dir) ;
370		my $cmd = Inline::Java::Portable::portable("SUB_FIX_CMD_QUOTES",
371			"\"$javac\" $args -d \"$pinstall_dir\" $source > cmd.out $redir") ;
372		if ($o->get_config('UNTAINT')){
373			($cmd) = $cmd =~ /(.*)/ ;
374		}
375		Inline::Java::debug(2, "$cmd") ;
376		my $res = system($cmd) ;
377		my $msg = $o->get_compile_error_msg() ;
378		if ($res){
379			croak $o->compile_error_msg($cmd, $msg) ;
380		} ;
381		if ($msg){
382			warn("\n$msg\n") ;
383		}
384
385		# When we run the commands, we quote them because in WIN32 you need it if
386		# the programs are in directories which contain spaces. Unfortunately, in
387		# WIN9x, when you quote a command, it masks it's exit value, and 0 is always
388		# returned. Therefore a command failure is not detected.
389		# We need to take care of checking whether there are actually files
390		# to be copied, and if not will exit the script.
391		if (Inline::Java::Portable::portable('COMMAND_COM')){
392			my @fl = Inline::Java::Portable::find_classes_in_dir($install_dir) ;
393		 	if (! scalar(@fl)){
394				croak "No class files produced. Previous command failed under command.com?" ;
395			}
396		 	foreach my $f (@fl){
397				if (! (-s $f->{file})){
398					croak "File $f->{file} has size zero. Previous command failed under command.com?" ;
399				}
400			}
401		}
402	}
403
404	$ENV{CLASSPATH} = $cp ;
405	Inline::Java::debug(2, "classpath: $ENV{CLASSPATH}") ;
406
407	# Touch the .jdat file.
408	my $jdat = File::Spec->catfile($install_dir, $o->get_api('modfname') . '.' . $o->get_api('suffix')) ;
409	if (! open(Inline::Java::TOUCH, ">$jdat")){
410		croak "Can't create file $jdat" ;
411	}
412	close(Inline::Java::TOUCH) ;
413
414	# Go back and clean up
415	chdir $cwd ;
416	if (($o->get_api('cleanup'))&&(! $o->get_java_config('DEBUGGER'))){
417		$o->rmpath('', $build_dir) ;
418	}
419
420	$o->set_java_config('built', 1) ;
421	Inline::Java::debug(1, "build done.") ;
422}
423
424
425sub get_compile_error_msg {
426	my $o = shift ;
427
428	my $msg = '' ;
429	if (open(Inline::Java::CMD, "<cmd.out")){
430		$msg = join("", <Inline::Java::CMD>) ;
431		close(Inline::Java::CMD) ;
432	}
433
434	return $msg ;
435}
436
437
438sub compile_error_msg {
439	my $o = shift ;
440	my $cmd = shift ;
441	my $error = shift ;
442
443	my $build_dir = $o->get_api('build_dir') ;
444
445	my $lang = $o->get_api('language') ;
446	return <<MSG
447
448A problem was encountered while attempting to compile and install your Inline
449$lang code. The command that failed was:
450  $cmd
451
452The build directory was:
453$build_dir
454
455The error message was:
456$error
457
458To debug the problem, cd to the build directory, and inspect the output files.
459
460MSG
461;
462}
463
464
465# Load and Run the Java Code.
466sub load {
467	my $o = shift ;
468
469	if ($o->get_java_config('loaded')){
470		return ;
471	}
472
473	Inline::Java::debug(1, "Starting load.") ;
474
475	my $install_dir = File::Spec->catdir($o->get_api('install_lib'),
476		'auto', $o->get_api('modpname')) ;
477
478	# If the JVM is not running, we need to start it here.
479	my $cp = $ENV{CLASSPATH} || '' ;
480	if (! $JVM){
481		$ENV{CLASSPATH} = Inline::Java::Portable::make_classpath(
482			Inline::Java::Portable::get_server_jar()) ;
483		Inline::Java::debug(2, "classpath: $ENV{CLASSPATH}") ;
484		$JVM = new Inline::Java::JVM($o) ;
485		$ENV{CLASSPATH}	= $cp ;
486		Inline::Java::debug(2, "classpath: $ENV{CLASSPATH}") ;
487
488		my $pc = new Inline::Java::Protocol(undef, $o) ;
489		$pc->AddClassPath(Inline::Java::Portable::portable("SUB_FIX_JAVA_PATH", Inline::Java::Portable::get_user_jar())) ;
490
491		my $st = $pc->ServerType() ;
492		if ((($st eq "shared")&&(! $o->get_java_config('SHARED_JVM')))||
493			(($st eq "private")&&($o->get_java_config('SHARED_JVM')))){
494			croak "JVM type mismatch on port " . $JVM->{port} ;
495		}
496	}
497
498	$ENV{CLASSPATH}	= '' ;
499	my @cp = Inline::Java::Portable::make_classpath($install_dir, $o->get_java_config('CLASSPATH')) ;
500	$ENV{CLASSPATH}	= $cp ;
501
502	my $pc = new Inline::Java::Protocol(undef, $o) ;
503	$pc->AddClassPath(@cp) ;
504
505	# Add our Inline object to the list.
506	push @INLINES, $o ;
507	$o->set_java_config('id', scalar(@INLINES) - 1) ;
508	Inline::Java::debug(3, "Inline::Java object id is " . $o->get_java_config('id')) ;
509
510	$o->study_module() ;
511	if ((defined($o->get_java_config('STUDY')))&&(scalar($o->get_java_config('STUDY')))){
512		$o->_study($o->get_java_config('STUDY')) ;
513	}
514
515	$o->set_java_config('loaded', 1) ;
516	Inline::Java::debug(1, "load done.") ;
517}
518
519
520# This function 'studies' the classes generated by the inlined code.
521sub study_module {
522	my $o = shift ;
523
524	my $install_dir = File::Spec->catdir($o->get_api('install_lib'),
525		'auto', $o->get_api('modpname')) ;
526	my $cache = $o->get_api('modfname') . '.' . $o->get_api('suffix') ;
527
528	my $lines = [] ;
529	if (! $o->get_java_config('built')){
530		# Since we didn't build the module, this means that
531		# it was up to date. We can therefore use the data
532		# from the cache.
533		Inline::Java::debug(1, "using jdat cache") ;
534		my $p = File::Spec->catfile($install_dir, $cache) ;
535		my $size = (-s $p) || 0 ;
536		if ($size > 0){
537			if (open(Inline::Java::CACHE, "<$p")){
538				while (<Inline::Java::CACHE>){
539					push @{$lines}, $_ ;
540				}
541				close(Inline::Java::CACHE) ;
542			}
543			else{
544				croak "Can't open $p for reading: $!" ;
545			}
546		}
547	}
548	else{
549		# First thing to do is get the list of classes that comprise the module.
550
551		# We need the classes that are in the directory or under...
552		my @classes = () ;
553		my $cwd = Cwd::cwd() ;
554		if ($o->get_config('UNTAINT')){
555			($cwd) = $cwd =~ /(.*)/ ;
556		}
557
558		# We chdir to the install dir, that makes it easier to figure out
559		# the packages for the classes.
560		chdir($install_dir) ;
561		my @fl = Inline::Java::Portable::find_classes_in_dir('.') ;
562		chdir $cwd ;
563		foreach my $f (@fl){
564			push @classes, $f->{class} ;
565		}
566
567		# Now we ask Java the info about those classes...
568		$lines = $o->report(@classes) ;
569
570		# and we update the cache with these results.
571		Inline::Java::debug(1, "updating jdat cache") ;
572		my $p = File::Spec->catfile($install_dir, $cache) ;
573		if (open(Inline::Java::CACHE, ">$p")){
574			foreach my $l (@{$lines}){
575				print Inline::Java::CACHE "$l\n" ;
576			}
577			close(Inline::Java::CACHE) ;
578		}
579		else{
580			croak "Can't open $p file for writing" ;
581		}
582	}
583
584	# Now we read up the symbols and bind them to Perl.
585	$o->bind_jdat($o->load_jdat($lines)) ;
586}
587
588
589# This function 'studies' the specified classes and binds them to
590# Perl.
591sub _study {
592	my $o = shift ;
593	my $classes = shift ;
594
595	my @new_classes = () ;
596	foreach my $class (@{$classes}){
597		$class = Inline::Java::Class::ValidateClass($class) ;
598		if (! Inline::Java::known_to_perl($o->get_api('pkg'), $class)){
599			push @new_classes, $class ;
600		}
601	}
602	if (! scalar(@new_classes)){
603		return ;
604	}
605
606	my $lines = $o->report(@new_classes) ;
607	# Now we read up the symbols and bind them to Perl.
608	$o->bind_jdat($o->load_jdat($lines)) ;
609}
610
611
612sub report {
613	my $o = shift ;
614	my @classes = @_ ;
615
616	my @lines = () ;
617	if (scalar(@classes)){
618		my $pc = new Inline::Java::Protocol(undef, $o) ;
619		my $resp = $pc->Report(join(" ", @classes)) ;
620		@lines = split("\n", $resp) ;
621	}
622
623	return \@lines ;
624}
625
626
627# Load the jdat code information file.
628sub load_jdat {
629	my $o = shift ;
630	my $lines = shift ;
631
632	Inline::Java::debug_obj($lines) ;
633
634	# We need an array here since the same object can have many
635	# study sessions.
636	if (! defined($o->{ILSM}->{data})){
637		$o->{ILSM}->{data} = [] ;
638	}
639	my $d = {} ;
640	my $data_idx = scalar(@{$o->{ILSM}->{data}}) ;
641	push @{$o->{ILSM}->{data}}, $d ;
642
643	# The original regexp didn't match anymore under the debugger...
644	# Very strange indeed...
645	# my $re = '[\w.\$\[;]+' ;
646	my $re = '.+' ;
647
648	my $idx = 0 ;
649	my $current_class = undef ;
650	if (scalar(@{$lines})){
651		my $vline = shift @{$lines} ;
652		chomp($vline) ;
653		if ($vline ne $report_version){
654			croak("Report version mismatch ($vline != $report_version). Delete your '_Inline' and try again.") ;
655		}
656	}
657	foreach my $line (@{$lines}){
658		chomp($line) ;
659		if ($line =~ /^class ($re) ($re)$/){
660			# We found a class definition
661			my $java_class = $1 ;
662			my $parent_java_class = $2 ;
663			$current_class = Inline::Java::java2perl($o->get_api('pkg'), $java_class) ;
664			$d->{classes}->{$current_class} = {} ;
665			$d->{classes}->{$current_class}->{java_class} = $java_class ;
666			if ($parent_java_class ne "null"){
667				$d->{classes}->{$current_class}->{parent_java_class} = $parent_java_class ;
668			}
669			$d->{classes}->{$current_class}->{constructors} = {} ;
670			$d->{classes}->{$current_class}->{methods} = {} ;
671			$d->{classes}->{$current_class}->{fields} = {} ;
672		}
673		elsif ($line =~ /^constructor \((.*)\)$/){
674			my $signature = $1 ;
675
676			$d->{classes}->{$current_class}->{constructors}->{$signature} =
677				{
678					SIGNATURE => [split(", ", $signature)],
679					STATIC => 1,
680					IDX => $idx,
681				} ;
682		}
683		elsif ($line =~ /^method (\w+) ($re) (\w+)\((.*)\)$/){
684			my $static = $1 ;
685			my $declared_in = $2 ;
686			my $method = $3 ;
687			my $signature = $4 ;
688
689			if (! defined($d->{classes}->{$current_class}->{methods}->{$method})){
690				$d->{classes}->{$current_class}->{methods}->{$method} = {} ;
691			}
692
693			$d->{classes}->{$current_class}->{methods}->{$method}->{$signature} =
694				{
695					SIGNATURE => [split(", ", $signature)],
696					STATIC => ($static eq "static" ? 1 : 0),
697					IDX => $idx,
698				} ;
699		}
700		elsif ($line =~ /^field (\w+) ($re) (\w+) ($re)$/){
701			my $static = $1 ;
702			my $declared_in = $2 ;
703			my $field = $3 ;
704			my $type = $4 ;
705
706			if (! defined($d->{classes}->{$current_class}->{fields}->{$field})){
707				$d->{classes}->{$current_class}->{fields}->{$field} = {} ;
708			}
709
710			$d->{classes}->{$current_class}->{fields}->{$field}->{$type} =
711				{
712					TYPE => $type,
713					STATIC => ($static eq "static" ? 1 : 0),
714					IDX => $idx,
715				} ;
716		}
717		$idx++ ;
718	}
719
720	Inline::Java::debug_obj($d) ;
721
722	return ($d, $data_idx) ;
723}
724
725
726# Binds the classes and the methods to Perl
727sub bind_jdat {
728	my $o = shift ;
729	my $d = shift ;
730	my $idx = shift ;
731
732	if (! defined($d->{classes})){
733		return ;
734	}
735
736	my $inline_idx = $o->get_java_config('id') ;
737
738	my %classes = %{$d->{classes}} ;
739	foreach my $class (sort keys %classes) {
740		my $class_name = $class ;
741		$class_name =~ s/^(.*)::// ;
742
743		my $java_class = $d->{classes}->{$class}->{java_class} ;
744		# This parent stuff is needed for PerlNatives (so that you can call PerlNatives methods
745		# from Perl...)
746		my $parent_java_class = $d->{classes}->{$class}->{parent_java_class} ;
747		my $parent_module = '' ;
748		my $parent_module_declare = '' ;
749		if (defined($parent_java_class)){
750			$parent_module = java2perl($o->get_api('pkg'), $parent_java_class) ;
751			$parent_module_declare = "\$$parent_module" . "::EXISTS_AS_PARENT = 1 ;" ;
752			$parent_module .= ' ' ;
753		}
754		if (Inline::Java::known_to_perl($o->get_api('pkg'), $java_class)){
755			next ;
756		}
757
758		my $colon = ":" ;
759		my $dash = "-" ;
760		my $ijo = 'Inline::Java::Object' ;
761
762		my $code = <<CODE;
763package $class ;
764use vars qw(\@ISA \$INLINE \$EXISTS \$JAVA_CLASS \$DUMMY_OBJECT) ;
765
766$parent_module_declare
767\@ISA = qw($parent_module$ijo) ;
768\$INLINE = \$INLINES[$inline_idx] ;
769\$EXISTS = 1 ;
770\$JAVA_CLASS = '$java_class' ;
771\$DUMMY_OBJECT = $class$dash>__new(
772	\$JAVA_CLASS, \$INLINE, 0) ;
773
774use Carp ;
775
776CODE
777
778		while (my ($field, $types) = each %{$d->{classes}->{$class}->{fields}}){
779			while (my ($type, $sign) = each %{$types}){
780				if ($sign->{STATIC}){
781					$code .= <<CODE;
782tie \$$class$colon:$field, "Inline::Java::Object::StaticMember",
783	\$DUMMY_OBJECT,
784	'$field' ;
785CODE
786					# We have at least one static version of this field,
787					# that's enough.
788					# Don't forget to reset the 'each' static pointer
789					keys %{$types} ;
790					last ;
791				}
792			}
793		}
794
795
796		if (scalar(keys %{$d->{classes}->{$class}->{constructors}})){
797			$code .= <<CODE;
798
799sub new {
800	my \$class = shift ;
801	my \@args = \@_ ;
802
803	my \$o = \$INLINE ;
804	my \$d = \$o->{ILSM}->{data}->[$idx] ;
805	my \$signatures = \$d->{classes}->{'$class'}->{constructors} ;
806	my (\$proto, \$new_args, \$static) = \$class->__validate_prototype('new', [\@args], \$signatures, \$o) ;
807
808	my \$ret = undef ;
809	eval {
810		\$ret = \$class->__new(\$JAVA_CLASS, \$o, -1, \$proto, \$new_args) ;
811	} ;
812	croak \$@ if \$@ ;
813
814	return \$ret ;
815}
816
817
818sub $class_name {
819	return new(\@_) ;
820}
821
822CODE
823		}
824
825		while (my ($method, $sign) = each %{$d->{classes}->{$class}->{methods}}){
826			$code .= $o->bind_method($idx, $class, $method) ;
827		}
828
829		Inline::Java::debug_obj(\$code) ;
830
831		# open (Inline::Java::CODE, ">>code") and print CODE $code and close(CODE) ;
832
833		# Here it seems that for the eval below to resolve the @INLINES
834		# list properly, it must be used in this function...
835		my $dummy = scalar(@INLINES) ;
836
837		eval $code ;
838
839		croak $@ if $@ ;
840	}
841}
842
843
844sub bind_method {
845	my $o = shift ;
846	my $idx = shift ;
847	my $class = shift ;
848	my $method = shift ;
849	my $static = shift ;
850
851	my $code = <<CODE;
852
853sub $method {
854	my \$this = shift ;
855	my \@args = \@_ ;
856
857	my \$o = \$INLINE ;
858	my \$d = \$o->{ILSM}->{data}->[$idx] ;
859	my \$signatures = \$d->{classes}->{'$class'}->{methods}->{'$method'} ;
860	my (\$proto, \$new_args, \$static) = \$this->__validate_prototype('$method', [\@args], \$signatures, \$o) ;
861
862	if ((\$static)&&(! ref(\$this))){
863		\$this = \$DUMMY_OBJECT ;
864	}
865
866	my \$ret = undef ;
867	eval {
868		\$ret = \$this->__get_private()->{proto}->CallJavaMethod('$method', \$proto, \$new_args) ;
869	} ;
870	croak \$@ if \$@ ;
871
872	return \$ret ;
873}
874
875CODE
876
877	return $code ;
878}
879
880
881sub get_fields {
882	my $o = shift ;
883	my $class = shift ;
884
885	my $fields = {} ;
886	my $data_list = $o->{ILSM}->{data} ;
887
888	foreach my $d (@{$data_list}){
889		if (exists($d->{classes}->{$class})){
890			while (my ($field, $value) = each %{$d->{classes}->{$class}->{fields}}){
891				# Here $value is a hash that contains all the different
892				# types available for the field $field
893				$fields->{$field} = $value ;
894			}
895		}
896	}
897
898	return $fields ;
899}
900
901
902# Return a small report about the Java code.
903sub info {
904	my $o = shift ;
905
906	if (! (($o->{INLINE}->{object_ready})||($o->get_java_config('built')))){
907		$o->build() ;
908	}
909
910	if (! $o->get_java_config('loaded')){
911		$o->load() ;
912	}
913
914	my $info = '' ;
915	my $data_list = $o->{ILSM}->{data} ;
916
917	foreach my $d (@{$data_list}){
918		if (! defined($d->{classes})){
919			next ;
920		}
921
922		my %classes = %{$d->{classes}} ;
923
924		$info .= "The following Java classes have been bound to Perl:\n" ;
925		foreach my $class (sort keys %classes) {
926			$info .= "\n  class $class:\n" ;
927
928			$info .= "    public methods:\n" ;
929			while (my ($k, $v) = each %{$d->{classes}->{$class}->{constructors}}){
930				my $name = $class ;
931				$name =~ s/^(.*)::// ;
932				$info .= "      $name($k)\n" ;
933			}
934
935			while (my ($k, $v) = each %{$d->{classes}->{$class}->{methods}}){
936				while (my ($k2, $v2) = each %{$d->{classes}->{$class}->{methods}->{$k}}){
937					my $static = ($v2->{STATIC} ? "static " : "") ;
938					$info .= "      $static$k($k2)\n" ;
939				}
940			}
941
942			$info .= "    public member variables:\n" ;
943			while (my ($k, $v) = each %{$d->{classes}->{$class}->{fields}}){
944				while (my ($k2, $v2) = each %{$d->{classes}->{$class}->{fields}->{$k}}){
945					my $static = ($v2->{STATIC} ? "static " : "") ;
946					my $type = $v2->{TYPE} ;
947
948					$info .= "      $static$type $k\n" ;
949				}
950			}
951		}
952	}
953
954    return $info ;
955}
956
957
958
959######################## General Functions ########################
960
961
962sub __get_JVM {
963	return $JVM ;
964}
965
966
967# For testing purposes only...
968sub __clear_JVM {
969	$JVM = undef ;
970}
971
972
973sub shutdown_JVM {
974	if ($JVM){
975		$JVM->shutdown() ;
976		$JVM = undef ;
977	}
978}
979
980
981sub reconnect_JVM {
982	if ($JVM){
983		$JVM->reconnect() ;
984	}
985}
986
987
988sub capture_JVM {
989	if ($JVM){
990		$JVM->capture() ;
991	}
992}
993
994
995sub i_am_JVM_owner {
996	if ($JVM){
997		return $JVM->am_owner() ;
998	}
999}
1000
1001
1002sub release_JVM {
1003	if ($JVM){
1004		$JVM->release() ;
1005	}
1006}
1007
1008
1009sub get_DEBUG {
1010	return $Inline::Java::DEBUG ;
1011}
1012
1013
1014sub get_DONE {
1015	return $DONE ;
1016}
1017
1018
1019sub set_DONE {
1020	$DONE = 1 ;
1021}
1022
1023
1024sub __get_INLINES {
1025	return \@INLINES ;
1026}
1027
1028
1029sub java2perl {
1030	my $pkg = shift ;
1031	my $jclass = shift ;
1032
1033	$jclass =~ s/[.\$]/::/g ;
1034
1035	if ((defined($pkg))&&($pkg)){
1036		$jclass = $pkg . "::" . $jclass ;
1037	}
1038
1039	return $jclass ;
1040}
1041
1042
1043sub known_to_perl {
1044	my $pkg = shift ;
1045	my $jclass = shift ;
1046
1047	my $perl_class = java2perl($pkg, $jclass) ;
1048
1049	no strict 'refs' ;
1050	if (defined(${$perl_class . "::" . "EXISTS"})){
1051		Inline::Java::debug(3, "perl knows about '$jclass' ('$perl_class')") ;
1052		return 1 ;
1053	}
1054	else{
1055		Inline::Java::debug(3, "perl doesn't know about '$jclass' ('$perl_class')") ;
1056	}
1057
1058	return 0 ;
1059}
1060
1061
1062sub debug {
1063	my $level = shift ;
1064
1065	if (($Inline::Java::DEBUG)&&($Inline::Java::DEBUG >= $level)){
1066		my $x = " " x $level ;
1067		my $str = join("\n$x", @_) ;
1068		while (chomp($str)) {}
1069		print DEBUG_STREAM sprintf("[perl][%s]$x%s\n", $level, $str) ;
1070	}
1071}
1072
1073
1074sub debug_obj {
1075	my $obj = shift ;
1076	my $force = shift || 0 ;
1077
1078	if (($Inline::Java::DEBUG >= 5)||($force)){
1079		debug(5, "Dump:\n" . Dumper($obj)) ;
1080		if (UNIVERSAL::isa($obj, "Inline::Java::Object")){
1081			# Print the guts as well...
1082			debug(5, "Private Dump:" . Dumper($obj->__get_private())) ;
1083		}
1084	}
1085}
1086
1087
1088sub dump_obj {
1089	my $obj = shift ;
1090
1091	return debug_obj($obj, 1) ;
1092}
1093
1094
1095######################## Public Functions ########################
1096
1097
1098# If we are dealing with a Java object, we simply ask for a new "reference"
1099# with the requested class.
1100sub cast {
1101	my $type = shift ;
1102	my $val = shift ;
1103
1104	if (! UNIVERSAL::isa($val, "Inline::Java::Object")){
1105		croak("Type casting can only be used on Java objects. Use 'coerce' instead.") ;
1106	}
1107
1108	return $val->__cast($type) ;
1109}
1110
1111
1112# coerce is used to force a specific prototype to be used.
1113sub coerce {
1114	my $type = shift ;
1115	my $val = shift ;
1116	my $array_type = shift ;
1117
1118	if (UNIVERSAL::isa($val, "Inline::Java::Object")){
1119		croak("Type coercing can't be used on Java objects. Use 'cast' instead.") ;
1120	}
1121
1122	my $o = undef ;
1123	eval {
1124		$o = new Inline::Java::Class::Coerce($type, $val, $array_type) ;
1125	} ;
1126	croak $@ if $@ ;
1127
1128	return $o ;
1129}
1130
1131
1132sub study_classes {
1133	my $classes = shift ;
1134	my $package = shift || caller() ;
1135
1136	my $o = undef ;
1137	my %pkgs = () ;
1138	foreach (@INLINES){
1139		my $i = $_ ;
1140		my $pkg = $i->get_api('pkg') || 'main' ;
1141		$pkgs{$pkg} = 1 ;
1142		if ($pkg eq $package){
1143			$o = $i ;
1144			last ;
1145		}
1146	}
1147
1148	if (defined($o)){
1149		$o->_study($classes) ;
1150	}
1151	else {
1152		my $msg = "Can't place studied classes under package '$package' since Inline::Java was not used there. Valid packages are:\n" ;
1153		foreach my $pkg (keys %pkgs){
1154			$msg .= "  $pkg\n" ;
1155		}
1156		croak($msg) ;
1157	}
1158}
1159
1160
1161sub caught {
1162	my $class = shift ;
1163
1164	my $e = $@ ;
1165
1166	$class = Inline::Java::Class::ValidateClass($class) ;
1167
1168	my $ret = 0 ;
1169	if (($e)&&(UNIVERSAL::isa($e, "Inline::Java::Object"))){
1170		my ($msg, $score) = $e->__isa($class) ;
1171		if ($msg){
1172			$ret = 0 ;
1173		}
1174		else{
1175			$ret = 1 ;
1176		}
1177	}
1178	$@ = $e ;
1179
1180	return $ret ;
1181}
1182
1183
1184sub	find_default_j2sdk {
1185	my $class = shift ;
1186
1187	return File::Spec->catfile('Inline', 'Java', 'default_j2sdk.pl') ;
1188}
1189
1190
11911 ;
1192