ctdwork.pas

Citadel v.1.6 Full Sources

      finally
        TCtdMemStream(ResStream).SetPointer(nil, 0);
        ResStream.Free;
      end;
    end;
  end;

  procedure FilterDFMs(ResList: TStringList; hExe: HModule;
    UpdateHandle: THandle);
  begin
    ShowMsg('Filtering DFMs');
    FilterMadExcept(ResList, hExe, UpdateHandle);
  end;

var
  hExe: HModule;
  hCtdTools: THandle;
  Discard: Boolean;
  ResList: TStringList;
  i: Integer;
  PackageFileName: array[0..MAX_PATH] of Char;
  UpdateHandle: THandle;
  DFMOrgSize,
  DFMDstSize: Double;
  WExeFileName: array[0..255] of WideChar;
begin
  ResList := TStringList.Create;
  try
    if not FileExists(ExeFileName) then
      raise Exception.Create(Format('File ''%s'' not found', [ExeFileName]));

    hExe := LoadLibraryEx(PChar(ExeFileName), 0,
              DONT_RESOLVE_DLL_REFERENCES or LOAD_LIBRARY_AS_DATAFILE);
    if hExe = 0 then
      {$ifdef D6UP}RaiseLastOSError;{$else}RaiseLastWin32Error;{$endif D6UP}
    try
      ShowMsg('Checking resources...');
      if not EnumResourceNames(HExe, RT_RCDATA,
               @EnumResourceNamesCallback, Longint(@ResList)) then
        {$ifndef D6Up}
        RaiseLastWin32Error;
        {$else}
        RaiseLastOSError;
        {$endif D6Up}
      ResList.Sorted := True;
    finally
      FreeLibrary(hExe);
    end;

    GetModuleFileName(HInstance, PackageFileName, SizeOf(PackageFileName));
    hCtdTools := LoadLibrary(PChar(ExtractFilePath(PackageFileName) + 'CtdT.ctd'));
    if hCtdTools = 0 then
      raise Exception.Create('Can''t load ' + ExtractFilePath(PackageFileName) + 'CtdT.ctd');
    try
      @CtdBeginUpdRes := GetProcAddress(HCtdTools, 'CtdBeginUpdRes');
      @CtdEndUpdRes   := GetProcAddress(HCtdTools, 'CtdEndUpdRes');
      @CtdUpdRes      := GetProcAddress(HCtdTools, 'CtdUpdRes');
      @CtdGetRes      := GetProcAddress(HCtdTools, 'CtdGetRes');

      UpdateHandle := CtdBeginUpdRes(
                        StringToWideChar(ExeFileName, WExeFileName, SizeOf(WExeFileName) div 2),
                        False);
      if UpdateHandle = 0
      then
        {$ifndef D6Up}
        RaiseLastWin32Error
        {$else}
        RaiseLastOSError
        {$endif D6Up}
      else
      begin
        Discard := True;
        try
          FilterDFMs(ResList, hExe, UpdateHandle);

          Inc(Steps, ResList.Count * 2);
          if DoCompress then
            Inc(Steps, ResList.Count * 2);
          if DoPack      then
            Inc(Steps, ResList.Count * 2);
          if DoCrypt  then
            Inc(Steps, ResList.Count * 2);

          SetProgressSteps(Steps);

          DFMCount := 0;
          for i := 0 to ResList.Count-1 do
          begin
            if ProcessDFM(ResList[i], DoPack, DoCompress, DoCrypt, DoRunTimeLog,
              Password, UpdateHandle, DFMOrgSize, DFMDstSize) then
            begin
              Inc(DFMCount);
              TotDFMOrgSize := TotDFMOrgSize + DFMOrgSize;
              TotDFMDstSize := TotDFMDstSize + DFMDstSize;
            end;
            if DoLog and (not DoRunTimeLog) then
              SecLog.Clear;
          end;

          Discard := False;
        finally
          if not CtdEndUpdRes(UpdateHandle, Discard) then
            {$ifndef D6Up}
            RaiseLastWin32Error;
            {$else}
            RaiseLastOSError;
            {$endif D6Up}
        end;
      end;
    finally
      FreeLibrary(hCtdTools);
    end;
  finally
    ResList.Free;
  end;
end;

