procs.pas

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

    raise EDecompilerError.Create('Project type introduces a new PossProcType.');
  // Set the private field.
  FPossProcTypes := Value;
  if FProcEnh <> nil then
    raise EDecompilerError.Create('There is already an proc enh.');
  if FPossProcTypes = [ptDestructor] then
    FProcEnh := TDestructorProcEnh.CreateEnh(Self);
  if FPossProcTypes = [ptInitialization] then
    FProcEnh := TInitProcEnh.CreateEnh(Self);
  // Set the ancestor proc types.
  if Overrides then
    AncestorMethod.PossProcTypes := Value;
end;

function TProc.GetProcType: TProcType;
begin
  if Overrides then
    Result := AncestorMethod.ProcType
  else
  begin
    if ptEntryPointProc in PossProcTypes then
      Result := ptEntryPointProc
    else
      if ptInitialization in PossProcTypes then
        Result := ptInitialization
      else
        if ptFinalization in PossProcTypes then
          Result := ptFinalization
        else
          if ptProcedure in PossProcTypes then
            Result := ptProcedure
          else
            if ptClassProcedure in PossProcTypes then
              Result := ptClassProcedure
            else
              if ptMethodProcedure in PossProcTypes then
                Result := ptMethodProcedure
              else
                if ptDestructor in PossProcTypes then
                  Result := ptDestructor
                else
                  if ptConstructor in PossProcTypes then
                    Result := ptConstructor
                  else
                    raise EDecompilerError.CreateFmt('Unknown proc type %d', [byte(PossProcTypes)]);
  end;
  // Set the possible proctypes only to the proc type
  PossProcTypes := [Result];
end;

procedure TProc.SetMethodBindingType(Value: TMethodBindingType);
var
  MsgVar: TVar;
begin
  Comments.Add(Format('Method binding type set %d', [Integer(Value)]));
  if not (PossProcTypes <= ptMethods) then
    raise EDecompilerError.Create('Setting binding type of a procedure.');
  FMethodBindingType := Value;
  // non-static proc may not be append before.
  if FMethodBindingType <> mbtStatic then
    AppendBefore := atMayNot;
  // Message handler are dynamic methods with index < $C000.
  if (FMethodBindingType = mbtDynamic) and (MethodIndex < $C000) then
  begin
    MsgVar := TVar.Create(TPEFileClass(PEFileClass).Miscs);
    with MsgVar do
    begin
      Address := AClass.Address - 1;
      Name := 'MI_' + AClass.AClass.ClassName + '_' + IntToStr(MethodIndex);
      VarConst := [vtConst];
      VarSize := 4;
      AUnit := AClass.AUnit;
      PInteger(InitValue )^:= MethodIndex;
      AType.PossTypeKinds := [etkUTInteger];
    end;
    AClass.AddReq(MsgVar, nil);
    PossProcTypes := [ptMethodProcedure];
    if Parameters.Parameters = '' then
      Parameters.Parameters := 'var Message: Integer';
  end;
end;

procedure TProc.SetClass(Value: TClassInfo);
var
  AClass1: TClass;
  AClass2: TClassInfo;
  I: Integer;
label
  Found;
begin
  if Value = AClass then
    exit;
  if (Value = nil) then
    raise EDecompilerError.Create('Trying to set class to nil');
  if (AClass <> nil) then
  begin
    if mbtStatic <> MethodBindingType then
      raise EDecompilerError.Create('Can''t change class again.');
    // Remove the proc from the old class.
    FClass.FMethods.Remove(Self);
    // This method has already a class, search the class with the classes have both in common.
    AClass1 := AClass.AClass;
    repeat
      AClass2 := Value;
      repeat
        // Exit the search when they are equal.
        if AClass1 = AClass2.AClass then
        begin
          Value := AClass2;
          goto Found;
        end;
        AClass2 := AClass2.AncestorClass;
      until AClass2 = nil;
      AClass1 := AClass1.ClassParent;
    until AClass1 = nil;
    Assert(False, 'Impossible to come here');
  end;
Found:
  // Make sure the method is in the same unit as the class. (except when this a imported proc).
  if (mbtStatic = MethodBindingType) and (not ImportInfo.Imported) then
    with TPEFileClass(PEFileClass).Units do
      while FindInUnitUsingFInit(PChar(Value.AClass)) <> FindInUnitUsingFInit(Self.Address) do
        Value := Value.AncestorClass;
  // Add the method to the class.
  FClass := Value;
  FClass.FMethods.Add(Self);
  // All items which require this proc also require the class.
  for I := 0 to ReqByDecompCount -1 do
    ReqByDecomps[I].AddReq(FClass, nil);
