[Amin_Mansouri]

کد:

unit retCompress;

{

RetCompress unit
=============================================================
author: retnyg @ krazz.net/retnyg
=============================================================

License: use this code whereever you want, but keep credits

=============================================================

uses a undocumented API of ntdll to compress data.
compression rate is similar to ZIP, but a lot faster.

disadvantage: needs winNT, API may be changed or abandoned
in the future.

i added also the routines Inflate/Deflate, which just
packs sequential #0's, which is quite effective when
packing small exe's.

take also a look at the function HardCodedString, it's
commented out, because it needs the command inttostr,
which is in sysutils. It can be used to Hardcode a binary
string into a delphi app, such as to generate an exe by code.

example application can be found here:
http://www.delphipraxis.net/topic54428_batch+dateien.html
( batch2exe, also written by me )

Information about the used Api Commands can be found here:

http://undocumented.ntinternals.net/

}

interface
uses windows
//     , retasmtools
//     , sysutils
     ;
type
  PVOID = pointer;
  ULONG = cardinal;
  NTSTATUS = cardinal;
const

// RtlCompressBuffer constants

  COMPRESSION_FORMAT_NONE      = $00000000;        // [result:STATUS_INVALID_PARAMETER]
  COMPRESSION_FORMAT_DEFAULT      = $00000001;        // [result:STATUS_INVALID_PARAMETER]
  COMPRESSION_FORMAT_LZNT1      = $00000002;
  COMPRESSION_FORMAT_NS3      = $00000003;        // STATUS_NOT_SUPPORTED
  COMPRESSION_FORMAT_NS15      = $0000000F;        // STATUS_NOT_SUPPORTED
  COMPRESSION_FORMAT_SPARSE      = $00004000;        // ??? [result:STATUS_INVALID_PARAMETER]

  COMPRESSION_ENGINE_STANDARD      = $00000000;        // Standart compression
  COMPRESSION_ENGINE_MAXIMUM      = $00000100;        // Maximum (slowest but better)
  COMPRESSION_ENGINE_HIBER      = $00000200;        // STATUS_NOT_SUPPORTED


function RtlGetCompressionWorkSpaceSize(CompressionFormatAndEngine: ULONG; CompressBufferWorkSpaceSize, CompressFragmentWorkSpaceSize : PULONG): NTSTATUS; stdcall;
function RtlCompressBuffer(CompressionFormatAndEngine:ULONG; SourceBuffer: PVOID; SourceBufferLength: ULONG; DestinationBuffer: PVOID; DestinationBufferLength: ULONG; SourceChunkSize: ULONG; pDestinationSize: PULONG; WorkspaceBuffer: PVOID):NTSTATUS; stdcall;
function RtlDeCompressBuffer(CompressionFormatAndEngine:ULONG; DestinationBuffer: PVOID; DestinationBufferLength: ULONG; SourceBuffer: PVOID; SourceBufferLength: ULONG; pDestinationSize: PULONG):NTSTATUS; stdcall;

function Compress(s:string):string; stdcall;
function DeCompress(s:string):string; stdcall;
function InFlate(s:string): string; stdcall;
function DeFlate(s:string): string; stdcall;
//function HardCodedString(s:string):string; stdcall;

implementation

const
  ntdll = 'ntdll.dll';

function RtlGetCompressionWorkSpaceSize;  external ntdll name 'RtlGetCompressionWorkSpaceSize';
function RtlCompressBuffer;  external ntdll name 'RtlCompressBuffer';
function RtlDeCompressBuffer;  external ntdll name 'RtlDecompressBuffer';

function fastlength(s:string):dword;
asm
   test eax, eax
   jz @ende
   sub eax, 4
   mov eax, [eax]
   @ende:
end;

function Compress(s:string):string; stdcall;
var wsbuf: pointer;
    destLen, destSize, wsSize, wsFragsize: cardinal;
    l: cardinal;
    p:pdword;
    compressionType: cardinal;
