procs.pas

SrcDecompiler is about creating a Delphi program decompiler. The program is written for Delphi 4 or

begin
  inherited SetItem(Index, Value);
end;

{ TGUIDConst }

function TGUIDConst.IsRefAddress(AAddress: PChar): Boolean;
begin
  Result := (AAddress = Address);
end;

{ TTypeInfoInfo }

function TTypeInfoInfo.IsRefAddress(AAddress: PChar): Boolean;
begin
  Result := (AAddress = Address) or (AAddress = Address + 4);
end;

function TTypeInfoInfo.GetTypeDef: string;
resourcestring
  STypeInfoWithoutDef = 'Error getting def from a TypeInfo without def at %p.';
begin
  if TypeInfo.Name[1] = '.' then
  begin
    if FName = '' then
      raise EDecompilerError.CreateFmt(STypeInfoWithoutDef, [Pointer(TypeInfo)]);
    Result := FName + ' = ' + TypeInfoUtils.GetTypeDef(TypeInfo) + ';';
  end
  else
    Result := TypeInfo^.Name + ' = ' + TypeInfoUtils.GetTypeDef(TypeInfo) + ';';
end;

function TTypeInfoInfo.GetTypeInfoVarName: string;
begin
  if TypeInfo.Name[1] = '.' then
  begin
    // Generate type info name.
    if FName = '' then
    begin
      // Make the name of "TypeInfo" + the old name - "."
      FName := 'TypeInfo';
      SetLength(FName, Length('TypeInfo')+ Ord(TypeInfo.Name[0]) -1);
      Move(TypeInfo.Name[2], FName[Length('TypeInfo') + 1], Ord(TypeInfo.Name[0]) -1);
    end;
    Result := FName + 'TypeInfo';
  end
  else
    Result := GetTypeInfoName(TypeInfo) + 'TypeInfo';
end;

function TTypeInfoInfo.GetName: string;
resourcestring
  SErrorTypeInfoWithoutAName = 'Can''t get name of TypeInfo at %p, because it doesn''t have one.';
begin
  if TypeInfo.Name[1] = '.' then
  begin
    if FName = '' then
      raise EDecompilerError.CreateFmt(SErrorTypeInfoWithoutAName, [Pointer(TypeInfo)]);
    Result := FName;
  end
  else
    Result := TypeInfo.Name;
end;

function TTypeInfoInfo.HasTypeDef: Boolean;
begin
  Result := ((not (TypeInfo^.Kind in [tkClass])) and (TypeInfo^.Name[1] <> '.')) or
            (FName <> '');
end;

procedure TTypeInfoInfo.LoadMethodRefs;
var
  I, J: Integer;
  ParamRecord: PParamRecord;
  TypeData: PTypeData;
  TypeName: PShortString;
  DC: TDecompItem;
  XUnit1, XUnit2: TUnit;
begin
  if TypeInfo.Kind = tkMethod then
  begin
    // Add all the type infos and classes requrired by the method type.
    TypeData := GetTypeData(TypeInfo);
    ParamRecord := @TypeData.ParamList;
    for I := 0 to TypeData.ParamCount -1 do
    begin
     TypeName := Pointer(Integer(@ParamRecord^.ParamName) + Length(ParamRecord^.ParamName) +1);
     DC := TPEFileClass(PEFileClass).Classes.FindClassByName(TypeName^);
     if DC = nil then
     begin
       J := TPEFileClass(PEFileClass).TypeInfos.IndexOfName(TypeName^);
       if J <> -1 then
         DC := TPEFileClass(PEFileClass).TypeInfos[J]
       else
       begin
         J := TPEFileClass(PEFileClass).NoTInfoTypes.IndexOfName(TypeName^);
         if J <> -1 then
         begin
           // Make the unit Index as Low as possible.
           DC := TPEFileClass(PEFileClass).NoTInfoTypes[J];
           XUnit1 := TPEFileClass(PEFileClass).Units.FindInUnitUsingFInit(DC.Address);
           XUnit2 := TPEFileClass(PEFileClass).Units.FindInUnitUsingFInit(Address);
           if XUnit2.Index < XUnit1.Index then
             DC.Address := Address
           else
             if (XUnit1.Index = XUnit1.Index) and (DC.Address > Address) then
               DC.Address := Address;
         end
         else
           if TypeName^ <> 'Pointer' then
           begin
             // If there isn't a type with th anme declare a new one.
             DC := TNoTInfoType.Create(TPEFileClass(PEFileClass).NoTInfoTypes);
             DC.Address := Address;
             TNoTInfoType(DC).Name := TypeName^;
             TNoTInfoType(DC).Defenition := TypeName^ + ' = Pointer;';
           end;
       end;
     end;
     if DC <> nil then
       Self.AddReq(DC, nil);
     ParamRecord := PParamRecord(Integer(ParamRecord) + SizeOf(TParamFlags) +
        (Length(ParamRecord^.Paramname) +1) + (Length(TypeName^) + 1));
    end;
    if TypeData.MethodKind = mkFunction then
    begin
      TypeName := PShortString(ParamRecord);
      DC := TPEFileClass(PEFileClass).Classes.FindClassByName(TypeName^);
      if DC = nil then
      begin
        J := TPEFileClass(PEFileClass).TypeInfos.IndexOfName(TypeName^);
        if J <> -1 then
          DC := TPEFileClass(PEFileClass).TypeInfos[J]
        else
        begin
          J := TPEFileClass(PEFileClass).NoTInfoTypes.IndexOfName(TypeName^);
          if J <> -1 then
          begin
            // If there is a type without type info with the name, make the address as low as possible.
            DC := TPEFileClass(PEFileClass).NoTInfoTypes[J];
            XUnit1 := TPEFileClass(PEFileClass).Units.FindInUnitUsingFInit(DC.Address);
            XUnit2 := TPEFileClass(PEFileClass).Units.FindInUnitUsingFInit(Address);
            if XUnit2.Index < XUnit1.Index then
              DC.Address := Address
            else
              if (XUnit1.Index = XUnit1.Index) and (DC.Address > Address) then
                DC.Address := Address;
          end
          else
          begin
            // If there isn't a type with th anme declare a new one.
            DC := TNoTInfoType.Create(TPEFileClass(PEFileClass).NoTInfoTypes);
            DC.Address := Address;
            TNoTInfoType(DC).Name := TypeName^;
            TNoTInfoType(DC).Defenition := TypeName^ + ' = Pointer;';
          end;
        end;
      end;
      if DC <> nil then
        Self.AddReq(DC, nil);
    end;
  end;
