#!/usr/bin/perl -w

use strict;
use Archive::Zip qw( :CONSTANTS :ERROR_CODES );
use Digest::MD5;

sub instructions {
  die <<'EOT';
Usage: makejar [-quiet]
               [-archive <arfile>] [-manifest <manifest>] [-nocompress]
               [-exclude <file>] <classfiles>
Options:
  -quiet        do not print non-fatal messages
  -archive      create an jar archive file
  -manifest     use a template manifest
  -nocompress   do not compress the output jar
  -exclude      specify file (or jar of files) to exclude

The -exclude option may be repeated to exclude multiple files.

All entry points and classes that are loaded through unusual means
(reflection, custon classloaders, etc.) should be explicitly
listed in <classfiles>.

If the -archive option is omitted, then the names of all the
class files that would be put in the archive are listed on stdout
instead.
EOT
}

my $quiet;
my $compress = COMPRESSION_DEFLATED;
my $arfile;
my $manifest;
my %exclude;
my @in_names;
my %closed;
my %out_files;

while (@ARGV) {
  my $arg = shift(@ARGV);
  my $pat = $arg;
  $pat =~ s/(\W)/\\$1/go;
  if ("-quiet" =~ /^$pat/) {
    $quiet = 1;
  } elsif ("-nocompress" =~ /^$pat/) {
    $compress = COMPRESSION_STORED;
  } elsif ("-archive" =~ /^$pat/) {
    $arfile = shift(@ARGV);
  } elsif ("-manifest" =~ /^$pat/) {
    $manifest = shift(@ARGV);
  } elsif ("-exclude" =~ /^$pat/) {
    my $file = shift(@ARGV);
    if ($file =~ /\.jar$/o) {
      my $zip = Archive::Zip->new();
      die "read error" unless $zip->read($file) == AZ_OK;
      my @members = $zip->memberNames();
      foreach $file (@members) {
        $exclude{$file} = 1;
      }
    } else {
      $exclude{$file} = 1;
    }
  } else {
    push(@in_names, $arg);
  }
}

unless (@in_names) {
  &instructions;
  exit;
}

sub read_u2 {
  my $CLASS = shift;
  my $file = shift;
  my $item = shift;
  my $buf;
  my $len = read($CLASS, $buf, 2);
  die "Class $file missing $item!\n" unless $len == 2;
  my $out = unpack("n", $buf);
  $out += 0x10000 if $out < 0;
  $out;
}