begin
  l:=fastlength(s);
  if l > 0 then begin

    // maximum compression can get really slow on bigger files, so we do fast if
    // file bigger than a half mb:

    if l > $80000 then
      compressionType := COMPRESSION_FORMAT_LZNT1 or COMPRESSION_ENGINE_STANDARD
    else
      compressionType := COMPRESSION_FORMAT_LZNT1 or COMPRESSION_ENGINE_MAXIMUM;

    rtlGetCompressionWorkspaceSize( compressionType, @wssize, @wsfragsize);
    getmem(wsbuf, wssize);
    destLen := l + 8;
    setlength(result, destLen);
    destsize := 0;
    rtlCompressBuffer(compressionType, @s[1], l, @result[5], destlen, $1000, @destSize, wsBuf);
    freemem(wsbuf);
    setlength(result, destSize + 4);
    p:=@result[1];
    p^:=l;

  end else result := '';
end;

function DeCompress(s:string):string; stdcall;
var l, destSize: cardinal;
    p:pdword;
    compressionType: cardinal;
begin
  l := fastlength(s);
  if l > 4 then begin
    p := @s[1];
    setlength(result,p^);

    if p^ > $80000 then
      compressionType := COMPRESSION_FORMAT_LZNT1 or COMPRESSION_ENGINE_STANDARD
    else
      compressionType := COMPRESSION_FORMAT_LZNT1 or COMPRESSION_ENGINE_MAXIMUM;

    rtlDeCompressBuffer( compressionType, @result[1],p^,@s[5],l-4,@DestSize );
    setlength(result, DestSize);
  end else result := '';
end;

function InFlate(s:string): string; stdcall;
var i: cardinal;
    c, ordc: byte;
    l: dword;
begin
  result := '';
  l:=fastlength(s);
  i := 1;
  while i <= l do begin
     ordc := byte(s[i]);
     if ordc = 0 then begin
        c:=0;
        while (byte(s[i])=0) and (c<255) and (i <= l) do begin
          inc(c);
          inc(i);
        end;
        result := result + #0 +char(c);
     end
     else  begin
       result := result + s[i];
       inc(i);
     end;
  end;
end;

function DeFlate(s:string): string; stdcall;
var i: cardinal;
    c, ordc: byte;
    l,l2: dword;
begin
  result := '';
  l:=fastlength(s);
  i := 1;
  while i <= l do begin
     ordc := byte(s[i]);
     if ordc = 0 then begin
        c:=byte(s[i+1]);
        l2:=fastlength(result);
        setlength(result, l2 + c);
        fillchar(pointer(@result[l2+1])^,c,0);
        inc(i);
     end
     else  begin
       result := result + s[i];
     end;
     inc(i);
  end;
end;

{

//commented because inttostr needed which is either in sysutils or in a custom unit


function HardCodedString(s:string):string; stdcall;

  function isText(b:byte):boolean;
  begin
    result := false;
    if (b >= 32) and (b <= 175) and (b<>168) then result := true;
  end;

var i : cardinal;
    stract, DoLF: boolean;
    ordc: byte;
begin
  stract := false;
  DoLF:=falsE;
  for i := 1 to fastlength(s) do begin
     ordc := byte(s[i]);
     if ((stract) and (not istext(ordc))) OR
     ((not stract) and (istext(ordc))) then begin
       stract := not stract;
       result := result + '''';
     end;
     if stract then result := result + s[i]
     else result := result + '#' + inttostr(ordc);
     if i mod 30 = 0 then DoLF := true;
     if (not stract) and (DoLF) then begin
       result := result + ' + '#13#10;
       DoLF := falsE;
     end;
  end;
  if stract then result := result + '''';
  result := result + ';';
end;
}

end.

کد:

unit rtlcompression;

interface

const
  COMPRESSION_ENGINE_STANDARD   = $00000000;
  COMPRESSION_ENGINE_MAXIMUM    = $00000100;

function Compress(const Source: Pointer; var Dest: Pointer; Count: Cardinal;
                Compression: Cardinal = COMPRESSION_ENGINE_STANDARD): Cardinal; overload;
function Compress(const Value: String; Compression: Cardinal = COMPRESSION_ENGINE_STANDARD): String; overload;
function Decompress(const Source: Pointer; var Dest: Pointer; Count: Cardinal): Cardinal; overload;
function Decompress(const Value: String): String; overload;

implementation