end;

{ TTypeInfoInfos }

procedure TTypeInfoInfos.LoadTypeInfos;
var
  I, J: Integer;
label
  NextFixup;
begin
  with TPEFileClass(PEFileClass) do
    for I := 0 to Fixups.Count -1 do
    begin
      if (Fixups[I].FixupType = 3) and
         (Fixups[I].Address >= Code) and
         (Fixups[I].Address < Code + CodeSize) and
         (PPChar(Fixups[I].Address)^ = Fixups[I].Address + 4) and
         (Fixups[I].Address[4] in [#0..#17]) and
         (Integer(Fixups[I].Address) mod 4 = 0) and
         (IsIdentifier(Fixups[I].Address + 5)) then
        begin
          // Check that the fixups isn't inside an class declaration.
          for J := 0 to Classes.Count -1 do
            if (Fixups[I].Address >= Classes[J].Address) and
               (Fixups[I].Address < Classes[J].Address + Classes[J].Size) then
              goto NextFixup;
          // Check that there is a fixup at the location.
          for J := 0 to Fixups.Count -1 do
            if Fixups[I].Address + 4 = Fixups[J].Address then
              goto NextFixup;

          // TypeInfo found.
          with TTypeInfoInfo.Create(Self) do
          begin
            FTypeInfo := PTypeInfo(Fixups[I].Address +4);
            Address := Fixups[I].Address;
            RefAddress := Fixups[I].Address;
            // include Pointer in size and align to 4 byte.
            Size := Align4(GetTypeInfoSize(FTypeInfo)) +4;
          end;
        end;
      NextFixup:
    end;
end;

function TTypeInfoInfos.FindTypeInfo(TypeInfo: PTypeInfo): TTypeInfoInfo;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
  begin
    Result := TTypeInfoInfo(inherited GetItem(I));
    if Result.TypeInfo = TypeInfo then Exit;
  end;
  Result := nil;
end;

function TTypeInfoInfos.GetItem(Index: Integer): TTypeInfoInfo;
begin
  Result := TTypeInfoInfo(inherited GetItem(Index));
end;

procedure TTypeInfoInfos.SetItem(Index: Integer; Value: TTypeInfoInfo);
begin
  inherited SetItem(Index, Value);
end;

function TTypeInfoInfos.IndexOfName(Name: string): Integer;
begin
  for Result := 0 to Count -1 do
    if TTypeInfoInfo(Items[Result]).TypeInfo.Name = Name then
      Exit;
  Result := -1;
end;

{ TInterface }

{ TInterfaces }

function TInterfaces.Add(GUID: TGUID; MethodCount: Integer): TInterface;
begin
  Result := TInterface.Create(Self);
  Result.FGUID := GUID;
  Result.FMethodCount := MethodCount;
end;

function TInterfaces.FindInterface(GUID: TGUID): TInterface;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
  begin
    Result := TInterface(inherited GetItem(I));
    if CompareMem(@Result.GUID, @GUID, SizeOf(TGUID)) then Exit;
  end;
  Result := nil;
end;

function TInterfaces.GetItem(Index: Integer): TInterface;
begin
  Result := TInterface(inherited GetItem(Index));
end;

procedure TInterfaces.SetItem(Index: Integer; Value: TInterface);
begin
  inherited SetItem(Index, Value);
end;

{ TProc }

constructor TProc.Create(Procs: TProcs; Address: PChar);
var
  I: Integer;
begin
  Procs.FindProcIndex(Address, I);
  inherited Create(Procs);
  Self.Address := Address;
  RefAddress := Address;
  FPossProcTypes := ptAll;
  FMethodBindingType := mbtStatic;
  FInstrSrc := TStringList.Create;
  FParameters := TdcParameters.Create;
  FOnSizeChange := TmlneMethodList.Create;
  FOnInitSizeChange := TmlneMethodList.Create;
  OnSizeChange.Add(ProcSizeChange);
  Index := I;
end;

destructor TProc.Destroy;
begin
  FProcEnh.Free;
  FOnInitSizeChange.Free;
  FOnSizeChange.Free;
  FInstrSrc.Free;
  if not Overrides then
    FParameters.Free;
  inherited Destroy;
end;

procedure TProc.GenerateInstr;
begin
  dcInstr.GenerateInstr(Self);
end;

function TProc.IsRefAddress(AAddress: PChar): Boolean;
begin
  Result := (AAddress = Address);
end;

procedure TProc.Append(Proc: TProc);
var
  I, J: Integer;
  AAddress: PChar;
resourcestring
  SMayNotAppendError = 'trying appending a proc which may not append, %p, %p';
begin
  Comments.Add(Format('Proc at %p append', [Pointer(Proc.Address)]));
  Comments.Add('Comments of the append proc');
  Comments.AddStrings(Proc.Comments);
  Comments.Add('Append Comments ended');
  if (AppendAfter = atMayNot) or (Proc.AppendBefore = atMayNot) then
    raise EDecompilerError.CreateFmt(SMayNotAppendError, [Pointer(Proc.Address), Pointer(Address)]);
  FAppend[1] := Proc.AppendAfter;
  // Add the req decomps to this one.
  for I := 0 to Proc.ReqDecompCount -1 do
    if Proc.ReqDecomps[I] <> Self then
      AddReq(Proc.ReqDecomps[I], PChar(Proc.ReqDecompsAddress[I]));
  // Add the Self to the items which requires the item to Append.
  for I := 0 to Proc.ReqByDecompCount -1 do
  begin
    if Proc.ReqByDecomps[I] <> Self then
    begin
      // Find the item which requires this item.
      AAddress := nil;
      for J := 0 to Proc.ReqByDecomps[I].ReqDecompCount -1 do
        if Proc.ReqByDecomps[I].ReqDecomps[J] = Proc then
        begin
          AAddress := PChar(Proc.ReqByDecomps[I].ReqDecompsAddress[J]);
          Break;
        end;
      Proc.ReqByDecomps[I].AddReq(Self, AAddress);
      // If item which requires the Append item is a Proc, it must append.
      if Proc.ReqByDecomps[I] is TProc then
      begin
        if Proc.ReqByDecomps[I].Address < Address then
        begin
          if TProc(Proc.ReqByDecomps[I]).AppendAfter = atMay then
            TProc(Proc.ReqByDecomps[I]).AppendAfter := atMust
        end
        else
          if TProc(Proc.ReqByDecomps[I]).AppendBefore = atMay then
            TProc(Proc.ReqByDecomps[I]).AppendBefore := atMust;
      end;
    end;
  end;
  Size := Proc.Address + Proc.Size - Address;
  ProcSize := Size;
  Proc.Free;
  // Recheck the req address,
  for I := 0 to ReqDecompCount -1 do
    if (ReqDecomps[I] is TProc) and (PChar(ReqDecompsAddress[I]) <> ReqDecomps[I].Address) and
       (ReqDecompsAddress[I] <> nil) then
    begin
      if ReqDecomps[I].Address > Address then
        AppendAfter := atMust
      else
        AppendBefore := atMust;
    end;
end;

procedure TProc.AddReqBy(Decomp: TDecompItem; AAddress: PChar);
begin
  inherited AddReqBy(Decomp, AAddress);
  // if this is method the class is also req.
  if AClass <> nil then
    Decomp.AddReq(AClass, nil);
end;

procedure TProc.SetPossProcTypes(Value: TProcTypes);
begin
  if Value = FPossProcTypes then
    Exit;
  if Value = [] then
    raise EDecompilerError.Create('Empty PossProcType');
  if not (Value <= FPossProcTypes) then