dcunits.pas

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

unit dcUnits;

interface

uses
  Classes, PEFile, Procs, dcDecomps, dcDFMs, MethodLists;

type
  { TUnit }

  TUnits = class;

  TUnitType = (utNormal, utSystem, utProgram);

  TUnit = class(TCollectionItem)
  private
    FAddress: PChar;
    FSize: Integer;
    FAInit: TProc;
    FFInit: TProc;
    FName: string;
    FUnitType: TUnitType;
    FDFM: TdcDFM;
    FPEFileClass: TPEFile;

    FDecompItems: TList;
    FImplUnits: TList;
    FIntfUnits: TList;
    FUnitSrc: TStrings;
    FImportedUnit: Boolean;

    FComments: TStrings;

    procedure SetName(Value: string);
    function GetImplUnitCount: Integer;
    function GetImplUnit(Index: Integer): TUnit;
    function GetIntfUnitCount: Integer;
    function GetIntfUnit(Index: Integer): TUnit;
    procedure SetAInit(AInit: TProc);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    function FindProcByName(Name: string): TProc;
    function FindClassByName(Name: string): TClassInfo;
    procedure InsertImplUnit(Index: Integer; AUnit: TUnit);
    procedure AddImplUnit(AUnit: TUnit);
    procedure InsertIntfUnit(Index: Integer; AUnit: TUnit);
    procedure AddIntfUnit(AUnit: TUnit);
    procedure GenUnitSrc;
    procedure DeterIntfImpl;

    property Address: PChar read FAddress write FAddress;
    property Size: Integer read FSize write FSize;
    property Init: TProc read FAInit write SetAInit;
    property FInit: TProc read FFInit write FFInit;
    property Name: string read FName write SetName;
    property UnitSrc: TStrings read FUnitSrc;
    property UnitType: TUnitType read FUnitType;
    property DFM: TdcDFM read FDFM write FDFM;
    property PEFileClass: TPEFile read FPEFileClass;

    property DecompItems: TList read FDecompItems;
    property ImplUnitCount: Integer read GetImplUnitCount;
    property ImplUnits[Index: Integer]: TUnit read GetImplUnit;
    property IntfUnitCount: Integer read GetIntfUnitCount;
    property IntfUnits[Index: Integer]: TUnit read GetIntfUnit;
    property ImportedUnit: Boolean read FImportedUnit;

    property Comments: TStrings read FComments;
  end;

  { TUnits }

  TUnits = class(TCollection)
  private
    FPEFileClass: TPEFile;
    FSysInitUnit: TUnit;
    FSystemUnit: TUnit;
    FProgramUnit: TUnit;
    FFirstNormalUnit: TUnit;
    
    FOnAssignUnits: TmlneMethodList;
    function GetItem(Index: Integer): TUnit;
    procedure SetItem(Index: Integer; Value: TUnit);
  public
    constructor Create(PEFileClass: TPEFile); reintroduce; overload;
    destructor Destroy; override;
    function FindInUnitUsingFInit(Address: PChar): TUnit;
    function FindInUnit(Address: PChar): TUnit;
    function FindByName(const Name: string): Integer;
    procedure GenerateReqUnits;
    procedure GenerateNames;
    procedure GenUnitSrcs;
    procedure DeterIntfImpls;
    procedure AssignUnits;
    procedure LoadInitFInit;

    property Items[Index: Integer]: TUnit read GetItem write SetItem; default;

    property OnAssignUnits: TmlneMethodList read FOnAssignUnits;
    property PEFileClass: TPEFile read FPEFileClass;
    property SysInitUnit: TUnit read FSysInitUnit;
    property SystemUnit: TUnit read FSystemUnit;
    property ProgramUnit: TUnit read FProgramUnit;
    property FirstNormalUnit: TUnit read FFirstNormalUnit;
  end;

implementation

uses
  {$IFOPT D+} dcDebug, {$ENDIF}
  SysUtils, PEFileClass, Vars, TypInfo, dcNTInfoTypes, dcThrVar, dcTypeIntf,
  DisAsm;

{ TUnit }

constructor TUnit.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FDecompItems := TList.Create;
  FImplUnits := TList.Create;
  FIntfUnits := TList.Create;
  FUnitSrc := TStringList.Create;
  FPEFileClass := (Collection as TUnits).FPEFileClass;
  FComments := TStringList.Create;