const
  ntdll = 'ntdll.dll';
  COMPRESSION_FORMAT_LZNT1      = $00000002;
  DECOMPRESSION_MULTIPLICATOR   = 150;

type
  PULONG = ^ULONG;
  ULONG = Cardinal;

function RtlGetCompressionWorkSpaceSize(CompressionFormatAndEngine: ULONG;
                CompressBufferWorkSpaceSize, CompressFragmentWorkSpaceSize: PULONG): Cardinal;
                  stdcall; external ntdll name 'RtlGetCompressionWorkSpaceSize';
function RtlCompressBuffer(CompressionFormatAndEngine: ULONG; UncompressedBuffer: Pointer;
                UncompressedBufferSize: ULONG; CompressedBuffer: Pointer; CompressedBufferSize: ULONG;
                UncompressedChunkSize: ULONG; FinalCompressedSize: PULONG; WorkSpace: Pointer): Cardinal;
                  stdcall; external ntdll name 'RtlCompressBuffer';
function RtlDecompressFragment(CompressionFormat:ULONG; UncompressedFragment: Pointer;
                UncompressedFragmentSize: ULONG; CompressedBuffer: Pointer; CompressedBufferSize: ULONG;
                FragmentOffset: ULONG; FinalUncompressedSize: PULONG; WorkSpace: Pointer): Cardinal;
                  stdcall; external ntdll name 'RtlDecompressFragment';

function Compress(const Source: Pointer; var Dest: Pointer; Count: Cardinal;
                Compression: Cardinal = COMPRESSION_ENGINE_STANDARD): Cardinal;
var
  WorkSpace: Pointer;
  WorkSpaceSize, ChunkSize: Cardinal;
begin
  Result := 0;
  Compression := COMPRESSION_FORMAT_LZNT1 or Compression;
  RtlGetCompressionWorkSpaceSize(Compression, @WorkSpaceSize, @ChunkSize);
  GetMem(Dest, Count);
  GetMem(WorkSpace, WorkSpaceSize);
  RtlCompressBuffer(Compression, Source, Count, Dest, Count, ChunkSize, @Result, WorkSpace);
  FreeMem(WorkSpace);
  if Result = 0 then
  begin
    Move(Source^, Dest^, Count);
    Result := Count;
  end
  else
    ReallocMem(Dest, Result);
end;

function Compress(const Value: String; Compression: Cardinal = COMPRESSION_ENGINE_STANDARD): String;
var
  Buffer: PChar;
  Size: Cardinal;
begin
  Size := Compress(@Value[1], Pointer(Buffer), Length(Value), Compression);
  SetString(Result, Buffer, Size);
  FreeMem(Buffer);
end;

function Decompress(const Source: Pointer; var Dest: Pointer; Count: Cardinal): Cardinal;
var
  WorkSpace: Pointer;
  WorkSpaceSize, ChunkSize, BytesDecompressed: Cardinal;
begin
  Result := 0;
  BytesDecompressed := 0;
  RtlGetCompressionWorkSpaceSize(COMPRESSION_FORMAT_LZNT1, @WorkSpaceSize, @ChunkSize);
  GetMem(WorkSpace, WorkSpaceSize);
  ChunkSize := Count * DECOMPRESSION_MULTIPLICATOR div 100;
  New(Dest);
  repeat
    ReallocMem(Dest, Result + ChunkSize);
    RtlDecompressFragment(COMPRESSION_FORMAT_LZNT1, Pointer(Cardinal(Dest) + Result), ChunkSize,
                          Source, Count, Result, @BytesDecompressed, WorkSpace);
    if BytesDecompressed <= ChunkSize then
      Inc(Result, BytesDecompressed);
  until BytesDecompressed <> ChunkSize;
  FreeMem(WorkSpace);
  if Result = 0 then
  begin
    Move(Source^, Dest^, Count);
    Result := Count;
  end
  else
    ReallocMem(Dest, Result);
end;

function Decompress(const Value: String): String;
var
  Buffer: PChar;
  Size: Cardinal;
begin
  Size := Decompress(@Value[1], Pointer(Buffer), Length(Value));
  SetString(Result, Buffer, Size);
  FreeMem(Buffer);
end;

end.