java-sablevm in Perl

#!/usr/bin/perl
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
# * This source file is part of SableVM.                            *
# *                                                                 *
# * See the file "LICENSE" for the copyright information and for    *
# * the terms and conditions for copying, distribution and          *
# * modification of this source file.                               *
# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
use 5.6.0;
use strict;
use warnings;
sub echo { print join (' ', @_), "\n" }
sub errecho { print STDERR join (' ', @_), "\n" }
#sub decho { echo @_ }
#sub doexec { echo @_ }
sub decho {}
sub doexec { exec @_ }

my $jvm='SABLEVM_BINARY';
my @rest=();
my @opts=();

if (@ARGV == 0) {
  echo 'You need to specify some parameters for java-sablevm wrapper.';
  echo q(Help option is not implemented yet. See 'man java-sablevm' for now.);
  exit 0;
}

my @classpath = split ':', ($ENV{CLASSPATH} || '');
decho q(This is 'java' wrapper for sablevm);

# Timezone detection should be handled in Classpath, but it's broken, so
# we work it around here.
if (-r '/etc/timezone') {
  local *TZFILE;
  if (open TZFILE, '<', '/etc/timezone') {
    while (<TZFILE>) {
      chop;
      next if m'^[ \t]*#'o || m/^[ \t]*$/o;
      my $ZONE_NAME = m'(\S+)'o ? $1 : '';
      if ($ZONE_NAME ne '') {
	push @opts, '-p', "user.timezone=${ZONE_NAME}";
	last;
      }
    }
    close TZFILE;
  }
}

# this may deserve some better handling - what if someone specifies another
# java.library.path in the cmdline w/o /usr/lib ?
my @svm_library_path = ('/usr/lib');
if (defined $ENV{LD_LIBRARY_PATH} && $ENV{LD_LIBRARY_PATH} ne '') {
  push @svm_library_path, $ENV{LD_LIBRARY_PATH};
}

# decho the first argument, and push the second arg onto @opts.
sub thunk_option
{
  decho $_[0];
  push @opts, $_[1];
}

# Set sablevm.boot.class.path.$firstarg to $1 (string match).
sub setbcp
{
  my $xtra = defined $_[0] ? '.' . $_[0] : '';
  decho "SET sablevm.boot.class.path$xtra to $1";
  push @opts, '-p', "sablevm.boot.class.path$xtra=$1";
}