end;

destructor TUnit.Destroy;
begin
  FComments.Free;
  FUnitSrc.Free;
  FIntfUnits.Free;
  FImplUnits.Free;
  FDecompItems.Free;
  inherited Destroy;
end;

procedure TUnit.SetName(Value: string);
var
  I: Integer;
resourcestring
  SUnitNameAlreadyExists = 'Unit named %s already exists.';
  SUnitAlreadyHasAName = 'Cann''t change that name to %s, because it is already set to %s.';
begin
  if AnsiCompareText(Value, FName) = 0 then Exit;

  if FName <> '' then
    raise EDecompilerError.CreateFmt(SUnitAlreadyHasAName, [FName, Value]);

  for I := 0 to TPEFileClass(PEFileClass).Units.Count -1 do
    if TPEFileClass(PEFileClass).Units[I].Name = Value then
      raise EDecompilerError.CreateFmt(SUnitNameAlreadyExists, [Value]);

  FName := Value;
end;

function TUnit.GetImplUnitCount: Integer;
begin
  Result := FImplUnits.Count;
end;

procedure TUnit.InsertImplUnit(Index: Integer; AUnit: TUnit);
var
  I: Integer;
begin
  // exit when the unit is not in one list already, or it is a system unit.
  if (FIntfUnits.IndexOf(AUnit) <> -1) or
     (AUnit.Index < 2) or
     (AUnit = Self) then
    exit;
  I := FImplUnits.IndexOf(AUnit);
  if I = -1 then
    FImplUnits.Insert(Index, AUnit)
  else
    if I >= Index then
      FImplUnits.Move(I, Index)
    else
      FImplUnits.Move(I, Index -1);
end;

procedure TUnit.AddImplUnit(AUnit: TUnit);
begin
  InsertImplUnit(ImplUnitCount, AUnit);
end;

function TUnit.GetImplUnit(Index: Integer): TUnit;
begin
  Result := TUnit(FImplUnits[Index]);
end;

function TUnit.GetIntfUnitCount: Integer;
begin
  Result := FIntfUnits.Count;
end;

procedure TUnit.InsertIntfUnit(Index: Integer; AUnit: TUnit);
var
  I: integer;
begin
  // exit when the unit is not in the list already, or it is a system unit.
  if (AUnit.Index < 2) or (AUnit = Self) then
    exit;
  // If this is the program unit only add it to the impl unit.
  if UnitType = utProgram then
  begin
    AddImplUnit(AUnit);
    Exit;
  end;
  // If the unit is in the Impl Unit list remove it from there
  FImplUnits.Remove(AUnit);
  I := FIntfUnits.IndexOf(AUnit);
  if I = -1 then
    FIntfUnits.Insert(Index, AUnit)
  else
    if I >= Index then
      FIntfUnits.Move(I, Index)
    else
      FIntfUnits.Move(I, Index -1);
end;

procedure TUnit.AddIntfUnit(AUnit: TUnit);
begin
  InsertIntfUnit(IntfUnitCount, AUnit);
end;

function TUnit.GetIntfUnit(Index: Integer): TUnit;
begin
  Result := TUnit(FIntfUnits[Index]);
end;

procedure TUnit.SetAInit(AInit: TProc);
begin
  if AInit.Address[0] = #$FF then
    FImportedUnit := True;
  FAInit := AInit;
end;

function TUnit.FindProcByName(Name: string): TProc;
var
  I: Integer;
begin
  for I := 0 to FDecompItems.Count -1 do
  begin
    Result := TProc(FDecompItems[I]);
    if (TDecompItem(Result) is TProc) and (Result.Name = Name) then
      exit;
  end;
  Result := nil;
end;

function TUnit.FindClassByName(Name: string): TClassInfo;
var
  I: Integer;
begin
  for I := 0 to FDecompItems.Count -1 do
  begin
    Result := TClassInfo(FDecompItems[I]);
    if (TDecompItem(Result) is TClassInfo) and (Result.AClass.ClassName = Name) then
      exit;
  end;
  Result := nil;
end;