procedure TCtdWork.ProcessExe(const DoLogValue, DoRunTimeLog: Boolean; 
  Steps: Integer);

  function GetOSVersion: String;
  const
    cOsUnknown = -1;
    cOsWin95   =  0;
    cOsWin98   =  1;
    cOsWin98SE =  2;
    cOsWinME   =  3;
    cOsWinNT   =  4;
    cOsWin2000 =  5;
    cOsWinXP   =  6;
  var
    osVerInfo: TOSVersionInfo;
    majorVer,
    minorVer,
    OSCode: Integer;
  begin
    osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);

    if GetVersionEx(osVerInfo) then
    begin
      majorVer := osVerInfo.dwMajorVersion;
      minorVer := osVerInfo.dwMinorVersion;

      case osVerInfo.dwPlatformId of
        VER_PLATFORM_WIN32_NT : // Windows NT/2000
        begin
          if majorVer <= 4
          then OSCode := cOsWinNT
          else if((majorVer = 5) and (minorVer = 0))
          then OSCode := cOsWin2000
          else if((majorVer = 5) and (minorVer = 1))
          then OSCode := cOsWinXP
          else OSCode := cOsUnknown;
        end;
        VER_PLATFORM_WIN32_WINDOWS : // Windows 9x/ME
        begin
          if((majorVer = 4) and (minorVer = 0))
          then OSCode := cOsWin95
          else if((majorVer = 4) and (minorVer = 10))
          then
          begin
            if(osVerInfo.szCSDVersion[1] = 'A')
            then OSCode := cOsWin98SE
            else OSCode := cOsWin98;
          end
          else if((majorVer = 4) and (minorVer = 90))
          then OSCode := cOsWinME
          else OSCode := cOsUnknown;
        end;
        else OSCode := cOsUnknown;
      end;
    end
    else OsCode := cOsUnknown;

    case OSCode of
      cOsUnknown: Result := '(unknown OS)';
      cOsWin95  : Result := 'Windows 95';
      cOsWin98  : Result := 'Windows 98';
      cOsWin98SE: Result := 'Windows 98 SE';
      cOsWinME  : Result := 'Windows Millennium';
      cOsWinNT  : Result := 'Windows NT';
      cOsWin2000: Result := 'Windows 2000 / NT 5';
      cOsWinXP  : Result := 'Microsoft Windows XP';
      else Result := 'Microsoft Windows';
    end;
  end;

  procedure SaveLog(var LogFile: TextFile; LogStrings: TStringList);
  var
    i: Integer;
  begin
    if LogStrings.Count > 0 then
    begin
      for i := 0 to LogStrings.Count-1 do
        WriteLn(LogFile, LogStrings[i]);
    end;
  end;

type
  TRemoveRelocResult = (rrOk, rrNotPE, rrLibrary, rrNoRelocations);
  TRemoveRelocations = function(FileName: PAnsiChar;
    var OriginalSize, NewSize: Cardinal): TRemoveRelocResult; stdcall;
var
  Msg: String;
  Handle,
  DFMCount: Integer;
  Savings,
  TotDFMOrgSize,
  TotDFMDstSize,
  InitialFileSize,
  FinalFileSize: Double;
  hCtdTools: THandle;
  RemoveRelocations: TRemoveRelocations;
  PackageFileName: array[0..MAX_PATH] of Char;
  LogFile: TextFile;
  Start: TDateTime;
  OriginalSize,
  NewSize: Cardinal;
  ExeFileName,
  ResName,
  IDEVersion: String;
  Config: TCtdConfig;
