ctdwork.pas

Citadel v.1.6 Full Sources

                TCtdMemStream(StreamCompress).SetPointer(StreamPak.Memory, StreamPak.Size);
                DoneCompress := False;
              end
              else
              begin
                if(not DoFullStats) and DoPackDFM then
                  FreeAndNil(StreamPak); // StreamPak no more needed
              end;
            end
            else TCtdMemStream(StreamCompress).SetPointer(StreamPak.Memory, StreamPak.Size);

            if DoSave then
              StreamCompress.SaveToFile('D:\Proyecto\Temp\Dfms\' + Name + '-Lha.txt');
            StreamCompress.Position := 0;

            StreamCrypt := TMemoryStream.Create;
            try
              if DoEncryptDFM
              then
              begin
                if DoPackDFM or DoneCompress
                then TCtdMemStream(StreamCrypt).SetPointer(StreamCompress.Memory,
                       StreamCompress.Size)
                else
                begin
                  StreamCrypt.CopyFrom(StreamCompress, 0);

                  if not DoFullStats then
                  begin
                    if DoneCompress then
                      FreeAndNil(StreamCompress); // StreamCompress no more needed

                    if DoPackDFM then
                      FreeAndNil(StreamPak); // StreamPak no more needed
                  end;
                end;
                ShowMsg('Encrypting DFM: ' + Name + '...');
                {$ifndef CtdNoCrypt}
                CtdEncrypt(PasswordDFM, StreamCrypt.Memory, StreamCrypt.Size);
                {$endif CtdNoCrypt}
                ProgressStep;
              end
              else TCtdMemStream(StreamCrypt).SetPointer(StreamCompress.Memory, StreamCompress.Size);
              if DoSave then
                StreamCrypt.SaveToFile('D:\Proyecto\Temp\Dfms\' + Name + '-Cry.txt');
              StreamCrypt.Position := 0;

              StreamUpd := TMemoryStream.Create;
              try
                Signature :=
                  CtdWriteSignature(DoPackDFM, DoneCompress, DoEncryptDFM);
                StreamUpd.Write(Signature, 4);
                StreamUpd.CopyFrom(StreamCrypt, 0);
                ShowMsg('Updating DFM: ' + Name + '...');
                if not CtdUpdRes(UpdateHandle, PWideChar(RT_RCDATA), WName, 0,
                         StreamUpd.Memory, StreamUpd.Size) then
                  raise Exception.Create('Resource ''' + Name + '''update error');
                DstSize := StreamUpd.Size;
                ProgressStep;
              finally
                StreamUpd.Free;
              end;

              {$ifndef CtdNoUnpackExact}
              ShowMsg('Verifying DFM: ' + Name + '...');
              if DoEncryptDFM then
              begin
                {$ifndef CtdNoCrypt}
                if DoLog then
                  ShowMsg('Decrypting DFM: ' + Name, [lmLogOnly, lmMain]);
                CtdDecrypt(PasswordDFM, StreamCrypt.Memory, StreamCrypt.Size);
                {$endif CtdNoCrypt}
                ProgressStep;
              end;
              if DoSave then
                StreamCrypt.SaveToFile('D:\Proyecto\Temp\Dfms\' + Name + '-Dec.txt');
              StreamCrypt.Position := 0;

              StreamExpand := TMemoryStream.Create;
              try
                if DoneCompress
                then
                begin
                  if DoLog then
                    ShowMsg('Expanding DFM: ' + Name, [lmLogOnly, lmMain]);
                  CtdExpand(StreamCrypt, StreamExpand);

                  if DoEncryptDFM then
                    FreeAndNil(StreamCrypt); // StreamCrypt no more needed
                end
                else TCtdMemStream(StreamExpand).SetPointer(StreamCrypt.Memory, StreamCrypt.Size);
                if DoCompressDFM then
                  ProgressStep;
                if DoSave then
                  StreamExpand.SaveToFile('D:\Proyecto\Temp\Dfms\' + Name + '-Exp.txt');
                StreamExpand.Position := 0;

                StreamUnpak := TMemoryStream.Create;
                try
                  if DoPackDFM
                  then
                  begin
                    {$ifndef CtdNoPack}
                    {$ifndef CtdNoRTLog}
                    if DoLog then
                    begin
                      ShowMsg('Unpacking DFM: ' + Name, [lmLogOnly, lmMain]);
                      ShowMsg('**** Unpacking details ****', [lmLogOnly, lmSecondary]);
                    end;
                    {$endif CtdNoRTLog}
                    ctdUnPak.RuntimeLog := DoRuntimeLog;
                    try
                      CtdObjectPackedToBinary(CompClass, StreamExpand, StreamUnpak);
                    finally
                      ctdUnPak.RuntimeLog := False;
                    end;
                    {$ifndef CtdNoRTLog}
                    if DoLog then
                      ShowMsg('**** Unpacking finished ****', [lmLogOnly, lmSecondary]);
                    {$endif CtdNoRTLog}
                    {$endif CtdNoPack}
                    ProgressStep;

                    if DoneCompress then
                      FreeAndNil(StreamExpand); // StreamExpand no more needed
                  end
                  else TCtdMemStream(StreamUnpak).SetPointer(StreamExpand.Memory, StreamExpand.Size);
                  if DoSave then
                    StreamUnpak.SaveToFile('D:\Proyecto\Temp\Dfms\' + Name + '-Unp.txt');
                  StreamUnpak.Position := 0;

                  NameOutput := Name;
                  {$ifndef CtdNoPack}
                  if DoPackDFM and (CompClass = nil) then
                    NameOutput := '(' + NameOutput + ')';
                  {$endif CtdNoPack}

                  if StreamUnpak.Size <> ResSize
                  then raise Exception.Create('Size of ' + NameOutput +
                         ' incorrect: ' + IntToStr(StreamUnpak.Size) + ' <> ' +
                         IntToStr(ResSize) + ' (' +
                         FirstDiffByte(ResData, StreamUnpak.Memory,
                          Min(ResSize, StreamUnpak.Size)) +
                         ')')
                  else if not CompareMem(ResData, StreamUnpak.Memory, ResSize)
                  then raise Exception.Create('Unpacking of ' + NameOutput +
                         ' incorrect' + ' (' +
                         FirstDiffByte(ResData, StreamUnpak.Memory, ResSize) +
                         ')')
                  else
                    if DoFullStats then
                      ShowMsg('Size of ' + NameOutput + ': ' + #13#10 +
                        IntToStr(ResSize            ) + ' -> ' +
                        IntToStr(StreamPak     .Size) + ' -> ' +
                        IntToStr(StreamCompress.Size) + #13#10 +
                        IntToStr(StreamPak     .Size * 100 div ResSize       ) + '% -> ' +
                        IntToStr(StreamCompress.Size * 100 div ResSize       ) + '% (' +
                        IntToStr(StreamCompress.Size * 100 div StreamPak.Size) + '%)');
                finally
                  if not DoPackDFM then
                    TCtdMemStream(StreamUnpak).SetPointer(nil, 0);
                  StreamUnpak.Free;
                end;
              finally
                if Assigned(StreamExpand) then
                begin
                  if not DoneCompress then
                    TCtdMemStream(StreamExpand).SetPointer(nil, 0);
                  StreamExpand.Free;
                end;
              end;
              {$endif CtdNoUnpackExact}
            finally
              if Assigned(StreamCrypt) then
              begin
                if(not DoEncryptDFM) or (DoPackDFM or DoneCompress) then
                  TCtdMemStream(StreamCrypt).SetPointer(nil, 0);
                StreamCrypt.Free;
              end;
            end;
          finally
            if Assigned(StreamCompress) then
            begin
              if not DoneCompress then
                TCtdMemStream(StreamCompress).SetPointer(nil, 0);
              StreamCompress.Free;
            end;
          end;
        finally
          if Assigned(StreamPak) then
          begin
            if not DoPackDFM then
              TCtdMemStream(StreamPak).SetPointer(nil, 0);
            StreamPak.Free;
          end;
        end;
      finally
        if Assigned(StreamRes) then
        begin
          TCtdMemStream(StreamRes).SetPointer(nil, 0);
          StreamRes.Free;
        end;
      end;
    finally
      {$ifndef CtdNoPack}
      if DoPackDFM then
      begin
        for i := 0 to ModuleClassesList.Count-1 do
          Unregisterclass(TComponentClass(ModuleClassesList[i]));
        ModuleClassesList.Clear;

        with BorlandIDEServices as IOTAModuleServices do
        begin
          while SaveModuleCount < ModuleCount do
            Modules[SaveModuleCount].CloseModule(True);
        end;
      end;
      {$endif CtdNoPack}
    end;
  end;
  Msg := Format('Processed DFM: %s - %.0n bytes', [Name, OrgSize]);
  if OrgSize > DstSize then
    Msg := Format('%s -> %.0n (%%%d ratio)',
      [Msg, DstSize, Round((DstSize * 100) / OrgSize)]);
  ShowMsg(Msg);
  Result := True;
end;

function EnumResourceNamesCallback(hModule: HMODULE;
  lpType, lpName: PChar; lParam: Longint): BOOL; stdcall; export;
var
  ResList: TStringList;
begin
  Result  := True;
  if(CompareText(String(lpName), 'DVCLAL'     ) <> 0) and
    (CompareText(String(lpName), 'PACKAGEINFO') <> 0) then
  begin
    ResList := TStringList(Pointer(lParam)^);
    ResList.Add(String(lpName));
  end;
end;

procedure TCtdWork.ProcessDFMs(const ExeFileName: String;
  const DoPack, DoCompress, DoCrypt, DoRunTimeLog: Boolean;
  const Password: AnsiString; Steps: Integer;
  var TotDFMOrgSize, TotDFMDstSize: Double; var DFMCount: Integer);

  procedure RejectDFM(ResList: TStringList; DFMName, Msg: String);
  begin
    ShowMsg(Format('''%s'' rejected: %s', [DFMName, Msg]));
    ResList.Delete(ResList.IndexOf(DFMName));
  end;

 function FindWord(pattern, text: String; caseSensitive: Boolean = false;
  startAt: Integer = 1): Integer;
  var
    offset,
    endOfPattern: Integer;
  begin
    if startAt > 1
    then
    begin
      offset := startAt - 1;
      Delete(text, 1, offset);
    end
    else offset := 0;
    if not caseSensitive then
    begin
      pattern:= AnsiLowerCase(pattern);
      text   := AnsiLowerCase(text);
    end;
    repeat
      result := Pos(pattern, text);
      if result = 0 then
        Exit;

      { We have a match, see if it constitutes a word. It does if
        the characters surrounding it are not alphanumeric.  You
        may want to restrict this to letters only, in which case
        use IsCharAlpha. }
      endOfPattern := Result + Length(pattern);
      if ((Result > 1) and IsCharAlphaNumeric(text[Result-1]))
         or
         (((endOfPattern) < Length(text)) and
          IsCharAlphaNumeric(text[endOfPattern]))
      then
      begin
        { No joy, this was a match inside a longer word. Remove
          the searched text and try again. }
        offset := offset + endOfPattern - 1;
        Delete(text, 1, endofPattern - 1);
        Result := 0;
      end;
    until Result > 0;
    Inc(Result, offset);
  end;

  procedure FilterMadExcept(ResList: TStringList; hExe: HModule;
    UpdateHandle: THandle);

    function DFMReferenced(DFMName, DFMText: String): Boolean;
    var
      Name: String;
    begin
      Result := False;
      if(Length(DFMName) > 3)                        and
        (CompareStr(Copy(DFMName, 1, 3), 'TME') = 0) then
      begin
        Name := Copy(DFMName, 4, Length(DFMName) - 3);
        Result := FindWord(Name, DFMText) > 0;
      end;
    end;

  const
    MainForm  = 'TMADEXCEPT';
    MadExcept = 'madExcept compatibility';
  var
    i: Integer;
    ResSize: DWord;
    Found: Boolean;
    ResStream: TMemoryStream;
    StrStream: TStringStream;
    ResStr: String;
    ResData: Pointer;
    WMainForm: array[0..255] of WideChar;
  begin
    Found := False;
    i     := 0;
    while i < ResList.Count do
    begin
      if CompareText(ResList[i], MainForm) = 0
      then
      begin
        Found := True;
        RejectDFM(ResList, ResList[i], MadExcept);
      end
      else Inc(i);
    end;
    if Found then
    begin
      // Reject additional MadExcept DFMs
      CtdGetRes(
        UpdateHandle,
        PWideChar(RT_RCDATA),
        StringToWideChar(MainForm, WMainForm, SizeOf(WMainForm) div 2),
        0, ResData, ResSize);
      ResStream := TMemoryStream.Create;
      try
        TCtdMemStream(ResStream).SetPointer(ResData, ResSize);
        StrStream := TStringStream.Create('');
        try
          ResStream.Position := 0;
          ObjectBinaryToText(ResStream, StrStream);
          ResStr := UpperCase(StrStream.DataString);
          i      := 0;
          while i < ResList.Count do
          begin
            if DFMReferenced(UpperCase(ResList[i]), ResStr)
            then RejectDFM(ResList, ResList[i], MadExcept)
            else Inc(i);
          end;
        finally
          StrStream.Free;
        end;