function DecompItemSortBssBeforeData(Item1, Item2: Pointer): Integer;
begin
  Result := TDecompItem(Item1).Address - TDecompItem(Item2).Address;
  // if both decomp items are vars and one is in the BSS section and the other not,
  // put the one in the bss section before the other.
  if (TDecompItem(Item1) is TVar) and (TDecompItem(Item2) is TVar) then
  begin
    if (TDecompItem(Item1).Address >= TVar(Item1).PEFileClass.BSS) and
       (TDecompItem(Item2).Address < TVar(Item1).PEFileClass.BSS) then
      Result := -1;
    if (TDecompItem(Item1).Address < TVar(Item1).PEFileClass.BSS) and
       (TDecompItem(Item2).Address >= TVar(Item1).PEFileClass.BSS) then
      Result := 1;
  end;
end;

procedure TUnit.GenUnitSrc;
type
  TSectionType = (stConst, stType, stVar, stProc, stLabel, stResourceString, stThreadVar);
var
  SectionType: TSectionType;
  Vars: TStringList;
  Consts: TStringList;

  procedure SetSectionType(ASectionType: TSectionType);
  const
    SectionTypeDecl: array[TSectionType] of string = ('const', 'type',
      'var', '', 'label', 'resourcestring', 'threadvar');
  var
    I: Integer;
  begin
    if ASectionType = SectionType then exit;
    // Add the vars if they exits.
    if Vars.Count > 0 then
    begin
      if SectionType <> stVar then
        UnitSrc.Add('var');
      for I := 0 to Vars.Count -1 do
        UnitSrc.Add(Vars[I]);
      Vars.Clear;
      SectionType := stVar;
    end;
    // Add the Consts if thet exits.
    if Consts.Count > 0 then
    begin
      if SectionType <> stConst then
        UnitSrc.Add('const');
      for I := 0 to Consts.Count -1 do
        UnitSrc.Add(Consts[I]);
      Consts.Clear;
      SectionType := stConst;
    end;
    if ASectionType = SectionType then exit;
    UnitSrc.Add(SectionTypeDecl[ASectionType]);
    SectionType := ASectionType;
  end;

  procedure AddComments(Strings: TStrings);
  begin
    if Strings.Count <> 0 then
    begin
      UnitSrc.Add('{');
      UnitSrc.AddStrings(Strings);
      UnitSrc.Add('}');
    end;
  end;

const
  BeginUnit = 'unit %s;' + #13#10#13#10 + 'interface';
  BeginProgram: array[TProjectType] of string = ('program %s;', 'library ^s;', 'package %s;');
  UsesClause = #13#10'uses';
  ContainsClause = #13#10'contains';
  ImplUnit = #13#10'implementation';
  EndUnit = #13#10'end.';
  DFMInclude = '{$R *.DFM}'#13#10;
var
  I, J, K, L, M: Integer;
  Changed: Boolean;
  Str: string;
begin
  // Add unit comments.
  AddComments(Comments);
  
  Vars := TStringList.Create;
  try
   Consts := TStringList.Create;
   try
    // Don't generate unit source if this is a system unit.
    if UnitType = utSystem then exit;
    if UnitType <> utProgram then
    begin
      // Start with the unit name and interface.
      UnitSrc.Add(Format(BeginUnit, [Name]));
    end
    else
      // It is the program "unit"
      UnitSrc.Add(Format(BeginProgram[TPEFileClass(FPEFileClass).ProjectType], [Name]));

    // Sort the decompItems (In this following they were also declared).
    DecompItems.Sort(DecompItemSortBssBeforeData);
    // Set all the req items before the items which requires them (possible endless loop).
    repeat
      Changed := False;
      for I := 0 to DecompItems.Count -1 do
      begin
        for J := 0 to TDecompItem(DecompItems[I]).ReqDecompCount -1 do
        begin
          with TDecompItem(DecompItems[I]) do
          begin

            // Don't Move if it is a proc or a type info which doesn't have a
            // type def or a ClassInfo which is requires by TypeInfo.
            if not ((ReqDecomps[J] is TProc) or
                   ((ReqDecomps[J] is TTypeInfoInfo) and
                    (not TTypeInfoInfo(ReqDecomps[J]).HasTypeDef))) then
            begin
              // Move the req item before the other.
              K := Self.DecompItems.IndexOf(ReqDecomps[J]);
              if K > I then
              begin
                // if there is a type and req item is a class, then it must only