ARG: for (my $arg = shift @ARGV; defined $arg; $arg = shift @ARGV) {
  sub nimpl {			# thunk to call if not implemented
    errecho "Warning: $arg option not implemented in java-sablevm wrapper.";
  }
  if ($arg =~ m/^(?:--?help|-h|-\?|-X)$/o) {
    decho 'help!';
    echo q(Help option is not implemented yet. See 'man java-sablevm' for now.);
    exit 0
  }
  elsif ($arg =~ m/^(?:-(?:-|X)?debug)$/o) {
    decho 'debug option';
    nimpl;
  }
  elsif ($arg =~ m/^(?:--?version|-V)$/o) {
    decho 'version';
    exec $jvm, '-V';
  }
  elsif ($arg =~ m/^(?:-ss|-ms|-mx)$/o) {
    nimpl;
    shift @ARGV;
  }
  elsif ($arg =~ m'^-Xgnuclasspath:(.*)'o) {
    # GNU Classpath *CVS* compatible mode
    my $value = $1;
    # check existence of gnucp-override.jar
    require File::Basename;
    my $svm_topdir = File::Basename::dirname ($0) . '/..';
    if (! -e "$svm_topdir/share/sablevm/gnucp-overrides.jar") {
      echo "Error processing $arg directive.  Could not find gnucp-overrides.jar in:";
      echo "$svm_topdir/share/sablevm/gnucp-overrides.jar";
      echo 'Try fetching one from http://sablevm.org/downloads/snapshots';
      echo 'or install classpath from SableVM-Classpath package.';
      exit 1;
    }
    # check existence of glibj.jar
    if (! -e "$value/share/classpath/glibj.zip") {
      echo "Error processing $arg directive.  Could not find glibj.jar in:";
      echo "$value/share/classpath/glibj.zip";
      echo 'Make sure path you gave is correct or install classpath from';
      echo 'SableVM-Classpath package.  See: http://sablevm.org/download';
      exit 1;
    }
    # Setup things
    push @svm_library_path, "$value/lib/classpath";
    push @opts, '-p', "sablevm.boot.class.path=$svm_topdir/share/sablevm/gnucp-overrides.jar:$value/share/classpath/glibj.zip";
  }
  elsif ($arg =~ m'^-Xbootclasspath/p:(.*)'o) {
    setbcp 'prepend';
  }
  elsif ($arg =~ m'^-Xbootclasspath/a:(.*)'o) {
    setbcp 'append';
  }
  elsif ($arg =~ m'-Xbootclasspath:(.*)'o) {
    setbcp;
  }
  elsif ($arg =~ m'^-X'o) {
    decho "catched some eXtra option: '$arg'";
    nimpl;
  }
  elsif ($arg =~ m/^(?:-client|-server|-noclassgc|--?noverify)$/o) {
    nimpl;
  }
  elsif ($arg =~ m/^(?:-ds?a|-disable(?:system)?assertions)$/o) {
    nimpl;
  }
  elsif ($arg =~ m/^(?:-es?a|-enable|-enable(?:system)?assertions)$/o) {
    nimpl;
    errecho 'You can compile SableVM with --enable-debugging-features option instead.';
  }
  elsif ($arg =~ m/^(?:--?classpath|--?cp)$/o) {
    my $argarg = shift @ARGV;
    decho "SET classpath $argarg";
    @classpath = split ':', $argarg;
  }
  elsif ($arg =~ m'^--?classpath=(.*)'o) {
    decho "SET classpath $1";
    @classpath = split ':', $1;
  }
  elsif ($arg =~ m/^--?addclasspath$/o) {
    my $argarg = shift @ARGV;
    decho "ADD classpath $argarg";
    push @classpath, (split ':', $argarg);
  }
  elsif ($arg =~ m'^-D(.*?)=(.*)'o) {
    my $rest = "$1=$2";
    decho "defined property $arg";
    my $value = $2;
    my $key = $1;
    decho "rest='$rest' key='$key' value='$value'";
    push @opts, "--property=${key}=${value}";
  }
  elsif ($arg =~ m/^--?jar$/o) {
    my $argarg = shift @ARGV;
    decho "JAR file $argarg";
    unshift @classpath, $argarg;
    local *MANIFEST;
    unless (open (MANIFEST, '-|',
		  'unzip', '-p', $argarg, 'META-INF/MANIFEST.MF')) {
      echo "Error: Unable to uncompress $argarg";
      exit 1;
    }
    my $class = '';
    while (<MANIFEST>) {
      if (m'Main-Class:\s+(\S+)'i) {
	$class = $1;
	$class =~ tr/\r//d;
	last;
      }
    }
    close MANIFEST;
    if ($? != 0) {
      echo "Error: Unable to uncompress $argarg";
      exit 1;
    }
    if ($class eq '') {
      echo "Error: No MANIFEST.MF or Main-Class: in MANIFEST.MF found in $argarg";
      exit 1;
    }
    decho 'class:', $class;
    push @opts, $class;
    # -jar is always the last option passed to java - the rest is being
    # passed to executed program (main method)
    last ARG;
  }
  elsif ($arg =~ m/^(?:-v|--?verbose)$/o) {
    thunk_option 'verbose output', '-v';
  }
  elsif ($arg =~ m/^(?:--?verbose-gc)$/o) {
    thunk_option 'verbose garbage collection', '-g';
  }
  elsif ($arg =~ m/^-verbose.*jni$/o) {
    thunk_option 'verbose JNI', '-j';
  }
  elsif ($arg =~ m'^-verbose'o) {
    nimpl;
  }
  elsif ($arg =~ m/^--?showversion$/o) {
    decho "just catched '$arg' request";
    # not exec, just show version and continue!
    system $jvm, '-V';
  }
  elsif ($arg eq '-vmdebug') {
    shift @ARGV; # a string of comma-separated flags follows -vmdebug
    nimpl;
    errecho 'You can compile SableVM with --enable-debugging-features option instead.';
  }
  elsif ($arg eq '--') {
    last ARG;
  }
  elsif ($arg =~ m'^-'o) {
    errecho "Warning: $arg option not RECOGNIZED by java-sablevm wrapper.";
    errecho 'A not recognized option will be just passed to SableVM.';
    errecho "Note that we don't know if we should expect an argument here!";
    errecho 'It almost _surely_ will result in an errors when the param is followed';
    errecho q(by an argument. Refer to 'man java-sablevm' and 'man sablevm'.);
    push @rest, $arg;
  }
  else {
    last ARG;
  }
}

sub dprint7 ($\@)
{
  my ($code, $lst) = @_;
  my $in7 = join ' ', @$lst;
  decho "$code:", "7${in7}7";
}
dprint7 'CP', @classpath;
dprint7 'OP', @opts;
dprint7 'RE', @rest;
dprint7 '@@', @ARGV;

if (@classpath) {		# redefining semantics for fun and profit!
  @classpath = ('--classpath=' . (join ':', @classpath));
}

push @classpath, '-p', 'java.library.path=' . (join ':', @svm_library_path);

# this is so that jikes worked w/o problems, i.e. when called by Ant
$ENV{BOOTCLASSPATH}='SABLEVM_CLASSDIR:SABLEVM_CLASSDIR/libclasspath.jar:SABLEVM_CLASSDIR/resources.jar';

my $tst=join ' ', @classpath, @opts, @rest, @ARGV;
decho 'TST:', $tst;

if ($tst ne '') {
  decho $jvm, '-Y', @classpath, @opts, @rest, @ARGV;
  doexec $jvm, '-Y', @classpath, @opts, @rest, @ARGV;
} else {
  echo 'You need to specify some parameters for java-sablevm wrapper.';
  echo q(Help option is not implemented yet. See 'man java-sablevm' for now.);
}

exit 0