begin
  DoLog := DoLogValue;

  MainLog.Clear;
  SecLog .Clear;

  Start := Now;
  try
    try
      PreProcess(ExeFileName, ResName);
      ReadResConfig(ExeFileName, ResName, Config);

      if Config.Encrypt and (Config.Password = '') then
        raise Exception.Create(
          'Please select a password of at least 8 characters in length.');
      Handle := FileOpen(ExeFileName, 0);
      try
        InitialFileSize := GetFileSize(Handle, nil);
      finally
        FileClose(Handle);
      end;

      if not(Config.Compress or Config.Pack or Config.Encrypt or Config.RmvReloc) then
        raise Exception.Create('Nothing to do');

      {$ifdef CtdNoPack}
      if Config.Pack then
        raise Exception.Create('Pack not supported');
      {$endif CtdNoPack}
      {$ifdef CtdNoCrypt}
      if Config.Encrypt then
        raise Exception.Create('Encryption not supported');
      {$endif CtdNoCrypt}

      if Config.Compress or Config.Pack or Config.Encrypt then
      begin
        TotDFMOrgSize := 0;
        TotDFMDstSize := 0;
        DFMCount      := 0;
        ProcessDFMs(ExeFileName, Config.Pack, Config.Compress, Config.Encrypt,
          DoRunTimeLog,
          {$ifdef CtdDoTrial}'trial'{$else}Config.Password{$endif CtdDoTrial},
          Steps, TotDFMOrgSize, TotDFMDstSize, DFMCount);
      end;

      if Config.RmvReloc then
      begin
        ShowMsg('Removing relocations...');
        GetModuleFileName(HInstance, PackageFileName, SizeOf(PackageFileName));
        hCtdTools := LoadLibrary(PChar(ExtractFilePath(PackageFileName) + 'CtdT.ctd'));
        if hCtdTools = 0 then
          raise Exception.Create('Can''t load ' + ExtractFilePath(PackageFileName) + 'CtdT.ctd');
        try
          @RemoveRelocations := GetProcAddress(hCtdTools, 'RemoveRelocations');
          case RemoveRelocations(PAnsiChar(AnsiString(ExeFileName)), OriginalSize, NewSize) of
            rrOk           :
            begin
              Savings := OriginalSize - NewSize;
              ShowMsg(Format('  %.0n bytes saved', [Savings]));
            end;
            rrNotPE        : ShowMsg('The PE format is unknown');
            rrLibrary      : ShowMsg('Must be an exe');
            rrNoRelocations: ShowMsg('Relocation section non-existent');
          end;
          ProgressStep;
        finally
          FreeLibrary(hCtdTools);
        end;
      end;
    except
      on E: Exception do
      begin
        ShowMsg(E.ClassName + ': ' + E.Message);
        raise;
      end;
    end;

    Handle := FileOpen(ExeFileName, 0);
    try
      Msg := Format('%d DFMs processed - %.0n bytes', [DFMCount, TotDFMOrgSize]);
      if TotDFMOrgSize > TotDFMDstSize then
        Msg := Format('%s -> %.0n (%%%d ratio)',
          [Msg, TotDFMDstSize, Round((TotDFMDstSize * 100) / TotDFMOrgSize)]);
      ShowMsg(Msg);
      FinalFileSize := GetFileSize(Handle, nil);
      ShowMsg(Format('Initial file size: %.0n bytes',  [InitialFileSize]));
      LastMsg := Format('Final file size: %.0n bytes', [FinalFileSize]);
      if Config.Compress or Config.RmvReloc then
        LastMsg := Format('%s (%%%d ratio)',
          [LastMsg, Round((FinalFileSize * 100) / InitialFileSize)]);
      ShowMsg(LastMsg);
    finally
      FileClose(Handle);
    end;
  finally
    if DoLog then
    begin
      AssignFile(LogFile, ExtractFilePath(ExeFileName) + 'ctdlog.txt');
      Rewrite(LogFile);
      try
        WriteLn(LogFile,
          'Design time log started at ' +
          FormatDateTime('dd/mm/yy hh:nn:ss', Start));
        WriteLn(LogFile, Format('Citadel %s (%s)', [Name, CtdVersion]));
        IDEVersion := GetIDEVersion;
        if IDEVersion <> '' then
          WriteLn(LogFile, IDEVersion);
        WriteLn(LogFile, GetOSVersion);

        SaveLog(LogFile, MainLog);
        SaveLog(LogFile, SecLog);
        WriteLn(LogFile, 'Log finished at ' + FormatDateTime('hh:nn:ss', Time));
      finally
        CloseFile(LogFile);
        MainLog.Clear;
        SecLog .Clear;
      end;
    end;
  end;
end;

procedure TCtdWork.ProgressStep(const StepSize: Integer);
begin
end;

procedure TCtdWork.SetProgressSteps(const Steps: Integer);
begin
end;

procedure TCtdWork.ShowMsg(const Msg: String; LogMode: TCtdLogModes);
begin
  if DoLog then
  begin
    if lmMain in LogMode then
      MainLog.Add(Msg);
    if lmSecondary in LogMode then
      SecLog .Add(Msg);
  end;
end;

end.