[kaffe] CVS kaffe (robilad): removed old class file dumper
Kaffe CVS
cvs-commits at kaffe.org
Mon Dec 31 08:24:40 PST 2007
PatchSet 7632
Date: 2007/12/31 16:22:35
Author: robilad
Branch: HEAD
Tag: (none)
Log:
removed old class file dumper
2007-12-31 Dalibor Topic <robilad at kaffe.org>
* developers/dumpClass.pl, developers/JavaClass.pm, developers/utf8munge.pl: Removed.
* developers/README: Removed dumpClass.pl,utf8munge.pl and JavaClass.pm.
* Makefile.am (EXTRA_DIST): Removed developers/dumpClass.pl, utf8munge.pl and
developers/JavaClass.pm.
Members:
ChangeLog:1.5130->1.5131
Makefile.am:1.135->1.136
developers/JavaClass.pm:1.3->1.4(DEAD)
developers/README:1.15->1.16
developers/dumpClass.pl:1.3->1.4(DEAD)
developers/utf8munge.pl:1.2->1.3(DEAD)
Index: kaffe/ChangeLog
diff -u kaffe/ChangeLog:1.5130 kaffe/ChangeLog:1.5131
--- kaffe/ChangeLog:1.5130 Mon Dec 31 16:05:31 2007
+++ kaffe/ChangeLog Mon Dec 31 16:22:35 2007
@@ -1,5 +1,12 @@
2007-12-31 Dalibor Topic <robilad at kaffe.org>
+ * developers/dumpClass.pl, developers/JavaClass.pm, developers/utf8munge.pl: Removed.
+ * developers/README: Removed dumpClass.pl,utf8munge.pl and JavaClass.pm.
+ * Makefile.am (EXTRA_DIST): Removed developers/dumpClass.pl, utf8munge.pl and
+ developers/JavaClass.pm.
+
+2007-12-31 Dalibor Topic <robilad at kaffe.org>
+
* developers/createLdScript.pl: Removed.
* developers/README: Removed createLdScript.pl.
* Makefile.am (EXTRA_DIST): Removed createLdScript.pl.
Index: kaffe/Makefile.am
diff -u kaffe/Makefile.am:1.135 kaffe/Makefile.am:1.136
--- kaffe/Makefile.am:1.135 Mon Dec 31 16:05:31 2007
+++ kaffe/Makefile.am Mon Dec 31 16:22:35 2007
@@ -127,7 +127,6 @@
developers/autogen.sh \
developers/config1.patch \
developers/config2.patch \
- developers/dumpClass.pl \
developers/gdbinit \
developers/geteh_from_libgcc2 \
developers/glibc-2.1.1-signal.patch \
@@ -140,10 +139,8 @@
developers/rpm-kaffe.spec \
developers/sp_offset.c \
developers/test-kaffe-sh \
- developers/utf8munge.pl \
developers/FullTest.sh \
developers/GCJ.note.1 \
- developers/JavaClass.pm \
developers/README \
developers/README.EUC_JP \
scripts/GCCWarning.pm \
===================================================================
Checking out kaffe/developers/JavaClass.pm
RCS: /home/cvs/kaffe/kaffe/developers/Attic/JavaClass.pm,v
VERS: 1.3
***************
--- kaffe/developers/JavaClass.pm Mon Dec 31 16:24:39 2007
+++ /dev/null Sun Aug 4 19:57:58 2002
@@ -1,1022 +0,0 @@
-#
-# Functions for reading in and writing out a Java .class file.
-# Also does a bit of consistency checking of the file.
-#
-# The only really nasty thing I've done (because of poor perl skils more
-# than anything else) is to make the %class a local() in a number of
-# places so that the check routines can see it.
-#
-# Class structure: Generally references to hashes. Tables are implemented as arrays.
-#
-# TODO:
-# make a &checkClass() function.
-# change a lot of 'local's to 'my's. (not local(%class), though)
-# Make CLASSIN and CLASSOUT parameters to read/write functions.
-# POD documentation
-# Cannot handle modifying float values. I can read and decode, but don't
-# have the math to convert back to a binary format (both floats and doubles).
-
-#
-# Copyright (c) 1999 University of Utah CSL.
-#
-# This file is distributed under the terms of the GNU Public License.
-#
-
-
-package JavaClass;
-
-###
-### Define constants for Java Classes
-###
-
-*classMagic = \0xcafebabe; # The magic header every .class file starts with
-
-## The magic identifiers for entries in the .class Constant Table.
-*CONSTANT_Class = \7;
-*CONSTANT_FieldRef = \9;
-*CONSTANT_MethodRef = \10;
-*CONSTANT_InterfaceMethodRef = \11;
-*CONSTANT_String = \8;
-*CONSTANT_Integer = \3;
-*CONSTANT_Float = \4;
-*CONSTANT_Long = \5;
-*CONSTANT_Double = \6;
-*CONSTANT_NameAndType = \12;
-*CONSTANT_Utf8 = \1;
-
-## String names associated with each type of Constant Table entry.
-%CONSTANTNames = (
- $CONSTANT_Class => "Class",
- $CONSTANT_FieldRef => "Field",
- $CONSTANT_MethodRef => "Method",
- $CONSTANT_InterfaceMethodRef => "Inteface Method",
- $CONSTANT_String => "String",
- $CONSTANT_Float => "Float",
- $CONSTANT_Integer => "Integer",
- $CONSTANT_Double => "Double",
- $CONSTANT_Long => "Long",
- $CONSTANT_NameAndType => "Name&Type",
- $CONSTANT_Utf8 => "Utf8"
- );
-
-## String names for the shorthand used in signatures
-$sig{'V'} = 'void';
-$sig{'I'} = 'int';
-$sig{'J'} = 'long';
-$sig{'Z'} = 'boolean';
-$sig{'F'} = 'float';
-$sig{'D'} = 'double';
-$sig{'B'} = 'byte';
-$sig{'S'} = 'short';
-$sig{'C'} = 'char';
-
-## Access control flags for classes, methods and fields.
-*ACC_PUBLIC = \0x0001;
-*ACC_PRIVATE = \0x0002;
-*ACC_PROTECTED = \0x0004;
-*ACC_STATIC = \0x0008;
-*ACC_FINAL = \0x0010;
-*ACC_SUPER = \0x0020; # class only
-*ACC_SYNCHRONIZED = \0x0020; # field/method
-*ACC_VOLATILE = \0x0040;
-*ACC_TRANSIENT = \0x0080;
-*ACC_INTERFACE = \0x0200;
-*ACC_ABSTRACT = \0x0400;
-*ACC_NATIVE = \0x0100;
-*ACC_STRICT = \0x0800;
-
-*ACC_UNKNOWN = \0xF000;
-
-###
-### Global variables
-###
-
-# Control the verbosity of &printClass()
-$detailedFields = 0;
-$detailedMethods = 0;
-
-###
-### Conversion functions
-###
-
-## parseJavaSig() takes a single argument, a single Java-internal
-## method signature and returns a list ($package, $return, $class,
-## $method, @args) where the items have been converted to a more
-## source-like format (e.g., english).
-sub parseJavaSig() {
- ## Parameters
- my $jsig = shift;
-
- ## Local variables
- my $class = '';
- my $package = '';
- my $method = '';
- my @args = ();
- my $ret = '';
-
- ## Temporaries
- my $depth = 0;
- my $repct = 0;
- my $arg = '';
-
- ### First is the class (all chars until a ".")
- $jsig =~ s/^([^.]*).//;
- $class = $1;
- $class =~ s,/,.,g; # / -> .
-
- # Peel the package name out of the class name (everything before last ".")
- if ($class =~ m/(.*)\.[^\.]*$/) {
- $package = $1;
- }
-
- ### Second comes the method name (all chars until a left paren)
- $jsig =~ s/^([^\(]*)\(//;
- $method = $1;
-
- ### Now the arguments
- SIGPARSE:
- while(1) {
- $repct = $jsig =~ s/^(I|J|Z|F|D|B|S|C|L|\[|\))//; ## No V types
- die "badly formed signature at $jsig" if ($repct == 0);
- $arg = $1;
-
- ## Stop if we hit the end paren
- last SIGPARSE if $arg eq "\)";
-
- if ($arg eq '[') {
- $depth++;
- # continue parsing array type...
- next SIGPARSE;
- } elsif ($arg eq 'L') {
- $jsig =~ s/^([^;]*);//;
- $arg = $1;
- $arg =~ s,/,.,g;
- } else {
- ## convert single-char identifier to english
- $arg = $sig{$arg};
- }
-
- ## If we hit an array, tack the array depth on the end
- if ($depth > 0) {
- $arg = $arg . "[]" x $depth;
- $depth = 0;
- }
-
- # Put the arg at the end of the list of args
- push (@args, $arg)
- }
-
- ### Last is the return type
- $depth = 0;
- $repct = $jsig =~ s/^(I|J|Z|F|D|B|S|C|L|V|\[)//; ## Adds V over argument types
- die "badly formed return type: \'$jsig\'" if ($repct == 0);
- $ret = $1;
-
- # If its an array, eat the [ and re-set $ret
- if ($ret eq '[') {
- $depth = 1;
- while ($jsig =~ s/\[//) {
- $depth++;
- }
- $jsig =~ s/^(I|J|Z|F|D|B|S|C|L)//; ## No [ or V
- die "badly formed return type: \'$jsig\'" if ($repct == 0);
- $ret = $1;
- }
-
- if ($ret eq 'L') {
- $jsig =~ s/^([^;]*);//;
- $ret = $1;
- $ret =~ s,/,.,g;
- } else {
- ## Convert single char identifier to english
- $ret = $sig{"$ret"};
- }
-
- # Tack the array brackets on
- if ($depth > 0) {
- $ret = $ret . "[]" x $depth;
- }
-
- ### Return the info in an easy-to-use list
- return ($package, $ret, $class, $method, @args);
-}
-
-###
-### Print functions
-###
-
-sub printClass {
- my $r_cl = shift;
- my %class = %{$r_cl};
-
- my $flStr = &ACCFlagsToString($class{accessFlags}, 1);
- print "$flStr\n";
-
- &printConstantPool($r_cl);
-
- ## Print 'this_class'
- my $thisClName = %{$class{constantPool}[$class{thisClass}]}->{nameIndex};
- $thisClName = %{$class{constantPool}[$thisClName]}->{val};
- print "this_class @ $class{thisClass} ($thisClName)\n";
-
- ## Print 'super_class'
- if ($class{superClass} != 0) {
- my $superClName = %{$class{constantPool}[$class{superClass}]}->{nameIndex};
- $superClName = %{$class{constantPool}[$superClName]}->{val};
- print "super_class @ $class{superClass} ($superClName)\n";
- } else {
- print "No super class\n";
- }
-
- ## Print direct super interfaces
- &printInterfaces($r_cl);
-
- ## Print fields
- &printFields($r_cl);
-
- ## Print methods
- &printMethods($r_cl);
-
- ## Print attributes
- &printAttributes("", $r_cl, $class{attributes});
-}
-
-sub printMethods {
- my $r_cl = shift;
- local(%class) = %{$r_cl};
-
- if ($class{methodCt} == 0) {
- print "No methods.\n";
- } else {
- $i = 0;
- print "Methods:\n";
- while ($i < $class{methodCt}) {
- my %method = %{$class{methods}[$i]};
-
- my $accflags = ACCFlagsToString($method{accessFlags}, 0);
- my $name = $class{constantPool}[$method{nameIndex}]->{val};
- my $desc = $class{constantPool}[$method{descriptorIndex}]->{val};
-
- if ($detailedMethods) {
- print ("\t$i: ");
- print (".accessFlags=$accflags; ");
- print (".name @ $method{nameIndex} ($name); ");
- print (".descriptor @ $method{descriptorIndex} ($desc); ");
- print (".attrCt = $method{attributesCt};\n");
- &printAttributes("\t\t", \%class, $method{attributes});
- } else {
- print ("\t$accflags $name $desc\n");
- }
- } continue {
- $i++;
- }
- }
-}
-
-sub printFields {
- my $r_cl = shift;
- local(%class) = %{$r_cl};
-
- if ($class{fieldCt} == 0) {
- print "No fields.\n";
- } else {
- $i = 0;
- print "Fields:\n";
- while ($i < $class{fieldCt}) {
- my %field = %{$class{fields}[$i]};
-
- my $accflags = ACCFlagsToString($field{accessFlags}, 0);
- my $name = $class{constantPool}[$field{nameIndex}]->{val};
- my $desc = $class{constantPool}[$field{descriptorIndex}]->{val};
-
- if ($detailedFields) {
- print ("\t$i: ");
- print (".accessFlags=$accflags; ");
- print (".name @ $field{nameIndex} ($name); ");
- print (".descriptor @ $field{descriptorIndex} ($desc); ");
- print (".attrCt = $field{attributesCt};\n");
- &printAttributes("\t\t", \%class, $field{attributes});
- } else {
- print ("\t$accflags $desc $name\n");
- }
- } continue {
- $i++;
- }
- }
-}
-
-sub printInterfaces {
- my $r_cl = shift;
- local(%class) = %{$r_cl};
-
- if ($class{interfaceCt} == 0) {
- print "No interfaces.\n";
- } else {
- my $i = 0;
- print "Interfaces:\n";
- while ($i < $class{interfaceCt}) {
- my $iClass = $class{interfaces}[$i];
- my %iClassConst = %{$class{constantPool}[$iClass]};
- my $iClassName = $iClassConst{nameIndex};
- my $interfaceName = %{$class{constantPool}[$iClassName]}->{val};
- print "\t$i] @ $iClass ($interfaceName)\n";
- } continue {
- $i++;
- }
- }
-}
-
-sub ACCFlagsToString {
- my $flags = shift;
- my $isClass = shift;
- my @flags = ();
-
- push(@flags, "public") if $flags & $ACC_PUBLIC;
- push(@flags, "private") if $flags & $ACC_PRIVATE;
- push(@flags, "protected") if $flags & $ACC_PROTECTED;
- push(@flags, "abstract") if $flags & $ACC_ABSTRACT;
- push(@flags, "static") if $flags & $ACC_STATIC;
- push(@flags, "final") if $flags & $ACC_FINAL;
- if ($isClass) {
- push(@flags, "super") if $flags & $ACC_SUPER;
- }
- else {
- push(@flags, "synchronized") if $flags & $ACC_SYNCHRONIZED;
- }
- push(@flags, "native") if $flags & $ACC_NATIVE;
- push(@flags, "volatile") if $flags & $ACC_VOLATILE;
- push(@flags, "transient") if $flags & $ACC_TRANSIENT;
- push(@flags, "strictfp") if $flags & $ACC_STRICT;
- push(@flags, "interface") if $flags & $ACC_INTERFACE;
- push(@flags, "UNKNOWN") if $flags & $ACC_UNKNOWN;
-
- return join(',', @flags);
-}
-
-sub printConstantPool {
- my $r_cl = shift;
- local(%class) = %{$r_cl}; # cvt the class reference to the class hash
-
- print("Constant Pool Entries: $class{constantPoolCt}\n");
-
- $i = 1;
- while ($i < $class{constantPoolCt}) {
- my %cpEntry = %{$class{constantPool}[$i]};
-
- print "$i] $CONSTANTNames{$cpEntry{tag}}: ";
-
- if ($cpEntry{tag} eq $CONSTANT_Class) {
- my $ni = $cpEntry{nameIndex};
-
- &checkIndex($ni, "Name", $CONSTANT_Utf8);
-
- my $nm = $class{constantPool}[$ni]->{val};
-
- print (".name @ $ni ($nm);");
-
- } elsif (($cpEntry{tag} eq $CONSTANT_FieldRef)
- || ($cpEntry{tag} eq $CONSTANT_MethodRef)
- || ($cpEntry{tag} eq $CONSTANT_InterfaceMethodRef)) {
- &checkIndex($cpEntry{classIndex}, "Class", $CONSTANT_Class);
- &checkIndex($cpEntry{nameTypeIndex}, "Name & Type", $CONSTANT_NameAndType);
-
- print (".class @ $cpEntry{classIndex}; .name&type @ $cpEntry{nameTypeIndex};");
- } elsif ($cpEntry{tag} eq $CONSTANT_String) {
- my $si = $cpEntry{stringIndex};
- &checkIndex($si, "String", $CONSTANT_Utf8);
-
- my $str = $class{constantPool}[$si]->{val};
-
- print (".string @ $cpEntry{stringIndex} ($str);");
- } elsif ($cpEntry{tag} eq $CONSTANT_NameAndType) {
- my $ni = $cpEntry{nameIndex};
- my $di = $cpEntry{descriptorIndex};
-
- &checkIndex($ni, "Name", $CONSTANT_Utf8);
- &checkIndex($di, "Descriptor", $CONSTANT_Utf8);
-
- my $nstr = $class{constantPool}[$ni]->{val};
- my $dstr = $class{constantPool}[$di]->{val};
-
- print (".name @ $ni ($nstr); .descriptor @ $di ($dstr); ");
- } elsif ($cpEntry{tag} eq $CONSTANT_Integer) {
- print (".value = $cpEntry{val}");
- } elsif ($cpEntry{tag} eq $CONSTANT_Utf8) {
- print (".length=$cpEntry{len}; ");
- print (".val=$cpEntry{val}; ");
- } elsif ($cpEntry{tag} eq $CONSTANT_Float) {
- print (".val=$cpEntry{strVal}; ");
- } elsif ($cpEntry{tag} eq $CONSTANT_Double) {
- print (".val=$cpEntry{strVal}; ");
- $i++; ## Ick. 8-byte entries take two constant pool entries
- } elsif ($cpEntry{tag} eq $CONSTANT_Long) {
- print (".val=$cpEntry{strVal}; ");
- $i++; ## Ick. 8-byte entries take two constant pool entries
- } else {
- &fatal("Unknown Constant type $cpEntry{tag}!\n");
- }
-
- print ("\n");
-
- $i++;
- }
-}
-
-sub printAttributes {
- my ($prefix, $r_class, $r_attrs) = @_;
-
- return if (!defined($r_attrs));
-
- my $i = 0;
- my %class = %{$r_class};
-
- print ("${prefix}Attributes:\n");
- foreach $r_attr (@{$r_attrs}) {
-
- my $name = $class{constantPool}[$r_attr->{nameIndex}]->{val};
- print ("${prefix}\t.name=$name; ");
- print (".length=" . $r_attr->{len} . ";");
-
- if ($name eq 'SourceFile') {
- if ($r_attr->{len} != 2) {
- print ("!Badly formed SourceFile Attribute, must be 2!");
- } else {
- my ($high, $low) = unpack("CC", $r_attr->{attr});
- my $idx = ($high * 256) + $low;
- my $name = $class{constantPool}[$idx]->{val};
- print (" @ " . $idx . " (\"" . $name . "\")");
- }
- }
- elsif ($name eq 'InnerClasses') {
- my ($high, $low) = unpack("CC", $r_attr->{attr});
- my $nr = ($high * 256) + $low;
-
- print (" @ $nr entries");
-
- my $array = substr ($r_attr->{attr}, 2);
- for (my $i = 0; $i < $nr; $i++, $array = substr ($array, 8)) {
- my ($inner, $outer, $name, $acces) = unpack ("nnnn", $array);
-
- print("\n");
- # print("${prefix}\t\t$i] $inner, $outer, $name, $acces");
-
- print("${prefix}\t\t$i]");
- print(" .inner = " . $inner);
- print(" (" . $class{constantPool}[$class{constantPool}[$inner]->{nameIndex}]->{val} . ")") if $inner;
-
- print(" .outer = $outer");
- print(" (" . $class{constantPool}[$class{constantPool}[$outer]->{nameIndex}]->{val} . ")") if $outer;
-
- print(" .name = $name");
- print(" ($class{constantPool}[$name]->{val})") if ($name);
-
- print(" .acces = $acces (" . &ACCFlagsToString($acces, 1) .")");
- }
- }
- print ("\n");
- }
-}
-
-###
-### Read Class function
-###
-
-sub readClass {
- my $classFile = shift;
- local(%class) = (());
-
- open(CLASSIN, $classFile)
- || open(CLASSIN, "${classFile}.class")
- || die ("Cannot open $classFile for reading");
-
- ###
- ### Header Magic
- ###
-
- $class{magic} = read_u4();
- if ($class{magic} != $classMagic) {
- fatal("Bad class magic '$class{magic}' --expected '$classMagic'. $classFile is probably not a Java class file.");
- }
-
- ## Read in the major and minor version numbers
- $class{minorVersion} = &read_u2();
- $class{majorVersion} = &read_u2();
-
- print("Version: $class{majorVersion}.$class{minorVersion} (expected 45.3)\n")
- if ($class{minorVersion} ne 3) || ($class{majorVersion} ne 45);
-
- ###
- ### Constant Pool
- ###
- $class{constantPoolCt} = &read_u2();
- $class{constantPool} = [];
-
- $i = 1; # constant pool actually starts with entry 1...
- while ($i < $class{constantPoolCt}) {
- my %cpEntry;
- $cpEntry{tag} = &read_u1();
-
- if ($cpEntry{tag} eq $CONSTANT_Class) {
- $cpEntry{nameIndex} = &read_u2();
-
- &checkIndex($cpEntry{nameIndex}, "Name");
- } elsif ($cpEntry{tag} eq $CONSTANT_FieldRef) {
- $cpEntry{classIndex} = &read_u2();
- $cpEntry{nameTypeIndex} = &read_u2();
-
- &checkIndex($cpEntry{classIndex}, "Class");
- &checkIndex($cpEntry{nameTypeIndex}, "Name & Type");
- } elsif ($cpEntry{tag} eq $CONSTANT_MethodRef) {
- $cpEntry{classIndex} = &read_u2();
- $cpEntry{nameTypeIndex} = &read_u2();
-
- &checkIndex($cpEntry{classIndex}, "Class");
- &checkIndex($cpEntry{nameTypeIndex}, "Name & Type");
- } elsif ($cpEntry{tag} eq $CONSTANT_InterfaceMethodRef) {
- $cpEntry{classIndex} = &read_u2();
- $cpEntry{nameTypeIndex} = &read_u2();
-
- &checkIndex($cpEntry{classIndex}, "Class");
- &checkIndex($cpEntry{nameTypeIndex}, "Name & Type");
- } elsif ($cpEntry{tag} eq $CONSTANT_String) {
- $cpEntry{stringIndex} = &read_u2();
-
- &checkIndex($cpEntry{stringIndex}, "String");
- } elsif ($cpEntry{tag} eq $CONSTANT_NameAndType) {
- $cpEntry{nameIndex} = &read_u2();
- $cpEntry{descriptorIndex} = &read_u2();
-
- &checkIndex($cpEntry{nameIndex}, "Name");
- &checkIndex($cpEntry{descriptorIndex}, "Descriptor");
- } elsif ($cpEntry{tag} eq $CONSTANT_Integer) {
- $cpEntry{val} = &read_u4();
- } elsif ($cpEntry{tag} eq $CONSTANT_Utf8) {
- $cpEntry{len} = &read_u2();
- $cpEntry{val} = &read_utf8($cpEntry{len});
- } elsif ($cpEntry{tag} eq $CONSTANT_Float) {
- $cpEntry{val} = &read_u4();
- $cpEntry{strVal} = &read_float($cpEntry{val});
- } elsif ($cpEntry{tag} eq $CONSTANT_Double) {
- $cpEntry{val} = &read_u8();
- $cpEntry{strVal} = &read_double($cpEntry{val});
- } elsif ($cpEntry{tag} eq $CONSTANT_Long) {
- $cpEntry{val} = &read_u8();
- $cpEntry{strVal} = "<Unknown>";
- } else {
- &fatal("Unknown Constant type $cpEntry{tag}!\n");
- }
-
- $class{constantPool}[$i] = \%cpEntry;
-
- ## Ick. 8-byte entries take two constant pool entries
- $i++ if (($cpEntry{tag} == $CONSTANT_Long)
- || ($cpEntry{tag} == $CONSTANT_Double));
- } continue {
- $i++;
- }
-
- ###
- ### Misc. Class Info
- ###
-
- $class{accessFlags} = &read_u2();
-
- $class{thisClass} = &read_u2();
- &checkIndex($class{thisClass}, "this_class", $CONSTANT_Class);
-
- $class{superClass} = &read_u2();
- if ($class{superClass} != 0) {
- &checkIndex($class{superClass}, "super_class", $CONSTANT_Class);
- }
- # so what if it's java.lang.Object
- # else {
- # print ("Warning: class has no super class. Must be java.lang.Object\n");
- #}
-
- ###
- ### Direct super-interfaces
- ###
- $class{interfaceCt} = &read_u2();
- $class{interfaces} = [];
-
- $i = 0;
- while ($i < $class{interfaceCt}) {
- $class{interfaces}[$i] = &read_u2();
-
- &checkIndex($class{interfaces}[$i], "Interface \#$i", $CONSTANT_Class);
- } continue {
- $i++;
- }
-
- ###
- ### Fields
- ###
- $class{fieldCt} = &read_u2();
- $class{fields} = [];
-
- $i = 0;
- while ($i < $class{fieldCt}) {
- my %field;
- $field{accessFlags} = &read_u2();
- $field{nameIndex} = &read_u2();
- $field{descriptorIndex} = &read_u2();
- $field{attributesCt} = &read_u2();
- $field{attributes} = &readAttributes($field{attributesCt});
-
- &checkIndex($field{nameIndex}, "Field Name", $CONSTANT_Utf8);
- &checkIndex($field{descriptorIndex}, "Field Descriptor", $CONSTANT_Utf8);
-
- $class{fields}[$i] = \%field;
- } continue {
- $i++;
- }
-
- ###
- ### Methods
- ###
- $class{methodCt} = &read_u2();
- $class{methods} = [];
-
- $i = 0;
- while ($i < $class{methodCt}) {
- my %method;
-
- $method{accessFlags} = &read_u2();
- $method{nameIndex} = &read_u2();
- $method{descriptorIndex} = &read_u2();
- $method{attributesCt} = &read_u2();
- $method{attributes} = &readAttributes($method{attributesCt});
-
- &checkIndex($method{nameIndex}, "Method Name", $CONSTANT_Utf8);
- &checkIndex($method{descriptorIndex}, "Method Descriptor", $CONSTANT_Utf8);
-
- $class{methods}[$i] = \%method;
- } continue {
- $i++;
- }
-
- ###
- ### Class attributes
- ###
- $class{attributesCt} = &read_u2();
- $class{attributes} = &readAttributes($class{attributesCt});
-
- ###
- ### End of .class file
- ###
-
- return \%class;
-}
-
-###
-### Write Class function
-###
-
-sub writeClass {
- my $r_class = shift;
- my $classFile = shift;
- local(%class) = %{$r_class};
-
- if ($classFile =~ /\.class$/) {
- open(CLASSOUT, ">$classFile")
- || die ("Cannot open $classFile for writing");
- } else {
- open(CLASSOUT, ">$classFile.class")
- || die ("Cannot open $classFile.class for writing");
- }
-
- ###
- ### Header Magic
- ###
-
- if ($class{magic} != $classMagic) {
- fatal("Bad class magic '$class{magic}' --expected '$classMagic'. Not writing class file.");
- }
-
- &write_u4($class{magic});
-
- ## Write major/minor version numbers
- &write_u2($class{minorVersion});
- &write_u2($class{majorVersion});
-
- ###
- ### Constant Pool
- ###
- &write_u2($class{constantPoolCt});
-
- $i = 1; # constant pool actually starts with entry 1...
- while ($i < $class{constantPoolCt}) {
- my %cpEntry = %{$class{constantPool}[$i]};
- &write_u1($cpEntry{tag});
-
- if ($cpEntry{tag} eq $CONSTANT_Class) {
- &checkIndex($cpEntry{nameIndex}, "Name", $CONSTANT_Utf8);
-
- &write_u2($cpEntry{nameIndex});
- } elsif (($cpEntry{tag} eq $CONSTANT_FieldRef)
- || ($cpEntry{tag} eq $CONSTANT_MethodRef)
- || ($cpEntry{tag} eq $CONSTANT_InterfaceMethodRef)) {
- &checkIndex($cpEntry{classIndex}, "Class", $CONSTANT_Class);
- &checkIndex($cpEntry{nameTypeIndex}, "Name & Type", $CONSTANT_NameAndType);
-
- &write_u2($cpEntry{classIndex});
- &write_u2($cpEntry{nameTypeIndex});
- } elsif ($cpEntry{tag} eq $CONSTANT_String) {
- &checkIndex($cpEntry{stringIndex}, "String", $CONSTANT_Utf8);
-
- &write_u2($cpEntry{stringIndex});
- } elsif ($cpEntry{tag} eq $CONSTANT_NameAndType) {
- &checkIndex($cpEntry{nameIndex}, "Name", $CONSTANT_Utf8);
- &checkIndex($cpEntry{descriptorIndex}, "Descriptor", $CONSTANT_Utf8);
-
- &write_u2($cpEntry{nameIndex});
- &write_u2($cpEntry{descriptorIndex});
- } elsif ($cpEntry{tag} eq $CONSTANT_Integer) {
- &write_u4($cpEntry{val});
- } elsif ($cpEntry{tag} eq $CONSTANT_Utf8) {
- &write_u2($cpEntry{len});
- &write_utf8($cpEntry{val});
- } elsif ($cpEntry{tag} eq $CONSTANT_Float) {
- &write_u4($cpEntry{val});
- } elsif ($cpEntry{tag} eq $CONSTANT_Double) {
- &write_u8($cpEntry{val});
- $i++; ## Ick. 8-byte entries take two constant pool entries
- } elsif ($cpEntry{tag} eq $CONSTANT_Long) {
- &write_u8($cpEntry{val});
- $i++; ## Ick. 8-byte entries take two constant pool entries
- } else {
- &fatal("Unknown Constant type $cpEntry{tag}!\n");
- }
- } continue {
- $i++;
- }
-
- ###
- ### Misc. Class Info
- ###
-
- &write_u2($class{accessFlags});
- &write_u2($class{thisClass});
- &write_u2($class{superClass});
-
- ###
- ### Direct super-interfaces
- ###
- &write_u2($class{interfaceCt});
-
- $i = 0;
- while ($i < $class{interfaceCt}) {
- &write_u2($class{interfaces}[$i]);
- } continue {
- $i++;
- }
-
- ###
- ### Fields
- ###
- &write_u2($class{fieldCt});
-
- $i = 0;
- while ($i < $class{fieldCt}) {
- my %field = %{$class{fields}[$i]};
- &write_u2($field{accessFlags});
- &write_u2($field{nameIndex});
- &write_u2($field{descriptorIndex});
- &write_u2($field{attributesCt});
- &writeAttributes($field{attributes});
- } continue {
- $i++;
- }
-
- ###
- ### Methods
- ###
- &write_u2($class{methodCt});
-
- $i = 0;
- while ($i < $class{methodCt}) {
- my %method = %{$class{methods}[$i]};
-
- &write_u2($method{accessFlags});
- &write_u2($method{nameIndex});
- &write_u2($method{descriptorIndex});
- &write_u2($method{attributesCt});
- &writeAttributes($method{attributes});
- } continue {
- $i++;
- }
-
- ###
- ### Class attributes
- ###
- &write_u2($class{attributesCt});
- &writeAttributes($class{attributes});
-
- ###
- ### End of .class file
- ###
-
- return \%class;
-}
-
-###
-### Integrity check functions
-###
-
-sub checkIndex {
- my ($val, $name, $type) = @_;
-
- # $class is a global
-
- if ($val == 0) {
- &fatal("ERROR: Found constant pool index 0 for $name. (Expecting a CONSTANT_$CONSTANTNames{$type} entry.)");
- }
-
- if ($val >= $class{constantPoolCt}) {
- &fatal("ERROR: $name index for current constant is $val, must be less than $class{constantPoolCt}\n");
- }
-
- if (defined($type)) {
- my $actualTag = $class{constantPool}[$val]{tag};
- if ($actualTag != $type) {
- &fatal("ERROR: $name expects a CONSTANT_$CONSTANTNames{$type} entry at $val, but found a CONSTANT_$CONSTANTNames{$actualTag} entry\n");
- }
- }
-}
-
-###
-### Read primitives
-###
-
-sub read_u8 {
- my $long = 0;
- (read(CLASSIN, $long, 8) == 8) || die ("premature eof in read_u8()\n");
- my ($b1, $b2, $b3, $b4, $b5, $b6, $b7, $b8) = unpack("CCCCCCCC", $long);
- return (($b1 << 56) + ($b2 << 48) + ($b3 << 40) + ($b4 << 32)
- + ($b5 << 24) + ($b6 << 16) + ($b7 << 8) + $b8);
-}
-
-sub read_u4 {
- my $long = 0;
- (read(CLASSIN, $long, 4) == 4) || die ("premature eof in read_u4()\n");
- my ($top, $highmid, $lowmid, $low) = unpack("CCCC", $long);
- return ($top * (256*256*256)) + ($highmid * (256*256)) + ($lowmid * 256) + $low;
-}
-
-sub read_u2 {
- my $short = 0;
- (read(CLASSIN, $short, 2) == 2) || die ("premature eof in read_u2()\n");
- my ($high, $low) = unpack("CC", $short);
- #print("read_u2: $high, $low\n");
- return ($high * 256) + $low;
-}
-
-sub read_u1 {
- my $byte = 0;
- (read(CLASSIN, $byte, 1) == 1) || die ("premature eof in read_u1()\n");
- my $val = unpack("C", $byte);
- return $val;
-}
-
-sub read_n {
- my $byteCt = shift;
- my $foo = '';
- (read(CLASSIN, $foo, $byteCt) == $byteCt) || die ("premature eof in read_n($byteCt)\n");
-
- return $foo;
-}
-
-sub read_float {
- my $intVal = shift;
-
- return "+INF" if ($intVal == 0x7f800000);
- return "-INF" if ($intVal == 0xff800000);
- if ((($intVal >= 0x7f800001) && ($intVal <= 0x7fffffff))
- || (($intVal >= 0xff800001) && ($intVal <= 0xffffffff))) {
- return "NaN";
- }
-
- ## Otherwise, convert to a floating point number
- $sign = (($intVal >> 31) == 0) ? 1 : -1;
- $exponent = (($intVal >> 23) & 0xFF);
- $mantissa = ($exponent == 0) ? ($intVal & 0x7fffff) << 1 : ($intVal & 0x7fffff) | 0x800000;
-
- return $sign * $mantissa * 2 ** ($exponent - 150);
-}
-
-sub read_double {
- my $intVal = shift;
-
- return "+INF" if ($intVal == 0x7f800000);
- return "-INF" if ($intVal == 0xff800000);
- if ((($intVal >= 0x7f800001) && ($intVal <= 0x7fffffff))
- || (($intVal >= 0xff800001) && ($intVal <= 0xffffffff))) {
- return "NaN";
- }
-
- ## Otherwise, convert to a floating point number
- $sign = (($intVal >> 31) == 0) ? 1 : -1;
- $exponent = (($intVal >> 23) & 0xFF);
- $mantissa = ($exponent == 0) ? ($intVal & 0x7fffff) << 1 : ($intVal & 0x7fffff) | 0x800000;
-
- return $sign * $mantissa * 2 ** ($exponent - 150);
-}
-
-sub read_utf8 {
- my $byteCt = shift;
- my $utf = '';
- (read(CLASSIN, $utf, $byteCt) == $byteCt) || die ("premature eof in read_utf8($byteCt)\n");
-
*** Patch too long, truncated ***
More information about the kaffe
mailing list