end;

function TProc.GetDefSrc: string;
const
  ProcTypeDef: array[Low(TProcType)..High(TProcType), Boolean] of string =
    (('procedure %s(%s);', 'function %s(%s): %s;'), ('class procedure %s(%s);', 'class function %s(%s): %s;'),
     ('procedure %s(%s);', 'function %s(%s): %s;'), ('constructor %s(%s);', 'constructor %s(%s);'),
     ('destructor %s(%s);', 'destructor %s(%s);'), ('', ''), ('', ''), ('', ''));
begin
  // start the proc types and the name.
  Result := Format(ProcTypeDef[ProcType, Parameters.FuncResult <> ''],
         [Name, Parameters.Parameters, Parameters.FuncResult]);
  if overrides then
    Result := Result + ' override;'
  else
    case MethodBindingType of
      mbtVirtual: Result := Result + ' virtual;' + '{' + IntToStr(MethodIndex) +'}';
      mbtDynamic: begin
                    if MethodIndex < $C000 then
                      // Message directive
                      Result := Result + ' message MI_'+ AClass.AClass.ClassName + '_' + IntToStr(MethodIndex) +';'
                    else
                      // dynamic
                      Result := Result + ' dynamic;' + '{' + IntToStr(MethodIndex) +'}';
                  end;
    end;
  if Address = nil then
    Result := Result + ' abstract;';
  if ImportInfo.Imported then
    Result := Result + ' external ' + EnhQuotedStr(ImportInfo.DLLName) + ' name ' +
      EnhQuotedStr(ImportInfo.Entry.Name);
end;

procedure TProc.PossSetToIntf(DecompItem: TDecompItem);
begin
  // Don't add it the decomp to the interface section.
end;

procedure TProc.SetSize(Value: Integer);
begin
  inherited SetSize(Value);
  Comments.Add(Format('Proc size changed to %d', [Value]));
  OnSizeChange.CallFirst;
end;

function TProc.GetAncestorMethod: TProc;
begin
  case MethodBindingType of
    mbtVirtual: Result := AClass.AncestorClass.GetVirtualMethod(MethodIndex);
    mbtDynamic: Result := AClass.AncestorClass.GetDynamicMethod(MethodIndex);
    else
      raise EDecompilerError.Create('not a virtual or static method');
  end;
end;

function TProc.GetIncName: string;
begin
  Result := Name;
  if ProcType in ptMethods then
    Result := AClass.AClass.ClassName + '.' + Result;
  if (Length(Result) > 0) and (Result[1] = '@') then
    Result := TUnit(AUnit).Name + '.' + Result;
end;

procedure TProc.SetInitSize(Value: Integer);
begin
  FInitSize := Value;
  OnInitSizeChange.CallFirst;
end;

procedure TProc.ProcSizeChange(Sender: TmlneMethodList);
var
  AAddress: PChar;
  I: Integer;
  Proc: TProc;
begin
  // Don't check if this is a system unit).
  if ((AUnit = nil) or (TUnit(AUnit).UnitType <> utSystem)) and
     (not ImportInfo.Imported) then
  begin
    with TPEFileClass(TProcs(Collection).PEFileClass) do
    begin
      // Check to see if the proc has a fixup to the middle of a proc, if that is
      // the case it must append.
      I := Fixups.FindFixupAfter(Address);
      if I <> -1 then
      begin
        repeat
          AAddress := Fixups[I].Address;
          // Search for proc which this proc points to.
          if AAddress >= Address + Size  then Break;
          Assert(AAddress >= Address, 'Error in sorting routine');
          Proc := Procs.FindProc(PPChar(AAddress)^);
          if (Proc <> nil) and (Proc.Address <> PPChar(AAddress)^) and
             ((PPChar(AAddress)^ < Address) or (PPChar(AAddress)^ >= Address + Size)) then
          begin
            AddReq(Proc, AAddress);
            // If this proc points to the middle of a proc it must append.
            if Proc.Address < Address then
            begin
              // Ignore if this is proc may not append before.
              if AppendBefore <> atMayNot then
              begin
                Comments.Add(Format('Append before set to must because of a Fixups at %p', [Pointer(AAddress)]));
                Proc.Comments.Add(Format('Append after set to must because of a Fixups from %p', [Pointer(AAddress)]));
                AppendBefore := atMust;
                Proc.AppendAfter := atMust;
              end;
            end
            else
            begin
              Comments.Add(Format('Append after set to must because of a Fixups at %p', [Pointer(AAddress)]));
              Proc.Comments.Add(Format('Append before set to must because of a Fixups from %p', [Pointer(AAddress)]));
              AppendAfter := atMust;
              Proc.AppendBefore := atMust;
            end;
          end;
          Inc(I);
        until I >= TProcs(Collection).PEFileClass.Fixups.Count;
      end;
      // If there is a fixup (to) directly after the proc and the proc doesn't end on a dword boundary
      // it must be larger.
      if (Integer(Address + Size) mod 4 <> 0) and
         ((Fixups.FindFixup(Address + Size) <> -1) or
          (Fixups.FindFixupTo(Address + Size) <> -1)) then
        AppendAfter := atMust;
    end;
  end;
  // Call the next event handler.
  if Sender <> nil then
    Sender.CallNext(ProcSizeChange);
