pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity

addons update

Browse Source 
git-svn-id: https://svn.code.sf.net/p/kolmck/code@67 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
This commit is contained in:
dkolmck
2010-10-04 12:58:59 +00:00
parent c0d3767042
commit 8a71ebf5bc
30 changed files with 49858 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2623
Addons/ActiveKOL.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1357
Addons/DHTMLEDLib_TLBKOL.pas Normal file
View File

File diff suppressed because it is too large Load Diff

267
Addons/GIF_ASM.inc Normal file
View File

@ -0,0 +1,267 @@
asm
push ebx
push esi
push edi
mov esi, [SourcePtr]
mov edi, [Target]
{$IFDEF GIF_SAFE}
xor ebx, ebx
{$ELSE}
mov ebx, [StackPointer]
{$ENDIF}
mov ch, byte ptr [Bits]
mov cl, byte ptr [CodeSize]
@@loop:
{$IFDEF GIF_SAFE}
cmp [Bad], 0
jnz @@exit
{$ENDIF}
mov eax, [UnpackedSize]
test eax, eax
setle al
mov edx, [PackedSize]
test edx, edx
setle ah
or al, ah
jnz @@exit
{$IFDEF GIF_LOG}
pushad
mov eax, [UnpackedSize]
mov edx, [PackedSize]
mov ecx, [Data]
call doGifLog
popad
{$ENDIF}
movzx eax, byte ptr [esi]
xchg cl, ch
shl eax, cl
xchg cl, ch
add [Data], eax
add ch, 8
@@while:
{$IFDEF GIF_SAFE}
cmp [Bad], 0
jnz @@exit
{$ENDIF}
cmp ch, cl
jb @@e_while
mov eax, [Data]
and eax, [CodeMask]
shr [Data], cl
sub ch, cl
cmp eax, [EOICode]
jz @@e_while
@@1:
cmp eax, [ClearCode]
jnz @@2
mov cl, [initial_code_size]
inc cl
xor eax, eax
inc eax
shl eax, cl
dec eax
mov [CodeMask], eax
mov eax, [ClearCode]
add eax, 2
mov [FreeCode], eax
mov [OldCode], NoLZWCode
jmp @@while
@@2:
cmp eax, [FreeCode]
ja @@e_while
@@3:
cmp [OldCode], NoLZWCode
jne @@4
mov [OldCode], eax
{$IFDEF GIF_SAFE}
cmp eax, GIFBufSize-1
jle @@suffix_good1
mov [Bad], 1
and eax, GIFBufSize-1
@@suffix_good1:
{$ENDIF}
mov al, byte ptr [suffix+eax]
mov [FirstChar], al
{$IFDEF GIF_LOG}
pushad
call doGifLog2
popad
{$ENDIF}
stosb
dec [UnpackedSize]
jmp @@while
@@4:
mov [InCode], eax
cmp eax, [FreeCode]
jne @@5
mov al, [FirstChar]
{$IFDEF GIF_SAFE}
cmp ebx, GIFBufSize
jae @@stk_bad1
mov byte ptr [Stack+ebx], al
inc ebx
jmp @@stk_good1
@@stk_bad1:
mov [Bad], 1
@@stk_good1:
{$ELSE}
mov [ebx], al
inc ebx
{$ENDIF}
mov eax, [OldCode]
@@5:
cmp eax, [ClearCode]
jbe @@6
{$IFDEF GIF_SAFE}
cmp eax, GIFBufSize-1
jle @@suffix_good2
and eax, GIFBufSize-1
mov [Bad], 1
@@suffix_good2:
{$ENDIF}
mov dl, byte ptr [Suffix+eax]
{$IFDEF GIF_SAFE}
cmp ebx, GIFBufSize
jb @@stk_good2
mov [Bad], 1
jmp @@exit
@@stk_good2:
mov byte ptr [Stack+ebx], dl
inc ebx
@@stk_bad2:
cmp eax, GIFBufSize-1
jle @@Prefix_good1
and eax, GIFBufSize-1
mov [Bad], 1
@@Prefix_good1:
{$ELSE}
mov byte ptr [ebx], dl
inc ebx
{$ENDIF}
mov eax, dword ptr [Prefix+eax*4]
jmp @@5
@@6:
{$IFDEF GIF_SAFE}
cmp eax, GIFBufSize-1
jle @@suffix_good3
and eax, GIFBufSize-1
mov [Bad], 1
@@suffix_good3:
{$ENDIF}
mov dl, byte ptr [Suffix+eax]
mov [FirstChar], dl
{$IFDEF GIF_SAFE}
cmp ebx, GIFBufSize
jae @@stk_bad3
mov byte ptr [Stack+ebx], dl
inc ebx
jmp @@stk_good3
@@stk_bad3:
mov [Bad], 1
@@stk_good3:
{$ELSE}
mov byte ptr [ebx], dl
inc ebx
{$ENDIF}
mov eax, [FreeCode]
{$IFDEF GIF_SAFE}
cmp eax, GIFBufSize-1
jle @@suffix_good4
and eax, GIFBufSize-1
mov [Bad], 1
@@suffix_good4:
{$ENDIF}
mov byte ptr [Suffix+eax], dl
mov edx, [OldCode]
{$IFDEF GIF_SAFE}
cmp edx, GIFBufSize-1
jle @@Prefix_good2
and edx, GIFBufSize-1
mov [Bad], 1
@@Prefix_good2:
{$ENDIF}
mov dword ptr [Prefix+eax*4], edx
cmp eax, [CodeMask]
jnz @@7
cmp cl, 12
jae @@7
inc cl
xor eax, eax
inc eax
shl eax, cl
dec eax
mov [CodeMask], eax
@@7:
cmp [FreeCode], GIFBufSize-1
jae @@8
inc [FreeCode]
@@8:
mov eax, [InCode]
mov [OldCode], eax
@@9:
{$IFDEF GIF_SAFE}
test ebx, ebx
jz @@stk_bad4
dec ebx
mov al, byte ptr [Stack+ebx]
jmp @@stk_good4
@@stk_bad4:
mov [Bad], 1
@@stk_good4:
{$ELSE}
dec ebx
mov al, byte ptr [ebx]
{$ENDIF}
{$IFDEF GIF_LOG}
pushad
call doGifLog2
popad
{$ENDIF}
stosb
dec [UnpackedSize]
{$IFDEF GIF_SAFE}
test ebx, ebx
{$ELSE}
cmp ebx, [StackPointer]
{$ENDIF}
jne @@9
jmp @@while
@@e_while:
inc esi
dec [PackedSize]
jmp @@loop
@@exit:
pop edi
pop esi
pop ebx
end;

315
Addons/GIF_MMX.inc Normal file
View File

@ -0,0 +1,315 @@
asm
pxor mm0, mm0
pxor mm1, mm1
xor eax, eax
inc eax
movd mm1, eax
movd mm2, eax
psllq mm2, 32
mov edx, [UnpackedSize]
movd mm3, edx
psllq mm3, 32
mov edx, [PackedSize]
pxor mm4, mm4
movd mm4, edx
por mm3, mm4 // mm3 hi dword = UnpackedSize, mm3 lo dword = PackedSize
pxor mm4, mm4 // mm4 = Data
mov eax, [CodeMask]
movd mm5, eax
mov eax, [OldCode]
movd mm6, eax
//
push ebx
push esi
push edi
mov esi, [SourcePtr]
mov edi, [Target]
{$IFDEF GIF_SAFE}
xor ebx, ebx
{$ELSE}
mov ebx, [StackPointer]
{$ENDIF}
mov ch, byte ptr [Bits]
mov cl, byte ptr [CodeSize]
@@loop:
{$IFDEF GIF_SAFE}
cmp [Bad], 0
jnz @@exit
{$ENDIF}
movq mm7, mm3 // check if (PackedSize > 0) and (UnpackedSize > 0) then
pcmpgtd mm7, mm0
packsswb mm7, mm7
movd eax, mm7
inc eax
jnz @@exit // end of loop if not (one of operands = 0)
{$IFDEF GIF_LOG}
pushad
movq mm7, mm3
movd edx, mm7
psrlq mm7, 32
movd eax, mm7
movd ecx, mm4
call doGifLog
popad
{$ENDIF}
movzx eax, byte ptr [esi]
xchg cl, ch
shl eax, cl
xchg cl, ch
//add [Data], eax
movd mm7, eax
paddd mm4, mm7
add ch, 8
@@while:
{$IFDEF GIF_SAFE}
cmp [Bad], 0
jnz @@exit
{$ENDIF}
cmp ch, cl
jb @@e_while
//mov eax, [Data]
movd eax, mm4
//and eax, [CodeMask]
movd edx, mm5
and eax, edx
//shr [Data], cl
movzx edx, cl
movd mm7, edx
psrld mm4, mm7
sub ch, cl
cmp eax, [EOICode]
jz @@e_while
@@1:
cmp eax, [ClearCode]
jnz @@2
mov cl, [initial_code_size]
inc cl
xor eax, eax
inc eax
shl eax, cl
dec eax
//mov [CodeMask], eax
movd mm5, eax
mov eax, [ClearCode]
add eax, 2
mov [FreeCode], eax
//mov [OldCode], NoLZWCode
mov edx, NoLZWCode
movd mm6, edx
jmp @@while
@@2:
cmp eax, [FreeCode]
ja @@e_while
@@3:
//cmp [OldCode], NoLZWCode
movd edx, mm6
cmp edx, NoLZWCode
jne @@4
//mov [OldCode], eax
movd mm6, eax
{$IFDEF GIF_SAFE}
cmp eax, GIFBufSize-1
jle @@suffix_good1
mov [Bad], 1
and eax, GIFBufSize-1
@@suffix_good1:
{$ENDIF}
mov al, byte ptr [suffix+eax]
mov [FirstChar], al
{$IFDEF GIF_LOG}
pushad
call doGifLog2
popad
{$ENDIF}
stosb
//dec [UnpackedSize]
psubd mm3, mm2
jmp @@while
@@4:
//mov [InCode], eax
movd mm7, eax
cmp eax, [FreeCode]
jne @@5
mov al, [FirstChar]
{$IFDEF GIF_SAFE}
cmp ebx, GIFBufSize
jae @@stk_bad1
mov byte ptr [Stack+ebx], al
inc ebx
jmp @@stk_good1
@@stk_bad1:
mov [Bad], 1
@@stk_good1:
{$ELSE}
mov [ebx], al
inc ebx
{$ENDIF}
//mov eax, [OldCode]
movd eax, mm6
@@5:
cmp eax, [ClearCode]
jbe @@6
{$IFDEF GIF_SAFE}
cmp eax, GIFBufSize-1
jle @@suffix_good2
and eax, GIFBufSize-1
mov [Bad], 1
@@suffix_good2:
{$ENDIF}
mov dl, byte ptr [Suffix+eax]
{$IFDEF GIF_SAFE}
cmp ebx, GIFBufSize
jb @@stk_good2
mov [Bad], 1
jmp @@exit
@@stk_good2:
mov byte ptr [Stack+ebx], dl
inc ebx
@@stk_bad2:
cmp eax, GIFBufSize-1
jle @@Prefix_good1
and eax, GIFBufSize-1
mov [Bad], 1
@@Prefix_good1:
{$ELSE}
mov byte ptr [ebx], dl
inc ebx
{$ENDIF}
mov eax, dword ptr [Prefix+eax*4]
jmp @@5
@@6:
{$IFDEF GIF_SAFE}
cmp eax, GIFBufSize-1
jle @@suffix_good3
and eax, GIFBufSize-1
mov [Bad], 1
@@suffix_good3:
{$ENDIF}
mov dl, byte ptr [Suffix+eax]
mov [FirstChar], dl
{$IFDEF GIF_SAFE}
cmp ebx, GIFBufSize
jae @@stk_bad3
mov byte ptr [Stack+ebx], dl
inc ebx
jmp @@stk_good3
@@stk_bad3:
mov [Bad], 1
@@stk_good3:
{$ELSE}
mov byte ptr [ebx], dl
inc ebx
{$ENDIF}
mov eax, [FreeCode]
{$IFDEF GIF_SAFE}
cmp eax, GIFBufSize-1
jle @@suffix_good4
and eax, GIFBufSize-1
mov [Bad], 1
@@suffix_good4:
{$ENDIF}
mov byte ptr [Suffix+eax], dl
//mov edx, [OldCode]
movd edx, mm6
{$IFDEF GIF_SAFE}
cmp edx, GIFBufSize-1
jle @@Prefix_good2
and edx, GIFBufSize-1
mov [Bad], 1
@@Prefix_good2:
{$ENDIF}
mov dword ptr [Prefix+eax*4], edx
//cmp eax, [CodeMask]
movd edx, mm5
cmp eax, edx
jnz @@7
cmp cl, 12
jae @@7
inc cl
xor eax, eax
inc eax
shl eax, cl
dec eax
//mov [CodeMask], eax
movd mm5, eax
@@7:
cmp [FreeCode], GIFBufSize-1
jae @@8
inc [FreeCode]
@@8:
//mov eax, [InCode]
movd eax, mm7
//mov [OldCode], eax
movd mm6, eax
@@9:
{$IFDEF GIF_SAFE}
test ebx, ebx
jz @@stk_bad4
dec ebx
mov al, byte ptr [Stack+ebx]
jmp @@stk_good4
@@stk_bad4:
mov [Bad], 1
@@stk_good4:
{$ELSE}
dec ebx
mov al, byte ptr [ebx]
{$ENDIF}
{$IFDEF GIF_LOG}
pushad
call doGifLog2
popad
{$ENDIF}
stosb
//dec [UnpackedSize]
psubd mm3, mm2
{$IFDEF GIF_SAFE}
test ebx, ebx
{$ELSE}
cmp ebx, [StackPointer]
{$ENDIF}
jne @@9
jmp @@while
@@e_while:
inc esi
//dec [PackedSize]
psubd mm3, mm1
jmp @@loop
@@exit:
pop edi
pop esi
pop ebx
emms
end

2352
Addons/KOLComObj.pas Normal file
View File

File diff suppressed because it is too large Load Diff

21
Addons/KOLDHTML.pas Normal file
View File

@ -0,0 +1,21 @@
unit KOLDHTML;
interface
uses KOL, DHTMLEDLib_TLBKOL;
type
TDHTMLEDIT = DHTMLEDLib_TLBKOL.PDHTMLEDIT;
PDHTMLEDIT = DHTMLEDLib_TLBKOL.PDHTMLEDIT;
function NewDHTMLEDIT(AOwner: PControl): PDHTMLEDIT;
implementation
function NewDHTMLEDIT;
begin
new( Result, CreateParented( AOwner ) );
end;
end.

583
Addons/KOLOleRE.pas Normal file
View File

