type // DFM TDFMByNameDict = TObjectDictionary<string, TMemoryStream>;
function IsDfmResource(Stream: TStream): Boolean; const FilerSignature: array [1..4] of AnsiChar = AnsiString('TPF0'); var Signature: LongInt; begin Stream.Position := 0; stream.Read(Signature, SizeOf(Signature)); Result := Signature = LongInt(FilerSignature); end;
function LoadDFMs(const FileName: string): TDFMByNameDict; //Callback- // function EnumResNameProc(Module: THandle; ResType, ResName: PChar; lParam: TDFMByNameDict): BOOL; stdcall; var ResStream: TResourceStream; begin Result := True; // ResStream := TResourceStream.Create(Module, ResName, ResType); try // DFM if not IsDfmResource(ResStream) then Exit; // DFM , lParam.Add(ResName, TMemoryStream.Create); lParam[ResName].CopyFrom(ResStream, 0); finally FreeAndNil(ResStream); end; end; var DllHandle: THandle; begin Result := TDFMByNameDict.Create([doOwnsValues]); try DllHandle := LoadLibraryEx(PChar(FileName), 0, LOAD_LIBRARY_AS_DATAFILE); Win32Check(DllHandle <> 0); try EnumResourceNamesW(DllHandle, RT_RCDATA, @EnumResNameProc, Integer(Result)); finally FreeLibrary(DllHandle); end; except FreeAndNil(Result); raise; end; end;
procedure ZCompressStream(Source: TMemoryStream); var pOut: Pointer; outSize: Integer; begin ZCompress(Source.Memory, Source.Size, pOut, outSize, zcMax); try Source.Size := outSize; Move(pOut^, Source.Memory^, outSize); Source.Position := 0; finally FreeMem(pOut); end; end;
procedure CompressDFMs(DFMs: TDFMByNameDict); var Stream: TMemoryStream; begin for Stream in DFMs.Values do ZCompressStream(Stream); end;
procedure DeleteDFMs(const FileName: string; DFMs: TDFMByNameDict); var ResName: string; Handle: THandle; begin Handle := MadRes.BeginUpdateResourceW(PChar(FileName), False); Win32Check(Handle <> 0); try for ResName in DFMs.Keys do Win32Check(MadRes.UpdateResourceW(Handle, RT_RCDATA, PChar(ResName), 0, nil, 0)); finally Win32Check(MadRes.EndUpdateResourceW(Handle, False)); end; end;
// EXE procedure AddDFMs(const FileName: string; DFMs: TDFMByNameDict); var Handle: THandle; Item: TPair<string, TMemoryStream>; begin Handle := BeginUpdateResource(PChar(FileName), False); Win32Check(Handle <> 0); try for Item in DFMs do Win32Check(UpdateResource(Handle, RT_RCDATA, PChar(Item.Key), 0, Item.Value.Memory, Int64Rec(Item.Value.Size).Lo)); finally Win32Check(EndUpdateResource(Handle, False)); end; end;
// procedure ExecuteApplication(const FileName: string); var DFMs: TDFMByNameDict; begin // DFM DFMs := LoadDFMs(FileName); try // , if DFMs.Count = 0 then Exit; // CompressDFMs(DFMs); // DeleteDFMs(FileName, DFMs); // , AddDFMs(FileName, DFMs); finally FreeAndNil(DFMs); end; end;
program dfmcompressor; {$APPTYPE CONSOLE} uses Windows, SysUtils, Classes, Generics.Collections, ZLib, madRes; // // // begin try ExecuteApplication(ParamStr(1)); Writeln('Done.') except on E: Exception do Writeln(E.ClassName, ': ', E.Message); end; end.
function InternalReadComponentRes(const ResName: UnicodeString; HInst: THandle; var Instance: TComponent): Boolean; overload; var HRsrc: THandle; begin { avoid possible EResNotFound exception } if HInst = 0 then HInst := HInstance; HRsrc := FindResourceW(HInst, PWideChar(ResName), PWideChar(RT_RCDATA)); Result := HRsrc <> 0; if not Result then Exit; with TResourceStream.Create(HInst, ResName, RT_RCDATA) do try Instance := ReadComponent(Instance); finally Free; end; Result := True; end;
function InternalReadComponentRes(const ResName: UnicodeString; HInst: THandle; var Instance: TComponent): Boolean; overload; var Signature: Longint; ResStream: TResourceStream; DecompressStream: TDecompressionStream; begin Result := True; if HInst = 0 then HInst := HInstance; if FindResource(HInst, PChar(ResName), PChar(RT_RCDATA)) = 0 then Exit(False); ResStream := TResourceStream.Create(HInst, ResName, RT_RCDATA); try //, // DFM , ResStream.Read(Signature, SizeOf(Signature)); // ResStream.Position := 0; // , if Signature = Longint(FilerSignature) then Instance := ResStream.ReadComponent(Instance) else begin // , DFM DecompressStream := TDecompressionStream.Create(ResStream); try Instance := DecompressStream.ReadComponent(Instance); finally FreeAndNil(DecompressStream); end; end; finally FreeAndNil(ResStream); end; end;
type PJump = ^TJump; TJump = packed record OpCode: Byte; Distance: Pointer; end; procedure ReplaceProcedure(ASource, ADestination: Pointer); var NewJump: PJump; OldProtect: Cardinal; begin if VirtualProtect(ASource, SizeOf(TJump), PAGE_EXECUTE_READWRITE, @OldProtect) then try NewJump := PJump(ASource); NewJump.OpCode := $E9; NewJump.Distance := Pointer(Integer(ADestination) - Integer(ASource) - 5); FlushInstructionCache(GetCurrentProcess, ASource, SizeOf(TJump)); finally VirtualProtect(ASource, SizeOf(TJump), OldProtect, @OldProtect); end; end;
{ DFM } unit DFMCompressorSupportUnit; interface uses Windows, SysUtils, Classes, ZLib; implementation const // classes.pas FilerSignature: array[1..4] of AnsiChar = AnsiString('TPF0'); // // ReplaceProcedure // InternalReadComponentRes // // classes.pas function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean; function InitComponent(ClassType: TClass): Boolean; begin Result := False; if (ClassType = TComponent) or (ClassType = RootAncestor) then Exit; Result := InitComponent(ClassType.ClassParent); Result := InternalReadComponentRes(ClassType.ClassName, FindResourceHInstance(FindClassHInstance(ClassType)), Instance) or Result; end; var LocalizeLoading: Boolean; begin GlobalNameSpace.BeginWrite; // hold lock across all ancestor loads (performance) try LocalizeLoading := (Instance.ComponentState * [csInline, csLoading]) = []; if LocalizeLoading then BeginGlobalLoading; // push new loadlist onto stack try Result := InitComponent(Instance.ClassType); if LocalizeLoading then NotifyGlobalLoading; // call Loaded finally if LocalizeLoading then EndGlobalLoading; // pop loadlist off stack end; finally GlobalNameSpace.EndWrite; end; end; initialization ReplaceProcedure(@Classes.InitInheritedComponent, @InitInheritedComponent); end.
Source: https://habr.com/ru/post/238961/
All Articles