sub read_class {
  my $file = shift;
  return () if ($exclude{$file} || $closed{$file});
  $closed{$file} = 1;

  my @typelen = (0, 0, 0, 4, 4, 8, 8, 0, 2, 4, 4, 4, 0);
  my @type = ("", "UTF8", "", "Integer", "Float", "Long",
              "Double", "Class", "String", "FieldRef", "MethodRef",
              "InterfaceMethodRef", "NameAndType");

  if (!open(CLASS, $file)) {
    warn "Cannot read $file: $!\n" unless $quiet;
    return ();
  } 
  binmode(CLASS);

  my @strings;
  my @classes;
  my @descriptors;
  my $magic;
  my $minor;
  my $major;
  my $len;
  my $buf;
  my $j;
  my $type;

  $len = read(CLASS, $buf, 8);
  ($len == 8) || die "Class $file missing header!\n";
  ($magic, $minor, $major) = unpack("Nnn", $buf);
  ($magic == 0xCAFEBABE) || die "Class $file has bad magic number!\n";
  ($major == 45) || die "Class $file has bad major number!\n";
  ($minor == 3) || die "Class $file has bad minor number!\n";

  my $count = &read_u2('CLASS', $file, "constant pool count");

  for ($j = 1; $j < $count; $j++) {
    $len = read(CLASS, $buf, 1);
    ($len == 1) || die "Class $file missing constant pool tag!\n";
    my $tag = unpack('C', $buf);
    if ($tag == 1) { # UTF8
      my $utflen = &read_u2('CLASS', $file, "UTF8 length");
      if ($utflen) {
        $len = read(CLASS, $buf, $utflen);
        ($len == $utflen) || die "Class $file missing UTF8 data! ($utflen)\n";
        $strings[$j] = $buf;
      }
    } elsif ($tag == 7) { # Class
      push(@classes, &read_u2('CLASS', $file, "class index"));
    } elsif ($tag == 12) { # NameAndType
      seek(CLASS, 2, 1) || die "Class $file constant name and type corrupt!\n";
      push(@descriptors, &read_u2('CLASS', $file, "descriptor index"));
    } else {
      if ($type[$tag]) {
        seek(CLASS, $typelen[$tag], 1)
          || die "Class $file constant $type[$tag] corrupt!\n";
      } else {
        warn "Class $file constant pool corrupt! ".
             "Unknown constant type $tag for constant $j of $count.\n";
      }
      $j++ if $tag == 5 || $tag == 6; # Long and Double take two slots
    }
  }

  seek(CLASS, 6, 1) || die "Class $file corrupt!\n";

  $count = &read_u2('CLASS', $file, "interface count");
  if ($count) {
    seek(CLASS, $count * 2, 1)
      || die "Class $file interface table corrupt! ($count)\n";
  }

  foreach $type ("field", "method") {
    $count = &read_u2('CLASS', $file, "$type count");
    for ($j = 0; $j < $count; $j++) {
      $len = read(CLASS, $buf, 4);
      ($len == 4) || die "Class $file $type table corrupt ($j of $count)!\n";
      push(@descriptors, &read_u2('CLASS', $file, "$type descriptor index"));
      my $acount = &read_u2('CLASS', $file, "$type attribute count");
      my $k;
      for ($k = 0; $k < $acount; $k++) {
        &read_u2('CLASS', $file, "$type attribute name ($k of $acount)");
        $len = read(CLASS, $buf, 4);
        ($len == 4) || die "Class $file missing $type attribute length!\n";
        my $alen = unpack('N', $buf);
        if ($alen < 0) {
          # deal with overflow into sign bit
          seek(CLASS, 0x40000000, 1)
            || die "Class $file $type attribute corrupt! ".
                   "($k of $acount, length $alen)\n";
          $alen += 0x40000000;
          seek(CLASS, 0x40000000, 1)
            || die "Class $file $type attribute corrupt! ".
                   "($k of $acount, length $alen)\n";
          $alen += 0x40000000;
        }
        if ($alen) {
          seek(CLASS, $alen, 1)
            || die "Class $file ${type}attribute corrupt! ".
                   "($k of $acount, length $alen)\n";
        }
      }
    }
  }

  close(CLASS);

  my $index;
  my %classes;
  foreach $index (@classes) {
    $buf = $strings[$index]
      || die "Class $file has broken reference in constant pool!\n";
    if ($buf =~ /^\[/o) {
      while ($buf =~ s/L([^;]*);//o) {
        my $name = "$1.class";
        $classes{$name} = 1;
      }
    } else {
      my $name = "$buf.class";
      $classes{$name} = 1;
    }
  }
  foreach $index (@descriptors) {
    $buf = $strings[$index]
      || die "Class $file has broken reference in constant pool!\n";
    while ($buf =~ s/L([^;]*);//o) {
      my $name = "$1.class";
      $classes{$name} = 1;
    }
  }

  $out_files{$file} = 1;

  @classes = sort(keys(%classes));
  @classes;
}

my @in_files;
my $name;

foreach $name (@in_names) {
  if (-d $name) {
    opendir(DIR, $name);
    my @files = readdir(DIR);
    closedir(DIR);
    @files = grep(/\.class$/o, @files);
    grep($_ = $name."/".$_, @files);
    push(@in_files, @files);
  } else {
    push(@in_files, $name);
  }
}

my @open = @in_files;

while (@open) {
  my $class = shift(@open);
  my @dclasses = &read_class($class);
  push(@open, @dclasses);
}

sub headerline {
  my $header = shift;
  my $value = shift;
  my $result = $header.": ";
  if (length($value) > 70 - length($result)) {
    my $len = 70 - length($result);
    $result .= substr($value, 0, $len)."\n ";
    $value = substr($value, $len);
    while (length($value) > 69) {
      $result .= substr($value, 0, 69)."\n ";
      $value = substr($value, 69);
    }
  }
  $result .= $value."\n";
}

if ($arfile) {
  my %manifest = (""=>{"Created-By"=>"0.9 (makejar)"});
  my $md5 = Digest::MD5->new;
  if ($manifest) {
    open(MANIFEST, $manifest) || die "Cannot open template manifest!\n";
    my $line;
    my $name = "";
    my $header = "";
    my $value = "";
    while ($line = <MANIFEST>) {
      if ($line =~ /^\s+(.*)/o) {
        $value .= $1;
      } elsif ($line =~ /^([A-Za-z0-9][-\w]*)\s*:\s*(.*)/o) {
        if ($header eq "Name") {
          $name = $value;
          $manifest{$name} = {};
        } elsif ($header) {
          $manifest{$name}->{$header} = $value;
        }
        ($header, $value) = ($1, $2);
      }
    }
    if ($header eq "Name") {
      $name = $value;
      $manifest{$name} = {};
    } elsif ($header) {
      $manifest{$name}->{$header} = $value;
    }
    close(MANIFEST);
  }
  my $file;
  my $zip = Archive::Zip->new();
  foreach $file (sort(keys(%out_files))) {
    my $member = $zip->addFile($file, $file);
    $member->desiredCompressionMethod($compress);
    $manifest{$file} = {} unless $manifest{$file};
    $md5->reset;
    open(FILE, $file) || die "Cannot digest $file!\n";
    $md5->addfile(*FILE);
    close(FILE);
    $manifest{$file}->{"MD5-Digest"} = $md5->b64digest;
  }
  my $mantext = "";
  my $name;
  foreach $name (sort(keys(%manifest))) {
    if ($name eq "") {
      $mantext .= "Manifest-Version: 1.0\n";
    } else {
      $mantext .= "\n".headerline("Name", $name);
    }
    my $header;
    foreach $header (sort(keys(%{$manifest{$name}}))) {
      $mantext .= headerline($header, $manifest{$name}->{$header});
    }
  }
  my $member = $zip->addString($mantext, "META-INF/MANIFEST.MF");
  $member->desiredCompressionMethod($compress);
  ($zip->writeToFileNamed($arfile) == AZ_OK) || die "Cannot write jar!\n";
} else {
  print join("\n", sort(keys(%out_files)))."\n";
}