@ -0,0 +1,583 @@
unit KOLOleRE;
interface
{$I KOLDEF.inc}
uses
Windows, Messages, KOL, ActiveX;//, KOLComObj; // {$IFDEF _D6orHigher}, Variants {$ENDIF};
type
ITextDocument = interface( IDispatch )
['{8CC497C0-A1DF-11ce-8098-00AA0047BE5D}']
function { [propget][id] } GetName(
var pName: WideString): HRESULT; stdcall;
function { [propget][id] } GetSelection(
var ppSel: {ITextSelection} Pointer): HRESULT; stdcall;
function { [propget][id] } GetStoryCount(
var Count: Integer): HRESULT; stdcall;
function { [propget][id] } GetStoryRanges(
var ppStories: {ITextStoryRanges} Pointer): HRESULT; stdcall;
function { [propget][id] } GetSaved(
var Value: Integer): HRESULT; stdcall;
function { [propput][id] } SetSaved(
Value: Integer): HRESULT; stdcall;
function { [propget][id] } GetDefaultTabStop(
var Value: Single): HRESULT; stdcall;
function { [propput][id] } SetDefaultTabStop(
Value: Single): HRESULT; stdcall;
function { [id] } New: HRESULT; stdcall;
function { [id] } Open(
var pVar: Variant;
Flags: Integer;
CodePage: Integer): HRESULT; stdcall;
function { [id] } Save(
var pVar: Variant;
Flags: Integer;
CodePage: Integer): HRESULT; stdcall;
function { [id] } Freeze(
var Count: Integer): HRESULT; stdcall;
function { [id] } Unfreeze(
var Count: Integer): HRESULT; stdcall;
function { [id] } BeginEditCollection: HRESULT; stdcall;
function { [id] } EndEditCollection: HRESULT; stdcall;
function { [id] } Undo(
Count: Integer;
var prop: Integer): HRESULT; stdcall;
function { [id] } Redo(
Count: Integer;
var prop: Integer): HRESULT; stdcall;
function { [id] } Range(
cp1: Integer;
cp2: Integer;
var ppRange: {ITextRange} Pointer): HRESULT; stdcall;
function { [id] } RangeFromPoint(
x: Integer;
y: Integer;
var ppRange: {ITextRange} Pointer): HRESULT; stdcall;
end;
PKOLOleRichEdit =^TKOLOleRichEdit;
TKOLOleRichEdit = object(TControl)
private
function GetITD: ITextDocument;
protected
procedure CreateHandle;
function GetDragOle: boolean;
procedure SetDragOle(d: boolean);
public
function BitmapToRTF(pict: PBitmap): string;
procedure HideFrames;
property CanDragOle: boolean read GetDragOle write SetDragOle;
property ITD: ITextDocument read GetITD;
procedure Freeze( ACount: Integer );
procedure Unfreeze( ACount: Integer );
end;
function NewOLERichEdit( AParent: PControl; Options: TEditOptions ): PKOLOleRichEdit;
implementation
{$B-}
const
{$EXTERNALSYM EM_GETOLEINTERFACE}
EM_GETOLEINTERFACE = WM_USER + 60;
type
_charrange = record
cpMin: Longint;
cpMax: LongInt;
end;
{$EXTERNALSYM _charrange}
TCharRange = _charrange;
CHARRANGE = _charrange;
{$EXTERNALSYM CHARRANGE}
TREOBJECT = packed record
cbStruct: DWORD; // Size of structure
cp: longint; // Character position of object
clsid: TCLSID; // Class ID of object
oleobj: IOleObject; // OLE object interface
stg: IStorage; // Associated storage interface
olesite: IOLEClientSite; // Associated client site interface
sizel: TSize; // Size of object (may be 0,0)
dvaspect: DWORD; // Display aspect to use
dwFlags: DWORD; // Object status flags
dwUser: DWORD; // Dword for user's use
end;
IRichEditOle = interface(IUnknown)
['{00020D00-0000-0000-C000-000000000046}']
function GetClientSite(out lplpolesite: IOLECLIENTSITE): HResult; stdcall;
function GetObjectCount: longint; stdcall;
function GetLinkCount: longint; stdcall;
function GetObject(iob: longint; out reobject: TREOBJECT; dwFlags: DWORD): HRESULT; stdcall;
function InsertObject(const reobject: TREOBJECT): HResult; stdcall;
function ConvertObject(iob: longint; const clsidNew: TCLSID;
lpStrUserTypeNew: POleStr): HRESULT; stdcall;
function ActivateAs(const clsid, clsidAs: TCLSID): HRESULT; stdcall;
function SetHostNames(lpstrContainerApp, lpstrContainerObj: POleStr): HRESULT; stdcall;
function SetLinkAvailable(iob: longint; fAvailable: BOOL): HRESULT; stdcall;
function SetDvaspect(iob: longint; dvaspect: DWORD): HRESULT; stdcall;
function HandsOffStorage(iob: longint): HRESULT; stdcall;
function SaveCompleted(iob: longint; stg: IStorage): HRESULT; stdcall;
function InPlaceDeactivate: HRESULT; stdcall;
function ContextSensitiveHelp(fEnterMode: BOOL): HRESULT; stdcall;
function GetClipboardData(const chrg: TCharRange; reco: DWORD;
out dataobj: IDataObject): HRESULT; stdcall;
function ImportDataObject(dataobj: IDataObject; cf: TClipFormat;
hMetaPict: HGLOBAL): HRESULT; stdcall;
end;
IRichEditOleCallback = interface(IUnknown)
['{00020D03-0000-0000-C000-000000000046}']
function GetNewStorage: IStorage; safecall;
procedure GetInPlaceContext(out Frame: IOleInPlaceFrame;
out Doc: IOleInPlaceUIWindow; var FrameInfo: TOleInPlaceFrameInfo); safecall;
procedure ShowContainerUI(fShow: Bool); safecall;
procedure QueryInsertObject(const ClsID: TCLSID; Stg: IStorage; CP: Longint); safecall;
procedure DeleteObject(OleObj: IOleObject); safecall;
procedure QueryAcceptData(dataobj: IDataObject; var cfFormat: TClipFormat;
reCO: DWord; fReally: Bool; hMetaPict: HGlobal); safecall;
function ContextSensitiveHelp(fEnterMode: Bool): HResult; stdcall;
function GetClipboardData(const ChRg: TCharRange; reCO: DWord; out DataObj: IDataObject): HResult; stdcall;
procedure GetDragDropEffect(fDrag: Bool; grfKeyState: DWord;
var dwEffect: DWord); safecall;
procedure GetContextMenu(SelType: Word; OleObj: IOleObject;
const ChRg: TCharRange; var Menu: HMenu); safecall;
end;
TRichEditOleCallback = class(TInterfacedObject, IRichEditOleCallback)
private
FOwner: PKOLOleRichEdit;
protected
{ IRichEditOleCallback }
function GetNewStorage: IStorage; safecall;
procedure GetInPlaceContext(out Frame: IOleInPlaceFrame;
out Doc: IOleInPlaceUIWindow; var FrameInfo: TOleInPlaceFrameInfo); safecall;
procedure ShowContainerUI(fShow: Bool); safecall;
procedure QueryInsertObject(const ClsID: TCLSID; Stg: IStorage; CP: Longint); safecall;
procedure DeleteObject(OleObj: IOleObject); safecall;
procedure QueryAcceptData(dataobj: IDataObject; var cfFormat: TClipFormat;
reCO: DWord; fReally: Bool; hMetaPict: HGlobal); safecall;
function ContextSensitiveHelp(fEnterMode: Bool): HResult; stdcall;
function GetClipboardData(const ChRg: TCharRange; reCO: DWord; out DataObj: IDataObject): HResult; stdcall;
procedure GetDragDropEffect(fDrag: Bool; grfKeyState: DWord;
var dwEffect: DWord); safecall;
procedure GetContextMenu(SelType: Word; OleObj: IOleObject;
const ChRg: TCharRange; var Menu: HMenu); safecall;
public
constructor Create(Owner: PKOLOleRichEdit);
destructor Destroy; override;
end;
PData =^TData;
TData = object( TObj )
IOle: IRichEditOle;
IBck: TRichEditOleCallback;
ITD : ITextDocument;
Drag: boolean;
destructor Destroy; virtual;
end;
const
{$EXTERNALSYM EM_SETOLECALLBACK}
EM_SETOLECALLBACK = WM_USER + 70;
procedure OleCheck(Result: HResult);
begin
if not Succeeded(Result) then
MsgOK('OleCheck Fail ');
end;
function NewOLERichEdit( AParent: PControl; Options: TEditOptions ): PKOLOleRichEdit;
label exit;
var p: PData;
begin
Result := PKOLOleRichEdit(KOL.NewRichEdit( AParent, Options ));
new(p, Create);
Result.CustomObj := p;
Result.CreateWindow;
Result.CreateHandle;
Result.Perform(EM_GETOLEINTERFACE, 0, integer(@p.IOle));
p.IOle.QueryInterface( ITextDocument, p.ITD );
{asm
MOV EDX, offset @@new_call + 4
MOV EDX, [EDX]
ADD EDX, 12
// MOV [EBX], EDX //-- may be this works for some cases, but not in case when optimization is off
MOV EAX, [Result]
MOV [EAX+12], EDX
jmp exit
@@new_call:
end;
new( Result, CreateParented( AParent ) );
exit:}
end;
procedure TKOLOleRichEdit.CreateHandle;
var I: IRichEditOleCallback;
T: TRichEditOleCallback;
P: PData;
begin
inherited;
T := TRichEditOleCallback.Create(@Self);
I := T as IRichEditOleCallback;
Perform(em_SetOleCallback, 0, Longint(I));
P := Pointer( CustomObj );
P.IBck := T;
end;
{ TRichEditOleCallback }
constructor TRichEditOleCallback.Create(Owner: PKOLOleRichEdit);
begin
inherited Create;
FOwner := Owner;
end;
destructor TRichEditOleCallback.Destroy;
//var Form: PControl;
begin
{ Form := GetParentForm(FOwner);}
{ if Assigned(Form) and Assigned(Form.OleFormObject) then
(Form.OleFormObject as IOleInPlaceUIWindow).SetActiveObject(nil, nil);}
inherited;
end;
function TRichEditOleCallback.ContextSensitiveHelp(fEnterMode: Bool): HResult;
begin
Result := E_NOTIMPL
end;
procedure TRichEditOleCallback.DeleteObject(OleObj: IOleObject);
begin
OleObj.Close(OLECLOSE_NOSAVE);
end;
function TRichEditOleCallback.GetClipboardData(const ChRg: TCharRange; reCO: DWord; out DataObj: IDataObject): HResult;
begin
Result := E_NOTIMPL;
end;
procedure TRichEditOleCallback.GetContextMenu(SelType: Word;
OleObj: IOleObject; const ChRg: TCharRange; var Menu: HMenu);
begin
Menu := 0
end;
procedure TRichEditOleCallback.GetDragDropEffect(fDrag: Bool;
grfKeyState: DWord; var dwEffect: DWord);
var p: PData;
begin
if fOwner <> nil then begin
if fOwner.CustomObj <> nil then
begin
p := Pointer( fOwner.CustomObj );
if not p.Drag then begin
dwEffect := 0;
end;
end;
end;
end;
procedure TRichEditOleCallback.GetInPlaceContext(
out Frame: IOleInPlaceFrame; out Doc: IOleInPlaceUIWindow;
var FrameInfo: TOleInPlaceFrameInfo);
//var Form: PControl;
begin
//Get richedit's underlying form
{ Form := ValidParentForm(FOwner);}
//Ensure there is a TOleForm object
{ if Form.OleFormObject = nil then
TOleForm.Create(Form);}
//Get relevant frame interface
{ Frame := Form.OleFormObject as IOleInPlaceFrame;}
Doc := nil; //Document window is same as frame window
FrameInfo.hWndFrame := 0; // Form.Handle;
FrameInfo.fMDIApp := False;
FrameInfo.hAccel := 0;
FrameInfo.cAccelEntries := 0;
end;
function TRichEditOleCallback.GetNewStorage: IStorage;
var
LockBytes: ILockBytes;
begin
//Basically copied from TOleContainer.CreateStorage
OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes));
OleCheck(StgCreateDocfileOnILockBytes(LockBytes,
STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, Result));
end;
procedure TRichEditOleCallback.QueryAcceptData(dataobj: IDataObject;
var cfFormat: TClipFormat; reCO: DWord; fReally: Bool;
hMetaPict: HGlobal);
begin
//Accept anything
end;
procedure TRichEditOleCallback.QueryInsertObject(const ClsID: TCLSID;
Stg: IStorage; CP: Integer);
begin
//Accept anything
end;
procedure TRichEditOleCallback.ShowContainerUI(fShow: Bool);
//var Form: PControl;
begin
if fShow then
begin
{ Form := GetParentForm(FOwner);}
{ if Assigned(Form) and Assigned(Form.Menu) then
begin
Form.Menu.SetOle2MenuHandle(0);
(Form.OleFormObject as IVCLFrameForm).ClearBorderSpace
end}
end
end;
{ TOleRichEdit }
function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
begin
Dec(Alignment);
Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
Result := Result div 8;
end;
procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
Colors: Integer);
var
DS: TDIBSection;
Bytes: Integer;
begin
DS.dsbmih.biSize := 0;
Bytes := GetObject(Bitmap, SizeOf(DS), @DS);
if Bytes = 0 then {InvalidBitmap}
else if (Bytes >= (sizeof(DS.dsbm) + sizeof(DS.dsbmih))) and
(DS.dsbmih.biSize >= DWORD(sizeof(DS.dsbmih))) then
BI := DS.dsbmih
else
begin
FillChar(BI, sizeof(BI), 0);
with BI, DS.dsbm do
begin
biSize := SizeOf(BI);
biWidth := bmWidth;
biHeight := bmHeight;
end;
end;
case Colors of
2: BI.biBitCount := 1;
3..16:
begin
BI.biBitCount := 4;
BI.biClrUsed := Colors;
end;
17..256:
begin
BI.biBitCount := 8;
BI.biClrUsed := Colors;
end;
else
BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
end;
BI.biPlanes := 1;
if BI.biClrImportant > BI.biClrUsed then
BI.biClrImportant := BI.biClrUsed;
if BI.biSizeImage = 0 then
BI.biSizeImage := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
end;
procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
var ImageSize: DWORD; Colors: Integer);
var
BI: TBitmapInfoHeader;
begin
InitializeBitmapInfoHeader(Bitmap, BI, Colors);
if BI.biBitCount > 8 then
begin
InfoHeaderSize := SizeOf(TBitmapInfoHeader);
if (BI.biCompression and BI_BITFIELDS) <> 0 then
Inc(InfoHeaderSize, 12);
end
else
if BI.biClrUsed = 0 then
InfoHeaderSize := SizeOf(TBitmapInfoHeader) +
SizeOf(TRGBQuad) * (1 shl BI.biBitCount)
else
InfoHeaderSize := SizeOf(TBitmapInfoHeader) +
SizeOf(TRGBQuad) * BI.biClrUsed;
ImageSize := BI.biSizeImage;
end;
procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
var ImageSize: DWORD);
begin
InternalGetDIBSizes(Bitmap, InfoHeaderSize, ImageSize, 0);
end;
function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
var BitmapInfo; var Bits; Colors: Integer): Boolean;
var
OldPal: HPALETTE;
DC: HDC;
begin
InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), Colors);
OldPal := 0;
DC := CreateCompatibleDC(0);
try
if Palette <> 0 then
begin
OldPal := SelectPalette(DC, Palette, False);
RealizePalette(DC);
end;
Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits,
TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
finally
if OldPal <> 0 then SelectPalette(DC, OldPal, False);
DeleteDC(DC);
end;
end;
function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
begin
Result := InternalGetDIB(Bitmap, Palette, BitmapInfo, Bits, 0);
end;
function TKOLOleRichEdit.BitmapToRTF(pict: PBitmap): string;
var
bi, bb, rtf: string;
bis, bbs: Cardinal;
achar: ShortString;
hexpict: string;
I: Integer;
begin
GetDIBSizes(pict.Handle, bis, bbs);
SetLength(bi, bis);
SetLength(bb, bbs);
GetDIB(pict.Handle, {pict.Palette}0, PChar(bi)^, PChar(bb)^);
rtf := '{\rtf1 {\pict\dibitmap ';
SetLength(hexpict, (Length(bb) + Length(bi)) * 2);
I := 2;
for bis := 1 to Length(bi) do
begin
achar := Format('%x', [Integer(bi[bis])]);
if Length(achar) = 1 then
achar := '0' + achar;
hexpict[I - 1] := achar[1];
hexpict[I] := achar[2];
Inc(I, 2);
end;
for bbs := 1 to Length(bb) do
begin
achar := Format('%x', [Integer(bb[bbs])]);
if Length(achar) = 1 then
achar := '0' + achar;
hexpict[I - 1] := achar[1];
hexpict[I] := achar[2];
Inc(I, 2);
end;
rtf := rtf + hexpict + ' }}';
Result := rtf;
end;
procedure TKOLOleRichEdit.HideFrames;
var p: PData;
i: integer;
n: integer;
o: TREOBJECT;
begin
p := Pointer( CustomObj );
n := p.IOle.GetObjectCount;
for i := n - 1 downto 0 do begin
fillchar(o, sizeof(o), 0);
o.cbStruct := sizeof(O);
if p.IOle.GetObject(i, o, 7) = S_OK then begin
o.dwFlags := 0;
p.IOle.InsertObject(o);
end;
end;
end;
function TKOLOleRichEdit.GetDragOle;
var p: PData;
begin
Result := False;
if CustomObj <> nil then
begin
p := Pointer( CustomObj );
Result := p.Drag;
end;
end;
procedure TKOLOleRichEdit.SetDragOle;
var p: PData;
begin
if CustomObj <> nil then
begin
p := Pointer( CustomObj );
p.Drag := d;
end;
end;
function TKOLOleRichEdit.GetITD: ITextDocument;
var Data: PData;
begin
Data := Pointer( CustomObj );
Result := Data.ITD;
end;
procedure TKOLOleRichEdit.Freeze(ACount: Integer);
var Data: PData;
begin
Data := Pointer( CustomObj );
if Data.ITD <> nil then
Data.ITD.Freeze( ACount );
end;
procedure TKOLOleRichEdit.Unfreeze(ACount: Integer);
var Data: PData;
begin
Data := Pointer( CustomObj );
if Data.ITD <> nil then
Data.ITD.Unfreeze( ACount );
end;
{ TData }
destructor TData.Destroy;
begin
IBck := nil;
ITD := nil;
IOLE := nil;
inherited;
end;
end.

5037
Addons/KOLPng.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1190
Addons/KOLSHDocVw.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1060
Addons/KOLTGA.pas Normal file
View File

File diff suppressed because it is too large Load Diff

31
Addons/KOLWebBrowser.pas Normal file
View File

@ -0,0 +1,31 @@
//////////////////////////////////////////////////////////////////////////////////
// //
// //
// TKOLWebBrowser v1.0 //
// //
// Author: Dimaxx (dimaxx@atnet.ru) //
// //
// //
//////////////////////////////////////////////////////////////////////////////////
unit KOLWebBrowser;
interface
uses KOL, KOLSHDocVw;
type
TKOLWebBrowser = PWebBrowser;
PKOLWebBrowser = PWebBrowser;
function NewKOLWebBrowser(AOwner: PControl): PKOLWebBrowser;
implementation
function NewKOLWebBrowser;
begin
New(Result,CreateParented(AOwner));
end;
end.

576
Addons/KolZLib.pas Normal file
View File

