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