end;

procedure TProc.SetName(Value: string);
resourcestring
  SErrorProcHasAName = 'Can''t set proc name to %s, because it is already %s';
begin
  if AnsiCompareText(Value, FName) <> 0 then
  begin
    if FName <> '' then
      Comments.Add(Format(SErrorProcHasAName, [value, fname]));
    FName := Value;
    if Overrides then
      AncestorMethod.Name := Value;
  end;
end;

function TProc.GetName: string;
begin
  if Overrides then
    Result := AncestorMethod.Name
  else
    Result := FName;
end;

function TProc.GetPossProcTypes: TProcTypes;
begin
  if Overrides then
    Result := AncestorMethod.PossProcTypes
  else
    Result := FPossProcTypes;
end;

procedure TProc.SetOverrides(Value: Boolean);
begin
  if Value <> FOverrides then
  begin
    if not Value then
      raise EDecompilerError.Create('Can not set overrides to false');
    FParameters.Free;
    FOverrides := Value;
    FParameters := AncestorMethod.Parameters;
  end;
end;

function TProc.GetAppend(Index: Integer): TAppendType;
begin
  Result := FAppend[Index];
end;

procedure TProc.SetAppend(Index: Integer; Value: TAppendType);
var
  Proc: TProc;
resourcestring
  SAppendAlreadySet = 'Append already set. %p';
  SConvlictingAppend = 'Must append convlicting with a not must append at %p';
begin
  if Value = FAppend[Index] then Exit;
  if FAppend[Index] <> atMay then
    raise EDecompilerError.CreateFmt(SAppendAlreadySet, [Pointer(Address)]);
  // If this proc must append before/after and there is a proc before/after this one,
  // which can't append there is something wrong.
  if (Value = atMust) then
  begin
    if Index = 0 then
    begin
      Proc := TProcs(Collection).FindProc(Address - 1);
      if (Proc <> nil) and (Proc.Size <> 0) and (Proc.AppendAfter = atMayNot) then
        raise EDecompilerError.CreateFmt(SConvlictingAppend, [Pointer(Address)]);
    end
    else
    begin
      Proc := TProcs(Collection).FindProc(Address + Size + 1);
      if (Proc <> nil) and (Proc.AppendBefore = atMayNot) then
        raise EDecompilerError.CreateFmt(SConvlictingAppend, [Pointer(Address)]);
    end
  end;
  // Set the private field.
  FAppend[Index] := Value;
end;

{ TProcEnh }

constructor TProcEnh.CreateEnh(Proc: TProc);
begin
  inherited Create;
  FProc := Proc;
end;

{ TDestructorProcEnh }

constructor TDestructorProcEnh.CreateEnh(Proc: TProc);
begin
  inherited CreateEnh(Proc);
  Proc.OnSizeChange.Add(ProcSizeChange);
  ProcSizeChange(nil);
end;

destructor TDestructorProcEnh.Destroy;
begin
  FProc.OnSizeChange.Remove(ProcSizeChange);
  inherited Destroy;
end;

procedure TDestructorProcEnh.ProcSizeChange(Sender: TmlneMethodList);
var
  I: Integer;
begin
  // Add the call to Beforedestruction and classdestroy to the auto generated code.
  if Proc.ImportInfo.Imported then Exit;
  with FProc do
  begin
    // BeforeDestruction.
    if not FHasBeforeDestruction then
    begin
      if InitSize <> 0 then
        raise EDecompilerError.Create('There alredy is some init code??');
      I := FindFirstSimpleCallTo(TPEFileClass(PEFileClass).Units.SystemUnit.FindProcByName('@BeforeDestruction').Address,
        Address, Size) - Address;
      if I <> - Integer(Address) then
      begin
        BeforeInitSize := I;
        InitSize := 5;
        FHasBeforeDestruction := True;
      end;
    end;
    // ClassDestroy
    if not FHasClassDestroy then