@ -0,0 +1,576 @@
{*******************************************************}
{ }
{ Delphi Supplemental Components }
{ ZLIB Data Compression Interface Unit }
{ }
{ Copyright (c) 1997 Borland International }
{ }
{*******************************************************}
{ Modified for zlib 1.1.3 by Davide Moretti <dave@rimini.com> }
{ Modified for KOL by Alexey Shuvalov <alekc_s@mail.ru> }
{ Updated to zlib 1.1.4 by Dimaxx <dimaxx@atnet.ru>}
// Important! As this unit does not use Kol_Err.pas and SysUtils.pas, there is no
// exceptions raised. Therefore check for errors by comparing the values returned by
// functions such as Read/Write/Seek with value ZLIB_ERROR.
//Uncomment this to enable CompressBuf & DecompressBuf procedures.
//!!! This procedures converted but UNTESTED and MAY BE UNSTABLE !!!
//{$DEFINE BUFFERPROCS}
unit KolZLib;
{$I KOLDEF.INC}
interface
uses Windows, Kol;
const
ZLIB_ERROR = TStrmSize (-1);
type
TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer;
TFree = procedure (AppData, Block: Pointer);
// Internal structure. Ignore.
TZStreamRec = packed record
next_in: PChar; // next input byte
avail_in: Integer; // number of bytes available at next_in
total_in: Integer; // total nb of input bytes read so far
next_out: PChar; // next output byte should be put here
avail_out: Integer; // remaining free space at next_out
total_out: Integer; // total nb of bytes output so far
msg: PChar; // last error message, NULL if no error
internal: Pointer; // not visible by applications
zalloc: TAlloc; // used to allocate the internal state
zfree: TFree; // used to free the internal state
AppData: Pointer; // private data object passed to zalloc and zfree
data_type: Integer; // best guess about the data type: ascii or binary
adler: Integer; // adler32 value of the uncompressed data
reserved: Integer; // reserved for future use
end;
TZLibEvent = procedure (Sender: PStream) of Object;
PZLibData = ^TZLibData;
TZLibData = record
FStrm: PStream;
FStrmPos: Cardinal;
FOnProgress: TZLibEvent;
FZRec: TZStreamRec;
FBuffer: array [Word] of Char;
end;
{ TCompressionStream compresses data on the fly as data is written to it, and
stores the compressed data to another stream.
TCompressionStream is write-only and strictly sequential. Reading from the
stream will raise an exception. Using Seek to move the stream pointer
will raise an exception.
Output data is cached internally, written to the output stream only when
the internal output buffer is full. All pending output data is flushed
when the stream is destroyed.
The Position property returns the number of uncompressed bytes of
data that have been written to the stream so far.
CompressionRate returns the on-the-fly percentage by which the original
data has been compressed: (1 - (CompressedBytes / UncompressedBytes)) * 100
If raw data size = 100 and compressed data size = 25, the CompressionRate
is 75%
The OnProgress event is called each time the output buffer is filled and
written to the output stream. This is useful for updating a progress
indicator when you are writing a large chunk of data to the compression
stream in a single call.}
TCompressionLevel = (clNone, clFastest, clDefault, clMax);
//******************* NewCompressionStream *************************
// Creates new ZLib decompression stream. If ZLib initialization failed returns Nil;
// On Read/Write errors Read/Write functions return ZLIB_ERROR value (also for Seek).
function NewCompressionStream (CompressionLevel: TCompressionLevel; Destination: PStream; OnProgress: TZLibEvent): PStream;
{ TDecompressionStream decompresses data on the fly as data is read from it.
Compressed data comes from a separate source stream. TDecompressionStream
is read-only and unidirectional; you can seek forward in the stream, but not
backwards. The special case of setting the stream position to zero is
allowed. Seeking forward decompresses data until the requested position in
the uncompressed data has been reached. Seeking backwards, seeking relative
to the end of the stream, requesting the size of the stream, and writing to
the stream will return ZLIB_ERROR as a Result.
The Position property returns the number of bytes of uncompressed data that
have been read from the stream so far.
The OnProgress event is called each time the internal input buffer of
compressed data is exhausted and the next block is read from the input stream.
This is useful for updating a progress indicator when you are reading a
large chunk of data from the decompression stream in a single call.}
//******************* NewDecompressionStream *************************
// Creates new ZLib decompression stream. If ZLib initialization failed returns Nil;
// On Read/Write errors Read/Write functions return ZLIB_ERROR value (also for Seek).
function NewDecompressionStream (Source: PStream; OnProgress: TZLibEvent): PStream;
//******************* NewZLibXStream *************************
//Calls New[De]CompressionStream and returns True if Result<>Nil; Stream = Result.
// !!! Don't use Overload on this functions - it may cause compilation error
// when called with OnProgress=Nil !!!
function NewZLibDStream (var Stream: PStream; Source: PStream; OnProgress: TZLibEvent): Boolean;
function NewZLibCStream (var Stream: PStream; CompressionLevel: TCompressionLevel; Destination: PStream; OnProgress: TZLibEvent): Boolean;
{$IFDEF BUFFERPROCS}
{ CompressBuf compresses data, buffer to buffer, in one call.
In: InBuf = ptr to compressed data
InBytes = number of bytes in InBuf
Out: OutBuf = ptr to newly allocated buffer containing decompressed data
OutBytes = number of bytes in OutBuf }
function CompressBuf(const InBuf: Pointer; InBytes: Integer; out OutBuf: Pointer; out OutBytes: Integer): Boolean;
{ DecompressBuf decompresses data, buffer to buffer, in one call.
In: InBuf = ptr to compressed data
InBytes = number of bytes in InBuf
OutEstimate = zero, or est. size of the decompressed data
Out: OutBuf = ptr to newly allocated buffer containing decompressed data
OutBytes = number of bytes in OutBuf }
function DecompressBuf(const InBuf: Pointer; InBytes: Integer; OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer): Boolean;
{$ENDIF BUFFERPROCS}
const
ZLib_Version = '1.1.4';
Z_NO_FLUSH = 0;
Z_PARTIAL_FLUSH = 1;
Z_SYNC_FLUSH = 2;
Z_FULL_FLUSH = 3;
Z_FINISH = 4;
Z_OK = 0;
Z_STREAM_END = 1;
Z_NEED_DICT = 2;
Z_ERRNO = (-1);
Z_STREAM_ERROR = (-2);
Z_DATA_ERROR = (-3);
Z_MEM_ERROR = (-4);
Z_BUF_ERROR = (-5);
Z_VERSION_ERROR = (-6);
Z_NO_COMPRESSION = 0;
Z_BEST_SPEED = 1;
Z_BEST_COMPRESSION = 9;
Z_DEFAULT_COMPRESSION = (-1);
Z_FILTERED = 1;
Z_HUFFMAN_ONLY = 2;
Z_DEFAULT_STRATEGY = 0;
Z_BINARY = 0;
Z_ASCII = 1;
Z_UNKNOWN = 2;
Z_DEFLATED = 8;
_z_errmsg: array[0..9] of PChar = (
'need dictionary', // Z_NEED_DICT (2)
'stream end', // Z_STREAM_END (1)
'', // Z_OK (0)
'file error', // Z_ERRNO (-1)
'stream error', // Z_STREAM_ERROR (-2)
'data error', // Z_DATA_ERROR (-3)
'insufficient memory', // Z_MEM_ERROR (-4)
'buffer error', // Z_BUF_ERROR (-5)
'incompatible version', // Z_VERSION_ERROR (-6)
'' );
function adler32(adler: Integer; buf: PChar; len: Integer): Integer;
{$L Obj\deflate.obj}
{$L Obj\trees.obj}
{$L Obj\inflate.obj}
{$L Obj\inftrees.obj}
{$L Obj\adler32.obj}
{$L Obj\infblock.obj}
{$L Obj\infcodes.obj}
{$L Obj\infutil.obj}
{$L Obj\inffast.obj}
procedure _tr_init; external;
procedure _tr_tally; external;
procedure _tr_flush_block; external;
procedure _tr_align; external;
procedure _tr_stored_block; external;
function adler32; external;
procedure inflate_blocks_new; external;
procedure inflate_blocks; external;
procedure inflate_blocks_reset; external;
procedure inflate_blocks_free; external;
procedure inflate_set_dictionary; external;
procedure inflate_trees_bits; external;
procedure inflate_trees_dynamic; external;
procedure inflate_trees_fixed; external;
procedure inflate_codes_new; external;
procedure inflate_codes; external;
procedure inflate_codes_free; external;
procedure _inflate_mask; external;
procedure inflate_flush; external;
procedure inflate_fast; external;
// deflate compresses data
function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; recsize: Integer): Integer; external;
function deflate(var strm: TZStreamRec; flush: Integer): Integer; external;
function deflateEnd(var strm: TZStreamRec): Integer; external;
// inflate decompresses data
function inflateInit_(var strm: TZStreamRec; Version: PChar; recsize: Integer): Integer; external;
function inflate(var strm: TZStreamRec; flush: Integer): Integer; external;
function inflateEnd(var strm: TZStreamRec): Integer; external;
function inflateReset(var strm: TZStreamRec): Integer; external;
implementation
procedure _memset(P: Pointer; B: Byte; count: Integer);cdecl;
begin
FillChar(P^, count, Char( B ));
end;
procedure _memcpy(dest, source: Pointer; count: Integer);cdecl;
begin
Move(source^, dest^, count);
end;
function zcalloc(AppData: Pointer; Items, Size: Integer): Pointer;
begin
GetMem(Result, Items*Size);
end;
procedure zcfree(AppData, Block: Pointer);
begin
FreeMem(Block);
end;
function ZCheck(Code: Integer; var Clear: Boolean): Integer;
begin
Result:=Code;
Clear:=Code>=0;
end;
{$IFDEF BUFFERPROCS}
function CompressBuf(const InBuf: Pointer; InBytes: Integer;
out OutBuf: Pointer; out OutBytes: Integer): Boolean;
var
strm: TZStreamRec;
P: Pointer;
begin
Result:=True;
FillChar(strm, SizeOf(strm), 0);
OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255;
GetMem(OutBuf, OutBytes);
try
strm.next_in := InBuf;
strm.avail_in := InBytes;
strm.next_out := OutBuf;
strm.avail_out := OutBytes;
ZCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm)), Result);
If not Result then Exit;
while (ZCheck(deflate(strm, Z_FINISH), Result)<>Z_STREAM_END) and Result do
begin
P := OutBuf;
Inc(OutBytes, 256);
ReallocMem(OutBuf, OutBytes);
strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
strm.avail_out := 256;
end;
If Result then ZCheck(deflateEnd(strm), Result)
else deflateEnd(strm);
If not Result then Exit;
ReallocMem(OutBuf, strm.total_out);
OutBytes := strm.total_out;
finally
If not Result then begin
FreeMem(OutBuf);
OutBuf:=nil;
end;
end;
end;
function DecompressBuf(const InBuf: Pointer; InBytes: Integer;
OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer): Boolean;
var
strm: TZStreamRec;
P: Pointer;
BufInc: Integer;
begin
Result:=True;
FillChar(strm, sizeof(strm), 0);
BufInc := (InBytes + 255) and not 255;
if OutEstimate = 0 then
OutBytes := BufInc
else
OutBytes := OutEstimate;
GetMem(OutBuf, OutBytes);
try
strm.next_in := InBuf;
strm.avail_in := InBytes;
strm.next_out := OutBuf;
strm.avail_out := OutBytes;
ZCheck(InflateInit_(strm, zlib_version, sizeof(strm)), Result);
If not Result then Exit;
while (ZCheck(Inflate(strm, Z_FINISH), Result) <> Z_STREAM_END) and Result do
begin
P := OutBuf;
Inc(OutBytes, BufInc);
ReallocMem(OutBuf, OutBytes);
strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
strm.avail_out := BufInc;
end;
If Result then ZCheck(inflateEnd(strm), Result)
else InflateEnd(strm);
If not Result Then Exit;
ReallocMem(OutBuf, strm.total_out);
OutBytes := strm.total_out;
finally
If not Result then begin
FreeMem(OutBuf);
OutBuf:=nil;
end;
end;
end;
{$ENDIF BUFFERPROCS}
// Dummy methods
procedure DummySetSize(Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Value: TStrmSize);
asm
end;
function DummyReadWrite (Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize;
begin
Result:=ZLIB_ERROR;
end;
function DummyGetSize(Strm: PStream): TStrmSize;
begin
Result:=ZLIB_ERROR;
end;
// CompressStream methods
function CZLibWriteStream(Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize;
var
Check: Boolean;
begin
Result:=ZLIB_ERROR;
With PZlibData (Strm.Methods.fCustom)^ do begin
FZRec.next_in := @Buffer;
FZRec.avail_in := Count;
If FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
While (FZRec.avail_in > 0) do begin
ZCheck(deflate(FZRec, 0), Check);
If not Check then Exit;
If FZRec.avail_out = 0 then begin
If FStrm.Write (FBuffer, SizeOf(FBuffer))<>SizeOf(FBuffer) then Exit;
FZRec.next_out := FBuffer;
FZRec.avail_out := SizeOf(FBuffer);
FStrmPos := FStrm.Position;
If Assigned (fOnProgress) then
fOnProgress (Strm);
end;
end;
end;
Result := Count;
end;
function CZLibSeekStream(Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Offset: TStrmMove; Origin: TMoveMethod): TStrmSize;
begin
If (Offset = 0) and (Origin=spCurrent) then Result:=PZlibData (Strm.Methods.fCustom).FZRec.total_in
else Result:=ZLIB_ERROR;
end;
procedure CZLibCloseStream(Strm: PStream);
var
Check: Boolean;
begin
With PZlibData (Strm.Methods.fCustom)^ do begin
FZRec.next_in := nil;
FZRec.avail_in := 0;
try
If FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos;
while (ZCheck(deflate(FZRec, Z_FINISH), Check) <> Z_STREAM_END) and (FZRec.avail_out = 0) do begin
If not Check then Exit;
If FStrm.Write (FBuffer, SizeOf(FBuffer))<>SizeOf(FBuffer) then Exit;
FZRec.next_out := FBuffer;
FZRec.avail_out := sizeof(FBuffer);
end;
If FZRec.avail_out < SizeOf(FBuffer) then
FStrm.Write (FBuffer, SizeOf(FBuffer) - FZRec.avail_out)
finally
deflateEnd(FZRec);
Dispose (PZLibData (Strm.Methods.fCustom));
end;
end;
end;
// DecompressStream methods
procedure DZLibCloseStream(Strm: PStream);
begin
InflateEnd(PZLibData (Strm.Methods.fCustom).FZRec);
Dispose (PZLibData (Strm.Methods.fCustom));
end;
function DZLibSeekStream(Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Offset: TStrmMove; Origin: TMoveMethod): TStrmSize;
var
I: Integer;
Buf: array [0..4095] of Char;
Check: Boolean;
Off: TStrmMove;
begin
Result:=ZLIB_ERROR;
Off := Offset;
With PZlibData (Strm.Methods.fCustom)^ do begin
If (Off=0) and (Origin=spBegin) then begin
ZCheck(InflateReset(FZRec), Check);
If not Check then Exit;
FZRec.next_in := FBuffer;
FZRec.avail_in := 0;
FStrm.Position := 0;
FStrmPos := 0;
end
else If ((Off>=0) and (Origin=spCurrent)) or (((Off-FZRec.total_out)>0) and (Origin=spBegin)) then begin
If Origin=spBegin then Dec(Off, FZRec.total_out);
If Off>0 then begin
for I:=1 to Off div SizeOf(Buf) do
If Strm.Read(Buf, SizeOf(Buf))=ZLIB_ERROR then Exit;
If Strm.Read(Buf, Off mod SizeOf(Buf))=ZLIB_ERROR then Exit;
end;
end else Exit;
Result:=FZRec.total_out;
end;
end;
function DZLibReadStream (Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize;
var
Check: Boolean;
D: PZLibData;
begin
Result:=ZLIB_ERROR;
D := PZlibData (Strm.Methods.fCustom);
D.FZRec.next_out := @Buffer;
D.FZRec.avail_out := Count;
If D.FStrm.Position <> D.FStrmPos then
D.FStrm.Position := D.FStrmPos;
While (D.FZRec.avail_out > 0) do begin
If D.FZRec.avail_in = 0 then begin
D.FZRec.avail_in := D.FStrm.Read(D.FBuffer, SizeOf(D.FBuffer));
If D.FZRec.avail_in = 0 then begin
Result := Count - DWord(D.FZRec.avail_out);
Exit;
end;
D.FZRec.next_in := D.FBuffer;
D.FStrmPos := D.FStrm.Position;
If Assigned (D.fOnProgress) then
D.fOnProgress (Strm);
end;
ZCheck(Inflate(D.FZRec, 0), Check);
If not Check then Exit;
end;
Result:=Count;
end;
const
BaseCZlibMethods: TStreamMethods = (
fSeek: CZLibSeekStream;
fGetSiz: DummyGetSize;
fSetSiz: DummySetSize;
fRead: DummyReadWrite;
fWrite: CZLibWriteStream;
fClose: CZLibCloseStream;
fCustom: nil; );
BaseDZlibMethods: TStreamMethods = (
fSeek: DZLibSeekStream;
fGetSiz: DummyGetSize;
fSetSiz: DummySetSize;
fRead: DZLibReadStream;
fWrite: DummyReadWrite;
fClose: DZLibCloseStream;
fCustom: nil; );
function NewDecompressionStream (Source: PStream; OnProgress: TZLibEvent): PStream;
var
Inited: Boolean;
ZLibData: PZLibData;
begin
New (ZLibData);
With ZLibData^ do begin
FillChar(FZRec, SizeOf(FZRec), #0);
FOnProgress:=OnProgress;
FStrm:=Source;
FStrmPos:=Source.Position;
FZRec.next_in := FBuffer;
FZRec.avail_in := 0;
ZCheck(InflateInit_(FZRec, ZLib_Version, SizeOf(FZRec)), Inited);
end;
If Inited then begin
Result:=_NewStream (BaseDZlibMethods);
Result.Methods.fCustom:=ZLibData;
end else begin
Dispose (ZLibData);
Result:=nil;
end;
end;
function NewCompressionStream (CompressionLevel: TCompressionLevel; Destination: PStream; OnProgress: TZLibEvent): PStream;
const
Levels: array [TCompressionLevel] of ShortInt = (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION);
var
Inited: Boolean;
ZLibData: PZLibData;
begin
New (ZLibData);
With ZLibData^ do begin
FillChar(FZRec, SizeOf(FZRec), #0);
FOnProgress:=OnProgress;
FStrm:=Destination;
FStrmPos:=Destination.Position;
FZRec.next_out := FBuffer;
FZRec.avail_out := SizeOf(FBuffer);
ZCheck(deflateInit_(FZRec, Levels[CompressionLevel], ZLib_Version, SizeOf(FZRec)), Inited);
end;
If Inited then begin
Result:=_NewStream (BaseCZlibMethods);
Result.Methods.fCustom:=ZLibData;
end else begin
Dispose (ZLibData);
Result:=nil;
end;
end;
function NewZLibDStream (var Stream: PStream; Source: PStream; OnProgress: TZLibEvent): boolean;
begin
Stream:=NewDecompressionStream (Source, OnProgress);
Result:=Assigned (Stream);
end;
function NewZLibCStream (var Stream: PStream; CompressionLevel: TCompressionLevel; Destination: PStream; OnProgress: TZLibEvent): boolean;
begin
Stream:=NewCompressionStream (CompressionLevel, Destination, OnProgress);
Result:=Assigned (Stream);
end;
end.

1926
Addons/KolZLibBzip.pas Normal file
View File

File diff suppressed because it is too large Load Diff

27016
Addons/MSHTML_TLBKOL.pas Normal file
View File

File diff suppressed because it is too large Load Diff

693
Addons/SevenZip.pas Normal file
View File

@ -0,0 +1,693 @@
unit SevenZip;
interface
uses KOL;
const //Property IDs
kEnd = $00;
kHeader = $01;
kArchiveProperties = $02;
kAdditionalStreamsInfo = $03;
kMainStreamsInfo = $04;
kFilesInfo = $05;
kPackInfo = $06;
kUnPackInfo = $07;
kSubStreamsInfo = $08;
kSize = $09;
kCRC = $0A;
kFolder = $0B;
kCodersUnPackSize = $0C;
kNumUnPackStream = $0D;
kEmptyStream = $0E;
kEmptyFile = $0F;
kAnti = $10;
kName = $11;
kCreationTime = $12;
kLastAccessTime = $13;
kLastWriteTime = $14;
kWinAttributes = $15;
kComment = $16;
kEncodedHeader = $17;
const kSignature: array [0..5] of Char = ('7', 'z', #$BC, #$AF, #$27, #$1C);
type //7z format headers
REAL_UINT64 = Int64;
TArchiveVersion = packed record
Major: Byte; // now = 0
Minor: Byte; // now = 2
end;
TStartHeader = packed record
NextHeaderOffset: REAL_UINT64;
NextHeaderSize: REAL_UINT64;
NextHeaderCRC: Cardinal;
end;
TSignatureHeader = packed record
ArchiveVersion: TArchiveVersion;
StartHeaderCRC: Cardinal;
StartHeader: TStartHeader;
end;
PUInt32 = ^UInt32;
UInt32 = Cardinal;
PUInt64 = ^UInt64;
UInt64 = Int64;
CFileSize = UInt64;
PCFileSize = PUInt64;
CMethodID= UInt64;
CSzByteBuffer = packed record
Capacity: Cardinal;
Items: PByte;
end;
PCCoderInfo = ^CCoderInfo;
CCoderInfo = packed record
NumInStreams: UInt32;
NumOutStreams: UInt32;
MethodID: CMethodID;
Properties: CSzByteBuffer;
end;
PCBindPair = ^CBindPair;
CBindPair = packed record
InIndex: UInt32;
OutIndex: UInt32;
end;
PCFolder = ^CFolder;
CFolder = packed record
NumCoders: UInt32;
Coders: PCCoderInfo;
NumBindPairs: UInt32;
BindPairs: PCBindPair;
NumPackStreams: UInt32;
PackStreams: UInt32;
UnPackSizes: PCFileSize;
UnPackCRCDefined: Integer ;
UnPackCRC: UInt32;
NumUnPackStreams: UInt32;
end;
CArchiveFileTime = packed record
Low:UInt32;
High:UInt32;
end;
PCFileItem = ^CFileItem;
CFileItem = packed record
LastWriteTime: CArchiveFileTime;
{
CFileSize StartPos;
UInt32 Attributes;
}
Size: CFileSize;
FileCRC: UInt32;
Name: PChar;
IsFileCRCDefined: Byte;
HasStream: Byte;
IsDirectory: Byte;
IsAnti: Byte;
IsLastWriteTimeDefined: Byte;
{
int AreAttributesDefined;
int IsLastWriteTimeDefined;
int IsStartPosDefined;
}
end;
CArchiveDatabase = packed record
NumPackStreams: UInt32;
PackSizes: PCFileSize;
PackCRCsDefined: PByte;
PackCRCs: PUInt32;
NumFolders: PUInt32;
Folders: PCFolder;
NumFiles:UInt32;
Files: PCFileItem;
end;
CInArchiveInfo = packed record
StartPositionAfterHeader: CFileSize;
DataStartPosition: CFileSize;
end;
PCArchiveDatabaseEx= ^CArchiveDatabaseEx;
CArchiveDatabaseEx = packed record
Database: CArchiveDatabase;
ArchiveInfo: CInArchiveInfo;
FolderStartPackStreamIndex: PUInt32;
PackStreamStartPositions: PCFileSize;
FolderStartFileIndex: PUInt32;
FileIndexToFolderIndexMap: PUInt32;
end;
CSzData = packed record
Data: PByte;
Size: UInt32;
end;
type SZ_RESULT = Integer;
const k7zMajorVersion = 0;
k7zStartHeaderSize = $20;
function SzArchiveOpen2: SZ_RESULT;
implementation
function SzArchiveOpen2: SZ_RESULT;
var db: CArchiveDatabaseEx;
InStream: PStream;
signature: array [0..5] of Char;
version: Byte;
crcFromArchive: UInt32;
nextHeaderOffset: UInt64;
nextHeaderSize: UInt64;
nextHeaderCRC: UInt32;
crc: UInt32;
pos: CFileSize;
buffer: CSzByteBuffer;
sd: CSzData;
_type: UInt64;
begin
crc:= 0; pos:= 0;
InStream:= NewReadFileStream('D:\Work\Main\MDVReader\CE\_Books\_Books.7z');
if InStream.Read(signature, 6) <> 6 then Exit;
if signature <> kSignature then Exit;
{
db.Clear();
db.ArchiveInfo.StartPosition = _arhiveBeginStreamPosition;
}
if InStream.Read(version, 1) <> 1 then Exit;
if version <> k7zMajorVersion then Exit;
if InStream.Read(version, 1) <> 1 then Exit;
if InStream.Read(crcFromArchive, SizeOf(UInt32)) <> SizeOf(UInt32) then Exit; //RINOK(SafeReadDirectUInt32(inStream, &crcFromArchive, &crc));
// crc:= CRC_INIT_VAL;
if InStream.Read(nextHeaderOffset, SizeOf(UInt64)) <> SizeOf(UInt64) then Exit; //RINOK(SafeReadDirectUInt64(inStream, &nextHeaderOffset, &crc));
if InStream.Read(nextHeaderSize, SizeOf(UInt64)) <> SizeOf(UInt64) then Exit; //RINOK(SafeReadDirectUInt64(inStream, &nextHeaderSize, &crc));
if InStream.Read(nextHeaderCRC, SizeOf(UInt32)) <> SizeOf(UInt32) then Exit; //RINOK(SafeReadDirectUInt32(inStream, &nextHeaderCRC, &crc));
pos:= k7zStartHeaderSize;
db.ArchiveInfo.StartPositionAfterHeader:= pos;
//if (CRC_GET_DIGEST(crc) != crcFromArchive) return SZE_ARCHIVE_ERROR;
if nextHeaderSize = 0 then begin Result:= 0; Exit; end;
InStream.Seek(pos + nextHeaderOffset, spBegin);
buffer.Capacity:= nextHeaderSize;
buffer.Items:= GetMemory(nextHeaderSize);
if InStream.Read(buffer.Items, nextHeaderSize) <> nextHeaderSize then Exit; //Result:= SafeReadDirect(inStream, buffer.Items, (size_t)nextHeaderSize);
(*
// if (CrcCalc(buffer.Items, (UInt32)nextHeaderSize) == nextHeaderCRC) then begin
while true do begin
sd.Data:= buffer.Items;
sd.Size:= buffer.Capacity;
Result:= SzReadID(&sd, &type);
if (res != SZ_OK)
break;
if (type == k7zIdHeader)
{
res = SzReadHeader(&sd, db, allocMain, allocTemp);
break;
}
if (type != k7zIdEncodedHeader)
{
res = SZE_ARCHIVE_ERROR;
break;
}
{
CSzByteBuffer outBuffer;
res = SzReadAndDecodePackedStreams(inStream, &sd, &outBuffer,
db->ArchiveInfo.StartPositionAfterHeader,
allocTemp);
if (res != SZ_OK)
{
SzByteBufferFree(&outBuffer, allocTemp->Free);
break;
}
SzByteBufferFree(&buffer, allocTemp->Free);
buffer.Items = outBuffer.Items;
buffer.Capacity = outBuffer.Capacity;
}
end;
// end;
SzByteBufferFree(&buffer, allocTemp->Free);
return res;
*)
end;
(*
7z Format description (2.30 Beta 25)
-----------------------------------
This file contains description of 7z archive format.
7z archive can contain files compressed with any method.
See "Methods.txt" for description for defined compressing methods.
Format structure Overview
-------------------------
Some fields can be optional.
Archive structure
~~~~~~~~~~~~~~~~~
SignatureHeader
[PackedStreams]
[PackedStreamsForHeaders]
[
Header
or
{
Packed Header
HeaderInfo
}
]
Header structure
~~~~~~~~~~~~~~~~
{
ArchiveProperties
AdditionalStreams
{
PackInfo
{
PackPos
NumPackStreams
Sizes[NumPackStreams]
CRCs[NumPackStreams]
}
CodersInfo
{
NumFolders
Folders[NumFolders]
{
NumCoders
CodersInfo[NumCoders]
{
ID
NumInStreams;
NumOutStreams;
PropertiesSize
Properties[PropertiesSize]
}
NumBindPairs
BindPairsInfo[NumBindPairs]
{
InIndex;
OutIndex;
}
PackedIndices
}
UnPackSize[Folders][Folders.NumOutstreams]
CRCs[NumFolders]
}
SubStreamsInfo
{
NumUnPackStreamsInFolders[NumFolders];
UnPackSizes[]
CRCs[]
}
}
MainStreamsInfo
{
(Same as in AdditionalStreams)
}
FilesInfo
{
NumFiles
Properties[]
{
ID
Size
Data
}
}
}
HeaderInfo structure
~~~~~~~~~~~~~~~~~~~~
{
(Same as in AdditionalStreams)
}
Notes about Notation and encoding
---------------------------------
7z uses little endian encoding.
7z archive format has optional headers that are marked as
[]
Header
[]
REAL_UINT64 means real UINT64.
UINT64 means real UINT64 encoded with the following scheme:
Size of encoding sequence depends from first byte:
First_Byte Extra_Bytes Value
(binary)
0xxxxxxx : ( xxxxxxx )
10xxxxxx BYTE y[1] : ( xxxxxx << (8 * 1)) + y
110xxxxx BYTE y[2] : ( xxxxx << (8 * 2)) + y
...
1111110x BYTE y[6] : ( x << (8 * 6)) + y
11111110 BYTE y[7] : y
11111111 BYTE y[8] : y
...........................
ArchiveProperties
~~~~~~~~~~~~~~~~~
BYTE NID::kArchiveProperties (0x02)
while(true)
{
BYTE PropertyType;
if (aType == 0)
break;
UINT64 PropertySize;
BYTE PropertyData[PropertySize];
}
Digests (NumStreams)
~~~~~~~~~~~~~~~~~~~~~
BYTE AllAreDefined
if (AllAreDefined == 0)
{
for(NumStreams)
BIT Defined
}
UINT32 CRCs[NumDefined]
PackInfo
~~~~~~~~~~~~
BYTE NID::kPackInfo (0x06)
UINT64 PackPos
UINT64 NumPackStreams
[]
BYTE NID::kSize (0x09)
UINT64 PackSizes[NumPackStreams]
[]
[]
BYTE NID::kCRC (0x0A)
PackStreamDigests[NumPackStreams]
[]
BYTE NID::kEnd
Folder
~~~~~~
UINT64 NumCoders;
for (NumCoders)
{
BYTE
{
0:3 DecompressionMethod.IDSize
4:
0 - IsSimple
1 - Is not simple
5:
0 - No Attributes
1 - There Are Attributes
7:
0 - Last Method in Alternative_Method_List
1 - There are more alternative methods
}
BYTE DecompressionMethod.ID[DecompressionMethod.IDSize]
if (!IsSimple)
{
UINT64 NumInStreams;
UINT64 NumOutStreams;
}
if (DecompressionMethod[0] != 0)
{
UINT64 PropertiesSize
BYTE Properties[PropertiesSize]
}
}
NumBindPairs = NumOutStreamsTotal - 1;
for (NumBindPairs)
{
UINT64 InIndex;
UINT64 OutIndex;
}
NumPackedStreams = NumInStreamsTotal - NumBindPairs;
if (NumPackedStreams > 1)
for(NumPackedStreams)
{
UINT64 Index;
};
Coders Info
~~~~~~~~~~~
BYTE NID::kUnPackInfo (0x07)
BYTE NID::kFolder (0x0B)
UINT64 NumFolders
BYTE External
switch(External)
{
case 0:
Folders[NumFolders]
case 1:
UINT64 DataStreamIndex
}
BYTE ID::kCodersUnPackSize (0x0C)
for(Folders)
for(Folder.NumOutStreams)
UINT64 UnPackSize;
[]
BYTE NID::kCRC (0x0A)
UnPackDigests[NumFolders]
[]
BYTE NID::kEnd
SubStreams Info
~~~~~~~~~~~~~~
BYTE NID::kSubStreamsInfo; (0x08)
[]
BYTE NID::kNumUnPackStream; (0x0D)
UINT64 NumUnPackStreamsInFolders[NumFolders];
[]
[]
BYTE NID::kSize (0x09)
UINT64 UnPackSizes[]
[]
[]
BYTE NID::kCRC (0x0A)
Digests[Number of streams with unknown CRC]
[]
BYTE NID::kEnd
Streams Info
~~~~~~~~~~~~
[]
PackInfo
[]
[]
CodersInfo
[]
[]
SubStreamsInfo
[]
BYTE NID::kEnd
FilesInfo
~~~~~~~~~
BYTE NID::kFilesInfo; (0x05)
UINT64 NumFiles
while(true)
{
BYTE PropertyType;
if (aType == 0)
break;
UINT64 Size;
switch(PropertyType)
{
kEmptyStream: (0x0E)
for(NumFiles)
BIT IsEmptyStream
kEmptyFile: (0x0F)
for(EmptyStreams)
BIT IsEmptyFile
kAnti: (0x10)
for(EmptyStreams)
BIT IsAntiFile
case kCreationTime: (0x12)
case kLastAccessTime: (0x13)
case kLastWriteTime: (0x14)
BYTE AllAreDefined
if (AllAreDefined == 0)
{
for(NumFiles)
BIT TimeDefined
}
BYTE External;
if(External != 0)
UINT64 DataIndex
[]
for(Definded Items)
UINT32 Time
[]
kNames: (0x11)
BYTE External;
if(External != 0)
UINT64 DataIndex
[]
for(Files)
{
wchar_t Names[NameSize];
wchar_t 0;
}
[]
kAttributes: (0x15)
BYTE AllAreDefined
if (AllAreDefined == 0)
{
for(NumFiles)
BIT AttributesAreDefined
}
BYTE External;
if(External != 0)
UINT64 DataIndex
[]
for(Definded Attributes)
UINT32 Attributes
[]
}
}
Header
~~~~~~
BYTE NID::kHeader (0x01)
[]
ArchiveProperties
[]
[]
BYTE NID::kAdditionalStreamsInfo; (0x03)
StreamsInfo
[]
[]
BYTE NID::kMainStreamsInfo; (0x04)
StreamsInfo
[]
[]
FilesInfo
[]
BYTE NID::kEnd
HeaderInfo
~~~~~~~~~~
[]
BYTE NID::kEncodedHeader; (0x17)
StreamsInfo for Encoded Header
[]
---
End of document
*)
end.

74
Addons/UBitTreeDecoder.pas Normal file
View File

@ -0,0 +1,74 @@
unit UBitTreeDecoder;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL, URangeDecoder;
type PBitTreeDecoder = ^TBitTreeDecoder;
TBitTreeDecoder=object(TObj)
public
Models: array of smallint;
NumBitLevels:integer;
constructor Create(const AnumBitLevels:integer);
procedure _Init;
function Decode(const ArangeDecoder:PRangeDecoder):integer;
function ReverseDecode(const ArangeDecoder:PRangeDecoder):integer;overload;
end;
function ReverseDecode(var AModels: array of smallint; const AstartIndex:integer;const ArangeDecoder:PRangeDecoder; const ANumBitLevels:integer):integer;overload;
implementation
constructor TBitTreeDecoder.Create(const AnumBitLevels:integer);
begin
self.NumBitLevels := AnumBitLevels;
setlength(Models,1 shl AnumBitLevels);
end;
procedure TBitTreeDecoder._Init;
begin
urangedecoder.InitBitModels(Models);
end;
function TBitTreeDecoder.Decode(const ArangeDecoder:PRangeDecoder):integer;
var m,bitIndex:integer;
begin
m:=1;
for bitIndex := NumBitLevels downto 1 do begin
m:=m shl 1 + ArangeDecoder.DecodeBit(Models, m);
end;
result:=m - (1 shl NumBitLevels);
end;
function TBitTreeDecoder.ReverseDecode(const ArangeDecoder:PRangeDecoder):integer;
var m,symbol,bitindex,bit:integer;
begin
m:=1;
symbol:=0;
for bitindex:=0 to numbitlevels-1 do begin
bit:=ArangeDecoder.DecodeBit(Models, m);
m:=(m shl 1) + bit;
symbol:=symbol or (bit shl bitIndex);
end;
result:=symbol;
end;
function ReverseDecode(var AModels: array of smallint;const AstartIndex:integer;
const ArangeDecoder:PRangeDecoder;const ANumBitLevels:integer):integer;
var m,symbol,bitindex,bit:integer;
begin
m:=1;
symbol:=0;
for bitindex:=0 to ANumBitLevels -1 do begin
bit := ArangeDecoder.DecodeBit(AModels, AstartIndex + m);
m := (m shl 1) + bit;
symbol := symbol or bit shl bitindex;
end;
result:=symbol;
end;
end.

116
Addons/UBitTreeEncoder.pas Normal file
View File

@ -0,0 +1,116 @@
unit UBitTreeEncoder;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL, URangeDecoder,URangeEncoder;
type PBitTreeEncoder =^TBitTreeEncoder;
TBitTreeEncoder=object(TObj)
public
Models: array of smallint;
NumBitLevels:integer;
constructor Create(const AnumBitLevels:integer);
procedure _Init;
procedure Encode(const ArangeEncoder:PRangeEncoder;const Asymbol:integer);
procedure ReverseEncode(const ArangeEncoder:PRangeEncoder;Asymbol:integer);
function GetPrice(const Asymbol:integer):integer;
function ReverseGetPrice(Asymbol:integer):integer;overload;
end;
procedure ReverseEncode(var AModels:array of smallint;const AstartIndex:integer;const ArangeEncoder:PRangeEncoder;const ANumBitLevels:integer; Asymbol:integer);
function ReverseGetPrice(var AModels:array of smallint;const AstartIndex,ANumBitLevels:integer; Asymbol:integer):integer;
implementation
constructor TBitTreeEncoder.Create(const AnumBitLevels:integer);
begin
self.NumBitLevels:=AnumBitLevels;
setlength(Models,1 shl AnumBitLevels);
end;
procedure TBitTreeEncoder._Init;
begin
URangeDecoder.InitBitModels(Models);
end;
procedure TBitTreeEncoder.Encode(const ArangeEncoder:PRangeEncoder;const Asymbol:integer);
var m,bitindex,bit:integer;
begin
m := 1;
for bitIndex := NumBitLevels -1 downto 0 do begin
bit := (Asymbol shr bitIndex) and 1;
ArangeEncoder.Encode(Models, m, bit);
m := (m shl 1) or bit;
end;
end;
procedure TBitTreeEncoder.ReverseEncode(const ArangeEncoder:PRangeEncoder;Asymbol:integer);
var m,i,bit:integer;
begin
m:=1;
for i:= 0 to NumBitLevels -1 do begin
bit := Asymbol and 1;
ArangeEncoder.Encode(Models, m, bit);
m := (m shl 1) or bit;
Asymbol := Asymbol shr 1;
end;
end;
function TBitTreeEncoder.GetPrice(const Asymbol:integer):integer;
var price,m,bitindex,bit:integer;
begin
price := 0;
m := 1;
for bitIndex := NumBitLevels - 1 downto 0 do begin
bit := (Asymbol shr bitIndex) and 1;
price := price + RangeEncoder.GetPrice(Models[m], bit);
m := (m shl 1) + bit;
end;
result:=price;
end;
function TBitTreeEncoder.ReverseGetPrice(Asymbol:integer):integer;
var price,m,i,bit:integer;
begin
price := 0;
m := 1;
for i:= NumBitLevels downto 1 do begin
bit := Asymbol and 1;
Asymbol := Asymbol shr 1;
price :=price + RangeEncoder.GetPrice(Models[m], bit);
m := (m shl 1) or bit;
end;
result:=price;
end;
function ReverseGetPrice(var AModels:array of smallint;const AstartIndex,ANumBitLevels:integer;Asymbol:integer):integer;
var price,m,i,bit:integer;
begin
price := 0;
m := 1;
for i := ANumBitLevels downto 1 do begin
bit := Asymbol and 1;
Asymbol := Asymbol shr 1;
price := price + RangeEncoder.GetPrice(AModels[AstartIndex + m], bit);
m := (m shl 1) or bit;
end;
result:=price;
end;
procedure ReverseEncode(var AModels:array of smallint;const AstartIndex:integer;const ArangeEncoder:PRangeEncoder;const ANumBitLevels:integer;Asymbol:integer);
var m,i,bit:integer;
begin
m:=1;
for i := 0 to ANumBitLevels -1 do begin
bit := Asymbol and 1;
ArangeEncoder.Encode(AModels, AstartIndex + m, bit);
m := (m shl 1) or bit;
Asymbol := Asymbol shr 1;
end;
end;
end.

174
Addons/UBufferedFS.pas Normal file
View File

@ -0,0 +1,174 @@
unit UBufferedFS;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL;
type PBufferedFS = PStream;
{
const BufferSize=$10000;//64K
type TBFSMode=(BFMRead,BFMWrite);
TBufferedFS=class(TFileStream)
private
membuffer:array [0..BufferSize-1] of byte;
bytesinbuffer:integer;
bufferpos:integer;
bufferdirty:boolean;
Mode:TBFSMode;
procedure _Init;
procedure Flush;
procedure ReadBuffer;
public
constructor Create(const FileName: string; Mode: Word); overload;
constructor Create(const FileName: string; Mode: Word; Rights: Cardinal); overload;
destructor Destroy; override;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
end;
type TByteArray = array of byte;
PByteArray = ^TByteArray;
}
implementation
{
function MovePointer(const P:pointer;const dist:integer):pointer;
begin
result:=pointer(integer(p)+dist);
end;
procedure TBufferedFS.Init;
begin
bytesinbuffer:=0;
bufferpos:=0;
bufferdirty:=false;
mode:=BFMWrite;
end;
procedure TBufferedFS.Flush;
begin
if bufferdirty then
inherited Write(membuffer[0],bufferpos);
bufferdirty:=false;
bytesinbuffer:=0;
bufferpos:=0;
end;
constructor TBufferedFS.Create(const FileName: string; Mode: Word);
begin
inherited;
init;
end;
constructor TBufferedFS.Create(const FileName: string; Mode: Word; Rights: Cardinal);
begin
inherited;
init;
end;
destructor TBufferedFS.Destroy;
begin
flush;
inherited;
end;
procedure TBufferedFS.ReadBuffer;
begin
flush;
bytesinbuffer:=inherited Read(membuffer,buffersize);
bufferpos:=0;
end;
function TBufferedFS.Read(var Buffer; Count: Longint): Longint;
var p:PByteArray;
bytestoread:integer;
b:integer;
begin
if Mode=BFMWrite then flush;
mode:=BFMRead;
result:=0;
if count<=bytesinbuffer then begin
//all data already in buffer
move(membuffer[bufferpos],buffer,count);
bytesinbuffer:=bytesinbuffer-count;
bufferpos:=bufferpos+count;
result:=count;
end else begin
bytestoread:=count;
if (bytestoread<>0)and(bytesinbuffer<>0) then begin
//read data remaining in buffer and increment data pointer
b:=Read(buffer,bytesinbuffer);
p:=PByteArray(@(TByteArray(buffer)[b]));
bytestoread:=bytestoread-b;
result:=b;
end else p:=@buffer;
if bytestoread>=BufferSize then begin
//data to read is larger than the buffer, read it directly
result:=result+inherited Read(p^,bytestoread);
end else begin
//refill buffer
ReadBuffer;
//recurse
result:=result+Read(p^,math.Min(bytestoread,bytesinbuffer));
end;
end;
end;
function TBufferedFS.Write(const Buffer; Count: Longint): Longint;
var p:pointer;
bytestowrite:integer;
b:integer;
begin
if mode=BFMRead then begin
seek(-BufferSize+bufferpos,soFromCurrent);
bytesinbuffer:=0;
bufferpos:=0;
end;
mode:=BFMWrite;
result:=0;
if count<=BufferSize-bytesinbuffer then begin
//all data fits in buffer
bufferdirty:=true;
move(buffer,membuffer[bufferpos],count);
bytesinbuffer:=bytesinbuffer+count;
bufferpos:=bufferpos+count;
result:=count;
end else begin
bytestowrite:=count;
if (bytestowrite<>0)and(bytesinbuffer<>BufferSize)and(bytesinbuffer<>0) then begin
//write data to remaining space in buffer and increment data pointer
b:=Write(buffer,BufferSize-bytesinbuffer);
p:=MovePointer(@buffer,b);
bytestowrite:=bytestowrite-b;
result:=b;
end else p:=@buffer;
if bytestowrite>=BufferSize then begin
//empty buffer
Flush;
//data to write is larger than the buffer, write it directly
result:=result+inherited Write(p^,bytestowrite);
end else begin
//empty buffer
Flush;
//recurse
result:=result+Write(p^,bytestowrite);
end;
end;
end;
function TBufferedFS.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
if (Origin=soCurrent)and(Offset=0) then result:=inherited seek(Offset,origin)+bufferpos
else begin
flush;
result:=inherited Seek(offset,origin);
end;
end;
}
end.

80
Addons/UCRC.pas Normal file
View File

@ -0,0 +1,80 @@
unit UCRC;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL;
type PCRC = ^TCRC;
TCRC = object(TObj)
public
Value:integer;
constructor Create;
procedure _Init;
procedure Update(const data: array of byte;const offset,size:integer);overload;
procedure Update(const data: array of byte);overload;
procedure UpdateByte(const b:integer);
function GetDigest:integer;
end;
implementation
var Table: array [0..255] of integer;
constructor TCRC.Create;
begin
Value:=-1;
end;
procedure TCRC._Init;
begin
Value:=-1;
end;
procedure TCRC.Update(const data: array of byte;const offset,size:integer);
var i:integer;
begin
for i := 0 to size-1 do
value := Table[(value xor data[offset + i]) and $FF] xor (value shr 8);
end;
procedure TCRC.Update(const data: array of byte);
var size:integer;
i:integer;
begin
size := length(data);
for i := 0 to size - 1 do
value := Table[(value xor data[i]) and $FF] xor (value shr 8);
end;
procedure TCRC.UpdateByte(const b:integer);
begin
value := Table[(value xor b) and $FF] xor (value shr 8);
end;
function TCRC.GetDigest:integer;
begin
result:=value xor (-1);
end;
procedure InitCRC;
var i,j,r:integer;
begin
for i := 0 to 255 do begin
r := i;
for j := 0 to 7 do begin
if ((r and 1) <> 0) then
r := (r shr 1) xor integer($EDB88320)
else r := r shr 1;
end;
Table[i] := r;
end;
end;
initialization
InitCRC;
end.

420
Addons/ULZBinTree.pas Normal file
View File

@ -0,0 +1,420 @@
unit ULZBinTree;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses ULZInWindow, KOL;
type
TArrayOfInteger = array [0..0] of Integer;
PArrayOfInteger = ^TArrayOfInteger;
type PLZBinTree = ^TLZBinTree;
TLZBinTree = object(TLZInWindow)
public
cyclicBufferPos:integer;
cyclicBufferSize:integer;
matchMaxLen:integer;
son: PArrayOfInteger;//array of integer;
hash: array of integer;
cutValue:integer;
hashMask:integer;
hashSizeSum:integer;
HASH_ARRAY:boolean;
kNumHashDirectBytes:integer;
kMinMatchCheck:integer;
kFixHashSize:integer;
constructor Create;
procedure SetType(const AnumHashBytes:integer);
procedure _Init;virtual;
procedure MovePos;virtual;
function _Create(const AhistorySize,AkeepAddBufferBefore,AmatchMaxLen,AkeepAddBufferAfter:integer):boolean;
function GetMatches(var Adistances:array of integer):integer;
procedure Skip(Anum:integer);
procedure NormalizeLinks(var Aitems:array of integer;const AnumItems,AsubValue:integer);
procedure Normalize;
procedure SetCutValue(const AcutValue:integer);
end;
implementation
const kHash2Size = 1 shl 10;
kHash3Size = 1 shl 16;
kBT2HashSize = 1 shl 16;
kStartMaxLen = 1;
kHash3Offset = kHash2Size;
kEmptyHashValue = 0;
kMaxValForNormalize = (1 shl 30) - 1;
var CRCTable: array [0..255] of integer;
constructor TLZBinTree.Create;
begin
inherited Create;
cyclicBufferSize:=0;
cutValue:=$FF;
hashSizeSum:=0;
HASH_ARRAY:=true;
kNumHashDirectBytes:=0;
kMinMatchCheck:=4;
kFixHashsize:=kHash2Size + kHash3Size;
end;
procedure TLZBinTree.SetType(const AnumHashBytes:integer);
begin
HASH_ARRAY := (AnumHashBytes > 2);
if HASH_ARRAY then begin
kNumHashDirectBytes := 0;
kMinMatchCheck := 4;
kFixHashSize := kHash2Size + kHash3Size;
end
else begin
kNumHashDirectBytes := 2;
kMinMatchCheck := 2 + 1;
kFixHashSize := 0;
end;
end;
procedure TLZBinTree._Init;
var i:integer;
begin
inherited _init;
for i := 0 to hashSizeSum - 1 do
hash[i] := kEmptyHashValue;
cyclicBufferPos := 0;
ReduceOffsets(-1);
end;
procedure TLZBinTree.MovePos;
begin
inc(cyclicBufferPos);
if cyclicBufferPos >= cyclicBufferSize then
cyclicBufferPos := 0;
inherited MovePos;
if pos = kMaxValForNormalize then
Normalize;
end;
function TLZBinTree._Create(const AhistorySize,AkeepAddBufferBefore,AmatchMaxLen,AkeepAddBufferAfter:integer):boolean;
var windowReservSize:integer;
_cyclicBufferSize:integer;
hs:integer;
begin
if (AhistorySize > kMaxValForNormalize - 256) then begin
result:=false;
exit;
end;
cutValue := 16 + (AmatchMaxLen shr 1);
windowReservSize := (AhistorySize + AkeepAddBufferBefore + AmatchMaxLen + AkeepAddBufferAfter) div 2 + 256;
inherited _Create(AhistorySize + AkeepAddBufferBefore, AmatchMaxLen + AkeepAddBufferAfter, windowReservSize);
self.matchMaxLen := AmatchMaxLen;
_cyclicBufferSize := AhistorySize + 1;
if self.cyclicBufferSize <> _cyclicBufferSize then begin
self.cyclicBufferSize:=_cyclicBufferSize;
son:= AllocMem(_cyclicBufferSize * 2);
// GetMem(son,_cyclicBufferSize * 2);
// setlength(son,_cyclicBufferSize * 2);
end;
hs := kBT2HashSize;
if HASH_ARRAY then begin
hs := AhistorySize - 1;
hs := hs or (hs shr 1);
hs := hs or (hs shr 2);
hs := hs or (hs shr 4);
hs := hs or (hs shr 8);
hs := hs shr 1;
hs := hs or $FFFF;
if (hs > (1 shl 24)) then
hs := hs shr 1;
hashMask := hs;
inc(hs);
hs := hs + kFixHashSize;
end;
if (hs <> hashSizeSum) then begin
hashSizeSum := hs;
setlength(hash,hashSizeSum);
end;
result:=true;
end;
function TLZBinTree.GetMatches(var Adistances:array of integer):integer;
var lenLimit:integer;
offset,matchMinPos,cur,maxlen,hashvalue,hash2value,hash3value:integer;
temp,curmatch,curmatch2,curmatch3,ptr0,ptr1,len0,len1,count:integer;
delta,cyclicpos,pby1,len:integer;
begin
if pos + matchMaxLen <= streamPos then
lenLimit := matchMaxLen
else begin
lenLimit := streamPos - pos;
if lenLimit < kMinMatchCheck then begin
MovePos();
result:=0;
exit;
end;
end;
offset := 0;
if (pos > cyclicBufferSize) then
matchMinPos:=(pos - cyclicBufferSize)
else matchMinPos:=0;
cur := bufferOffset + pos;
maxLen := kStartMaxLen; // to avoid items for len < hashSize;
hash2Value := 0;
hash3Value := 0;
if HASH_ARRAY then begin
temp := CrcTable[bufferBase[cur] and $FF] xor (bufferBase[cur + 1] and $FF);
hash2Value := temp and (kHash2Size - 1);
temp := temp xor ((bufferBase[cur + 2] and $FF) shl 8);
hash3Value := temp and (kHash3Size - 1);
hashValue := (temp xor (CrcTable[bufferBase[cur + 3] and $FF] shl 5)) and hashMask;
end else
hashValue := ((bufferBase[cur] and $FF) xor ((bufferBase[cur + 1] and $FF) shl 8));
curMatch := hash[kFixHashSize + hashValue];
if HASH_ARRAY then begin
curMatch2 := hash[hash2Value];
curMatch3 := hash[kHash3Offset + hash3Value];
hash[hash2Value] := pos;
hash[kHash3Offset + hash3Value] := pos;
if curMatch2 > matchMinPos then
if bufferBase[bufferOffset + curMatch2] = bufferBase[cur] then begin
maxLen := 2;
Adistances[offset] := maxLen;
inc(offset);
Adistances[offset] := pos - curMatch2 - 1;
inc(offset);
end;
if curMatch3 > matchMinPos then
if bufferBase[bufferOffset + curMatch3] = bufferBase[cur] then begin
if curMatch3 = curMatch2 then
offset := offset - 2;
maxLen := 3;
Adistances[offset] := maxlen;
inc(offset);
Adistances[offset] := pos - curMatch3 - 1;
inc(offset);
curMatch2 := curMatch3;
end;
if (offset <> 0) and (curMatch2 = curMatch) then begin
offset := offset - 2;
maxLen := kStartMaxLen;
end;
end;
hash[kFixHashSize + hashValue] := pos;
ptr0 := (cyclicBufferPos shl 1) + 1;
ptr1 := (cyclicBufferPos shl 1);
len0 := kNumHashDirectBytes;
len1 := len0;
if kNumHashDirectBytes <> 0 then begin
if (curMatch > matchMinPos) then begin
if (bufferBase[bufferOffset + curMatch + kNumHashDirectBytes] <> bufferBase[cur + kNumHashDirectBytes]) then begin
maxLen := kNumHashDirectBytes;
Adistances[offset] := maxLen;
inc(offset);
Adistances[offset] := pos - curMatch - 1;
inc(offset);
end;
end;
end;
count := cutValue;
while (true) do begin
if (curMatch <= matchMinPos) or (count = 0) then begin
son[ptr1] := kEmptyHashValue;
son[ptr0] := son[ptr1];
break;
end;
dec(count);
delta := pos - curMatch;
if delta<=cyclicBufferPos then
cyclicpos:=(cyclicBufferPos - delta) shl 1
else cyclicpos:=(cyclicBufferPos - delta + cyclicBufferSize) shl 1;
pby1 := bufferOffset + curMatch;
len := min(len0, len1);
if bufferBase[pby1 + len] = bufferBase[cur + len] then begin
inc(len);
while (len <> lenLimit) do begin
if (bufferBase[pby1 + len] <> bufferBase[cur + len]) then
break;
inc(len);
end;
if maxLen < len then begin
maxLen := len;
Adistances[offset] := maxlen;
inc(offset);
Adistances[offset] := delta - 1;
inc(offset);
if (len = lenLimit) then begin
son[ptr1] := son[cyclicPos];
son[ptr0] := son[cyclicPos + 1];
break;
end;
end;
end;
if (bufferBase[pby1 + len] and $FF) < (bufferBase[cur + len] and $FF) then begin
son[ptr1] := curMatch;
ptr1 := cyclicPos + 1;
curMatch := son[ptr1];
len1 := len;
end else begin
son[ptr0] := curMatch;
ptr0 := cyclicPos;
curMatch := son[ptr0];
len0 := len;
end;
end;
MovePos;
result:=offset;
end;
procedure TLZBinTree.Skip(Anum:integer);
var lenLimit,matchminpos,cur,hashvalue,temp,hash2value,hash3value,curMatch:integer;
ptr0,ptr1,len,len0,len1,count,delta,cyclicpos,pby1:integer;
begin
repeat
if pos + matchMaxLen <= streamPos then
lenLimit := matchMaxLen
else begin
lenLimit := streamPos - pos;
if lenLimit < kMinMatchCheck then begin
MovePos();
dec(Anum);
continue;
end;
end;
if pos>cyclicBufferSize then
matchminpos:=(pos - cyclicBufferSize)
else matchminpos:=0;
cur := bufferOffset + pos;
if HASH_ARRAY then begin
temp := CrcTable[bufferBase[cur] and $FF] xor (bufferBase[cur + 1] and $FF);
hash2Value := temp and (kHash2Size - 1);
hash[hash2Value] := pos;
temp := temp xor ((bufferBase[cur + 2] and $FF) shl 8);
hash3Value := temp and (kHash3Size - 1);
hash[kHash3Offset + hash3Value] := pos;
hashValue := (temp xor (CrcTable[bufferBase[cur + 3] and $FF] shl 5)) and hashMask;
end else
hashValue := ((bufferBase[cur] and $FF) xor ((bufferBase[cur + 1] and $FF) shl 8));
curMatch := hash[kFixHashSize + hashValue];
hash[kFixHashSize + hashValue] := pos;
ptr0 := (cyclicBufferPos shl 1) + 1;
ptr1 := (cyclicBufferPos shl 1);
len0 := kNumHashDirectBytes;
len1 := kNumHashDirectBytes;
count := cutValue;
while true do begin
if (curMatch <= matchMinPos) or (count = 0) then begin
son[ptr1] := kEmptyHashValue;
son[ptr0] := son[ptr1];
break;
end else dec(count);
delta := pos - curMatch;
if (delta <= cyclicBufferPos) then
cyclicpos:=(cyclicBufferPos - delta) shl 1
else cyclicpos:=(cyclicBufferPos - delta + cyclicBufferSize) shl 1;
pby1 := bufferOffset + curMatch;
len := min(len0, len1);
if bufferBase[pby1 + len] = bufferBase[cur + len] then begin
inc(len);
while (len <> lenLimit) do begin
if bufferBase[pby1 + len] <> bufferBase[cur + len] then
break;
inc(len);
end;
if len = lenLimit then begin
son[ptr1] := son[cyclicPos];
son[ptr0] := son[cyclicPos + 1];
break;
end;
end;
if ((bufferBase[pby1 + len] and $FF) < (bufferBase[cur + len] and $FF)) then begin
son[ptr1] := curMatch;
ptr1 := cyclicPos + 1;
curMatch := son[ptr1];
len1 := len;
end else begin
son[ptr0] := curMatch;
ptr0 := cyclicPos;
curMatch := son[ptr0];
len0 := len;
end;
end;
MovePos;
dec(Anum);
until Anum=0;
end;
procedure TLZBinTree.NormalizeLinks(var Aitems:array of integer;const AnumItems,AsubValue:integer);
var i,value:integer;
begin
for i:=0 to AnumItems-1 do begin
value := Aitems[i];
if value <= AsubValue then
value := kEmptyHashValue
else value := value - AsubValue;
Aitems[i] := value;
end;
end;
procedure TLZBinTree.Normalize;
var subvalue:integer;
begin
subValue := pos - cyclicBufferSize;
NormalizeLinks(son^, cyclicBufferSize * 2, subValue);
NormalizeLinks(hash, hashSizeSum, subValue);
ReduceOffsets(subValue);
end;
procedure TLZBinTree.SetCutValue(const Acutvalue:integer);
begin
self.cutValue:=Acutvalue;
end;
procedure InitCRC;
var i,r,j:integer;
begin
for i := 0 to 255 do begin
r := i;
for j := 0 to 7 do
if ((r and 1) <> 0) then
r := (r shr 1) xor integer($EDB88320)
else
r := r shr 1;
CrcTable[i] := r;
end;
end;
initialization
InitCRC;
end.

170
Addons/ULZInWindow.pas Normal file
View File

@ -0,0 +1,170 @@
unit ULZInWindow;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL;
type TLZInWindow= object(TObj)
public
bufferBase: array of byte;// pointer to buffer with data
stream:PStream;
posLimit:integer; // offset (from _buffer) of first byte when new block reading must be done
streamEndWasReached:boolean; // if (true) then _streamPos shows real end of stream
pointerToLastSafePosition:integer;
bufferOffset:integer;
blockSize:integer; // Size of Allocated memory block
pos:integer; // offset (from _buffer) of curent byte
keepSizeBefore:integer; // how many BYTEs must be kept in buffer before _pos
keepSizeAfter:integer; // how many BYTEs must be kept buffer after _pos
streamPos:integer; // offset (from _buffer) of first not read byte from Stream
procedure MoveBlock;
procedure ReadBlock;
procedure _Free;
procedure _Create(const AkeepSizeBefore, AkeepSizeAfter, AkeepSizeReserv:integer);
procedure SetStream(const Astream:PStream);
procedure ReleaseStream;
procedure _Init;virtual;
procedure MovePos;virtual;
function GetIndexByte(const Aindex:integer):byte;
// index + limit have not to exceed _keepSizeAfter;
function GetMatchLen(const Aindex:integer;Adistance,Alimit:integer):integer;
function GetNumAvailableBytes:integer;
procedure ReduceOffsets(const AsubValue:integer);
end;
implementation
procedure TLZInWindow.MoveBlock;
var offset,numbytes,i:integer;
begin
offset := bufferOffset + pos - keepSizeBefore;
// we need one additional byte, since MovePos moves on 1 byte.
if (offset > 0) then
dec(offset);
numBytes := bufferOffset + streamPos - offset;
// check negative offset ????
for i := 0 to numBytes -1 do
bufferBase[i] := bufferBase[offset + i];
bufferOffset := bufferOffset - offset;
end;
procedure TLZInWindow.ReadBlock;
var size,numreadbytes,pointerToPostion:integer;
begin
if streamEndWasReached then
exit;
while (true) do begin
size := (0 - bufferOffset) + blockSize - streamPos;
if size = 0 then
exit;
numReadBytes := stream.Read(bufferBase[bufferOffset + streamPos], size);
if (numReadBytes = 0) then begin
posLimit := streamPos;
pointerToPostion := bufferOffset + posLimit;
if (pointerToPostion > pointerToLastSafePosition) then
posLimit := pointerToLastSafePosition - bufferOffset;
streamEndWasReached := true;
exit;
end;
streamPos := streamPos + numReadBytes;
if (streamPos >= pos + keepSizeAfter) then
posLimit := streamPos - keepSizeAfter;
end;
end;
procedure TLZInWindow._Free;
begin
setlength(bufferBase,0);
end;
procedure TLZInWindow._Create(const AkeepSizeBefore, AkeepSizeAfter, AkeepSizeReserv:integer);
var _blocksize:integer;
begin
self.keepSizeBefore := AkeepSizeBefore;
self.keepSizeAfter := AkeepSizeAfter;
_blocksize := AkeepSizeBefore + AkeepSizeAfter + AkeepSizeReserv;
if (length(bufferBase) = 0) or (self.blockSize <> _blocksize) then begin
_Free;
self.blockSize := _blocksize;
setlength(bufferBase,self.blockSize);
end;
pointerToLastSafePosition := self.blockSize - AkeepSizeAfter;
end;
procedure TLZInWindow.SetStream(const Astream:PStream);
begin
self.stream:=Astream;
end;
procedure TLZInWindow.ReleaseStream;
begin
stream:=nil;
end;
procedure TLZInWindow._Init;
begin
bufferOffset := 0;
pos := 0;
streamPos := 0;
streamEndWasReached := false;
ReadBlock;
end;
procedure TLZInWindow.MovePos;
var pointerToPostion:integer;
begin
inc(pos);
if pos > posLimit then begin
pointerToPostion := bufferOffset + pos;
if pointerToPostion > pointerToLastSafePosition then
MoveBlock;
ReadBlock;
end;
end;
function TLZInWindow.GetIndexByte(const Aindex:integer):byte;
begin
result:=bufferBase[bufferOffset + pos + Aindex];
end;
function TLZInWindow.GetMatchLen(const Aindex:integer;Adistance,Alimit:integer):integer;
var pby,i:integer;
begin
if streamEndWasReached then
if (pos + Aindex) + Alimit > streamPos then
Alimit := streamPos - (pos + Aindex);
inc(Adistance);
// Byte *pby = _buffer + (size_t)_pos + Aindex;
pby := bufferOffset + pos + Aindex;
i:=0;
while (i<Alimit)and(bufferBase[pby + i] = bufferBase[pby + i - Adistance]) do begin
inc(i);
end;
result:=i;
end;
function TLZInWindow.GetNumAvailableBytes:integer;
begin
result:=streamPos - pos;
end;
procedure TLZInWindow.ReduceOffsets(const Asubvalue:integer);
begin
bufferOffset := bufferOffset + Asubvalue;
posLimit := posLimit - Asubvalue;
pos := pos - Asubvalue;
streamPos := streamPos - Asubvalue;
end;
end.

104
Addons/ULZMABase.pas Normal file
View File

@ -0,0 +1,104 @@
unit ULZMABase;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
function StateInit:integer;
function StateUpdateChar(const index:integer):integer;
function StateUpdateMatch(const index:integer):integer;
function StateUpdateRep(const index:integer):integer;
function StateUpdateShortRep(const index:integer):integer;
function StateIsCharState(const index:integer):boolean;
function GetLenToPosState(len:integer):integer;
const kNumRepDistances = 4;
kNumStates = 12;
kNumPosSlotBits = 6;
kDicLogSizeMin = 0;
// kDicLogSizeMax = 28;
// kDistTableSizeMax = kDicLogSizeMax * 2;
kNumLenToPosStatesBits = 2; // it's for speed optimization
kNumLenToPosStates = 1 shl kNumLenToPosStatesBits;
kMatchMinLen = 2;
kNumAlignBits = 4;
kAlignTableSize = 1 shl kNumAlignBits;
kAlignMask = (kAlignTableSize - 1);
kStartPosModelIndex = 4;
kEndPosModelIndex = 14;
kNumPosModels = kEndPosModelIndex - kStartPosModelIndex;
kNumFullDistances = 1 shl (kEndPosModelIndex div 2);
kNumLitPosStatesBitsEncodingMax = 4;
kNumLitContextBitsMax = 8;
kNumPosStatesBitsMax = 4;
kNumPosStatesMax = (1 shl kNumPosStatesBitsMax);
kNumPosStatesBitsEncodingMax = 4;
kNumPosStatesEncodingMax = (1 shl kNumPosStatesBitsEncodingMax);
kNumLowLenBits = 3;
kNumMidLenBits = 3;
kNumHighLenBits = 8;
kNumLowLenSymbols = 1 shl kNumLowLenBits;
kNumMidLenSymbols = 1 shl kNumMidLenBits;
kNumLenSymbols = kNumLowLenSymbols + kNumMidLenSymbols + (1 shl kNumHighLenBits);
kMatchMaxLen = kMatchMinLen + kNumLenSymbols - 1;
implementation
function StateInit:integer;
begin
result:=0;
end;
function StateUpdateChar(const index:integer):integer;
begin
if (index < 4) then
result:=0
else
if (index < 10) then
result:=index - 3
else
result:=index - 6;
end;
function StateUpdateMatch(const index:integer):integer;
begin
if index<7 then result:=7
else result:=10;
end;
function StateUpdateRep(const index:integer):integer;
begin
if index<7 then result:=8
else result:=11;
end;
function StateUpdateShortRep(const index:integer):integer;
begin
if index<7 then result:=9
else result:=11;
end;
function StateIsCharState(const index:integer):boolean;
begin
result:=index<7;
end;
function GetLenToPosState(len:integer):integer;
begin
len := len - kMatchMinLen;
if (len < kNumLenToPosStates) then
result:=len
else result:=(kNumLenToPosStates - 1);
end;
end.

31
Addons/ULZMACommon.pas Normal file
View File

@ -0,0 +1,31 @@
unit ULZMACommon;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL;
type TLZMAProgressAction=(LPAMax,LPAPos);
TLZMAProgress=procedure (const Action:TLZMAProgressAction;const Value:int64) of object;
function ReadByte(const stream:PStream):byte;
procedure WriteByte(const stream:PStream;b:byte);
const CodeProgressInterval = 50;//approx. number of times an OnProgress event will be fired during coding
implementation
function ReadByte(const stream:PStream):byte;
begin
stream.Read(result,1);
end;
procedure WriteByte(const stream:PStream;b:byte);
begin
stream.Write(b,1);
end;
end.

428
Addons/ULZMADecoder.pas Normal file
View File

@ -0,0 +1,428 @@
unit ULZMADecoder;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses ULZMABase,UBitTreeDecoder,ULZOutWindow,URangeDecoder,KOL,ULZMACommon;
type PLZMALenDecoder = ^TLZMALenDecoder;
PLZMALiteralDecoder = ^TLZMALiteralDecoder;
PLZMADecoder = ^TLZMADecoder;
TLZMADecoder = object(TObj)
private
FOnProgress:TLZMAProgress;
procedure DoProgress(const Action:TLZMAProgressAction;const Value:integer);
public
m_OutWindow:PLZOutWindow;
m_RangeDecoder:PRangeDecoder;
m_IsMatchDecoders: array [0..ULZMABase.kNumStates shl ULZMABase.kNumPosStatesBitsMax-1] of smallint;
m_IsRepDecoders: array [0..ULZMABase.kNumStates-1] of smallint;
m_IsRepG0Decoders: array [0..ULZMABase.kNumStates-1] of smallint;
m_IsRepG1Decoders: array [0..ULZMABase.kNumStates-1] of smallint;
m_IsRepG2Decoders: array [0..ULZMABase.kNumStates-1] of smallint;
m_IsRep0LongDecoders: array [0..ULZMABase.kNumStates shl ULZMABase.kNumPosStatesBitsMax-1] of smallint;
m_PosSlotDecoder: array [0..ULZMABase.kNumLenToPosStates-1] of PBitTreeDecoder;
m_PosDecoders: array [0..ULZMABase.kNumFullDistances - ULZMABase.kEndPosModelIndex-1] of smallint;
m_PosAlignDecoder:PBitTreeDecoder;
m_LenDecoder:PLZMALenDecoder;
m_RepLenDecoder:PLZMALenDecoder;
m_LiteralDecoder:PLZMALiteralDecoder;
m_DictionarySize:integer;
m_DictionarySizeCheck:integer;
m_PosStateMask:integer;
constructor Create;
destructor Destroy;virtual;
function SetDictionarySize(const dictionarySize:integer):boolean;
function SetLcLpPb(const lc,lp,pb:integer):boolean;
procedure _Init;
function Code(const inStream,outStream:PStream;outSize:int64):boolean;
function SetDecoderProperties(const properties:array of byte):boolean;
property OnProgress:TLZMAProgress read FOnProgress write FOnProgress;
end;
TLZMALenDecoder = object(TObj)
public
m_Choice:array [0..1] of smallint;
m_LowCoder: array[0..ULZMABase.kNumPosStatesMax-1] of PBitTreeDecoder;
m_MidCoder: array[0..ULZMABase.kNumPosStatesMax-1] of PBitTreeDecoder;
m_HighCoder: PBitTreeDecoder;
m_NumPosStates:integer;
constructor Create;
destructor Destroy;virtual;
procedure _Create(const numPosStates:integer);
procedure _Init;
function Decode(const rangeDecoder:PRangeDecoder;const posState:integer):integer;
end;
PLZMADecoder2 = ^TLZMADecoder2;
TLZMADecoder2 = object(TObj)
public
m_Decoders: array [0..$300-1] of smallint;
procedure _Init;
function DecodeNormal(const ArangeDecoder:PRangeDecoder):byte;
function DecodeWithMatchByte(const ArangeDecoder:PRangeDecoder;AmatchByte:byte):byte;
end;
TLZMALiteralDecoder = object(TObj)
public
m_Coders: array of PLZMADecoder2;
m_NumPrevBits:integer;
m_NumPosBits:integer;
m_PosMask:integer;
procedure _Create(const AnumPosBits, AnumPrevBits:integer);
procedure _Init;
function GetDecoder(const Apos:integer;const AprevByte:byte):PLZMADecoder2;
destructor Destroy;virtual;
end;
implementation
constructor TLZMALenDecoder.Create;
begin
New(m_HighCoder, Create(ULZMABase.kNumHighLenBits));
m_NumPosStates:=0;
end;
destructor TLZMALenDecoder.Destroy;
var i:integer;
begin
m_HighCoder.free;
for i:=low(m_LowCoder) to high(m_LowCoder) do begin
if m_LowCoder[i]<>nil then m_LowCoder[i].free;
if m_MidCoder[i]<>nil then m_MidCoder[i].free;
end;
inherited;
end;
procedure TLZMALenDecoder._Create(const numPosStates:integer);
begin
while m_NumPosStates < numPosStates do begin
New(m_LowCoder[m_NumPosStates], Create(ULZMABase.kNumLowLenBits));
New(m_MidCoder[m_NumPosStates], Create(ULZMABase.kNumMidLenBits));
inc(m_NumPosStates);
end;
end;
procedure TLZMALenDecoder._Init;
var posState:integer;
begin
URangeDecoder.InitBitModels(m_Choice);
for posState := 0 to m_NumPosStates-1 do begin
m_LowCoder[posState]._Init;
m_MidCoder[posState]._Init;
end;
m_HighCoder._Init;
end;
function TLZMALenDecoder.Decode(const rangeDecoder:PRangeDecoder;const posState:integer):integer;
var symbol:integer;
begin
if (rangeDecoder.DecodeBit(m_Choice, 0) = 0) then begin
result:=m_LowCoder[posState].Decode(rangeDecoder);
exit;
end;
symbol := ULZMABase.kNumLowLenSymbols;
if (rangeDecoder.DecodeBit(m_Choice, 1) = 0) then
symbol := symbol + m_MidCoder[posState].Decode(rangeDecoder)
else symbol := symbol + ULZMABase.kNumMidLenSymbols + m_HighCoder.Decode(rangeDecoder);
result:=symbol;
end;
procedure TLZMADecoder2._Init;
begin
URangeDecoder.InitBitModels(m_Decoders);
end;
function TLZMADecoder2.DecodeNormal(const ArangeDecoder:PRangeDecoder):byte;
var symbol:integer;
begin
symbol := 1;
repeat
symbol := (symbol shl 1) or ArangeDecoder.DecodeBit(m_Decoders, symbol);
until not (symbol < $100);
result:=symbol;
end;
function TLZMADecoder2.DecodeWithMatchByte(const ArangeDecoder:PRangeDecoder;AmatchByte:byte):byte;
var symbol:integer;
matchbit:integer;
bit:integer;
begin
symbol := 1;
repeat
matchBit := (AmatchByte shr 7) and 1;
AmatchByte := AmatchByte shl 1;
bit := ArangeDecoder.DecodeBit(m_Decoders, ((1 + matchBit) shl 8) + symbol);
symbol := (symbol shl 1) or bit;
if (matchBit <> bit) then begin
while (symbol < $100) do begin
symbol := (symbol shl 1) or ArangeDecoder.DecodeBit(m_Decoders, symbol);
end;
break;
end;
until not (symbol < $100);
result:=symbol;
end;
procedure TLZMALiteralDecoder._Create(const AnumPosBits, AnumPrevBits:integer);
var numStates,i:integer;
begin
if (length(m_Coders) <> 0) and (m_NumPrevBits = AnumPrevBits) and (m_NumPosBits = AnumPosBits) then
exit;
m_NumPosBits := AnumPosBits;
m_PosMask := (1 shl AnumPosBits) - 1;
m_NumPrevBits := AnumPrevBits;
numStates := 1 shl (m_NumPrevBits + m_NumPosBits);
setlength(m_Coders,numStates);
for i :=0 to numStates-1 do
New(m_Coders[i], Create);
end;
destructor TLZMALiteralDecoder.Destroy;
var i:integer;
begin
for i :=low(m_Coders) to high(m_Coders) do
if m_Coders[i]<>nil then m_Coders[i].Free;
inherited;
end;
procedure TLZMALiteralDecoder._Init;
var numStates,i:integer;
begin
numStates := 1 shl (m_NumPrevBits + m_NumPosBits);
for i := 0 to numStates -1 do
m_Coders[i]._Init;
end;
function TLZMALiteralDecoder.GetDecoder(const Apos:integer;const AprevByte:byte):PLZMADecoder2;
begin
result:=m_Coders[((Apos and m_PosMask) shl m_NumPrevBits) + ((AprevByte and $FF) shr (8 - m_NumPrevBits))];
end;
constructor TLZMADecoder.Create;
var i:integer;
begin
FOnProgress:=nil;
New(m_OutWindow, Create);
New(m_RangeDecoder, Create);
New(m_PosAlignDecoder, Create(ULZMABase.kNumAlignBits));
New(m_LenDecoder, Create);
New(m_RepLenDecoder, Create);
New(m_LiteralDecoder, Create);
m_DictionarySize:= -1;
m_DictionarySizeCheck:= -1;
for i := 0 to ULZMABase.kNumLenToPosStates -1 do
New(m_PosSlotDecoder[i], Create(ULZMABase.kNumPosSlotBits));
end;
destructor TLZMADecoder.Destroy;
var i:integer;
begin
m_OutWindow.Free;
m_RangeDecoder.Free;
m_PosAlignDecoder.Free;
m_LenDecoder.Free;
m_RepLenDecoder.Free;
m_LiteralDecoder.Free;
for i := 0 to ULZMABase.kNumLenToPosStates -1 do
m_PosSlotDecoder[i].Free;
end;
function TLZMADecoder.SetDictionarySize(const dictionarySize:integer):boolean;
begin
if dictionarySize < 0 then
result:=false
else begin
if m_DictionarySize <> dictionarySize then begin
m_DictionarySize := dictionarySize;
m_DictionarySizeCheck := max(m_DictionarySize, 1);
m_OutWindow._Create(max(m_DictionarySizeCheck, (1 shl 12)));
end;
result:=true;
end;
end;
function TLZMADecoder.SetLcLpPb(const lc,lp,pb:integer):boolean;
var numPosStates:integer;
begin
if (lc > ULZMABase.kNumLitContextBitsMax) or (lp > 4) or (pb > ULZMABase.kNumPosStatesBitsMax) then begin
result:=false;
exit;
end;
m_LiteralDecoder._Create(lp, lc);
numPosStates := 1 shl pb;
m_LenDecoder._Create(numPosStates);
m_RepLenDecoder._Create(numPosStates);
m_PosStateMask := numPosStates - 1;
result:=true;
end;
procedure TLZMADecoder._Init;
var i:integer;
begin
m_OutWindow._Init(false);
URangeDecoder.InitBitModels(m_IsMatchDecoders);
URangeDecoder.InitBitModels(m_IsRep0LongDecoders);
URangeDecoder.InitBitModels(m_IsRepDecoders);
URangeDecoder.InitBitModels(m_IsRepG0Decoders);
URangeDecoder.InitBitModels(m_IsRepG1Decoders);
URangeDecoder.InitBitModels(m_IsRepG2Decoders);
URangeDecoder.InitBitModels(m_PosDecoders);
m_LiteralDecoder._Init();
for i := 0 to ULZMABase.kNumLenToPosStates -1 do
m_PosSlotDecoder[i]._Init;
m_LenDecoder._Init;
m_RepLenDecoder._Init;
m_PosAlignDecoder._Init;
m_RangeDecoder._Init;
end;
function TLZMADecoder.Code(const inStream,outStream:PStream;outSize:int64):boolean;
var state,rep0,rep1,rep2,rep3:integer;
nowPos64:int64;
prevByte:byte;
posState:integer;
decoder2:PLZMADecoder2;
len,distance,posSlot,numDirectBits:integer;
lpos:int64;
progint:int64;
begin
DoProgress(LPAMax,outSize);
m_RangeDecoder.SetStream(inStream);
m_OutWindow.SetStream(outStream);
_Init;
state := ULZMABase.StateInit;
rep0 := 0; rep1 := 0; rep2 := 0; rep3 := 0;
nowPos64 := 0;
prevByte := 0;
progint:=outsize div CodeProgressInterval;
lpos:=progint;
while (outSize < 0) or (nowPos64 < outSize) do begin
if (nowPos64 >=lpos) then begin
DoProgress(LPAPos,nowPos64);
lpos:=lpos+progint;
end;
posState := nowPos64 and m_PosStateMask;
if (m_RangeDecoder.DecodeBit(m_IsMatchDecoders, (state shl ULZMABase.kNumPosStatesBitsMax) + posState) = 0) then begin
decoder2 := m_LiteralDecoder.GetDecoder(nowPos64, prevByte);
if not ULZMABase.StateIsCharState(state) then
prevByte := decoder2.DecodeWithMatchByte(m_RangeDecoder, m_OutWindow.GetByte(rep0))
else prevByte := decoder2.DecodeNormal(m_RangeDecoder);
m_OutWindow.PutByte(prevByte);
state := ULZMABase.StateUpdateChar(state);
inc(nowPos64);
end else begin
if (m_RangeDecoder.DecodeBit(m_IsRepDecoders, state) = 1) then begin
len := 0;
if (m_RangeDecoder.DecodeBit(m_IsRepG0Decoders, state) = 0) then begin
if (m_RangeDecoder.DecodeBit(m_IsRep0LongDecoders, (state shl ULZMABase.kNumPosStatesBitsMax) + posState) = 0) then begin
state := ULZMABase.StateUpdateShortRep(state);
len := 1;
end;
end else begin
if m_RangeDecoder.DecodeBit(m_IsRepG1Decoders, state) = 0 then
distance := rep1
else begin
if (m_RangeDecoder.DecodeBit(m_IsRepG2Decoders, state) = 0) then
distance := rep2
else begin
distance := rep3;
rep3 := rep2;
end;
rep2 := rep1;
end;
rep1 := rep0;
rep0 := distance;
end;
if len = 0 then begin
len := m_RepLenDecoder.Decode(m_RangeDecoder, posState) + ULZMABase.kMatchMinLen;
state := ULZMABase.StateUpdateRep(state);
end;
end else begin
rep3 := rep2;
rep2 := rep1;
rep1 := rep0;
len := ULZMABase.kMatchMinLen + m_LenDecoder.Decode(m_RangeDecoder, posState);
state := ULZMABase.StateUpdateMatch(state);
posSlot := m_PosSlotDecoder[ULZMABase.GetLenToPosState(len)].Decode(m_RangeDecoder);
if posSlot >= ULZMABase.kStartPosModelIndex then begin
numDirectBits := (posSlot shr 1) - 1;
rep0 := ((2 or (posSlot and 1)) shl numDirectBits);
if posSlot < ULZMABase.kEndPosModelIndex then
rep0 := rep0 + UBitTreeDecoder.ReverseDecode(m_PosDecoders,
rep0 - posSlot - 1, m_RangeDecoder, numDirectBits)
else begin
rep0 := rep0 + (m_RangeDecoder.DecodeDirectBits(
numDirectBits - ULZMABase.kNumAlignBits) shl ULZMABase.kNumAlignBits);
rep0 := rep0 + m_PosAlignDecoder.ReverseDecode(m_RangeDecoder);
if rep0 < 0 then begin
if rep0 = -1 then
break;
result:=false;
exit;
end;
end;
end else rep0 := posSlot;
end;
if (rep0 >= nowPos64) or (rep0 >= m_DictionarySizeCheck) then begin
m_OutWindow.Flush();
result:=false;
exit;
end;
m_OutWindow.CopyBlock(rep0, len);
nowPos64 := nowPos64 + len;
prevByte := m_OutWindow.GetByte(0);
end;
end;
m_OutWindow.Flush();
m_OutWindow.ReleaseStream();
m_RangeDecoder.ReleaseStream();
DoProgress(LPAPos,nowPos64);
result:=true;
end;
function TLZMADecoder.SetDecoderProperties(const properties:array of byte):boolean;
var val,lc,remainder,lp,pb,dictionarysize,i:integer;
begin
if length(properties) < 5 then begin
result:=false;
exit;
end;
val := properties[0] and $FF;
lc := val mod 9;
remainder := val div 9;
lp := remainder mod 5;
pb := remainder div 5;
dictionarySize := 0;
for i := 0 to 3 do
dictionarySize := dictionarysize + ((properties[1 + i]) and $FF) shl (i * 8);
if (not SetLcLpPb(lc, lp, pb)) then begin
result:=false;
exit;
end;
result:=SetDictionarySize(dictionarySize);
end;
procedure TLZMADecoder.DoProgress(const Action:TLZMAProgressAction;const Value:integer);
begin
if assigned(fonprogress) then
fonprogress(action,value);
end;
end.

1518
Addons/ULZMAEncoder.pas Normal file
View File

File diff suppressed because it is too large Load Diff

107
Addons/ULZOutWindow.pas Normal file
View File

@ -0,0 +1,107 @@
unit ULZOutWindow;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL;
type PLZOutWindow = ^TLZOutWindow;
TLZOutWindow=object(TObj)
public
buffer: array of byte;
pos:integer;
windowSize:integer;
streamPos:integer;
stream:PStream;
procedure _Create(const AwindowSize:integer);
procedure SetStream(const Astream:PStream);
procedure ReleaseStream;
procedure _Init(const Asolid:boolean);
procedure Flush;
procedure CopyBlock(const Adistance:integer; Alen:integer);
procedure PutByte(const Ab:byte);
function GetByte(const Adistance:integer):byte;
end;
implementation
procedure TLZOutWindow._Create(const AwindowSize:integer);
begin
if (length(buffer)=0) or (self.windowSize <> AwindowSize) then
setlength(buffer,AwindowSize);
self.windowSize := AwindowSize;
pos := 0;
streamPos := 0;
end;
procedure TLZOutWindow.SetStream(const Astream:PStream);
begin
ReleaseStream;
self.stream:=Astream;
end;
procedure TLZOutWindow.ReleaseStream;
begin
flush;
self.stream:=nil;
end;
procedure TLZOutWindow._Init(const Asolid:boolean);
begin
if not Asolid then begin
streamPos:=0;
Pos:=0;
end;
end;
procedure TLZOutWindow.Flush;
var size:integer;
begin
size := pos - streamPos;
if (size = 0) then
exit;
stream.write(buffer[streamPos], size);
if (pos >= windowSize) then
pos := 0;
streamPos := pos;
end;
procedure TLZOutWindow.CopyBlock(const Adistance:integer;Alen:integer);
var _pos:integer;
begin
_pos := self.pos - Adistance - 1;
if _pos < 0 then
_pos := _pos + windowSize;
while Alen<>0 do begin
if _pos >= windowSize then
_pos := 0;
buffer[self.pos] := buffer[_pos];
inc(self.pos);
inc(_pos);
if self.pos >= windowSize then
Flush();
dec(Alen);
end;
end;
procedure TLZOutWindow.PutByte(const Ab:byte);
begin
buffer[pos] := Ab;
inc(pos);
if (pos >= windowSize) then
Flush();
end;
function TLZOutWindow.GetByte(const Adistance:integer):byte;
var _pos:integer;
begin
_pos := self.pos - Adistance - 1;
if (_pos < 0) then
_pos := _pos + windowSize;
result:=buffer[_pos];
end;
end.

100
Addons/URangeDecoder.pas Normal file
View File

@ -0,0 +1,100 @@
unit URangeDecoder;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL,ULZMACommon;
type PRangeDecoder = ^TRangeDecoder;
TRangeDecoder=object(TObj)
public
Range,Code:integer;
Stream:PStream;
procedure SetStream(const AStream:PStream);
procedure ReleaseStream;
procedure _Init;
function DecodeDirectBits(const AnumTotalBits:integer):integer;
function DecodeBit(var Aprobs: array of smallint;const Aindex:integer):integer;
end;
procedure InitBitModels(var Aprobs: array of smallint);
implementation
const kTopMask = not ((1 shl 24) - 1);
kNumBitModelTotalBits = 11;
kBitModelTotal = (1 shl kNumBitModelTotalBits);
kNumMoveBits = 5;
procedure TRangeDecoder.SetStream(const AStream:PStream);
begin
self.Stream:=AStream;
end;
procedure TRangeDecoder.ReleaseStream;
begin
stream:=nil;
end;
procedure TRangeDecoder._Init;
var i:integer;
begin
code:=0;
Range:=-1;
for i:=0 to 4 do begin
code:=(code shl 8) or byte(ReadByte(stream));
end;
end;
function TRangeDecoder.DecodeDirectBits(const AnumTotalBits:integer):integer;
var i,t:integer;
begin
result:=0;
for i := AnumTotalBits downto 1 do begin
range:=range shr 1;
t := ((Code - Range) shr 31);
Code := Code - Range and (t - 1);
result := (result shl 1) or (1 - t);
if ((Range and kTopMask) = 0) then begin
Code := (Code shl 8) or ReadByte(stream);
Range := Range shl 8;
end;
end;
end;
function TRangeDecoder.DecodeBit(var Aprobs: array of smallint;const Aindex:integer):integer;
var prob,newbound:integer;
begin
prob:=Aprobs[Aindex];
newbound:=(Range shr kNumBitModelTotalBits) * prob;
if (integer((integer(Code) xor integer($80000000))) < integer((integer(newBound) xor integer($80000000)))) then begin
Range := newBound;
Aprobs[Aindex] := (prob + ((kBitModelTotal - prob) shr kNumMoveBits));
if ((Range and kTopMask) = 0) then begin
Code := (Code shl 8) or ReadByte(stream);
Range := Range shl 8;
end;
result:=0;
end else begin
Range := Range - newBound;
Code := Code - newBound;
Aprobs[Aindex] := (prob - ((prob) shr kNumMoveBits));
if ((Range and kTopMask) = 0) then begin
Code := (Code shl 8) or ReadByte(stream);
Range := Range shl 8;
end;
result:=1;
end;
end;
procedure InitBitModels(var Aprobs: array of smallint);
var i:integer;
begin
for i:=0 to length(Aprobs)-1 do
Aprobs[i] := kBitModelTotal shr 1;
end;
end.

175
Addons/URangeEncoder.pas Normal file
View File

@ -0,0 +1,175 @@
unit URangeEncoder;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses KOL,ULZMACommon;
const kNumBitPriceShiftBits = 6;
kTopMask = not ((1 shl 24) - 1);
kNumBitModelTotalBits = 11;
kBitModelTotal = (1 shl kNumBitModelTotalBits);
kNumMoveBits = 5;
kNumMoveReducingBits = 2;
type PRangeEncoder = ^TRangeEncoder;
TRangeEncoder=object(TObj)
private
ProbPrices: array [0..kBitModelTotal shr kNumMoveReducingBits-1] of integer;
public
Stream:PStream;
Low,Position:int64;
Range,cacheSize,cache:integer;
procedure SetStream(const Astream:PStream);
procedure ReleaseStream;
procedure _Init;
procedure FlushData;
procedure FlushStream;
procedure ShiftLow;
procedure EncodeDirectBits(const v,AnumTotalBits:integer);
function GetProcessedSizeAdd:int64;
procedure Encode(var Aprobs: array of smallint;const Aindex,Asymbol:integer);
constructor Create;
function GetPrice(const AProb,Asymbol:integer):integer;
function GetPrice0(const AProb:integer):integer;
function GetPrice1(const AProb:integer):integer;
end;
var RangeEncoder:PRangeEncoder;
procedure InitBitModels(var probs:array of smallint);
implementation
procedure TRangeEncoder.SetStream(const Astream:PStream);
begin
self.Stream:=AStream;
end;
procedure TRangeEncoder.ReleaseStream;
begin
stream:=nil;
end;
procedure TRangeEncoder._Init;
begin
position := 0;
Low := 0;
Range := -1;
cacheSize := 1;
cache := 0;
end;
procedure TRangeEncoder.FlushData;
var i:integer;
begin
for i:=0 to 4 do
ShiftLow();
end;
procedure TRangeEncoder.FlushStream;
begin
//stream.flush;
end;
procedure TRangeEncoder.ShiftLow;
var LowHi:integer;
temp:integer;
begin
LowHi := (Low shr 32);
if (LowHi <> 0) or (Low < int64($FF000000)) then begin
position := position + cacheSize;
temp := cache;
repeat
WriteByte(stream,temp + LowHi);
temp := $FF;
dec(cacheSize);
until(cacheSize = 0);
cache := (Low shr 24);
end;
inc(cacheSize);
Low := (Low and integer($FFFFFF)) shl 8;
end;
procedure TRangeEncoder.EncodeDirectBits(const v,AnumTotalBits:integer);
var i:integer;
begin
for i := AnumTotalBits - 1 downto 0 do begin
Range := Range shr 1;
if (((v shr i) and 1) = 1) then
Low := Low + Range;
if ((Range and kTopMask) = 0) then begin
Range := range shl 8;
ShiftLow;
end;
end;
end;
function TRangeEncoder.GetProcessedSizeAdd:int64;
begin
result:=cacheSize + position + 4;
end;
procedure InitBitModels(var probs:array of smallint);
var i:integer;
begin
for i := 0 to length(probs) -1 do
probs[i] := kBitModelTotal shr 1;
end;
procedure TRangeEncoder.Encode(var Aprobs: array of smallint;const Aindex,Asymbol:integer);
var prob,newbound:integer;
begin
prob := Aprobs[Aindex];
newBound := (Range shr kNumBitModelTotalBits) * prob;
if (Asymbol = 0) then begin
Range := newBound;
Aprobs[Aindex] := (prob + ((kBitModelTotal - prob) shr kNumMoveBits));
end else begin
Low := Low + (newBound and int64($FFFFFFFF));
Range := Range - newBound;
Aprobs[Aindex] := (prob - ((prob) shr kNumMoveBits));
end;
if ((Range and kTopMask) = 0) then begin
Range := Range shl 8;
ShiftLow;
end;
end;
constructor TRangeEncoder.Create;
var kNumBits:integer;
i,j,start,_end:integer;
begin
kNumBits := (kNumBitModelTotalBits - kNumMoveReducingBits);
for i := kNumBits - 1 downto 0 do begin
start := 1 shl (kNumBits - i - 1);
_end := 1 shl (kNumBits - i);
for j := start to _end -1 do
ProbPrices[j] := (i shl kNumBitPriceShiftBits) +
(((_end - j) shl kNumBitPriceShiftBits) shr (kNumBits - i - 1));
end;
end;
function TRangeEncoder.GetPrice(const AProb,Asymbol:integer):integer;
begin
result:=ProbPrices[(((AProb - Asymbol) xor ((-Asymbol))) and (kBitModelTotal - 1)) shr kNumMoveReducingBits];
end;
function TRangeEncoder.GetPrice0(const AProb:integer):integer;
begin
result:= ProbPrices[AProb shr kNumMoveReducingBits];
end;
function TRangeEncoder.GetPrice1(const AProb:integer):integer;
begin
result:= ProbPrices[(kBitModelTotal - AProb) shr kNumMoveReducingBits];
end;
initialization
New(RangeEncoder, Create);
finalization
RangeEncoder.Free;
end.

1017
Addons/bis.pas Normal file
View File

File diff suppressed because it is too large Load Diff

297
Addons/mckWebBrowser.pas Normal file
View File

@ -0,0 +1,297 @@
//////////////////////////////////////////////////////////////////////////////////
// //
// //
// TKOLWebBrowser v1.0 //
// //
// Author: Dimaxx (dimaxx@atnet.ru) //
// //
// //
//////////////////////////////////////////////////////////////////////////////////
unit mckWebBrowser;
interface
uses Classes, Kol, Mirror;
type
TWebBrowserStatusTextChange = procedure(Sender: TObject; const Text: WideString) of object;
TWebBrowserProgressChange = procedure(Sender: TObject; Progress: Integer; ProgressMax: Integer) of object;
TWebBrowserCommandStateChange = procedure(Sender: TObject; Command: Integer; Enable: WordBool) of object;
TWebBrowserTitleChange = procedure(Sender: TObject; const Text: WideString) of object;
TWebBrowserPropertyChange = procedure(Sender: TObject; const szProperty: WideString) of object;
TWebBrowserBeforeNavigate2 = procedure(Sender: TObject; const pDisp: IDispatch;
var URL: OleVariant;
var Flags: OleVariant;
var TargetFrameName: OleVariant;
var PostData: OleVariant;
var Headers: OleVariant;
var Cancel: WordBool) of object;
TWebBrowserNewWindow2 = procedure(Sender: TObject; var ppDisp: IDispatch; var Cancel: WordBool) of object;
TWebBrowserNavigateComplete2 = procedure(Sender: TObject; const pDisp: IDispatch;
var URL: OleVariant) of object;
TWebBrowserDocumentComplete = procedure(Sender: TObject; const pDisp: IDispatch;
var URL: OleVariant) of object;
TWebBrowserOnVisible = procedure(Sender: TObject; Visible: WordBool) of object;
TWebBrowserOnToolBar = procedure(Sender: TObject; ToolBar: WordBool) of object;
TWebBrowserOnMenuBar = procedure(Sender: TObject; MenuBar: WordBool) of object;
TWebBrowserOnStatusBar = procedure(Sender: TObject; StatusBar: WordBool) of object;
TWebBrowserOnFullScreen = procedure(Sender: TObject; FullScreen: WordBool) of object;
TWebBrowserOnTheaterMode = procedure(Sender: TObject; TheaterMode: WordBool) of object;
TKOLWebBrowser = class(TKOLCustomControl)
private
FOnStatusTextChange: TWebBrowserStatusTextChange;
FOnProgressChange: TWebBrowserProgressChange;
FOnCommandStateChange: TWebBrowserCommandStateChange;
FOnTitleChange: TWebBrowserTitleChange;
FOnPropertyChange: TWebBrowserPropertyChange;
FOnBeforeNavigate2: TWebBrowserBeforeNavigate2;
FOnNewWindow2: TWebBrowserNewWindow2;
FOnNavigateComplete2: TWebBrowserNavigateComplete2;
FOnDocumentComplete: TWebBrowserDocumentComplete;
FOnVisible: TWebBrowserOnVisible;
FOnToolBar: TWebBrowserOnToolBar;
FOnMenuBar: TWebBrowserOnMenuBar;
FOnStatusBar: TWebBrowserOnStatusBar;
FOnFullScreen: TWebBrowserOnFullScreen;
FOnTheaterMode: TWebBrowserOnTheaterMode;
FOffline: boolean;
FSilent: boolean;
FRegisterAsBrowser: boolean;
FRegisterAsDropTarget: boolean;
protected
function AdditionalUnits: string; override;
procedure SetupFirst(SL: TStringList; const AName,AParent,Prefix: string); override;
procedure AssignEvents(SL: TStringList; const AName: string); override;
procedure SetOnStatusTextChange(E: TWebBrowserStatusTextChange);
procedure SetOnProgressChange(E: TWebBrowserProgressChange);
procedure SetOnCommandStateChange(E: TWebBrowserCommandStateChange);
procedure SetOnTitleChange(E: TWebBrowserTitleChange);
procedure SetOnPropertyChange(E: TWebBrowserPropertyChange);
procedure SetOnBeforeNavigate2(E: TWebBrowserBeforeNavigate2);
procedure SetOnNewWindow2(E: TWebBrowserNewWindow2);
procedure SetOnNavigateComplete2(E: TWebBrowserNavigateComplete2);
procedure SetOnDocumentComplete(E: TWebBrowserDocumentComplete);
procedure SetOnVisible(E: TWebBrowserOnVisible);
procedure SetOnToolBar(E: TWebBrowserOnToolBar);
procedure SetOnMenuBar(E: TWebBrowserOnMenuBar);
procedure SetOnStatusBar(E: TWebBrowserOnStatusBar);
procedure SetOnFullScreen(E: TWebBrowserOnFullScreen);
procedure SetOnTheaterMode(E: TWebBrowserOnTheaterMode);
procedure SetOffline(V: boolean);
procedure SetSilent(V: boolean);
procedure SetRegisterAsBrowser(V: boolean);
procedure SetRegisterAsDropTarget(V: boolean);
public
constructor Create(AOwner: TComponent); override;
published
property Align;
property Visible;
property TabStop;
property TabOrder;
property OnEnter;
property OnExit;
property Offline: boolean read FOffline write SetOffline default True;
property Silent: boolean read FSilent write SetSilent default False;
property RegisterAsBrowser: boolean read FRegisterAsBrowser write SetRegisterAsBrowser default True;
property RegisterAsDropTarget: boolean read FRegisterAsDropTarget write SetRegisterAsDropTarget default False;
property OnStatusTextChange: TWebBrowserStatusTextChange read FOnStatusTextChange write SetOnStatusTextChange;
property OnProgressChange: TWebBrowserProgressChange read FOnProgressChange write SetOnProgressChange;
property OnCommandStateChange: TWebBrowserCommandStateChange read FOnCommandStateChange write SetOnCommandStateChange;
property OnTitleChange: TWebBrowserTitleChange read FOnTitleChange write SetOnTitleChange;
property OnPropertyChange: TWebBrowserPropertyChange read FOnPropertyChange write SetOnPropertyChange;
property OnBeforeNavigate2: TWebBrowserBeforeNavigate2 read FOnBeforeNavigate2 write SetOnBeforeNavigate2;
property OnNewWindow2: TWebBrowserNewWindow2 read FOnNewWindow2 write SetOnNewWindow2;
property OnNavigateComplete2: TWebBrowserNavigateComplete2 read FOnNavigateComplete2 write SetOnNavigateComplete2;
property OnDocumentComplete: TWebBrowserDocumentComplete read FOnDocumentComplete write SetOnDocumentComplete;
property OnVisible: TWebBrowserOnVisible read FOnVisible write SetOnVisible;
property OnToolBar: TWebBrowserOnToolBar read FOnToolBar write SetOnToolBar;
property OnMenuBar: TWebBrowserOnMenuBar read FOnMenuBar write SetOnMenuBar;
property OnStatusBar: TWebBrowserOnStatusBar read FOnStatusBar write SetOnStatusBar;
property OnFullScreen: TWebBrowserOnFullScreen read FOnFullScreen write SetOnFullScreen;
property OnTheaterMode: TWebBrowserOnTheaterMode read FOnTheaterMode write SetOnTheaterMode;
end;
procedure Register;
{$R *.dcr}
implementation
const
AlignValues: array[TKOLAlign] of string = ('caNone','caLeft','caTop','caRight','caBottom','caClient');
Bool2Str: array [Boolean] of string = ('False','True');
procedure Register;
begin
RegisterComponents('KOLAddons',[TKOLWebBrowser]);
end;
constructor TKOLWebBrowser.Create;
begin
inherited;
FOffline:=True;
FSilent:=True;
FRegisterAsBrowser:=True;
FRegisterAsDropTarget:=False;
end;
function TKOLWebBrowser.AdditionalUnits;
begin
Result:=', KOLWebBrowser';
end;
procedure TKOLWebBrowser.SetupFirst;
begin
SL.Add(Prefix+AName+' := NewKOLWebBrowser(Result.Form); ');
if Align<>caNone then
begin
SL.Add(Prefix+AName+'.SetAlign( '+AlignValues[Align]+'); ');
end
else
begin
SL.Add(Prefix+AName+'.SetPosition(' +int2str(Left)+', '+int2str(Top)+' );');
SL.Add(Prefix+AName+'.SetSize(' +int2str(Width)+', '+int2str(Height)+' );');
end;
SL.Add(Prefix+AName+'.Offline := '+Bool2Str[FOffline]+';');
SL.Add(Prefix+AName+'.Silent := '+Bool2Str[FSilent]+';');
SL.Add(Prefix+AName+'.RegisterAsBrowser := '+Bool2Str[FRegisterAsBrowser]+';');
SL.Add(Prefix+AName+'.RegisterAsDropTarget := '+Bool2Str[FRegisterAsDropTarget]+';');
AssignEvents(SL,AName);
end;
procedure TKOLWebBrowser.AssignEvents;
begin
inherited;
DoAssignEvents(SL,AName,
['OnStatusTextChange','OnProgressChange','OnCommandStateChange',
'OnTitleChange','OnPropertyChange','OnBeforeNavigate2','OnNewWindow2',
'OnNavigateComplete2','OnDocumentComplete','OnVisible','OnToolBar',
'OnMenuBar','OnStatusBar','OnFullScreen','OnTheaterMode'],
[@OnStatusTextChange,@OnProgressChange,@OnCommandStateChange,
@OnTitleChange,@OnPropertyChange,@OnBeforeNavigate2,@OnNewWindow2,
@OnNavigateComplete2,@OnDocumentComplete,@OnVisible,@OnToolBar,
@OnMenuBar,@OnStatusBar,@OnFullScreen,@OnTheaterMode]);
end;
procedure TKOLWebBrowser.SetOffline;
begin
FOffline:=V;
Change;
end;
procedure TKOLWebBrowser.SetSilent;
begin
FSilent:=V;
Change;
end;
procedure TKOLWebBrowser.SetRegisterAsBrowser;
begin
FRegisterAsBrowser:=V;
Change;
end;
procedure TKOLWebBrowser.SetRegisterAsDropTarget;
begin
FRegisterAsDropTarget:=V;
Change;
end;
procedure TKOLWebBrowser.SetOnStatusTextChange;
begin
FOnStatusTextChange:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnProgressChange;
begin
FOnProgressChange:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnCommandStateChange;
begin
FOnCommandStateChange:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnTitleChange;
begin
FOnTitleChange:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnPropertyChange;
begin
FOnPropertyChange:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnBeforeNavigate2;
begin
FOnBeforeNavigate2:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnNewWindow2;
begin
FOnNewWindow2:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnNavigateComplete2;
begin
FOnNavigateComplete2:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnDocumentComplete;
begin
FOnDocumentComplete:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnVisible;
begin
FOnVisible:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnToolBar;
begin
FOnToolBar:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnMenuBar;
begin
FOnMenuBar:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnStatusBar;
begin
FOnStatusBar:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnFullScreen;
begin
FOnFullScreen:=E;
Change;
end;
procedure TKOLWebBrowser.SetOnTheaterMode;
begin
FOnTheaterMode:=E;
Change;
end;
end.