addons update
git-svn-id: https://svn.code.sf.net/p/kolmck/code@67 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
This commit is contained in:
dkolmck
2623
Addons/ActiveKOL.pas
Normal file
2623
Addons/ActiveKOL.pas
Normal file
File diff suppressed because it is too large
Load Diff
1357
Addons/DHTMLEDLib_TLBKOL.pas
Normal file
1357
Addons/DHTMLEDLib_TLBKOL.pas
Normal file
File diff suppressed because it is too large
Load Diff
267
Addons/GIF_ASM.inc
Normal file
267
Addons/GIF_ASM.inc
Normal 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
315
Addons/GIF_MMX.inc
Normal 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
2352
Addons/KOLComObj.pas
Normal file
File diff suppressed because it is too large
Load Diff
21
Addons/KOLDHTML.pas
Normal file
21
Addons/KOLDHTML.pas
Normal 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
583
Addons/KOLOleRE.pas
Normal 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
5037
Addons/KOLPng.pas
Normal file
File diff suppressed because it is too large
Load Diff
1190
Addons/KOLSHDocVw.pas
Normal file
1190
Addons/KOLSHDocVw.pas
Normal file
File diff suppressed because it is too large
Load Diff
1060
Addons/KOLTGA.pas
Normal file
1060
Addons/KOLTGA.pas
Normal file
File diff suppressed because it is too large
Load Diff
31
Addons/KOLWebBrowser.pas
Normal file
31
Addons/KOLWebBrowser.pas
Normal 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
576
Addons/KolZLib.pas
Normal 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
1926
Addons/KolZLibBzip.pas
Normal file
File diff suppressed because it is too large
Load Diff
27016
Addons/MSHTML_TLBKOL.pas
Normal file
27016
Addons/MSHTML_TLBKOL.pas
Normal file
File diff suppressed because it is too large
Load Diff
693
Addons/SevenZip.pas
Normal file
693
Addons/SevenZip.pas
Normal 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
74
Addons/UBitTreeDecoder.pas
Normal 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
116
Addons/UBitTreeEncoder.pas
Normal 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
174
Addons/UBufferedFS.pas
Normal 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
80
Addons/UCRC.pas
Normal 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
420
Addons/ULZBinTree.pas
Normal 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
170
Addons/ULZInWindow.pas
Normal 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
104
Addons/ULZMABase.pas
Normal 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
31
Addons/ULZMACommon.pas
Normal 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
428
Addons/ULZMADecoder.pas
Normal 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
1518
Addons/ULZMAEncoder.pas
Normal file
File diff suppressed because it is too large
Load Diff
107
Addons/ULZOutWindow.pas
Normal file
107
Addons/ULZOutWindow.pas
Normal 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
100
Addons/URangeDecoder.pas
Normal 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
175
Addons/URangeEncoder.pas
Normal 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
1017
Addons/bis.pas
Normal file
File diff suppressed because it is too large
Load Diff
297
Addons/mckWebBrowser.pas
Normal file
297
Addons/mckWebBrowser.pas
Normal 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.
|
||||
|
||||
Reference in New Issue
Block a user