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.