[satan]

Вощем во...

{$apptype console}

{$R+,S+}
const
  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;
  CONSTANT_Unicode = 2;
  {------------------------------}
  ACC_PUBLIC = 1;
  ACC_PRIVATE = 2;
  ACC_PROTECTED = 4;
  ACC_STATIC = 8;
  ACC_FINAL = 16;
  ACC_SYNCHRONIZED = 32;
  ACC_SUPER = 32;
  ACC_VOLATILE = 64;
  ACC_TRANSIENT = 128;
  ACC_NATIVE = 256;
  ACC_INTERFACE = 512;
  ACC_ABSTRACT = 1024;
  {}
  TAB             = ^I;
  TAB2            = ^I^I;
  TAB3            = ^I^I^I;
  TAB4            = ^I^I^I^I;
  CR              = ^M;
  LF              = ^J;
  {}
type
  tfield_info = record
  access_flags : word;
  name_index : word;
  signature_index : word;
  attributes_count : word;
  {attributes[attribute_count]}
  end;
  {}
  tmethod_info = record
  access_flags : word;
  name_index : word;
  signature_index : word;
  attributes_count : word;
  {attributes[attribute_count]}
  end;
  {--атрибуты--}
  tGenericAttribute_info = record
  attribute_name : word;
  attribute_length : longInt;
  {info[attribute_length] of byte}
  end;
  {}
  tSourceFile_attribute = record
  attribute_name_index : word;
  attribute_length : longInt;
  sourcefile_index : word;
  end;
  {}
  tLineNumberTable_attribute = record
  attribute_name_index : word;
  attribute_length : longInt;
  line_number_table_length : word;
  {line_number_table[line_number_table_length] of record start_pc,line_number:word;end;}
  end;
  {}
  tConstantValue_attribute = record
  attribute_name_index : word;
  attribute_length : longInt;
  constantvalue_index : word;
  end;
  {}
  tLocalVariableTable_attribute = record
  attribute_name_index : word;
  attribute_length : longInt;
  local_variable_table_length : word;
  {local_variable_table[local_variable_table_length]}
  end;
  tLocal_variable_table = record
  start_pc : word;
  length : word;
  name_index : word;
  signature_index : word;
  slot : word;
  end;
  {}
  tExceptions_attribute = record
  attribute_name_index : word;
  attribute_length : longInt;
  number_of_exceptions : word;
  {exception_index_table[number_of_exceptions] of word}
  end;
  {}
  tInnerClasses_attribute = record
  attribute_name_index : word;
  attribute_length : longInt;
  number_of_classes : word;
  {classes[number_of_classes] of record
  inner_class_info_index : word;
  outer_class_info_index : word;
  inner_name_index : word;
  inner_class_access_flags : word;
  end}
  end;
  {}
  tSynthetic_attribute = record
  attribute_name_index : word;
  attribute_length : longInt;
  end;
  {}
  Deprecated_attribute = record
  attribute_name_index : word;
  attribute_length : longInt;
  end;
  {}
  tCode_attribute = record
  //attribute_name_index : word;
  //attribute_length : longInt;
  max_stack : word;
  max_locals : word;
  code_length : longInt;
  end;
  {code[code_length]}
  {exception_table_length : word;{***}
  {exception_table[exception_table_length]}
  {attributes_count : word;{***}
  {attribute_info[attribute_count]}
  tException_table = record
  start_pc : word;
  end_pc : word;
  handler_pc : word;
  catch_type : word;
  end;
  {--------------------------}

tarr = array[0..$FFFF-1] of byte;

var
  cf : record {ClassFile}
  magic : longInt;
  minor_version : word;
  major_version : word;
  constant_pool_count : word;
  cp_info :^tarr;{constant_pool[constant_pool_count - 1];}
  access_flags : word;
  this_class : word;
  super_class : word;
  interfaces_count : word;
  interfaces :^tarr;{[interfaces_count];}
  fields_count : word;
  field_info :^tarr;{fields[fields_count];}
  methods_count : word;
  method_info :^tarr;{methods[methods_count];}
  attributes_count : word;
  attribute_info :^tarr;{attributes[attribute_count];}
end;

var
  f : file;
  i,j,n,rc : integer; {longInt;}
  s : string;
  tag : byte;
  p :^byte;
  pfield_info :^tfield_info;
  pmethod_info :^tmethod_info;
  pGenericAttribute_info :^tGenericAttribute_info;
  pCode_attribute :^tCode_attribute;
  pException_table :^tException_table;
  pexception_table_length :^word;
  pattributes_count :^word;
  pLocalVariableTable_attribute :^tLocalVariableTable_attribute;
  pLocal_variable_table :^tLocal_variable_table;


function hex(b : byte) : string;
const
  h : array[0..$F] of char = '0123456789ABCDEF';
begin
  hex := h[b shr 4]+h[b and $F];
end;


function hexw(w : word) : string;
begin
  hexw := hex(hi(w))+hex(lo(w));
end;


function get(p : pointer; count : integer) : pointer;
var
  n : integer;
begin
  blockRead(f,p^,count,n);
  inc(longInt(p),n); {pasc}
  inc(rc,n);
  get := p; {get := ptr(cardinal(p)+count); //delphi}
end;

function swap2(p : pointer; offs : integer) : pointer;
var
  b1,b2 :^byte;
  b : byte;
begin
  dec(longInt(p),offs+1);
  b1 := p;
  dec(longInt(p));
  b2 := p;
  b := b1^; b1^ := b2^; b2^ := b;
  swap2 := p;
end;


function swap4(p : pointer; offs : integer) : pointer;
var
  w1,w2 : ^word;
  w : word;
begin
  w1 := swap2(p,0);
  w2 := swap2(w1,0);
  w := w1^; w1^ := w2^; w2^ := w;
  swap4 := w2;
end;


function pconst(i : integer) : pointer;
var
  w :^word;
  p :^byte;
begin
  p := nil;
  if (i>=1) and (i<cf.constant_pool_count-1) then
  begin
    p := @cf.cp_info^;
    while i>=1 do
    begin
      case p^ of
        CONSTANT_Class                        : inc(p,1+2);
        CONSTANT_Fieldref,CONSTANT_Methodref,
        CONSTANT_InterfaceMethodref           : inc(p,1+4);
        CONSTANT_String                       : inc(p,1+2);
        CONSTANT_Integer,CONSTANT_Float       : inc(p,1+4);
        CONSTANT_Long                         : inc(p,1+8 );
        CONSTANT_NameAndType                  : inc(p,1+4);
        CONSTANT_Utf8, CONSTANT_Unicode       :
                                                begin {null=$0000, 1b=$0001-$007F,2b=$0008-$07FF,3b=$0800-$FFFF{}
                                                  inc(p);
                                                  w := @p^;
                                                  inc(p,2);
                                                  inc(p,w^)
                                                end;
      else
      begin
        p := nil; i := 0;
      end;
    end;
    dec(i);
    end;
  end;
  pconst := p;
end;

function getConstStr(index : word) : string;
var
  s : string;
  j : word;
  p :^byte;
  w :^word;
begin
  s := '';
  p := pconst(index);
  if p<>nil then
  case p^ of
    CONSTANT_Class                          :
                                              begin
                                                w := @p^;
                                                inc(w);
                                                p := pconst(w^);
                                              end;
    CONSTANT_Fieldref,CONSTANT_Methodref,
    CONSTANT_InterfaceMethodref             :
                                              begin
                                                w := @p^;
                                                inc(w);
                                                p := pconst(w^);
                                              end;
    CONSTANT_String                         :
                                              begin
                                                w := @p^;
                                                inc(w);
                                                p := pconst(w^);
                                              end;
    CONSTANT_NameAndType                    :
                                              begin
                                                w := @p^;
                                                inc(w);
                                                p := pconst(w^);
                                              end;
  end;
  {null=$0000, 1b=$0001-$007F,2b=$0008-$07FF,3b=$0800-$FFFF{}
  if p<>nil then
    if (p^ in [CONSTANT_Utf8, CONSTANT_Unicode]) then
    begin
      inc(p);
      w := @p^;
      inc(p,2);
      for j := 0 to w^-1 do
      begin
        s := s+chr(p^);
        inc(p);
      end;
    end;
  getConstStr := s;
end;

{-------------------}

procedure load_const;
begin
  get(p,1);
  tag := p^;
  inc(p);
  write(tag:2,' ');
  case tag of
  CONSTANT_Class                                  :
                                                    begin
                                                      p := get(p,2);
                                                      write('CONSTANT_Class             :',TAB,word(swap2(p,0)^));
                                                    end;
  CONSTANT_Fieldref,CONSTANT_Methodref,
  CONSTANT_InterfaceMethodref                     :
                                                    begin
                                                      case tag of
                                                        CONSTANT_Fieldref             : write('CONSTANT_Fieldref          :');
                                                        CONSTANT_Methodref            : write('CONSTANT_Methodref         :');
                                                        CONSTANT_InterfaceMethodref   : write('CONSTANT_InterfaceMethodref:');
                                                      end;
                                                      p := get(p,4);
                                                      write(TAB,word(swap2(p,2)^),TAB,word(swap2(p,0)^));
                                                    end;
  CONSTANT_String                                 :
                                                    begin
                                                      p := get(p,2);
                                                      write('CONSTANT_String            :',TAB,word(swap2(p,0)^));
                                                    end;
  CONSTANT_Integer,CONSTANT_Float                 :
                                                    begin
                                                      case tag of
                                                        CONSTANT_Integer  : write('CONSTANT_Integer         :');
                                                        CONSTANT_Float    : write('CONSTANT_Float           :');
                                                      end;
                                                      p := get(p,4);
                                                      write(TAB,longInt(swap4(p,0)^));
                                                    end;
  CONSTANT_Long,CONSTANT_Double                   :
                                                    begin
                                                      case tag of
                                                        CONSTANT_Long: write('CONSTANT_Integer          :');
                                                        CONSTANT_Double: write('CONSTANT_Double         :');
                                                      end;
                                                      p := get(p,8 );
                                                      write(TAB,'_hi_',longInt(swap4(p,4)^),TAB,'_lo_',longInt(swap4(p,0)^));
                                                    end;
  CONSTANT_NameAndType                            :
                                                    begin
                                                      p := get(p,4);
                                                      write('CONSTANT_NameAndType       :',TAB,word(swap2(p,2)^),TAB,word(swap2(p,0)^));
                                                    end;
  CONSTANT_Utf8, CONSTANT_Unicode                 :
                                                    begin {null=$0000, 1b=$0001-$007F,2b=$0008-$07FF,3b=$0800-$FFFF{}
                                                      p := get(p,2); {length}
                                                      n := word(swap2(p,0)^);
                                                      write('CONSTANT_Utf8-Unicode [',n,']',TAB,'=',TAB);
                                                      for j := 0 to n-1 do
                                                      begin
                                                        get(p,1);
                                                        write(chr(p^));
                                                        inc(p);
                                                      end;
                                                    end;
  else
    if tag<>0 then
    begin
      write('error:',tag);
      halt;
    end;
  end;
  writeln;
end;


procedure load_attribute_info;
begin

  writeln(hexw(rc), 'h',TAB2,'GenericAttribute_info');
  p:=get(p,sizeof(pGenericAttribute_info^));
  pGenericAttribute_info:=swap2(swap4(p,0),0);
  s := getConstStr(pGenericAttribute_info^.attribute_name-1);
  writeln(TAB2,'attribute_name    :',TAB2,pGenericAttribute_info^.attribute_name,TAB,'-> ',s);
  writeln(TAB2,'attribute_length  :',TAB2,pGenericAttribute_info ^.attribute_length);

  if s='Code' then
  begin

    writeln(hexw(rc), 'h',TAB,'Code:');
    p := get(p,sizeof(pCode_attribute^));
    pCode_attribute := swap2(swap2(swap4(p,0),0),0);

    writeln(hexw(rc-sizeof(pCode_attribute^.max_stack)),
    'h',TAB2,'max_stack         :',TAB2,pCode_attribute^.max_stack);
    writeln(hexw(rc-sizeof(pCode_attribute^.max_locals)),
    'h',TAB2,'max_locals        :',TAB2,pCode_attribute^.max_locals);
    writeln(hexw(rc-sizeof(pCode_attribute^.code_length)),
    'h',TAB2,'code_length       :',TAB2,pCode_attribute^.code_length);

    write(#10#13,TAB2);
    for n := 0 to pCode_attribute^.code_length-1 do
    begin
      get(p,1);
      write(hex(byte(p^)),' ');
      if ((n+1) mod 8)=0 then write(#10#13,TAB2);
    end;
    writeln;
    writeln;

    p := get(p,sizeof(pexception_table_length^));
    pexception_table_length:=swap2(p,0);
    for n := 0 to pexception_table_length^-1 do
    begin
      p := get(p,sizeof(pException_table^));
      pException_table := swap2(swap2(swap2(swap2(p,0),0),0),0);
    end;
    p := get(p,sizeof(pattributes_count^));
    pattributes_count :=swap2(p,0);
    for n := 0 to pattributes_count^-1 do
      load_attribute_info;
  end
  else if s='LocalVariableTable' then
  begin
    writeln(hexw(rc), 'h',TAB2,'LocalVariableTable');
    p := get(p,sizeof(pLocalVariableTable_attribute^));
    pLocalVariableTable_attribute := swap2(swap4(swap2(p,0),0),0);
    writeln(hexw(rc-sizeof(pLocalVariableTable_attribute^.attribute_name_index)),
    ' attribute_name_index:',pLocalVariableTable_attribute^.attribute_name_index);
    writeln(hexw(rc-sizeof(pLocalVariableTable_attribute^.attribute_length)),
    ' attribute_length:',pLocalVariableTable_attribute^. attribute_length);
    writeln(hexw(rc-sizeof(pLocalVariableTable_attribute^.local_variable_table_length)),
    ' local_variable_table_length:',pLocalVariableTable_attribute^.local_variable_table_length);
    for n := 0 to pLocalVariableTable_attribute^.local_variable_table_length-1 do
    begin
      p := get(p,sizeof(pLocal_variable_table^));
      pLocal_variable_table := swap2(swap2(swap2(swap2(swap2(p,0),0),0),0),0);
      writeln('start_pc:',pLocal_variable_table^.start_pc);
      writeln('length:',pLocal_variable_table^.length);
      writeln('name_index:',pLocal_variable_table^.name_index);
      writeln('signature_index:',pLocal_variable_table^. signature_index);
      writeln('slot:',pLocal_variable_table^.slot);
    end;
  end
  {if s='SourceFile' then
  begin
  end{}
  else if s='LineNumberTable' then
  begin
    for n := 0 to pGenericAttribute_info^.attribute_length-1 do
    begin
      get(p,1);
      //write(hex(byte(p^)),' ');
      inc(p);
    end;
  end{}
  else {don't know... skip atributes}
  begin
    write(#10#13,TAB2);
    for n := 0 to pGenericAttribute_info^.attribute_length-1 do
    begin
      get(p,1);
      write(hex(byte(p^)),' ');
      inc(p);
    end;
  end;
  writeln;
end;


procedure load_interfaces;
begin
  p := get(p,2);
  write(word(swap2(p,0)^),',');
end;


procedure load_field_info;
begin
  p := get(p,sizeof(pfield_info^));
  pfield_info := swap2(swap2(swap2(swap2(p,0),0),0),0);
  writeln(TAB2,'access_flags      :',TAB2,pfield_info^.access_flags) ;
  writeln(TAB2,'name_index        :',TAB2,pfield_info^.name_index);
  writeln(TAB2,'signature_index   :',TAB2,pfield_info^.signature_index);
  writeln(TAB2,'attributes_count  :',TAB2,pfield_info^.attributes_count,TAB,'offs:[',hexw(rc), 'h]');
  for j := 0 to pfield_info^.attributes_count-1 do
    load_attribute_info;
end;


procedure method_info;
begin
  p := get(p,sizeof(pmethod_info^));
  pmethod_info := swap2(swap2(swap2(swap2(p,0),0),0),0);
  s := getConstStr(pmethod_info^.name_index-1);
  writeln(TAB2,'access_flags      :',TAB2,pmethod_info^.access_flags );
  writeln(TAB2,'name_index        :',TAB2,'[',pmethod_info^.name_index,']',TAB,'-> ',s);
  writeln(TAB2,'signature_index   :',TAB2,pmethod_info^.signature_index);
  writeln(TAB2,'attributes_count  :',TAB2,pmethod_info^.attributes_count,TAB,'offs:[',hexw(rc), 'h]' );
  for j := 0 to pmethod_info^.attributes_count-1 do
    load_attribute_info;
end;


begin

  getMem(cf.cp_info,            $FFFF);
  getMem(cf.interfaces,         $7FFF);
  getMem(cf.field_info,         $FFFF);
  getMem(cf.method_info,        $FFFF);
  getMem(cf.attribute_info,     $FFFF);

  fillChar(cf.cp_info^,         $FFFF, 0);
  fillChar(cf.interfaces^,      $7FFF, 0);
  fillChar(cf.field_info^,      $FFFF, 0);
  fillChar(cf.method_info^,     $FFFF, 0);
  fillChar(cf.attribute_info^,  $FFFF, 0);

  assign(f,'fw.clas');
  {cf.magic := $CAFEBABE; cf.minor_version := $0000; cf.major_version := $002E;
  rewrite(f,1);
  blockWrite(f,cf.magic,sizeof(cf.magic),n);
  blockWrite(f,cf.minor_version,sizeof(cf.minor_version),n);
  blockWrite(f,cf.major_version,sizeof(cf.major_version),n);{...}
  reset(f,1);

  rc := 0;

  swap4(get(@cf.magic,sizeof(cf.magic)),0);
  swap2(get(@cf.minor_version,sizeof(cf.minor_version)),0);
  swap2(get(@cf.major_version,sizeof(cf.major_version)),0);
  swap2(get(@cf.constant_pool_count,sizeof(cf.constant_pool_count)),0);

  p := @cf.cp_info^;
  for i := 1 to cf.constant_pool_count-1 do {здесь именно с 1 по cf.constant_pool_count-1}
  begin
    write(hexw(rc-1),'h ',i:3,' ');
    load_const; {загрузка и распознование cp_info}
  end;

  writeln;
  swap2(get(@cf.access_flags,sizeof(cf.access_flags) ),0);
  writeln(hexw(rc-sizeof(cf.access_flags)),'h',TAB2,'access_flags      :',TAB2,cf.access_flags);
  swap2(get(@cf.this_class,sizeof(cf.this_class)),0) ;
  writeln(hexw(rc-sizeof(cf.this_class)),'h',TAB2,'this_class        :',TAB2,cf.this_class);
  swap2(get(@cf.super_class,sizeof(cf.super_class)), 0);
  writeln(hexw(rc-sizeof(cf.super_class)),'h',TAB2,'super_class       :',TAB2,cf.super_class);

  writeln;
  swap2(get(@cf.interfaces_count,sizeof(cf.interfaces_count)),0);
  writeln(hexw(rc-sizeof(cf.interfaces_count)),'h',TAB2,'interfaces',TAB,'[',cf.interfaces_count,']',TAB3);
  p := @cf.interfaces^;
  for i := 0 to cf.interfaces_count-1 do
    load_interfaces; {загрузка interfaces}

  writeln;
  swap2(get(@cf.fields_count,sizeof(cf.fields_count) ),0);
  writeln(hexw(rc-sizeof(cf.fields_count)),'h',TAB2,'field_info',TAB,'[',cf.fields_count,']',TAB3);
  p := @cf.field_info^;
  for i := 0 to cf.fields_count-1 do
  begin
    writeln(hexw(rc), 'h',TAB2,'field_info       :',TAB,i:3,'-----------');
    load_field_info; {загрузка field_info}
  end;

  writeln;
  swap2(get(@cf.methods_count,sizeof(cf.methods_count)),0);
  writeln(hexw(rc-sizeof(cf.methods_count)), 'h',TAB2,'method_info',TAB,'[',cf.methods_count,']',TAB3);
  p := @cf.method_info^;
  for i := 0 to cf.methods_count-1 do
  begin
    writeln(hexw(rc),'h',TAB2,'method_info       :',TAB,i:3,'-----------');
    method_info; //загрузка method_info

  end;

  writeln;
  writeln('OFFSET:         ',hexw(rc),'h');
  swap2(get(@cf.attributes_count,sizeof(cf.attributes_count)),0);
  writeln(hexw(rc-sizeof(cf.attributes_count)),'h',TAB2,'attribute_info',TAB,'[',cf.attributes_count,']');
  p := @cf.attribute_info^;
  for i := 0 to cf.attributes_count-1 do
  begin
    load_attribute_info;
    writeln(#10#13'------------------------------------------------------------------');
  end;

  close(f);
  
  freeMem(cf.attribute_info,  $FFFF);
  freeMem(cf.method_info,     $FFFF);
  freeMem(cf.field_info,      $FFFF);
  freeMem(cf.interfaces,      $7FFF);
  freeMem(cf.cp_info,         $FFFF);

end.