delphi并行压缩
2024-08-28 07:25:27
real case test MM parallel 4x scalable (i7 6700)
(on the newer processors will be linear)
I did a small test with real code scenario,
look at parallel zlib with my patch, zcompress loop 1000 of a 1100KB text file:
uses System.Zlib;
threadvar
INS: TMemoryStream;
OUTS: pointer;
SizeIn: integer;
SizeOUT: integer;
procedure TForm.CompressClick(Sender: TObject);
var
Count: integer;
begin
Count := GetTickCount;
TParallel.For(1,1000,procedure(I:integer)
begin
INS := TMemoryStream.Create;
INS.LoadFromFile('c:\teststream.txt');
SizeIn := INS.Size;
GetMem(OUTS, SizeIn);
SizeOUT := SizeIn;
ZCompress(INS.Memory, SizeIn, OUTS, SizeOUT, zcFastest);
INS.Free;
FreeMem(OUTS);
end);
ShowMessage(IntToStr(GetTickCount - Count));
end;
- fastmm4 900-1000msec
- brainMM 563msec
- msheap 532msec
- my patch Intel IPP + TTB 281 msec
procedure TForm1.Button1Click(Sender: TObject);
var
task: ITask;
begin
Task := TTask.Create(
procedure()
var
context: TRTTIContext;
methods: TArray<TRTTIMethod>;
method: TRTTIMethod;
arg: TValue;
begin
methods := context.GetType(Self.ClassType).GetMethods;
for method in methods do
begin
if method.Name = 'Test' then
begin
arg := 'Hello World!';
method.Invoke(Self, [arg]);
Exit;
end;
end;
end);
Task.Start;
end;
procedure TForm1.Test(Text: string);
begin
TThread.Synchronize(nil,
procedure
begin
Self.Caption := Text;
end);
end;
program Project1;
{$APPTYPE CONSOLE}
{$MAXSTACKSIZE $10000000} // 256Mb
procedure surprise;
var a: array[1 .. 1024 * 1024 * 128] of byte; // 128Mb
begin
writeln(sizeOf(a), ' bytes on the stack');
end;
begin
surprise;
readln;
end.
p := VirtualAlloc(nil, 8 * 200000000, MEM_COMMIT, PAGE_READWRITE);
procedure T();
var p2,p:PData;
i :longint;
begin
p:=VirtualAlloc(nil,8*100000000,MEM_COMMIT ,PAGE_READWRITE); for i:=0 to 100000000 do p^[i]:=1;
writeln(p^[200002]);
readln(); VirtualFree(p,0,MEM_RELEASE); end;
p := VirtualAlloc(nil, SizeOf(Real) * 200000000, MEM_COMMIT, PAGE_READWRITE); |
procedure T();
var p2,p:PData;
i :longint;
begin
p:=VirtualAlloc(nil,8*100000000,MEM_COMMIT ,PAGE_READWRITE);
writeln(0);
p2:=VirtualAlloc(nil,8*100000000,MEM_COMMIT ,PAGE_READWRITE);
writeln(1);
for i:=0 to 100000000 do p^[i]:=1;
writeln(2);
for i:=0 to 100000000 do p2^[i]:=1;
writeln(p^[200002]);
readln(); VirtualFree(p,0,MEM_RELEASE);
VirtualFree(p2,0,MEM_RELEASE); end;
TLargeArray<T> = record |
procedure T2();
var p: array of real;
i :longint;
begin
SetLength(p,100000000);
for i:=0 to 100000000-1 do p[i]:=1;
writeln(p[200002]);
readln();
end;
procedure T2();
var p: array of real;
i :longint;
begin
SetLength(p,200000000);
for i:=0 to 200000000-1 do p[i]:=1;
writeln(p[200002]);
readln();
end;
try
start:=GetTickCount;
with ibquery2 do
for i := 1 to 3 do
for j := 1 to 2 do
for k := 1 to 163 do
for l := 1 to 60 do
for m := 1 to 10 do
begin
sql.text:= // 'execute procedure NEW_FLUX ('+inttostr(i)+','+inttostr(j)+','+inttostr(k)+','+inttostr(l)+','+inttostr(m)+','''+inttostr(1)+''',''' + inttostr(1)+ ''')';
'insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ") values ('+
inttostr(i)+','+inttostr(j)+','+inttostr(k)+','+inttostr(l)+','+inttostr(m)+','''+inttostr(1)+''',''' + inttostr(1)+ ''')';
transaction.starttransaction;
execSQL;
transaction.commit;
transaction.Active:=false;
end;
IBquery1.Close;
ibquery1.Open;
finish:=GetTickCount;
form2.TimeLabel.Caption:=('Время заполнения: '+floattostr((finish-start)/1000)+' секунд');
except
if ibquery1.active then
ibquery2.transaction.rollback;
showmessage ('Ошибка');
end;
try
start:=GetTickCount;
with ibquery2 do
transaction.starttransaction;
sql.text:=
'insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ") values ('
+':Pi, :Pj, :Pk, :Pl, :Pm, 1, 1,)';
Prepare;
for i := 1 to 3 do
for j := 1 to 2 do
for k := 1 to 163 do
for l := 1 to 60 do
for m := 1 to 10 do
begin
sql.ParamByName('Pi').AsInteger := i;
sql.ParamByName('Pj').AsInteger := j;
...
execSQL;
end;
transaction.commit;
transaction.Active:=false; IBquery1.Close;
ibquery1.Open;
finish:=GetTickCount;
form2.TimeLabel.Caption:=('Время заполнения: '+floattostr((finish-start)/1000)+' секунд');
except
if ibquery1.active then
ibquery2.transaction.rollback;
showmessage ('Ошибка');
end;
try
start:=GetTickCount;
ibquery2.transaction.starttransaction;
with ibquery2 do
begin
sql.text:=
'insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ") values (:Pi, :Pj, :Pk, :Pl, :Pm, 1, 1)';
Prepare; for i := 1 to 3 do
for j := 1 to 2 do
for k := 1 to 163 do
for l := 1 to 60 do
for m := 1 to 10 do
begin
ParamByName('Pi').AsInteger := i;
ParamByName('Pj').AsInteger := j;
ParamByName('Pk').AsInteger := k;
ParamByName('Pl').AsInteger := l;
ParamByName('Pm').AsInteger := m;
execSQL;
end;
end; // ibquery2.
ibquery2.transaction.commit;
ibquery2.transaction.Active:=false; IBquery1.Close;
ibquery1.Open;
finish:=GetTickCount;
form2.TimeLabel.Caption:=('Время заполнения: '+floattostr((finish-start)/1000)+' секунд'); except
if ibquery1.active then
ibquery2.transaction.rollback;
showmessage ('Ошибка');
end;
try
start:=GetTickCount;
ibquery2.transaction.starttransaction; // fPn:= ibquery2.ParamByName('Pn');
with ibquery2 do
begin
sql.text:=
// 'insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ") values (:Pi, :Pj, :Pk, :Pl, :Pm, 1, 1)';
'execute block ('+
'PI1 int = :PI1, '+
'PJ1 int = :PJ1, '+
'PK1 int = :PK1, '+
'Pl1 int = :Pl1, '+
'Pm1 int = :Pm1, '+ 'PI2 int = :PI2, '+
'PJ2 int = :PJ2, '+
'PK2 int = :PK2, '+
'Pl2 int = :Pl2, '+
'Pm2 int = :Pm2, '+ 'PI3 int = :PI3, '+
'PJ3 int = :PJ3, '+
'PK3 int = :PK3, '+
'Pl3 int = :Pl3, '+
'Pm3 int = :Pm3) '+ ' as '+
' begin '+
' insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ")'+
' values (:PI1, :PJ1, :PK1, :Pl1, :Pm1, 1, 1); '+
' insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ")'+
' values (:PI2, :PJ2, :PK2, :Pl2, :Pm2, 1, 1); '+
' insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ")'+
' values (:PI3, :PJ3, :PK3, :Pl3, :Pm3, 1, 1); '+
' end '; Prepare; fPi1:= ibquery2.ParamByName('Pi1');
fPj1:= ibquery2.ParamByName('Pj1');
fPk1:= ibquery2.ParamByName('Pk1');
fPl1:= ibquery2.ParamByName('Pl1');
fPm1:= ibquery2.ParamByName('Pm1'); fPi2:= ibquery2.ParamByName('Pi2');
fPj2:= ibquery2.ParamByName('Pj2');
fPk2:= ibquery2.ParamByName('Pk2');
fPl2:= ibquery2.ParamByName('Pl2');
fPm2:= ibquery2.ParamByName('Pm2'); fPi3:= ibquery2.ParamByName('Pi3');
fPj3:= ibquery2.ParamByName('Pj3');
fPk3:= ibquery2.ParamByName('Pk3');
fPl3:= ibquery2.ParamByName('Pl3');
fPm3:= ibquery2.ParamByName('Pm3'); for i := 1 to 3 do
for j := 1 to 2 do
for k := 1 to 163 do
for l := 1 to 60 do
for m := 1 to 10 do
begin
fPi1.AsInteger:= i;
fPj1.AsInteger := j;
fPk1.AsInteger:= k;
fPl1.AsInteger := l;
fPm1.AsInteger := m; fPi2.AsInteger:= i;
fPj2.AsInteger := j;
fPk2.AsInteger:= k;
fPl2.AsInteger := l;
fPm2.AsInteger := m+10; fPi3.AsInteger:= i;
fPj3.AsInteger := j;
fPk3.AsInteger:= k;
fPl3.AsInteger := l;
fPm3.AsInteger := m+20;
execSQL;
end;
end; // ibquery2.
ibquery2.transaction.commit;
ibquery2.transaction.Active:=false; IBquery1.Close;
ibquery1.Open;
finish:=GetTickCount;
form2.TimeLabel.Caption:=('Время заполнения: '+floattostr((finish-start)/1000)+' секунд'); except
if ibquery1.active then
ibquery2.transaction.rollback;
showmessage ('Ошибка');
end;
var t: TextFile;
s1: UnicodeString;
s2: AnsiString;
s3, s4: RawByteString;
s5: UTF8String;
begin
try
// AssignFile(t, 'd:\write.txt');
// AssignFile(t, 'd:\write.txt', 866);
// AssignFile(t, 'd:\write.txt', 1251);
AssignFile(t, 'd:\write.txt', 65001);
s1 := 'Мама мыла раму';
s2 := s1;
s3 := s2; SetCodePage(s3, 866);
s4 := s3; SetCodePage(s4, 65001);
s5 := s2;
Rewrite(t);
Writeln(t, s1);
Writeln(t, s2);
Writeln(t, s3);
Writeln(t, s4);
Writeln(t, s5);
Writeln(t, s1, s2, s3, s4, s5);
CloseFile(t);
var
mSize :NativeUInt;
tResult :string; procedure Test(aVoid:Pointer);
var
i,n:NativeInt;
t:Cardinal;
pA,pB:Pointer;
zA,zB:PNativeInt;
begin
tResult := 'Error?!'; pA := GetMemory(mSize); // VirtualAlloc(nil,mSize,MEM_COMMIT or MEM_RESERVE,PAGE_READWRITE);//
pB := GetMemory(mSize); // VirtualAlloc(nil,mSize,MEM_COMMIT or MEM_RESERVE,PAGE_READWRITE);// if (pA <> nil) and (pB <> nil) then begin n := mSize div sizeOf(zA^) - 1; t := GetTickCount();
zA := pA; for i := 0 to n do begin zA^:=i; inc(zA); end;
zB := pB; for i := 0 to n do begin zB^:=i; inc(zB); end;
t := GetTickCount() - t;
tResult := IntToStr(mSize div (1024*1024))+'::'#9'Zz ' + IntToStr(t); t := GetTickCount();
NonCollisionMove(pA^,pB^,mSize);
t := GetTickCount() - t;
tResult :=tResult + #9'Na ' + IntToStr(t); t := GetTickCount();
Move(pA^,pB^,mSize);
t := GetTickCount() - t;
tResult := tResult + #9'Ma ' + IntToStr(t); t := GetTickCount();
NonCollisionMove(pA^,pB^,mSize);
t := GetTickCount() - t;
tResult := tResult + #9'Nb ' + IntToStr(t); t := GetTickCount();
Move(pA^,pB^,mSize);
t := GetTickCount() - t;
tResult := tResult + #9'Mb ' + IntToStr(t); t := GetTickCount();
NonCollisionMove(pA^,pB^,mSize);
t := GetTickCount() - t;
tResult :=tResult + #9'Nc ' + IntToStr(t); end;
FreeMemory(pB); // VirtualFree(pB,0,MEM_RELEASE); //
FreeMemory(pA); // VirtualFree(pA,0,MEM_RELEASE); // SendMessage(Form1.Handle,WM_USER,0,0);
end; procedure TForm1.Button1Click(Sender: TObject);
begin
Caption := 'Go...';
Button1.Enabled := False;
mSize := StrToInt64Def(Edit1.Text,512)*(1024*1024);
CloseHandle(BeginThread(nil,0,@Test,nil,0,PCardinal(nil)^));
end; procedure TForm1.WmUser(var Message: TMessage);
begin
Caption := 'SuperTest!';
Memo1.Lines.Add(tResult);
Button1.Enabled := True;
end;
var
mSize :Cardinal;
mOffsetS :Cardinal;
mOffsetD :Cardinal;
tResult :string; procedure Test(aVoid:Pointer);
const
GB = UInt64(8)*1024*1024*1024;
var
i,n,t :NativeUInt;
pS,pD :Pointer;
begin tResult := 'Error?!'; pS := VirtualAlloc(nil,mSize,MEM_COMMIT or MEM_RESERVE,PAGE_READWRITE); // pS := GetMemory(mSize);
pD := VirtualAlloc(nil,mSize,MEM_COMMIT or MEM_RESERVE,PAGE_READWRITE); // pD := GetMemory(mSize); if (pS <> nil) and (pD <> nil) then begin ZeroMemory(pS,mSize);
ZeroMemory(pD,mSize); n := GB div mSize - 1;
tResult := IntToStr( mSize div 1024) +'KB x ' +IntToStr((n+1) div 1024) +'Kn S+' +IntToStr(mOffsetS) +' D+' +IntToStr(mOffsetD) +' :'; pS := PByte(pS) + mOffsetS;
pD := PByte(pD) + mOffsetD;
if (mOffsetS > mOffsetD) then Dec(mSize, mOffsetS) else Dec(mSize, mOffsetD); t := GetTickCount();
for i := 0 to n do NonCollisionMove(pS^,pD^,mSize);
tResult := tResult + #9'Na ' + IntToStr(GetTickCount() - t); t := GetTickCount();
for i := 0 to n do Move(pS^,pD^,mSize);
tResult := tResult + #9'Ma ' + IntToStr(GetTickCount() - t); t := GetTickCount();
for i := 0 to n do NonCollisionMove(pS^,pD^,mSize);
tResult := tResult + #9'Nb ' + IntToStr(GetTickCount() - t); t := GetTickCount();
for i := 0 to n do Move(pS^,pD^,mSize);
tResult := tResult + #9'Mb ' + IntToStr(GetTickCount() - t); t := GetTickCount();
for i := 0 to n do NonCollisionMove(pS^,pD^,mSize);
tResult := tResult + #9'Nc ' + IntToStr(GetTickCount() - t); end; pS:=PByte(pS)-mOffsetS;
pD:=PByte(pD)-mOffsetD; VirtualFree(pD,0,MEM_RELEASE); // FreeMemory(pS);
VirtualFree(pS,0,MEM_RELEASE); // FreeMemory(pD); PostMessage(Form1.Handle,WM_USER,0,0);
end; procedure TForm1.Button1Click(Sender: TObject);
begin
mSize := StrToIntDef(Edit1.Text,4);
mOffsetS := StrToIntDef(Edit2.Text,0);
mOffsetD := StrToIntDef(Edit3.Text,0);
mSize:=mSize * 1024;
Button1.Enabled := False;
CloseHandle(BeginThread(nil,0,@Test,nil,0,PCardinal(nil)^));
end; procedure TForm1.WmUser(var Message: TMessage);
begin
Memo1.Lines.Add(tResult);
Button1.Enabled := True;
end;
function Q_PStrScan(P: PWideChar; Ch: WideChar; Size: Integer): Integer; // x32
asm
test eax, eax // P=nil?
jz @@exit push ecx
lea eax, [eax + 2*ecx]
neg ecx
jnl @@zero @@loop:
cmp dx, [eax + 2*ecx]
je @@found inc ecx
jne @@loop @@zero:
pop ecx
xor eax, eax
@@exit:
ret @@found:
pop eax
lea eax, [eax + ecx + 1]
end;
function MyMove(const Source; var Dest; Count: NativeInt): Integer;
asm
push ebx
cmp ecx, 15
jbe @@Move8
@@Move16:
mov ebx, DWORD PTR [eax]
mov DWORD PTR [edx], ebx
mov ebx, DWORD PTR [eax+4]
mov DWORD PTR [edx+4], ebx
add edx, 16
add eax, 16
sub ecx, 16
cmp ecx, 15
ja @@Move16
@@Move8:
test ecx, ecx
je @@Exit
test cl, 8
je @@Move4
mov ebx, DWORD PTR [eax]
mov DWORD PTR [edx], ebx
add edx, 8
add eax, 8
@@Move4:
test cl, 4
je @@Move2
mov ebx, DWORD PTR [eax]
mov DWORD PTR [edx], ebx
add edx, 4
add eax, 4
@@Move2:
test cl, 2
je @@Move1
movzx ebx, WORD PTR [eax]
mov WORD PTR [edx], bx
add edx, 2
add eax, 2
@@Move1:
test cl, 1
je @@Exit
movzx eax, BYTE PTR [eax]
mov BYTE PTR [edx], al
@@Exit:
pop ebx
end;
program Project71; uses
Windows; function sprintf(S: PAnsiChar; const Format: PAnsiChar): Integer; cdecl;
varargs; external 'msvcrt.dll';
function QueryPerformanceCounter(var lpPerformanceCount: Int64): LongBool;
stdcall; external 'kernel32.dll' name 'QueryPerformanceCounter';
function QueryPerformanceFrequency(var lpFrequency: Int64): LongBool; stdcall;
external 'kernel32.dll' name 'QueryPerformanceFrequency'; function PrintTime(time: Single): AnsiString;
begin
Result := '';
SetLength(Result, 25);
SetLength(Result, sprintf(PAnsiChar(Result), '%f', time));
end; function MyMove(const Source; var Dest; Count: NativeInt): Integer;
asm
push ebx
cmp ecx, 15
jbe @@Move8
@@Move16:
mov ebx, DWORD PTR [eax]
mov DWORD PTR [edx], ebx
mov ebx, DWORD PTR [eax+4]
mov DWORD PTR [edx+4], ebx
add edx, 16
add eax, 16
sub ecx, 16
cmp ecx, 15
ja @@Move16
@@Move8:
test ecx, ecx
je @@Exit
test cl, 8
je @@Move4
mov ebx, DWORD PTR [eax]
mov DWORD PTR [edx], ebx
add edx, 8
add eax, 8
@@Move4:
test cl, 4
je @@Move2
mov ebx, DWORD PTR [eax]
mov DWORD PTR [edx], ebx
add edx, 4
add eax, 4
@@Move2:
test cl, 2
je @@Move1
movzx ebx, WORD PTR [eax]
mov WORD PTR [edx], bx
add edx, 2
add eax, 2
@@Move1:
test cl, 1
je @@Exit
movzx eax, BYTE PTR [eax]
mov BYTE PTR [edx], al
@@Exit:
pop ebx
end; procedure NonCollisionMove(const Source; var Dest; const size: NativeUInt);
asm
// basic routine
{$IFDEF CPUX86}
cmp ecx, 32
{$ELSE .CPUX64}
cmp r8, 32
// make Source = eax/rax, Dest = edx/rdx, Size = ecx/rcx
mov rax, rcx
xchg rcx, r8
// r9 as pointer to @move_03_items
lea r9, [@move_03_items]
{$ENDIF} // is big/large (32...inf)
jae @move_big // is small (0..3)
cmp ecx, 4
jb @move_03 // move middle(4..31) = move 16(0..16) + move dwords(0..12) + move small(0..3)
cmp ecx, 16
jb @move_015 {$IFDEF CPUX86}
movups xmm0, [eax]
movups [edx], xmm0
jne @move_015_offset
ret
@move_015_offset:
sub ecx, 16
add eax, 16
add edx, 16
@move_015:
push ecx
and ecx, -4
add eax, ecx
add edx, ecx
jmp [ecx + @move_dwords]
@move_dwords: DD @rw_0,@rw_4,@rw_8,@rw_12
@rw_12:
mov ecx, [eax-12]
mov [edx-12], ecx
@rw_8:
mov ecx, [eax-8]
mov [edx-8], ecx
@rw_4:
mov ecx, [eax-4]
mov [edx-4], ecx
@rw_0:
pop ecx
and ecx, 3
{$ELSE .CPUX64}
movups xmm0, [rax]
movups [rdx], xmm0
jne @move_015_offset
ret
@move_015_offset:
sub rcx, 16
add rax, 16
add rdx, 16
@move_015:
// make r9 = dest 0..3 pointer, rcx = dwords count
mov r8, rcx
shr rcx, 2
and r8, 3
lea r9, [r9 + r8*8]
// case jump
lea r8, [@move_dwords]
jmp qword ptr [r8 + rcx*8]
@move_dwords: DQ @rw_0,@rw_4,@rw_8,@rw_12
@rw_8:
mov rcx, [rax]
mov [rdx], rcx
add rax, 8
add rdx, 8
jmp qword ptr [r9]
@rw_12:
mov rcx, [rax]
mov [rdx], rcx
add rax, 8
add rdx, 8
@rw_4:
mov ecx, [rax]
mov [rdx], ecx
add rax, 4
add rdx, 4
@rw_0:
jmp qword ptr [r9]
{$ENDIF} @move_03:
{$IFDEF CPUX86}
jmp [offset @move_03_items + ecx*4]
@move_03_items: DD @0,@1,@2,@3
@2: mov cx, [eax]
mov [edx], cx
ret
@3: mov cx, [eax]
mov [edx], cx
add eax, 2
add edx, 2
@1: mov cl, [eax]
mov [edx], cl
@0: ret
{$ELSE .CPUX64}
jmp qword ptr [r9 + rcx*8]
@move_03_items: DQ @0,@1,@2,@3
@2: mov cx, [rax]
mov [rdx], cx
ret
@3: mov cx, [rax]
mov [rdx], cx
add rax, 2
add rdx, 2
@1: mov cl, [rax]
mov [rdx], cl
@0: ret
{$ENDIF} @move_big:
{$IFDEF CPUX86}
cmp ecx, 16*4
{$ELSE .CPUX64}
cmp rcx, 16*4
{$ENDIF}
jae @move_large // big memory move by SSE (32..63) = (32..48) + (0..15)
{$IFDEF CPUX86}
test ecx, 15
jz @move_32_48 push ecx
and ecx, 15
movups xmm0, [eax]
movups [edx], xmm0
add eax, ecx
add edx, ecx pop ecx
and ecx, -16
{$ELSE .CPUX64}
mov r8, rcx
test rcx, 15
jz @move_32_48 and r8, 15
movups xmm0, [rax]
movups [rdx], xmm0
add rax, r8
add rdx, r8 and rcx, -16
{$ENDIF} @move_32_48:
{$IFDEF CPUX86}
add eax, ecx
add edx, ecx
cmp ecx, 48
jb @rw_32
@rw_48: movups xmm2, [eax - 2*16 - 16]
movups [edx - 2*16 - 16], xmm2
@rw_32: movups xmm1, [eax - 1*16 - 16]
movups xmm0, [eax - 0*16 - 16]
movups [edx - 1*16 - 16], xmm1
movups [edx - 0*16 - 16], xmm0
{$ELSE .CPUX64}
add rax, rcx
add rdx, rcx
cmp rcx, 48
jb @rw_32
@rw_48: movups xmm2, [rax - 2*16 - 16]
movups [rdx - 2*16 - 16], xmm2
@rw_32: movups xmm1, [rax - 1*16 - 16]
movups xmm0, [rax - 0*16 - 16]
movups [rdx - 1*16 - 16], xmm1
movups [rdx - 0*16 - 16], xmm0
{$ENDIF} ret
@move_large:
// large memory move by SSE (64..inf) // destination alignment
{$IFDEF CPUX86}
push ebx
test edx, 15
jz @move_16128_initialize mov ebx, edx
movups xmm0, [eax]
movups [ebx], xmm0 add edx, 15
and edx, -16
sub ebx, edx
sub eax, ebx
add ecx, ebx
{$ELSE .CPUX64}
test rdx, 15
jz @move_16128_initialize mov r8, rdx
movups xmm0, [rax]
movups [r8], xmm0 add rdx, 15
and rdx, -16
sub r8, rdx
sub rax, r8
add rcx, r8
{$ENDIF} @move_16128_initialize:
{$IFDEF CPUX86}
push ecx
mov ebx, offset @aligned_reads
shr ecx, 4
test eax, 15
jz @move_16128
mov ebx, offset @unaligned_reads
{$ELSE .CPUX64}
movaps [rsp-8-16], xmm6
movaps [rsp-8-32], xmm7
mov r8, rcx
lea r9, [@aligned_reads]
shr rcx, 4
test rax, 15
jz @move_16128
lea r9, [@unaligned_reads]
{$ENDIF} @move_16128:
{$IFDEF CPUX86}
cmp ecx, 8
jae @move_128 lea ecx, [ecx + ecx]
lea eax, [eax + ecx*8]
lea edx, [edx + ecx*8]
lea ebx, [ebx + 8*4]
neg ecx
lea ebx, [ebx + ecx*2]
jmp ebx
@move_128:
lea eax, [eax + 128]
lea edx, [edx + 128]
lea ecx, [ecx - 8]
jmp ebx
{$ELSE .CPUX64}
cmp rcx, 8
jae @move_128 lea rcx, [rcx + rcx]
lea rax, [rax + rcx*8]
lea rdx, [rdx + rcx*8]
lea r9, [r9 + 8*4]
neg rcx
lea r9, [r9 + rcx*2]
jmp r9
@move_128:
lea rax, [rax + 128]
lea rdx, [rdx + 128]
lea rcx, [rcx - 8]
jmp r9
{$ENDIF} // aligned sse read
@aligned_reads:
{$IFDEF CPUX86}
movaps xmm7, [eax - 7*16 - 16]
movaps xmm6, [eax - 6*16 - 16]
movaps xmm5, [eax - 5*16 - 16]
movaps xmm4, [eax - 4*16 - 16]
movaps xmm3, [eax - 3*16 - 16]
movaps xmm2, [eax - 2*16 - 16]
movaps xmm1, [eax - 1*16 - 16]
movaps xmm0, [eax - 0*16 - 16]
{$ELSE .CPUX64}
movaps xmm7, [rax - 7*16 - 16]
movaps xmm6, [rax - 6*16 - 16]
movaps xmm5, [rax - 5*16 - 16]
movaps xmm4, [rax - 4*16 - 16]
movaps xmm3, [rax - 3*16 - 16]
movaps xmm2, [rax - 2*16 - 16]
movaps xmm1, [rax - 1*16 - 16]
movaps xmm0, [rax - 0*16 - 16]
{$ENDIF}
jae @aligned_writes
jmp @write_16112 // unaligned sse read
@unaligned_reads:
{$IFDEF CPUX86}
movups xmm7, [eax - 7*16 - 16]
movups xmm6, [eax - 6*16 - 16]
movups xmm5, [eax - 5*16 - 16]
movups xmm4, [eax - 4*16 - 16]
movups xmm3, [eax - 3*16 - 16]
movups xmm2, [eax - 2*16 - 16]
movups xmm1, [eax - 1*16 - 16]
movups xmm0, [eax - 0*16 - 16]
jae @aligned_writes
@write_16112:
lea ebx, [offset @aligned_writes + 8*4 + ecx*2]
jmp ebx
{$ELSE .CPUX64}
movups xmm7, [rax - 7*16 - 16]
movups xmm6, [rax - 6*16 - 16]
movups xmm5, [rax - 5*16 - 16]
movups xmm4, [rax - 4*16 - 16]
movups xmm3, [rax - 3*16 - 16]
movups xmm2, [rax - 2*16 - 16]
movups xmm1, [rax - 1*16 - 16]
movups xmm0, [rax - 0*16 - 16]
jae @aligned_writes
@write_16112:
lea r9, [@aligned_writes + 8*4]
lea r9, [r9 + rcx*2]
jmp r9
{$ENDIF} // aligned sse write, loop
@aligned_writes:
{$IFDEF CPUX86}
movaps [edx - 7*16 - 16], xmm7
movaps [edx - 6*16 - 16], xmm6
movaps [edx - 5*16 - 16], xmm5
movaps [edx - 4*16 - 16], xmm4
movaps [edx - 3*16 - 16], xmm3
movaps [edx - 2*16 - 16], xmm2
movaps [edx - 1*16 - 16], xmm1
movaps [edx - 0*16 - 16], xmm0
test ecx, ecx
{$ELSE .CPUX64}
movaps [rdx - 7*16 - 16], xmm7
movaps [rdx - 6*16 - 16], xmm6
movaps [rdx - 5*16 - 16], xmm5
movaps [rdx - 4*16 - 16], xmm4
movaps [rdx - 3*16 - 16], xmm3
movaps [rdx - 2*16 - 16], xmm2
movaps [rdx - 1*16 - 16], xmm1
movaps [rdx - 0*16 - 16], xmm0
test rcx, rcx
{$ENDIF}
jg @move_16128 // last 0..15 bytes
{$IFDEF CPUX86}
pop ecx
pop ebx
and ecx, 15
jnz @move_115
ret
@move_115:
add eax, ecx
add edx, ecx
movups xmm0, [eax - 0*16 - 16]
movups [edx - 0*16 - 16], xmm0
{$ELSE .CPUX64}
movaps xmm6, [rsp-8-16]
movaps xmm7, [rsp-8-32]
and r8, 15
jnz @move_115
ret
@move_115:
add rax, r8
add rdx, r8
movups xmm0, [rax - 0*16 - 16]
movups [rdx - 0*16 - 16], xmm0
{$ENDIF}
end; type
TCall = procedure(const Source; var Dest; Count: NativeInt); var
i, g: Integer; Str1, Str2: AnsiString;
StartTime, StopTime: Int64;
iCounterPerSec: Int64; procedure Speed(const n: string; c: Pointer; i: Integer);
begin
QueryPerformanceCounter(StartTime); for g := 0 to 10000000 do
begin
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
end; if QueryPerformanceCounter(StopTime) and QueryPerformanceFrequency
(iCounterPerSec) then
Writeln(n, ':: ', PrintTime((StopTime - StartTime) / iCounterPerSec));
end; begin
{$IFNDEF DEBUG}
Write('Release');
{$ELSE}
Write('Debug');
{$ENDIF}
{$IF Defined(CPUX64) or Defined(CPUARM64)}
Writeln(' 64bit');
{$ELSE}
Writeln(' 32Bit');
{$IFEND}
System.SetMinimumBlockAlignment(mba16Byte); Str1 := 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'
+ 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'; Str2 := '------------------------------------------------------------------------------------------------------------------------------------------------'
+ '------------------------------------------------------------------------------------------------------------------------------------------------'; i := 9;
Writeln('-- ', i ,' -- ');
Speed('MyMove', @MyMove, i);
Speed('Move', @Move, i);
Speed('NonCollisionMove', @NonCollisionMove, i); i := 0;
Writeln('-- ', i ,' -- ');
Speed('MyMove', @MyMove, i);
Speed('Move', @Move, i);
Speed('NonCollisionMove', @NonCollisionMove, i); i := 3;
Writeln('-- ', i ,' -- ');
Speed('MyMove', @MyMove, i);
Speed('Move', @Move, i);
Speed('NonCollisionMove', @NonCollisionMove, i); Readln; end.
program console;
{$APPTYPE CONSOLE}
uses
SysUtils;
var
Sum: int64;
S: string;
F: TextFile;
begin
Sum := 0;
AssignFile(F, 'correct_file.txt');
Reset(F);
while not Eof(F) do
begin
Readln(F, S);
Sum := Sum + StrToIntDef(S, 0);
end;
writeln(Format('Sum is %d, %x', [Sum, Sum]));
end.
procedure Init;
var
Start: Cardinal;
Step : Integer;
Temp : PString;
begin
Start:=GetTickCount;
for Step:=1 to 22000000
do begin
New(Temp);
Temp^:='123';
StrToInt(Temp^);
Dispose(Temp)
end;
WriteLn('Init: ', GetTickCount-Start, 'ms.')
end;
procedure Test;
var
i : integer;
Count : integer;
CF : TCachedFileReader;
begin
CF:=TCachedFileReader.Create('D:\Test.dat'); // Название файла прямо сюда
try
while CF.Position<CF.Size do begin // Реальный файл с данными скопирован для тестов ~100 раз
CF.ReadWord; // Пошли данные о заголовке, читаем в /dev/null
CF.ReadByte;
Count:=CF.ReadInteger; // Кол-во объектов
for i:=1 to Count do begin // Куча объектов
CF.ReadDouble; // Опять привет /dev/null
CF.ReadDouble;
CF.ReadInteger;
CF.ReadInteger;
CF.ReadAnsiString(0,1); // Заголовок - 1й байт (длина строки)
CF.ReadBoolean;
CF.ReadSmallInt;
end;
end;
finally
CF.Free; // Очищаем все.
end;
end;
TCachedFileReader = class(TFileStream)
public
constructor Create(FN: string); overload; Function ReadByte: Byte;
Function ReadWord: Word;
Function ReadSmallInt: SmallInt;
Function ReadInteger: integer;
Function ReadIntegerEx(Bytes: integer): integer;
function ReadInt64: int64;
Function ReadSingle: single;
Function ReadDouble: double;
Function ReadAnsiString(CharCount: integer = 0; HeaderSize: byte = 4): AnsiString;
Function ReadBoolean: boolean;
end; implementation { TCachedFileReader } constructor TCachedFileReader.Create(FN: string);
begin
inherited Create(FN,0);
end; function TCachedFileReader.ReadAnsiString(CharCount: integer; HeaderSize: byte): AnsiString;
begin
if CharCount=0 then begin
Read(CharCount,HeaderSize);
end; SetLength(Result,CharCount);
Read(Result[1],CharCount);
end; function TCachedFileReader.ReadBoolean: boolean;
begin
Read(Result,1);
end; function TCachedFileReader.ReadByte: Byte;
begin
Read(Result,1);
end; function TCachedFileReader.ReadDouble: double;
begin
Read(Result,8);
end; function TCachedFileReader.ReadInt64: int64;
begin
Read(Result,8);
end; function TCachedFileReader.ReadInteger: integer;
begin
Read(Result,4);
end; function TCachedFileReader.ReadIntegerEx(Bytes: integer): integer;
begin
Read(Result,Bytes);
end; function TCachedFileReader.ReadSingle: single;
begin
Read(Result,4);
end; function TCachedFileReader.ReadSmallInt: SmallInt;
begin
Read(Result,2);
end; function TCachedFileReader.ReadWord: Word;
begin
Read(Result,2);
end;
procedure Test;
var
i : integer;
t1,t2,t3 : cardinal; a1,s1 : RawByteString;
a2,s2 : TBytes;
a3,s3 : Pointer;
const
BlockLen = 1000000;
begin
SetLength(s1,BlockLen);
SetLength(s2,BlockLen);
GetMem(s3,BlockLen); t1:=GetTickCount;
for i:=0 to 10000 do begin
a1:=Copy(s1,1,BlockLen);
a1:='';
end;
t1:=GetTickCount-t1; t2:=GetTickCount;
for i:=0 to 10000 do begin
SetLength(a2,BlockLen);
Move(s2[1],a2[1],BlockLen);
SetLength(a2,0);
end;
t2:=GetTickCount-t2; t3:=GetTickCount;
for i:=0 to 10000 do begin
GetMem(a3,BlockLen);
Move(s3^,a3^,BlockLen);
FreeMem(a3);
end;
t3:=GetTickCount-t3; ShowMessage(Format('%d,%d,%d',[t1,t2,t3]));
end;
const
ID_UNKNOWN = 0;
ID_CELL = 1;
ID_DATA = 2;
ID_ROW = 3;
ID_SHEET = 4;
ID_STYLE = 5;
ID_VALUE = 6; function ValueToID(const S: AnsiString): Cardinal;
begin
// default value
Result := ID_UNKNOWN; // byte ascii
with PMemoryItems(S)^ do
case Length(S) of
3: if (Words[0] + Bytes[2] shl 16 = $776F72) then Result := ID_ROW; // "row"
4: case (Cardinals[0]) of // "cell", "data"
$6C6C6563: Result := ID_CELL; // "cell"
$61746164: Result := ID_DATA; // "data"
end;
5: case (Cardinals[0]) of // "sheet", "style", "value"
$65656873: if (Bytes[4] = $74) then Result := ID_SHEET; // "sheet"
$6C797473: if (Bytes[4] = $65) then Result := ID_STYLE; // "style"
$756C6176: if (Bytes[4] = $65) then Result := ID_VALUE; // "value"
end;
end;
end;
procedure TFindMatchThread.Execute;
var
Q: TpFIBQuery;
D: TpFIBDataSet;
i, w1, w2, Dist, C, F, RELDENUM: Integer;
SL1, SL2: TStringList; S: String;
REL, MaxRelFound, RelForIns, RELNUM: Double;
TradeMarkDone: Boolean; function IsTradeMark(S: String): Boolean;
var i: Integer;
B1, B2: Boolean;
begin
Result := False; B1 := False; B2 := False;
for i := 1 to length(S) do
if StrToIntDef(S[i], -1) in [0,1,2,3,4,5,6,7,8,9] then
begin
B1 := True; //содержит цифры
Break;
end;
for i := 1 to length(S) do
if StrToIntDef(S[i], -1) = -1 then
begin
B2 := True; //содержит буквы, дефис, слешы
Break;
end;
Result := B1 and B2; //маркой считаем буквы+цифры
end; function NoQ(S: String): String;
begin
S := StringReplace(S, '. ', ' ', [rfReplaceAll]);
S := StringReplace(S, ', ', ' ', [rfReplaceAll]);
S := StringReplace(S, '"', '', [rfReplaceAll]);
while Pos(' ', S) > 0 do S := StringReplace(S, ' ', ' ', [rfReplaceAll]);
Result := S;
end; begin
inherited;
// FreeOnTerminate := True; try
LaDB := TFIBDatabase.Create(MainForm);
LaTRN := TFIBTransaction.Create(MainForm);
Q := TpFIBQuery.Create(LaDB);
Q.Database := LaDB;
Q.Transaction := LaTRN; D := TpFIBDataSet.Create(LaDB);
D.Database := LaDB;
D.Transaction := LaTRN; LaDB.UseLoginPrompt := False;
LaDB.DatabaseName := DM.FIBDB.DatabaseName;
LaDB.DBParams := DM.FIBDB.DBParams;
LaDB.SQLDialect := DM.FIBDB.SQLDialect;
LaDB.DefaultTransaction := LaTRN;
LaTRN.DefaultDatabase := LaDB;
LaTRN.TRParams := DM.TRNShort.TRParams;
LaDB.Connected := True;
LaTRN.StartTransaction; SL1 := TStringList.Create; SL1.Delimiter := ' ';
SL2 := TStringList.Create; SL2.Delimiter := ' '; D.SelectSQL.Text := 'select * from TPRICEIMPORT where IDPRICE='+IntToStr(dlgPriceImportMatch.IDPrice)+' order by ID';
D.Open; MyI := 0; while not D.EOF do
begin
for i := 0 to dlgPriceImportMatch.ResList.Count - 1 do
if (i mod MaxT) = MyT - 1 then
begin
if Terminated then Exit; S := NoQ(D.FieldByName('NAME').AsString);
SL1.Clear; SL1.DelimitedText := AnsiUpperCase(S); SL2.Clear; SL2.DelimitedText := AnsiUpperCase(dlgPriceImportMatch.ResList[i]);
RelForIns := 1/SL1.Count; if RelForIns<0.3 then RelForIns := 0.3;
C := 0; MaxRelFound := 0; F := 0; RELNUM := 0; RELDENUM := 0;
for w1 := 1 to SL1.Count do
begin
for w2 := 1 to SL2.Count do
begin
if Terminated then Exit; TradeMarkDone := False;
if IsTradeMark(SL1[w1-1]) then
begin
if SL1[w1-1] = SL2[w2-1] then
begin //полные совпадения марок оцениваем в 2 раза
TradeMarkDone := True;
RelNum := RelNum + 2;
Break;
end;
end; if not TradeMarkDone then //как марка слово не обработано, ищем по расстоянию
begin
Dist := EditDistance(SL1[w1-1], SL2[w2-1]); //находим кол-во редактирований (расстояние левенштейна)
if Dist <= Round(Length(SL1[w1-1])*0.2) then //слово схоже более чем на 80% (1 буква в 5 буквах, 2 в 10и)
begin
RelNum := RelNum + (Length(SL1[w1-1]) - Dist)/Length(SL1[w1-1]); //складываем числитель для вычисления схожести строки
Break; //чтобы второе слово такое же не шло в расчет (иначе опоры 50х50х50 обгоняют задвижки 50)
end;
end;
end;
RelDenum := RelDenum + 1; //знаменатель (кол-во слов в прайс-позиции)
end;
if RelDenum>0 then REL := RelNum / RelDenum else REL := 0;
MaxRelFound := Max(REL, MaxRelFound);
if REL > RelForIns then
begin
Q.SQL.Text := 'update or insert into TPRICEIMPORTMATCH (IDPI, IDRES, REL) values (:IDPI, :IDRES, :REL) matching (IDPI, IDRES)';
Q.ParamByName('IDPI').AsInteger := D.FieldByName('ID').AsInteger;
Q.ParamByName('IDRES').AsInteger := Integer(dlgPriceImportMatch.ResList.Objects[i]);
Q.ParamByName('REL').AsFloat := REL;
Q.ExecQuery; InterlockedIncrement(dlgPriceImportMatch.MatchFound);
Inc(F);
end;
end; MyI := D.RecNo;
D.Next; end;
D.Close;
LaTRN.Commit;
finally
LaDB.Close;
FreeAndNil(SL1);
FreeAndNil(SL2);
FreeAndNil(Q);
FreeAndNil(D);
FreeAndNil(LaDB);
Terminate;
end;
end;
function EditDistance(s, t: string): integer;
var
d : array of array of integer;
i,j,cost : integer;
begin
{
Compute the edit-distance between two strings.
Algorithm and description may be found at either of these two links:
http://en.wikipedia.org/wiki/Levenshtein_distance
http://www.google.com/search?q=Levenshtein+distance
} //initialize our cost array
SetLength(d,Length(s)+1);
for i := Low(d) to High(d) do begin
SetLength(d[i],Length(t)+1);
end; for i := Low(d) to High(d) do begin
d[i,0] := i;
for j := Low(d[i]) to High(d[i]) do begin
d[0,j] := j;
end;
end; //store our costs in a 2-d grid
for i := Low(d)+1 to High(d) do begin
for j := Low(d[i])+1 to High(d[i]) do begin
if s[i] = t[j] then begin
cost := 0;
end
else begin
cost := 1;
end; //to use "Min", add "Math" to your uses clause!
d[i,j] := Min(Min(
d[i-1,j]+1, //deletion
d[i,j-1]+1), //insertion
d[i-1,j-1]+cost //substitution
);
end; //for j
end; //for i //now that we've stored the costs, return the final one
Result := d[Length(s),Length(t)]; //dynamic arrays are reference counted.
//no need to deallocate them
end;
function EditDistance(const s, t: string): integer;
var
d : PInteger;
i,j,cost : integer;
LRowSize: Integer;
LColSize: Integer;
function Idx(ARow, ACol: Integer): PInteger;
begin
Result := PInteger(WPARAM(d) + ARow * LRowSize + ACol);
end;
begin
{
Compute the edit-distance between two strings.
Algorithm and description may be found at either of these two links:
http://en.wikipedia.org/wiki/Levenshtein_distance
http://www.google.com/search?q=Levenshtein+distance
} //initialize our cost array
LRowSize := Length(s) + 1;
LColSize := Length(t) + 1;
d := HeapAlloc(GetProcessHeap, 0, LRowSize * LColSize * SizeOf(d^));
Win32Check(d <> nil);
try
for i := 0 to LRowSize do begin
Idx(i, 0)^ := i;
for j := 0 to LColSize do
Idx(0, j)^ := j;
end; //store our costs in a 2-d grid
for i := 1 to LRowSize do begin
for j := 1 to LColSize do begin
cost := Ord(s[i] <> t[j]); //to use "Min", add "Math" to your uses clause!
Idx(i, j)^ := Min(Min(
Idx(i -1, j)^ + 1, //deletion
Idx(i, j-1)^ + 1), //insertion
Idx(i - 1, j - 1)^ + cost //substitution
);
end; //for j
end; //for i
//now that we've stored the costs, return the final one
Result := Idx(Length(s),Length(t))^;
finally
HeapFree(GetProcessHeap, 0, d);
end;
end;
function Idx(d, LRowSize, ARow, ACol: Integer): PInteger; inline;
begin
Result := PInteger(WPARAM(d) + ARow * LRowSize + ACol);
end;
type
TTagKind = (tkUnknown, tkCell, tkData, tkRow, tkSheet, tkStyle, tkValue); function ValueToEnum(const S: ByteString): TTagKind;
begin
// default value
Result := tkUnknown; // byte ascii
with PMemoryItems(S.Chars)^ do
case S.Length of
3: if (Words[0] + Bytes[2] shl 16 = $776F72) then Result := tkRow; // "row"
4: case (Cardinals[0]) of // "cell", "data"
$6C6C6563: Result := tkCell; // "cell"
$61746164: Result := tkData; // "data"
end;
5: case (Cardinals[0]) of // "sheet", "style", "value"
$65656873: if (Bytes[4] = $74) then Result := tkSheet; // "sheet"
$6C797473: if (Bytes[4] = $65) then Result := tkStyle; // "style"
$756C6176: if (Bytes[4] = $65) then Result := tkValue; // "value"
end;
end;
end;
function ReplaceSubstring(const ASourceText, APattern, ANewText: string): string;
var
L1, L2, L3, Count: Integer;
Site, Source: PChar;
Position, X, Y, Delta: Integer;
begin
L2 := Length(APattern);
Count := 0;
Position := PosEx(APattern, ASourceText, 1);
while Position <> 0 do
begin
Inc(Position, L2);
asm
PUSH POSITION
end;
Inc(Count);
Position := PosEx(APattern, ASourceText, Position)
end;
if Count = 0 then
Result := ASourceText
else
begin
L1 := Length(ASourceText);
L3 := Length(ANewText);
X := Succ(L1);
Inc(L1, (L3 - L2) * Count);
if L1 = 0 then
begin
for Position := 0 to Pred(Count) do
asm
POP Y
end;
Result := EmptyStr
end
else
begin
SetLength(Result, L1);
Site := Pointer(Result);
Inc(Site, L1);
Source := Pointer(ASourceText);
Dec(Source);
for Position := 0 to Pred(Count) do
begin
asm
POP Y
end;
Delta := X - Y;
if Delta > 0 then
begin
Dec(Site, Delta);
Move(Source[Y], Site^, Delta shl 1);
end;
Dec(Site, L3);
Move(Pointer(ANewText)^, Site^, L3 shl 1);
X := Y - L2
end;
Dec(X);
if X <> 0 then
Move(Pointer(ASourceText)^, Pointer(Result)^, X shl 1)
end
end
end;
function StringReplace(const S, OldPattern, NewPattern: String; Flags: TReplaceFlags): String;
var
SearchStr : String;
Patt : String;
Offset,P : Integer;
ROffset : Integer;
SLen : Integer;
RLen : Integer;
PLen : Integer;
NLen : Integer;
DSize : Integer;
SingleCheck : Boolean;
begin
if length(s)=0 then begin
Result:='';
Exit;
end; SingleCheck:=not (rfReplaceAll in Flags); if rfIgnoreCase in Flags then begin
SearchStr:=AnsiUpperCase(S);
Patt:=AnsiUpperCase(OldPattern);
end else begin
SearchStr:=S;
Patt:=OldPattern;
end; DSize:=Length(NewPattern)-Length(OldPattern); Offset:=1;
ROffset:=1;
SLen:=Length(SearchStr);
RLen:=SLen;
NLen:=Length(NewPattern);
PLen:=Length(Patt); SetLength(Result,RLen);
while Offset<SLen do begin
P:=Pos(Patt,SearchStr,Offset);
if P=0 then begin
Break;
end else begin
Move(S[Offset],Result[ROffset],P-Offset);
inc(ROffset,P-Offset);
if DSize>0 then begin
inc(Rlen,DSize);
SetLength(Result,RLen);
end;
if NLen>0 then Move(NewPattern[1],Result[ROffset],NLen);
inc(ROffset,NLen);
inc(Offset,P+PLen-Offset);
if SingleCheck then Break;
end;
end; if (SLen-Offset+1)>0 then Move(S[Offset],Result[ROffset],SLen-Offset+1);
inc(ROffset,SLen-Offset+1);
SetLength(Result,ROffset-1);
end;
procedure TForm5.Button1Click(Sender: TObject);
var
t1,t2 : Cardinal;
i : Integer;
L : TStringList;
s1,s2 : string;
begin
L:=TStringList.Create;
L.LoadFromFile('d:\book1.txt'); T1:=GetTickCount;
for i:=0 to 9 do begin
s1:=System.SysUtils.StringReplace(L.Text,'Пьер','Петька',[rfReplaceAll]);
end;
T1:=GetTickCount-T1; T2:=GetTickCount;
for i:=0 to 9 do begin
s2:=StringReplace(L.Text,'Пьер','Петька',[rfReplaceAll]);
end;
T2:=GetTickCount-T2; Assert(s1<>s2,'Разные строки!'); LabeledEdit2.Text:=T1.ToString+' '+T2.ToString;
end;
function StringReplace(const S, OldPattern, NewPattern: String; Flags: TReplaceFlags): String;
var
SearchStr : String;
Patt : String;
Offset,P : Integer;
ROffset : Integer;
SLen : Integer;
RLen : Integer;
PLen : Integer;
NLen : Integer;
DSize : Integer;
SingleCheck : Boolean;
begin if length(s)=0 then begin
Result:='';
Exit;
end; SingleCheck:=not (rfReplaceAll in Flags); if rfIgnoreCase in Flags then begin
SearchStr:=AnsiUpperCase(S);
Patt:=AnsiUpperCase(OldPattern);
end else begin
SearchStr:=S;
Patt:=OldPattern;
end; DSize:=Length(NewPattern)-Length(OldPattern); Offset:=1;
ROffset:=1;
SLen:=Length(SearchStr);
RLen:=SLen;
NLen:=Length(NewPattern);
PLen:=Length(Patt); SetLength(Result,RLen);
while Offset<SLen do begin
// if
P:=Pos(Patt,SearchStr,Offset);
if P=0 then begin
Break;
end else begin
Move(S[Offset],Result[ROffset],(P-Offset)*SizeOf(Char));
inc(ROffset,P-Offset);
if DSize>0 then begin
inc(Rlen,DSize);
SetLength(Result,RLen);
end;
if NLen>0 then Move(NewPattern[1],Result[ROffset],NLen*SizeOf(Char));
inc(ROffset,NLen);
inc(Offset,P+PLen-Offset);
if SingleCheck then Break;
end;
end; if (SLen-Offset+1)>0 then Move(S[Offset],Result[ROffset],(SLen-Offset+1)*SizeOf(Char));
inc(ROffset,SLen-Offset+1);
SetLength(Result,ROffset-1);
end;
function StringReplace(const S, OldPattern, NewPattern: String; Flags: TReplaceFlags): String;
var
SearchStr : String;
Patt : String;
Offset,P : Integer;
ROffset : Integer;
SLen : Integer;
RLen : Integer;
PLen : Integer;
NLen : Integer;
DSize : Integer;
SingleCheck : Boolean;
begin
if length(s)=0 then begin
Result:='';
Exit;
end; SingleCheck:=not (rfReplaceAll in Flags); if rfIgnoreCase in Flags then begin
SearchStr:=AnsiUpperCase(S);
Patt:=AnsiUpperCase(OldPattern);
end else begin
SearchStr:=S;
Patt:=OldPattern;
end; DSize:=Length(NewPattern)-Length(OldPattern); Offset:=1;
ROffset:=1;
SLen:=Length(SearchStr);
RLen:=SLen;
NLen:=Length(NewPattern);
PLen:=Length(Patt); SetLength(Result,RLen);
while Offset<SLen do begin
P:=Pos(Patt,SearchStr,Offset);
if P=0 then begin
Break;
end else begin
Move(S[Offset],Result[ROffset],(P-Offset)*SizeOf(Char));
inc(ROffset,P-Offset);
if DSize>0 then begin
inc(Rlen,DSize);
if Length(Result)<RLen then begin
SetLength(Result,RLen+65535);
end;
end;
if NLen>0 then Move(NewPattern[1],Result[ROffset],NLen*SizeOf(Char));
inc(ROffset,NLen);
inc(Offset,P+PLen-Offset);
if SingleCheck then Break;
end;
end; if (SLen-Offset+1)>0 then Move(S[Offset],Result[ROffset],(SLen-Offset+1)*SizeOf(Char));
inc(ROffset,SLen-Offset+1);
SetLength(Result,ROffset-1);
end;
function ReplaceStr(const s, OldPattern, NewPattern: hstring): hstring;
var
Offset, SL, OL, NL{$IFNDEF AUTOREFCOUNT}, SI, RI, RL, n{$ENDIF}: int;
begin
OL := length(OldPattern);
SL := length(s);
if (OL = 0) or (SL < OL) then
begin
result := s;
exit;
end;
NL := length(NewPattern);
if (OL = 1) and (NL = 1) then
begin
result := s;
ReplaceChar(result, OldPattern[StringStart], NewPattern[StringStart]);
exit
end;
if OL = 1 then
Offset := FindChar(OldPattern[StringStart], s)
else
Offset := Pos(OldPattern, s);
if Offset = 0 then
begin
result := s;
exit
end;
{$IFDEF NEXTGEN}
result := AnsiReplaceStr(s, OldPattern, NewPattern);
{$ELSE}
RL := SL - OL + NL;
SetLength(result, RL);
SI := StringStart;
RI := StringStart;
repeat
if RI + (Offset - SI) + NL > RL then
begin
n := min(integer(65535), integer(RL div 2));
if RL + n < RI + (Offset - SI) + NL then
n := RI + (Offset - SI) + NL - RL;
Inc(RL, n);
SetLength(result, RL);
end;
Move(s[SI], result[RI], (Offset - SI - 1 + StringStart) * SizeOf(hchar));
Inc(RI, Offset - SI - 1 + StringStart);
SI := Offset + OL - 1 + StringStart;
if NL > 0 then
begin
Move(pointer(NewPattern)^, result[RI], NL * SizeOf(hchar));
Inc(RI, length(NewPattern));
end;
if OL = 1 then
Offset := FindChar(OldPattern[StringStart], s, SI + 1 - StringStart)
else
Offset := PosEx(OldPattern, s, SI + 1 - StringStart);
until Offset = 0;
if SI + 1 - StringStart <= SL then
begin
if RI + SL - SI > RL then
begin
RL := RI + SL - SI;
SetLength(result, RL);
end;
Move(s[SI], result[RI], (SL - SI + 2 - StringStart) * SizeOf(hchar));
end;
if RL <> RI + SL - SI then
SetLength(result, RI + SL - SI);
{$ENDIF}
end;
unit Unit4; interface uses
Winapi.Windows, Winapi.Messages, System.Diagnostics,
System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls; type
TForm4 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end; var
Form4: TForm4; implementation {$R *.dfm} uses
StrUtils; type
TReplaceFunc = function(const ASourceText, APattern, ANewText: string; Flags: TReplaceFlags): string; function ReplaceSubstring_Quaid(const ASourceText, APattern, ANewText: string; Flags: TReplaceFlags): string;
var
L1, L2, L3, Count: Integer;
Site, Source: PChar;
Position, X, Y, Delta: Integer;
begin
L2 := Length(APattern);
Count := 0;
Position := PosEx(APattern, ASourceText, 1);
while Position <> 0 do
begin
Inc(Position, L2);
asm
PUSH POSITION
end;
Inc(Count);
Position := PosEx(APattern, ASourceText, Position)
end;
if Count = 0 then
Result := ASourceText
else
begin
L1 := Length(ASourceText);
L3 := Length(ANewText);
X := Succ(L1);
Inc(L1, (L3 - L2) * Count);
if L1 = 0 then
begin
for Position := 0 to Pred(Count) do
asm
POP Y
end;
Result := EmptyStr
end
else
begin
SetLength(Result, L1);
Site := Pointer(Result);
Inc(Site, L1);
Source := Pointer(ASourceText);
Dec(Source);
for Position := 0 to Pred(Count) do
begin
asm
POP Y
end;
Delta := X - Y;
if Delta > 0 then
begin
Dec(Site, Delta);
Move(Source[Y], Site^, Delta shl 1);
end;
Dec(Site, L3);
Move(Pointer(ANewText)^, Site^, L3 shl 1);
X := Y - L2
end;
Dec(X);
if X <> 0 then
Move(Pointer(ASourceText)^, Pointer(Result)^, X shl 1)
end
end
end; function ReplaceSubstring_rgreat(const S, OldPattern, NewPattern: String; Flags: TReplaceFlags): String;
var
SearchStr : String;
Patt : String;
Offset,P : Integer;
ROffset : Integer;
SLen : Integer;
RLen : Integer;
PLen : Integer;
NLen : Integer;
DSize : Integer;
SingleCheck : Boolean;
begin
if length(s)=0 then begin
Result:='';
Exit;
end; SingleCheck:=not (rfReplaceAll in Flags); if rfIgnoreCase in Flags then begin
SearchStr:=AnsiUpperCase(S);
Patt:=AnsiUpperCase(OldPattern);
end else begin
SearchStr:=S;
Patt:=OldPattern;
end; DSize:=Length(NewPattern)-Length(OldPattern); Offset:=1;
ROffset:=1;
SLen:=Length(SearchStr);
RLen:=SLen;
NLen:=Length(NewPattern);
PLen:=Length(Patt); SetLength(Result,RLen);
while Offset<SLen do begin
P:=Pos(Patt,SearchStr,Offset);
if P=0 then begin
Break;
end else begin
Move(S[Offset],Result[ROffset],(P-Offset)*SizeOf(Char));
inc(ROffset,P-Offset);
if DSize>0 then begin
inc(Rlen,DSize);
if Length(Result)<RLen then begin
SetLength(Result,RLen+65535);
end;
end;
if NLen>0 then Move(NewPattern[1],Result[ROffset],NLen*SizeOf(Char));
inc(ROffset,NLen);
inc(Offset,P+PLen-Offset);
if SingleCheck then Break;
end;
end; if (SLen-Offset+1)>0 then Move(S[Offset],Result[ROffset],(SLen-Offset+1)*SizeOf(Char));
inc(ROffset,SLen-Offset+1);
SetLength(Result,ROffset-1);
end; procedure TForm4.FormCreate(Sender: TObject);
var
SS: TStringStream;
S: string; function TestReplace(AReplaceFunc: TReplaceFunc): Cardinal;
var
T: TStopwatch;
I: Integer;
Txt: string;
begin
T := TStopwatch.StartNew;
for I := 1 to 100 do
Txt := AReplaceFunc(S, 'Пьер', 'Петька', [rfReplaceAll]);
T.Stop;
Result := T.ElapsedMilliseconds
end; begin
SS := TStringStream.Create;
try
SS.LoadFromFile('D:\Война и beer.txt');
S := SS.DataString;
Memo1.Lines.Add('ReplaceSubstring_VCL - ' + TestReplace(StringReplace).ToString + ' msec');
Memo1.Lines.Add('ReplaceSubstring_rgreat - ' + TestReplace(ReplaceSubstring_rgreat).ToString + ' msec');
Memo1.Lines.Add('ReplaceSubstring_Quaid - ' + TestReplace(ReplaceSubstring_Quaid).ToString + ' msec');
finally
SS.Free
end
end; end.
function G_ReplaceStr(const SourceStr, FindStr, ReplacementStr: string): string;
var
P, PS: PChar;
L, L1, L2, Count: Integer;
I, J, K, M: Integer;
begin
L1 := Length(FindStr);
Count := 0;
I := G_PosStr(FindStr, SourceStr, 1);
while I <> 0 do
begin
Inc(I, L1);
asm
PUSH I
end;
Inc(Count);
I := G_PosStr(FindStr, SourceStr, I);
end;
if Count <> 0 then
begin
L := Length(SourceStr);
L2 := Length(ReplacementStr);
J := L + 1;
Inc(L, (L2 - L1) * Count);
if L <> 0 then
begin
SetString(Result, nil, L);
P := Pointer(Result);
Inc(P, L);
PS := Pointer(LongWord(SourceStr) - 1);
for I := 0 to Count - 1 do
begin
asm
POP K
end;
M := J - K;
if M > 0 then
begin
Dec(P, M);
G_CopyMem(@PS[K], P, M);
end;
Dec(P, L2);
G_CopyMem(Pointer(ReplacementStr), P, L2);
J := K - L1;
end;
Dec(J);
if J > 0 then
G_CopyMem(Pointer(SourceStr), Pointer(Result), J);
end else
begin
Result := '';
for I := 0 to Count - 1 do
asm
POP K
end;
end;
end else
Result := SourceStr;
end;
function StringReplace(const S, OldPattern, NewPattern: string;
Flags: TReplaceFlags): string;
const
FirstIndex = Low(string);
var
SearchStr, Patt, NewStr: string;
Offset, I, L: Integer;
begin
if rfIgnoreCase in Flags then
begin
SearchStr := AnsiUpperCase(S);
Patt := AnsiUpperCase(OldPattern);
end else
begin
SearchStr := S;
Patt := OldPattern;
end;
NewStr := S;
Result := '';
if SearchStr.Length <> S.Length then
begin
I := FirstIndex;
L := OldPattern.Length;
while I <= High(S) do
begin
if string.Compare(S, I - FirstIndex, OldPattern, 0, L, True) = 0 then
begin
Result := Result + NewPattern;
Inc(I, L);
if not (rfReplaceAll in Flags) then
begin
Result := Result + S.Substring(I - FirstIndex, MaxInt);
Break;
end;
end
else
begin
Result := Result + S[I];
Inc(I);
end;
end;
end
else
begin
while SearchStr <> '' do
begin
Offset := AnsiPos(Patt, SearchStr);
if Offset = 0 then
begin
Result := Result + NewStr;
Break;
end;
Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
if not (rfReplaceAll in Flags) then
begin
Result := Result + NewStr;
Break;
end;
SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
end;
end;
end;
uses
CachedTexts, UniConv, CachedBuffers; const
BUFFER_ITEMS_COUNT = 512; type
PBuffer = ^TBuffer;
TBuffer = packed record
Next: PBuffer;
Items: array[0..BUFFER_ITEMS_COUNT - 1] of NativeUInt;
end; TInternalData = record
S: Pointer;
SLength: NativeUInt;
Result: PUnicodeString;
Str, Ptn, NewPtn: UTF16String;
Count: NativeUInt;
First: PBuffer;
end; procedure InternalReplaceStr(var Data: TInternalData; const LastBuffer: PBuffer);
label
last_buffer;
var
P, i: NativeInt;
Size: NativeUInt;
Buffer: TBuffer;
Current: PNativeUInt;
Dest, Source: PByte;
begin
Current := @Buffer.Items[High(Buffer.Items)];
if (LastBuffer <> nil) then
begin
LastBuffer.Next := @Buffer;
end else
begin
Data.First := @Buffer;
end; repeat
P := Data.Str.Pos(Data.Ptn);
if (P < 0) then Break; Current^ := P;
Dec(Current);
Data.Str.Skip(NativeUInt(P) + Data.Ptn.Length);
Inc(Data.Count); if (Current = Pointer(@Buffer)) then
begin
InternalReplaceStr(Data, @Buffer);
Exit;
end;
until (False); if (Data.Count <> 0) then
begin
Dest := UnicodeStringAlloc(Pointer(Data.Result^),
NativeInt(Data.SLength) +
NativeInt(Data.Count) * (NativeInt(Data.NewPtn.Length) - NativeInt(Data.Ptn.Length)), 0);
Pointer(Data.Result^) := Dest; Source := Data.S;
if (Data.Count < BUFFER_ITEMS_COUNT) then
begin
last_buffer:
Current := @Buffer.Items[High(Buffer.Items)];
for i := 0 to NativeInt(Data.Count and (BUFFER_ITEMS_COUNT - 1)) - 1 do
begin
Size := Current^ shl 1;
Dec(Current);
NcMove(Source^, Dest^, Size);
Inc(Dest, Size);
Inc(Source, Size); Size := Data.NewPtn.Length shl 1;
NcMove(Data.NewPtn.Chars^, Dest^, Size);
Inc(Dest, Size);
Inc(Source, Data.Ptn.Length shl 1);
end; Size := Data.Str.Length shl 1;
NcMove(Data.Str.Chars^, Dest^, Size);
end else
begin
Current := Pointer(Data.First);
repeat
Inc(Current, BUFFER_ITEMS_COUNT - 1 + 1);
for i := 0 to BUFFER_ITEMS_COUNT - 1 do
begin
Size := Current^ shl 1;
Dec(Current);
NcMove(Source^, Dest^, Size);
Inc(Dest, Size);
Inc(Source, Size); Size := Data.NewPtn.Length shl 1;
NcMove(Data.NewPtn.Chars^, Dest^, Size);
Inc(Dest, Size);
Inc(Source, Data.Ptn.Length shl 1);
end; Current := Pointer(PBuffer(Current).Next);
if (Current = Pointer(@Buffer)) then goto last_buffer;
until (False);
end; end else
begin
Data.Result^ := UnicodeString(Data.S);
end;
end; function ReplaceStr(const S, OldPattern, NewPattern: UnicodeString): UnicodeString;
var
Data: TInternalData;
begin
if (Pointer(S) <> nil) and (Pointer(OldPattern) <> nil) then
begin
Data.S := Pointer(S);
Data.Result := @Result;
Data.Str.Assign(S);
Data.Ptn.Assign(OldPattern);
Data.NewPtn.Assign(NewPattern);
Data.SLength := Data.Str.Length;
Data.Count := 0; InternalReplaceStr(Data, nil);
end else
begin
Result := S;
end;
end;
function ReplaceStrEx(const AText,AFromText,AToText:string):string;
var
P : PByte;
//W : PWideChar absolute P; //for viewing in debugger
I : Integer;
J : Integer;
K : Integer;
D : Integer;
Delta : Integer;
LText : Integer;
LFrom : Integer;
LTo : Integer;
LSafe : Integer;
label
LOOP, DONE;
begin
LText := Length(AText);
LFrom := Length(AFromText);
if LText<=0 then Exit('') else
if (LFrom<=0) or (LFrom>LText) then Exit(AText);
LTo := Length(AToText);
LSafe := (LText div LFrom) * LTo + LText;
GetMem(P,LSafe);
I := 1;
D := 0;
repeat
K := I-1;
LOOP:
while AText[I] <> AFromText[1] do
begin
Inc(I);
if I>LText then goto DONE;
end;
for J := 0 to LFrom-1 do
if AText[I+J] <> AFromText[J+1] then
begin
Inc(I,J);
goto LOOP;
end;
Delta := I-K-1;
System.Move(PByte(@AText[K+1])^, PByte(P+D*2)^, Delta * SizeOf(WideChar));
System.Move(PByte(@AToText[1])^, PByte(P+(D+Delta)*2)^, LTo * SizeOf(WideChar));
Inc(D,Delta);
Inc(D,LTo);
Inc(I,LFrom);
until I>LText;
DONE:
PWord(P+D*2)^ := 0;
Result := string(PWideChar(P));
FreeMem(P);
end;
function ReplaceStr(const S, OldPattern, NewPattern: UnicodeString): UnicodeString;
label
store_p_char, store_p_str, big_new_pattern, _3, _2, _1, str_assign;
const
BUFFER_ITEMS_COUNT = 1024;
type
PBuffer = ^TBuffer;
TBuffer = packed record
Next: PBuffer;
Items: array[0..BUFFER_ITEMS_COUNT - 1] of NativeUInt;
end;
var
Data: record
Buffer: TBuffer;
S: Pointer;
SLength: NativeUInt;
Result: PUnicodeString;
Str, Ptn, NewPtn: UTF16String;
Count, P: NativeUInt;
Bottom: PNativeUInt;
end;
P, Size, i: NativeUInt;
Current, Bottom: PNativeUInt;
Dest, NewPtnSrc: PByte;
TopSource: PNativeUInt;
WDest: PWideChar;
LastChar, NewChar: WideChar;
begin
Data.S := Pointer(S);
Data.Result := @Result;
if (Pointer(S) = nil) or (Pointer(OldPattern) = nil) then goto str_assign;
Data.Str.Assign(S);
Data.Ptn.Assign(OldPattern);
Data.NewPtn.Assign(NewPattern);
Data.SLength := Data.Str.Length;
Data.Count := 0; Current := Pointer(@Data.Buffer);
Bottom := Current;
Inc(Current, BUFFER_ITEMS_COUNT + 1); if (Data.Ptn.Length = 1) then
begin
if (Data.NewPtn.Length = 1) then
begin
Dest := {$ifdef UNICODE}UnicodeStringAlloc{$else}WideStringAlloc{$endif}(Pointer(Data.Result^), Data.SLength, 0);
Pointer(Data.Result^) := Dest;
NcMove(Data.S^, Dest^, Data.SLength shl 1); WDest := Pointer(Dest);
LastChar := Data.Ptn.Chars^;
NewChar := Data.NewPtn.Chars^; i := Data.SLength;
repeat
Dec(i);
if (WDest^ <> LastChar) then
begin
Inc(WDest);
if (i <> 0) then Continue;
Break;
end else
begin
WDest^ := NewChar;
Inc(WDest);
end;
until (i = 0); Exit;
end; repeat
P := Data.Str.CharPos(Data.Ptn.Chars^);
Dec(Current);
if (NativeInt(P) < 0) then Break; if (Current <> Bottom) then
begin
store_p_char:
Current^ := P;
P := P + 1;
Data.Str.Length := Data.Str.Length - P;
Data.Str.Chars := Pointer(@PWideChar(Data.Str.Chars)[P]);
Inc(Data.Count);
end else
begin
Data.P := P;
GetMem(Current, SizeOf(TBuffer));
PBuffer(Bottom).Next := Pointer(Bottom);
Bottom := Current;
Inc(Current, BUFFER_ITEMS_COUNT);
P := Data.P;
goto store_p_char;
end;
until (False);
end else
begin
repeat
P := Data.Str.Pos(Data.Ptn);
Dec(Current);
if (NativeInt(P) < 0) then Break; if (Current <> Bottom) then
begin
store_p_str:
Current^ := P;
P := P + Data.Ptn.Length;
Data.Str.Length := Data.Str.Length - P;
Data.Str.Chars := Pointer(@PWideChar(Data.Str.Chars)[P]);
Inc(Data.Count);
end else
begin
Data.P := P;
GetMem(Current, SizeOf(TBuffer));
PBuffer(Bottom).Next := Pointer(Current);
Bottom := Current;
Inc(Current, BUFFER_ITEMS_COUNT);
P := Data.P;
goto store_p_str;
end;
until (False);
end; if (Data.Count <> 0) then
begin
Dest := {$ifdef UNICODE}UnicodeStringAlloc{$else}WideStringAlloc{$endif}(Pointer(Data.Result^),
NativeInt(Data.SLength) +
NativeInt(Data.Count) * (NativeInt(Data.NewPtn.Length) - NativeInt(Data.Ptn.Length)), 0);
Pointer(Data.Result^) := Dest; Bottom{Source} := Data.S;
TopSource := Pointer(@PWideChar(Bottom{Source})[Data.SLength - Data.Str.Length]);
Current := Pointer(@Data.Buffer);
Data.Bottom := Current;
Inc(Current, BUFFER_ITEMS_COUNT);
repeat
// source
Size := Current^ shl 1;
NcMove(Bottom{Source}^, Dest^, Size);
{$ifdef CPUX86}
Size := Current^ shl 1;
{$endif}
Inc(Dest, Size);
Inc(NativeUInt(Bottom){Source}, Size);
Dec(Current);
Inc(NativeUInt(Bottom){Source}, Data.Ptn.Length shl 1); // pattern
Size := Data.NewPtn.Length shl 1;
NewPtnSrc := Pointer(Data.NewPtn.Chars);
case ((Size + 2) shr 2) of
5:
begin
big_new_pattern:
NcMove(NewPtnSrc^, Dest^, Size);
Inc(Dest, Data.NewPtn.Length shl 1); if (Bottom{Source} = TopSource) then Break;
if (Current <> Data.Bottom) then Continue;
end;
0:
begin
// none
end;
4:
begin
PCardinal(Dest)^ := PCardinal(NewPtnSrc)^;
Inc(Dest, SizeOf(Cardinal));
Inc(NewPtnSrc, SizeOf(Cardinal));
goto _3;
end;
3:
begin
_3:
PCardinal(Dest)^ := PCardinal(NewPtnSrc)^;
Inc(Dest, SizeOf(Cardinal));
Inc(NewPtnSrc, SizeOf(Cardinal));
goto _2;
end;
2:
begin
_2:
PCardinal(Dest)^ := PCardinal(NewPtnSrc)^;
Inc(Dest, SizeOf(Cardinal));
Inc(NewPtnSrc, SizeOf(Cardinal));
goto _1;
end;
1:
begin
_1:
PCardinal(Dest)^ := PCardinal(NewPtnSrc)^;
Inc(Dest, SizeOf(Cardinal));
Dec(Dest, {$ifdef CPUX86}(Data.NewPtn.Length shl 1){$else}Size{$endif} and 2);
end;
else
goto big_new_pattern;
end; if (Bottom{Source} = TopSource) then Break;
if (Current = Data.Bottom) then
begin
Current := Pointer(PBuffer(Current).Next);
if (Data.Bottom <> Pointer(@Data.Buffer)) then FreeMem(Data.Bottom);
Data.Bottom := Current;
Inc(Current, BUFFER_ITEMS_COUNT);
end;
until (False); // dispose buffer, margin str
Bottom := Data.Bottom;
if (Bottom = Pointer(@Data.Buffer)) then
begin
NcMove(Data.Str.Chars^, Dest^, Data.Str.Length shl 1);
end else
begin
FreeMem(Bottom);
NcMove(Data.Str.Chars^, Dest^, Data.Str.Length shl 1);
end;
end else
begin
str_assign:
Data.Result^ := UnicodeString(Data.S);
end;
end;
function StringReplace(const Source, OldPattern, NewPattern: string; Flags: TReplaceFlags): string;
var
Str: string;
xOldPattern: string;
FoundPos: Integer;
I, J: Integer;
SourceIdx: Integer;
DestIdx: Integer;
LCharsToCopy: Integer;
FindCount: Integer;
PosArray: array of Integer;
LenOP: Integer;
LenNP: Integer;
LenS: Integer;
ArrLen: Integer;
LPResult, LPSource, LPNewPattern: PChar;
LReplaceAll: Boolean;
begin
LenOP := Length(OldPattern);
LenS := Length(Source);
if (LenOP = 0) or (LenS = 0) then
Exit(Source); if rfIgnoreCase in Flags then
begin
xOldPattern := AnsiUpperCase(OldPattern);
LenOP := Length(xOldPattern);
if SameStr(xOldPattern, AnsiLowerCase(OldPattern)) then // Special case, for example only symbols (+ - , * .....)
Str := Source
else
begin
Str := AnsiUpperCase(Source);
LenS := Length(Str);
end;
end
else
begin
xOldPattern := OldPattern;
Str := Source;
end; if Str.Length <> Source.Length then
begin
Result := '';
I := Low(string);
while I <= High(Source) do
begin
if string.Compare(Source, I - Low(string), OldPattern, 0, LenOP, True) = 0 then
begin
Result := Result + NewPattern;
Inc(I, LenOP);
if not (rfReplaceAll in Flags) then
begin
Result := Result + Source.Substring(I - Low(string), MaxInt);
Break;
end;
end
else
begin
Result := Result + Source[I];
Inc(I);
end;
end;
end
else
begin
FoundPos := 1;
FindCount := 0;
ArrLen := 0;
LReplaceAll := not (rfReplaceAll in Flags);
repeat
FoundPos := Pos(xOldPattern, Str, FoundPos);
if FoundPos = 0 then
Break; Inc(FindCount);
if ArrLen < FindCount then
begin
if ArrLen = 0 then
ArrLen := 32
else
ArrLen := ArrLen * 2;
SetLength(PosArray, ArrLen); // call SetLength less frequently makes a huge difference when replacing multiple occurrences
end;
PosArray[FindCount - 1] := FoundPos - 1; // Zero based array
Inc(FoundPos, LenOP);
until LReplaceAll; if FindCount > 0 then
begin
LenNP := Length(NewPattern);
LPSource := Pointer(Source); // We use a pointer cast to avoid the _UStrToPWChar call injected by the compiler
LPNewPattern := Pointer(NewPattern); // We use a pointer cast to avoid the _UStrToPWChar call injected by the compiler
if LenNP = LenOP then
begin // special case where Length(OldPattern) = Length(NewPattern)
SetLength(Result, LenS); // in this case, we can optimize it even further
LPResult := Pointer(Result); // We use a pointer cast to avoid the uniquestring call injected by the compiler
Move(LPSource^, LPResult^, LenS * SizeOf(Char));
if LenNP = 1 then
for I := 0 to FindCount - 1 do
LPResult[PosArray[I]] := LPNewPattern^
else if LenNP <= 8 then
for I := 0 to FindCount - 1 do
for J := 0 to LenNP -1 do
LPResult[PosArray[I] + J] := LPNewPattern[J]
else
for I := 0 to FindCount - 1 do
Move(LPNewPattern^, LPResult[PosArray[I]], LenNP * SizeOf(Char));
end
else
begin
SetLength(Result, LenS + ((LenNP - LenOP) * FindCount));
LPResult := Pointer(Result); // We use a pointer cast to avoid the uniquestring call injected by the compiler
SourceIdx := 0;
DestIdx := 0;
if LenNP = 0 then
for I := 0 to FindCount - 1 do
begin
LCharsToCopy := PosArray[I] - SourceIdx;
if LCharsToCopy > 0 then
begin
if LCharsToCopy = 1 then
begin
LPResult[DestIdx] := LPSource[SourceIdx];
Inc(SourceIdx);
Inc(DestIdx);
end
else if LCharsToCopy <= 8 then
begin
for J := 0 to LCharsToCopy - 1 do
LPResult[DestIdx + J] := LPSource[SourceIdx + J];
Inc(SourceIdx, LCharsToCopy);
Inc(DestIdx, LCharsToCopy);
end
else
begin
Move(LPSource[SourceIdx], LPResult[DestIdx], LCharsToCopy * SizeOf(Char));
Inc(SourceIdx, LCharsToCopy);
Inc(DestIdx, LCharsToCopy);
end;
end;
Inc(SourceIdx, LenOP);
end
else if LenNP = 1 then
for I := 0 to FindCount - 1 do
begin
LCharsToCopy := PosArray[I] - SourceIdx;
if LCharsToCopy > 0 then
begin
if LCharsToCopy = 1 then
begin
LPResult[DestIdx] := LPSource[SourceIdx];
Inc(SourceIdx);
Inc(DestIdx);
end
else if LCharsToCopy <= 8 then
begin
for J := 0 to LCharsToCopy - 1 do
LPResult[DestIdx + J] := LPSource[SourceIdx + J];
Inc(SourceIdx, LCharsToCopy);
Inc(DestIdx, LCharsToCopy);
end
else
begin
Move(LPSource[SourceIdx], LPResult[DestIdx], LCharsToCopy * SizeOf(Char));
Inc(SourceIdx, LCharsToCopy);
Inc(DestIdx, LCharsToCopy);
end;
end;
LPResult[DestIdx] := LPNewPattern[0];
Inc(DestIdx);
Inc(SourceIdx, LenOP);
end
else
for I := 0 to FindCount - 1 do
begin
LCharsToCopy := PosArray[I] - SourceIdx;
if LCharsToCopy > 0 then
begin
if LCharsToCopy = 1 then
begin
LPResult[DestIdx] := LPSource[SourceIdx];
Inc(SourceIdx);
Inc(DestIdx);
end
else if LCharsToCopy <= 8 then
begin
for J := 0 to LCharsToCopy - 1 do
LPResult[DestIdx + J] := LPSource[SourceIdx + J];
Inc(SourceIdx, LCharsToCopy);
Inc(DestIdx, LCharsToCopy);
end
else
begin
Move(LPSource[SourceIdx], LPResult[DestIdx], LCharsToCopy * SizeOf(Char));
Inc(SourceIdx, LCharsToCopy);
Inc(DestIdx, LCharsToCopy);
end;
end;
Move(LPNewPattern^, LPResult[DestIdx], LenNP * SizeOf(Char));
Inc(DestIdx, LenNP);
Inc(SourceIdx, LenOP);
end; LCharsToCopy := LenS - SourceIdx;
if LCharsToCopy > 0 then
Move(LPSource[SourceIdx], LPResult[DestIdx], LCharsToCopy * SizeOf(Char));
end;
end
else
Result := Source;
end;
end;
function StringReplace(const S, OldPattern, NewPattern: string;
Flags: TReplaceFlags): string;
var
SearchStr, Patt, NewStr: string;
Offset: Integer;
begin
if rfIgnoreCase in Flags then
begin
SearchStr := AnsiUpperCase(S);
Patt := AnsiUpperCase(OldPattern);
end else
begin
SearchStr := S;
Patt := OldPattern;
end;
NewStr := S;
Result := '';
while SearchStr <> '' do
begin
Offset := AnsiPos(Patt, SearchStr);
if Offset = 0 then
begin
Result := Result + NewStr;
Break;
end;
Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
if not (rfReplaceAll in Flags) then
begin
Result := Result + NewStr;
Break;
end;
SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
end;
end;
{$IFNDEF CPUX86}
function Pos1(const SubStr, Str: String; Offset: Integer = 1): Integer;
var
i,L,H : NativeInt;
C : char;
begin
Result:=0;
L:=Length(SubStr);
if (L=0) or (length(SubStr)=0) then Exit;
C:=SubStr[1];
H:=Length(Str)-L+1;
for Result:=Offset to H do begin
if Str[Result]=C then Exit;
end;
Result:=0;
end;
function Pos2(const SubStr, S: string; Offset: Integer = 1): Integer;
Type
PInteger =^Integer;
var
len, lenSub: Integer;
ch: char;
p, pSub, pStart, pStop: pchar;
label
Loop0, Loop4,
TestT, Test0, Test1, Test2, Test3, Test4,
AfterTestT, AfterTest0,
Ret, Exit;
begin;
pSub := pointer(SubStr);
p := pointer(S);
if (p = nil) or (pSub = nil) or (Offset < 1) then
begin;
Result := 0;
goto Exit;
end;
lenSub := PLongInt(PByte(pSub) - 4)^ - 1;
len := PLongInt(PByte(p) - 4)^;
if (len < lenSub + Offset) or (lenSub < 0) then
begin;
Result := 0;
goto Exit;
end;
pStop := p + len;
p := p + lenSub;
pSub := pSub + lenSub;
pStart := p;
p := p + Offset + 3;
ch := pSub[0];
lenSub := -lenSub;
if p < pStop then
goto Loop4;
p := p - 4;
goto Loop0;
Loop4:
if ch = p[-4] then
goto Test4;
if ch = p[-3] then
goto Test3;
if ch = p[-2] then
goto Test2;
if ch = p[-1] then
goto Test1;
Loop0:
if ch = p[0] then
goto Test0;
AfterTest0:
if ch = p[1] then
goto TestT;
AfterTestT:
p := p + 6;
if p < pStop then
goto Loop4;
p := p - 4;
if p < pStop then
goto Loop0;
Result := 0;
goto Exit;
Test3:
p := p - 2;
Test1:
p := p - 2;
TestT:
len := lenSub;
if lenSub <> 0 then
repeat
;
if (pSub[len] <> p[len + 1]) or (pSub[len + 1] <> p[len + 2]) then
goto AfterTestT;
len := len + 2;
until len >= 0;
p := p + 2;
if p <= pStop then
goto Ret;
Result := 0;
goto Exit;
Test4:
p := p - 2;
Test2:
p := p - 2;
Test0:
len := lenSub;
if lenSub <> 0 then
repeat
;
if (pSub[len] <> p[len]) or (pSub[len + 1] <> p[len + 1]) then
goto AfterTest0;
len := len + 2;
until len >= 0;
Inc(p);
Ret:
Result := p - pStart;
Exit:
end;
{$ENDIF}
function ReplaceSubstring_rgreat(const S, OldPattern, NewPattern: String; Flags: TReplaceFlags): String;
type
TPosFunc = function(const SubStr, Str: String; Offset: Integer = 1): Integer;
var
SearchStr : String;
Patt : String;
Offset,P : NativeInt;
ROffset : NativeInt;
SLen : NativeInt;
RLen : NativeInt;
PLen : NativeInt;
NLen : NativeInt;
DSize : NativeInt;
SingleCheck : Boolean;
MyPos : TPosFunc;
begin
if length(s)=0 then begin
Result:='';
Exit;
end;
SingleCheck:=not (rfReplaceAll in Flags);
if rfIgnoreCase in Flags then begin
SearchStr:=AnsiUpperCase(S);
Patt:=AnsiUpperCase(OldPattern);
end else begin
SearchStr:=S;
Patt:=OldPattern;
end;
DSize:=Length(NewPattern)-Length(OldPattern);
Offset:=1;
ROffset:=1;
SLen:=Length(SearchStr);
RLen:=SLen;
NLen:=Length(NewPattern);
PLen:=Length(Patt);
MyPos:=Pos;
{$IFNDEF CPUX86}
if Length(Patt)=1 then begin
MyPos:=Pos1;
end else begin
MyPos:=Pos2;
end;
{$ENDIF}
SetLength(Result,RLen);
while Offset<SLen do begin
P:=MyPos(Patt,SearchStr,Offset);
if P=0 then begin
Break;
end else begin
Move(S[Offset],Result[ROffset],(P-Offset)*SizeOf(Char));
inc(ROffset,P-Offset);
if DSize>0 then begin
inc(Rlen,DSize);
if Length(Result)<RLen then begin
SetLength(Result,RLen+1024);
end;
end;
if NLen>0 then Move(NewPattern[1],Result[ROffset],NLen*SizeOf(Char));
inc(ROffset,NLen);
inc(Offset,P+PLen-Offset);
if SingleCheck then Break;
end;
end;
if (SLen-Offset+1)>0 then Move(S[Offset],Result[ROffset],(SLen-Offset+1)*SizeOf(Char));
inc(ROffset,SLen-Offset+1);
SetLength(Result,ROffset-1);
end;
unit MainUnit; interface uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, DateUtils, System.Diagnostics,
CachedTexts, UniConv, CachedBuffers; type
TForm5 = class(TForm)
Button1: TButton;
Memo1: TMemo;
CheckBox1: TCheckBox;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end; var
Form5: TForm5; implementation {$R *.dfm} type
TReplaceFunc = function(const ASourceText, APattern, ANewText: string; Flags: TReplaceFlags): string; {$IFDEF CPUX86}
function ReplaceSubstring_Quaid(const ASourceText, APattern, ANewText: string; Flags: TReplaceFlags): string;
var
L1, L2, L3, Count: Integer;
Site, Source: PChar;
Position, X, Y, Delta: Integer;
begin
L2 := Length(APattern);
Count := 0;
Position := Pos(APattern, ASourceText, 1);
while Position <> 0 do
begin
Inc(Position, L2);
asm
PUSH POSITION
end;
Inc(Count);
Position := Pos(APattern, ASourceText, Position)
end;
if Count = 0 then
Result := ASourceText
else
begin
L1 := Length(ASourceText);
L3 := Length(ANewText);
X := Succ(L1);
Inc(L1, (L3 - L2) * Count);
if L1 = 0 then
begin
for Position := 0 to Pred(Count) do
asm
POP Y
end;
Result := EmptyStr
end
else
begin
SetLength(Result, L1);
Site := Pointer(Result);
Inc(Site, L1);
Source := Pointer(ASourceText);
Dec(Source);
for Position := 0 to Pred(Count) do
begin
asm
POP Y
end;
Delta := X - Y;
if Delta > 0 then
begin
Dec(Site, Delta);
Move(Source[Y], Site^, Delta shl 1);
end;
Dec(Site, L3);
Move(Pointer(ANewText)^, Site^, L3 shl 1);
X := Y - L2
end;
Dec(X);
if X <> 0 then
Move(Pointer(ASourceText)^, Pointer(Result)^, X shl 1)
end
end
end;
{$ENDIF} {$IFNDEF CPUX86}
function Pos(const SubStr, Str: String; Offset: Integer = 1): NativeInt;
Type
PInteger = ^Integer;
var
L,H : NativeInt;
Ch : Char;
len, lenSub : NativeInt;
p, pSub : PChar;
pStart : PChar;
pStop : PChar;
label
Loop0, Loop4,
TestT, Test0, Test1, Test2, Test3, Test4,
AfterTestT, AfterTest0,
Ret, LExit;
begin
Result:=0;
L:=Length(SubStr);
if (Length(Str)=0) or (L=0) then Exit; if L=1 then begin
Ch:=SubStr[1];
H:=Length(Str)-L+1;
for Result:=Offset to H do begin
if Str[Result]=Ch then Exit;
end;
Result:=0;
end else begin
pSub := pointer(SubStr);
p := pointer(Str); if (p = nil) or (pSub = nil) or (Offset < 1) then
begin;
Result := 0;
goto LExit;
end; lenSub := PLongInt(PByte(pSub) - 4)^ - 1;
len := PLongInt(PByte(p) - 4)^;
if (len < lenSub + Offset) or (lenSub < 0) then
begin;
Result := 0;
goto LExit;
end; pStop := p + len;
p := p + lenSub;
pSub := pSub + lenSub;
pStart := p;
p := p + Offset + 3; ch := pSub[0];
lenSub := -lenSub;
if p < pStop then
goto Loop4;
p := p - 4;
goto Loop0; Loop4:
if ch = p[-4] then
goto Test4;
if ch = p[-3] then
goto Test3;
if ch = p[-2] then
goto Test2;
if ch = p[-1] then
goto Test1;
Loop0:
if ch = p[0] then
goto Test0;
AfterTest0:
if ch = p[1] then
goto TestT;
AfterTestT:
p := p + 6;
if p < pStop then
goto Loop4;
p := p - 4;
if p < pStop then
goto Loop0;
Result := 0;
goto LExit; Test3:
p := p - 2;
Test1:
p := p - 2;
TestT:
len := lenSub;
if lenSub <> 0 then
repeat
;
if (pSub[len] <> p[len + 1]) or (pSub[len + 1] <> p[len + 2]) then
goto AfterTestT;
len := len + 2;
until len >= 0;
p := p + 2;
if p <= pStop then
goto Ret;
Result := 0;
goto LExit; Test4:
p := p - 2;
Test2:
p := p - 2;
Test0:
len := lenSub;
if lenSub <> 0 then
repeat
;
if (pSub[len] <> p[len]) or (pSub[len + 1] <> p[len + 1]) then
goto AfterTest0;
len := len + 2;
until len >= 0;
Inc(p);
Ret:
Result := p - pStart;
LExit:
end;
end;
{$ENDIF} function ReplaceSubstring_rgreat(const S, OldPattern, NewPattern: String; Flags: TReplaceFlags): String;
var
SearchStr : String;
Patt : String;
Offset,P : NativeInt;
ROffset : NativeInt;
SLen : NativeInt;
RLen : NativeInt;
PLen : NativeInt;
NLen : NativeInt;
DSize : NativeInt;
SingleCheck : Boolean;
begin
if length(s)=0 then begin
Result:='';
Exit;
end; SingleCheck:=not (rfReplaceAll in Flags); if rfIgnoreCase in Flags then begin
SearchStr:=AnsiUpperCase(S);
Patt:=AnsiUpperCase(OldPattern);
end else begin
SearchStr:=S;
Patt:=OldPattern;
end; DSize:=Length(NewPattern)-Length(OldPattern); Offset:=1;
ROffset:=1;
SLen:=Length(SearchStr);
RLen:=SLen;
NLen:=Length(NewPattern);
PLen:=Length(Patt); if PLen=NLen then begin
Result:=S;
while Offset<SLen do begin
P:=Pos(Patt,SearchStr,Offset);
if P=0 then begin
Break;
end else begin
Move(NewPattern[1],Result[P],NLen*SizeOf(Char));
inc(Offset,P+PLen-Offset);
if SingleCheck then Break;
end;
end;
end else begin
SetLength(Result,RLen);
while Offset<SLen do begin
P:=Pos(Patt,SearchStr,Offset);
if P=0 then begin
Break;
end else begin
Move(S[Offset],Result[ROffset],(P-Offset)*SizeOf(Char));
inc(ROffset,P-Offset);
if DSize>0 then begin
inc(Rlen,DSize);
if Length(Result)<RLen then begin
SetLength(Result,RLen+2048);
end;
end;
if NLen>0 then Move(NewPattern[1],Result[ROffset],NLen*SizeOf(Char));
inc(ROffset,NLen);
inc(Offset,P+PLen-Offset);
if SingleCheck then Break;
end;
end;
if (SLen-Offset+1)>0 then Move(S[Offset],Result[ROffset],(SLen-Offset+1)*SizeOf(Char));
inc(ROffset,SLen-Offset+1);
SetLength(Result,ROffset-1);
end;
end; function ReplaceSubstring_RTL_Berlin(const Source, OldPattern, NewPattern: String; Flags: TReplaceFlags): UnicodeString;
var
Str: string;
xOldPattern: string;
FoundPos: Integer;
I, J: Integer;
SourceIdx: Integer;
DestIdx: Integer;
LCharsToCopy: Integer;
FindCount: Integer;
PosArray: array of Integer;
LenOP: Integer;
LenNP: Integer;
LenS: Integer;
ArrLen: Integer;
LPResult, LPSource, LPNewPattern: PChar;
LReplaceAll: Boolean;
begin
LenOP := Length(OldPattern);
LenS := Length(Source);
if (LenOP = 0) or (LenS = 0) then
Exit(Source); if rfIgnoreCase in Flags then
begin
xOldPattern := AnsiUpperCase(OldPattern);
LenOP := Length(xOldPattern);
if SameStr(xOldPattern, AnsiLowerCase(OldPattern)) then // Special case, for example only symbols (+ - , * .....)
Str := Source
else
begin
Str := AnsiUpperCase(Source);
LenS := Length(Str);
end;
end
else
begin
xOldPattern := OldPattern;
Str := Source;
end; if Str.Length <> Source.Length then
begin
Result := '';
I := Low(string);
while I <= High(Source) do
begin
if string.Compare(Source, I - Low(string), OldPattern, 0, LenOP, True) = 0 then
begin
Result := Result + NewPattern;
Inc(I, LenOP);
if not (rfReplaceAll in Flags) then
begin
Result := Result + Source.Substring(I - Low(string), MaxInt);
Break;
end;
end
else
begin
Result := Result + Source[I];
Inc(I);
end;
end;
end
else
begin
FoundPos := 1;
FindCount := 0;
ArrLen := 0;
LReplaceAll := not (rfReplaceAll in Flags);
repeat
FoundPos := Pos(xOldPattern, Str, FoundPos);
if FoundPos = 0 then
Break; Inc(FindCount);
if ArrLen < FindCount then
begin
if ArrLen = 0 then
ArrLen := 32
else
ArrLen := ArrLen * 2;
SetLength(PosArray, ArrLen); // call SetLength less frequently makes a huge difference when replacing multiple occurrences
end;
PosArray[FindCount - 1] := FoundPos - 1; // Zero based array
Inc(FoundPos, LenOP);
until LReplaceAll; if FindCount > 0 then
begin
LenNP := Length(NewPattern);
LPSource := Pointer(Source); // We use a pointer cast to avoid the _UStrToPWChar call injected by the compiler
LPNewPattern := Pointer(NewPattern); // We use a pointer cast to avoid the _UStrToPWChar call injected by the compiler
if LenNP = LenOP then
begin // special case where Length(OldPattern) = Length(NewPattern)
SetLength(Result, LenS); // in this case, we can optimize it even further
LPResult := Pointer(Result); // We use a pointer cast to avoid the uniquestring call injected by the compiler
Move(LPSource^, LPResult^, LenS * SizeOf(Char));
if LenNP = 1 then
for I := 0 to FindCount - 1 do
LPResult[PosArray[I]] := LPNewPattern^
else if LenNP <= 8 then
for I := 0 to FindCount - 1 do
for J := 0 to LenNP -1 do
LPResult[PosArray[I] + J] := LPNewPattern[J]
else
for I := 0 to FindCount - 1 do
Move(LPNewPattern^, LPResult[PosArray[I]], LenNP * SizeOf(Char));
end
else
begin
SetLength(Result, LenS + ((LenNP - LenOP) * FindCount));
LPResult := Pointer(Result); // We use a pointer cast to avoid the uniquestring call injected by the compiler
SourceIdx := 0;
DestIdx := 0;
if LenNP = 0 then
for I := 0 to FindCount - 1 do
begin
LCharsToCopy := PosArray[I] - SourceIdx;
if LCharsToCopy > 0 then
begin
if LCharsToCopy = 1 then
begin
LPResult[DestIdx] := LPSource[SourceIdx];
Inc(SourceIdx);
Inc(DestIdx);
end
else if LCharsToCopy <= 8 then
begin
for J := 0 to LCharsToCopy - 1 do
LPResult[DestIdx + J] := LPSource[SourceIdx + J];
Inc(SourceIdx, LCharsToCopy);
Inc(DestIdx, LCharsToCopy);
end
else
begin
Move(LPSource[SourceIdx], LPResult[DestIdx], LCharsToCopy * SizeOf(Char));
Inc(SourceIdx, LCharsToCopy);
Inc(DestIdx, LCharsToCopy);
end;
end;
Inc(SourceIdx, LenOP);
end
else if LenNP = 1 then
for I := 0 to FindCount - 1 do
begin
LCharsToCopy := PosArray[I] - SourceIdx;
if LCharsToCopy > 0 then
begin
if LCharsToCopy = 1 then
begin
LPResult[DestIdx] := LPSource[SourceIdx];
Inc(SourceIdx);
Inc(DestIdx);
end
else if LCharsToCopy <= 8 then
begin
for J := 0 to LCharsToCopy - 1 do
LPResult[DestIdx + J] := LPSource[SourceIdx + J];
Inc(SourceIdx, LCharsToCopy);
Inc(DestIdx, LCharsToCopy);
end
else
begin
Move(LPSource[SourceIdx], LPResult[DestIdx], LCharsToCopy * SizeOf(Char));
Inc(SourceIdx, LCharsToCopy);
Inc(DestIdx, LCharsToCopy);
end;
end;
LPResult[DestIdx] := LPNewPattern[0];
Inc(DestIdx);
Inc(SourceIdx, LenOP);
end
else
for I := 0 to FindCount - 1 do
begin
LCharsToCopy := PosArray[I] - SourceIdx;
if LCharsToCopy > 0 then
begin
if LCharsToCopy = 1 then
begin
LPResult[DestIdx] := LPSource[SourceIdx];
Inc(SourceIdx);
Inc(DestIdx);
end
else if LCharsToCopy <= 8 then
begin
for J := 0 to LCharsToCopy - 1 do
LPResult[DestIdx + J] := LPSource[SourceIdx + J];
Inc(SourceIdx, LCharsToCopy);
Inc(DestIdx, LCharsToCopy);
end
else
begin
Move(LPSource[SourceIdx], LPResult[DestIdx], LCharsToCopy * SizeOf(Char));
Inc(SourceIdx, LCharsToCopy);
Inc(DestIdx, LCharsToCopy);
end;
end;
Move(LPNewPattern^, LPResult[DestIdx], LenNP * SizeOf(Char));
Inc(DestIdx, LenNP);
Inc(SourceIdx, LenOP);
end; LCharsToCopy := LenS - SourceIdx;
if LCharsToCopy > 0 then
Move(LPSource[SourceIdx], LPResult[DestIdx], LCharsToCopy * SizeOf(Char));
end;
end
else
Result := Source;
end;
end; function ReplaceSubstring_SFY(const S, OldPattern, NewPattern: String; Flags: TReplaceFlags): UnicodeString;
label
found_p_char, store_p_char, store_p_str, big_new_pattern, _3, _2, _1, str_assign;
const
BUFFER_ITEMS_COUNT = 1024;
type
PBuffer = ^TBuffer;
TBuffer = packed record
Next: PBuffer;
Items: array[0..BUFFER_ITEMS_COUNT - 1] of NativeUInt;
end;
var
Data: record
Buffer: TBuffer;
S: Pointer;
SLength: NativeUInt;
Result: PUnicodeString;
Str, Ptn, NewPtn: UTF16String;
Count, P: NativeUInt;
Bottom: PNativeUInt;
end;
P, Size, i: NativeUInt;
Current, Bottom: PNativeUInt;
Dest, NewPtnSrc: PByte;
TopSource: PNativeUInt;
WDest, WTop: PWideChar;
LastChar, NewChar: WideChar;
begin
Data.S := Pointer(S);
Data.Result := @Result;
if (Pointer(S) = nil) or (Pointer(OldPattern) = nil) then goto str_assign;
Data.Str.Assign(S);
Data.Ptn.Assign(OldPattern);
Data.NewPtn.Assign(NewPattern);
Data.SLength := Data.Str.Length;
Data.Count := 0; Current := Pointer(@Data.Buffer);
Bottom := Current;
Inc(Current, BUFFER_ITEMS_COUNT + 1); if (Data.Ptn.Length = 1) then
begin
if (Data.NewPtn.Length = 1) then
begin
Dest := {$ifdef UNICODE}UnicodeStringAlloc{$else}WideStringAlloc{$endif}(Pointer(Data.Result^), Data.SLength, 0);
Pointer(Data.Result^) := Dest;
NcMove(Data.S^, Dest^, Data.SLength shl 1); WDest := Pointer(Dest);
LastChar := Data.Ptn.Chars^;
NewChar := Data.NewPtn.Chars^; i := Data.SLength;
repeat
Dec(i);
if (WDest^ <> LastChar) then
begin
Inc(WDest);
if (i <> 0) then Continue;
Break;
end else
begin
WDest^ := NewChar;
Inc(WDest);
end;
until (i = 0); Exit;
end; repeat
// char pos
LastChar := Data.Ptn.Chars^;
WDest := Data.Str.Chars;
WTop := Pointer(@WDest[Data.Str.Length]);
P := 0;
if (WDest <> WTop) then
repeat
if (WDest^ = LastChar) then goto found_p_char;
Inc(WDest);
Inc(P);
until (WDest = WTop);
Break;
found_p_char:
Dec(Current); if (Current <> Bottom) then
begin
store_p_char:
Current^ := P;
P := P + 1;
Data.Str.Length := Data.Str.Length - P;
Data.Str.Chars := Pointer(@PWideChar(Data.Str.Chars)[P]);
Inc(Data.Count);
end else
begin
Data.P := P;
GetMem(Current, SizeOf(TBuffer));
PBuffer(Bottom).Next := Pointer(Current);
Bottom := Current;
Inc(Current, BUFFER_ITEMS_COUNT);
P := Data.P;
goto store_p_char;
end;
until (False);
end else
begin
repeat
P := Data.Str.Pos(Data.Ptn);
Dec(Current);
if (NativeInt(P) < 0) then Break; if (Current <> Bottom) then
begin
store_p_str:
Current^ := P;
P := P + Data.Ptn.Length;
Data.Str.Length := Data.Str.Length - P;
Data.Str.Chars := Pointer(@PWideChar(Data.Str.Chars)[P]);
Inc(Data.Count);
end else
begin
Data.P := P;
GetMem(Current, SizeOf(TBuffer));
PBuffer(Bottom).Next := Pointer(Current);
Bottom := Current;
Inc(Current, BUFFER_ITEMS_COUNT);
P := Data.P;
goto store_p_str;
end;
until (False);
end; if (Data.Count <> 0) then
begin
Dest := {$ifdef UNICODE}UnicodeStringAlloc{$else}WideStringAlloc{$endif}(Pointer(Data.Result^),
NativeInt(Data.SLength) +
NativeInt(Data.Count) * (NativeInt(Data.NewPtn.Length) - NativeInt(Data.Ptn.Length)), 0);
Pointer(Data.Result^) := Dest; Bottom{Source} := Data.S;
TopSource := Pointer(@PWideChar(Bottom{Source})[Data.SLength - Data.Str.Length]);
Current := Pointer(@Data.Buffer);
Data.Bottom := Current;
Inc(Current, BUFFER_ITEMS_COUNT);
repeat
// source
Size := Current^ shl 1;
NcMove(Bottom{Source}^, Dest^, Size);
{$ifdef CPUX86}
Size := Current^ shl 1;
{$endif}
Inc(Dest, Size);
Inc(NativeUInt(Bottom){Source}, Size);
Dec(Current);
Inc(NativeUInt(Bottom){Source}, Data.Ptn.Length shl 1); // pattern
Size := Data.NewPtn.Length shl 1;
NewPtnSrc := Pointer(Data.NewPtn.Chars);
case ((Size + 2) shr 2) of
5:
begin
big_new_pattern:
NcMove(NewPtnSrc^, Dest^, Size);
Inc(Dest, {$ifdef CPUX86}(Data.NewPtn.Length shl 1){$else}Size{$endif}); if (Bottom = TopSource) then Break;
if (Current <> Data.Bottom) then Continue;
end;
0:
begin
// none
end;
4:
begin
PCardinal(Dest)^ := PCardinal(NewPtnSrc)^;
Inc(Dest, SizeOf(Cardinal));
Inc(NewPtnSrc, SizeOf(Cardinal));
goto _3;
end;
3:
begin
_3:
PCardinal(Dest)^ := PCardinal(NewPtnSrc)^;
Inc(Dest, SizeOf(Cardinal));
Inc(NewPtnSrc, SizeOf(Cardinal));
goto _2;
end;
2:
begin
_2:
PCardinal(Dest)^ := PCardinal(NewPtnSrc)^;
Inc(Dest, SizeOf(Cardinal));
Inc(NewPtnSrc, SizeOf(Cardinal));
goto _1;
end;
1:
begin
_1:
PCardinal(Dest)^ := PCardinal(NewPtnSrc)^;
Inc(Dest, SizeOf(Cardinal));
Dec(Dest, {$ifdef CPUX86}(Data.NewPtn.Length shl 1){$else}Size{$endif} and 2);
end;
else
goto big_new_pattern;
end; if (Bottom = TopSource) then Break;
if (Current = Data.Bottom) then
begin
Current := Pointer(PBuffer(Current).Next);
if (Data.Bottom <> Pointer(@Data.Buffer)) then FreeMem(Data.Bottom);
Data.Bottom := Current;
Inc(Current, BUFFER_ITEMS_COUNT);
end;
until (False); Bottom := Data.Bottom;
if (Bottom = Pointer(@Data.Buffer)) then
begin
NcMove(Data.Str.Chars^, Dest^, Data.Str.Length shl 1);
end else
begin
FreeMem(Bottom);
NcMove(Data.Str.Chars^, Dest^, Data.Str.Length shl 1);
end;
end else
begin
str_assign:
Data.Result^ := UnicodeString(Data.S);
end;
end; function ReplaceSubstring_KAR(const AText,AFromText,AToText:string; Flags: TReplaceFlags):string;
var
P : PByte;
I : Integer;
J : Integer;
K : Integer;
D : Integer;
Delta : Integer;
LText : Integer;
LFrom : Integer;
LTo : Integer;
LSafe : Integer;
label
LOOP, OVER, DONE;
begin
LText := Length(AText);
LFrom := Length(AFromText);
if LText<=0 then Exit('') else
if (LFrom<=0) or (LFrom>LText) then Exit(AText);
LTo := Length(AToText);
LSafe := ((LText div LFrom) * LTo + LText) * SizeOf(WideChar);
GetMem(P,LSafe);
I := 1;
D := 0;
repeat
K := I-1;
LOOP:
while AText[I] <> AFromText[1] do
begin
Inc(I);
if I>LText then
begin
OVER:
Delta := I-K-1;
System.Move(PByte(@AText[K+1])^, PByte(P+D*2)^, Delta * SizeOf(WideChar));
Inc(D,Delta);
goto DONE;
end;
end;
if I+LFrom>LText then
begin
I := LText+1;
goto OVER;
end;
for J := 0 to LFrom-1 do
if AText[I+J] <> AFromText[J+1] then
begin
Inc(I,J);
goto LOOP;
end; Delta := I-K-1;
System.Move(PByte(@AText[K+1])^, PByte(P+D*2)^, Delta * SizeOf(WideChar));
System.Move(PByte(@AToText[1])^, PByte(P+(D+Delta)*2)^, LTo * SizeOf(WideChar));
Inc(D,Delta);
Inc(D,LTo);
Inc(I,LFrom);
until I>LText;
DONE:
PWord(P+D*2)^ := 0;
Result := string(PWideChar(P));
FreeMem(P);
end; function ReplaceSubstring_KAR2(const AText,AFromText,AToText:string; Flags:TReplaceFlags):string;
var
I : Integer;
P : Integer;
K : Integer;
D : Integer;
Delta : Integer;
LText : Integer;
LFrom : Integer;
LTo : Integer;
LSafe : Integer;
begin
LText := Length(AText);
LFrom := Length(AFromText);
LTo := Length(AToText);
if LText<=0 then Exit('') else
if (LFrom<=0) or (LFrom>LText) then Exit(AText) else
if (LFrom=LTo) then
LSafe := LText else
LSafe := ((LText div LFrom) * LTo + LText);
SetLength(Result,LSafe);
I := 1;
D := 0;
repeat
K := I-1;
P := Pos(AFromText,AText,I);
if P > 0 then
I := P else
I := LText+1;
Delta := I-K-1;
System.Move((PWideChar(AText)+K)^, (PWideChar(Result)+D)^, Delta shl 1);
if P>0 then
begin
System.Move(PWideChar(AToText)^, (PWideChar(Result)+D+Delta)^, LTo shl 1);
Inc(D,LTo);
Inc(I,LFrom);
end;
Inc(D,Delta);
until I>LText;
SetLength(Result,D);
end; procedure TForm5.Button1Click(Sender: TObject);
var
SS : TStringStream;
S : string;
Mode : TReplaceFlags;
Smode : string; function TestReplace(OldPattern, NewPattern: String; AReplaceFunc: TReplaceFunc): string;
var
T : TStopwatch;
I : NativeInt;
Txt : string;
begin
try
T := TStopwatch.StartNew;
for i:=1 to 1000 do begin
Txt := AReplaceFunc(S, OldPattern, NewPattern, Mode);
if T.ElapsedMilliseconds>10000 then break;
end;
T.Stop; if i<1000 then begin
Result := '~'+trunc(T.ElapsedMilliseconds*1000/i).ToString+' msec';
end else begin
Result := T.ElapsedMilliseconds.ToString+' msec';
end; Assert(ReplaceSubstring_RTL_Berlin(S, OldPattern, NewPattern, Mode)=Txt,'Incorrect function result!')
except
on E: Exception do begin
Result:='Error: '+E.Message;
end;
end;
end; procedure DoTests(OldPattern, NewPattern: String);
begin
Memo1.Lines.Add('Replace "'+OldPattern+'" -> "'+NewPattern+'"');
if CheckBox1.Checked then
Memo1.Lines.Add('ReplaceSubstring_RTL - ' + TestReplace(OldPattern, NewPattern, System.SysUtils.StringReplace));
Memo1.Lines.Add('ReplaceSubstring_RTL_Berlin - ' + TestReplace(OldPattern, NewPattern, ReplaceSubstring_RTL_Berlin));
Memo1.Lines.Add('ReplaceSubstring_rgreat - ' + TestReplace(OldPattern, NewPattern, ReplaceSubstring_rgreat));
{$IFDEF CPUX86}
Memo1.Lines.Add('ReplaceSubstring_Quaid - ' + TestReplace(OldPattern, NewPattern, ReplaceSubstring_Quaid));
{$ENDIF}
Memo1.Lines.Add('ReplaceSubstring_KAR - ' + TestReplace(OldPattern, NewPattern, ReplaceSubstring_KAR));
Memo1.Lines.Add('ReplaceSubstring_KAR2 - ' + TestReplace(OldPattern, NewPattern, ReplaceSubstring_KAR2));
Memo1.Lines.Add('ReplaceSubstring_SFY - ' + TestReplace(OldPattern, NewPattern, ReplaceSubstring_SFY));
Memo1.Lines.Add('---------------');
end; begin
SS := TStringStream.Create;
try
SS.LoadFromFile('book1.txt');
S := SS.DataString;
finally
SS.Free;
end;
Mode:=[rfReplaceAll{,rfIgnoreCase}]; SMode:='[]';
if Mode=[rfReplaceAll] then SMode:='[rfReplaceAll]';
if Mode=[rfIgnoreCase] then SMode:='[rfIgnoreCase]';
if Mode=[rfReplaceAll,rfIgnoreCase] then SMode:='[rfReplaceAll,rfIgnoreCase]'; {$IFDEF CPUX86}
Memo1.Lines.Add('1000 iterations. x86, '+SMode);
{$ELSE}
Memo1.Lines.Add('1000 iterations. x64, '+SMode);
{$ENDIF}
Memo1.Lines.Add('---------------'); DoTests('Пьер','Петька');
DoTests(' ','!!');
end; end.
program SimpleTest;
{$APPTYPE CONSOLE}
{$R *.res}
uses
SysUtils, Windows;
function ReplaceSubstring_rgreat(const S, OldPattern, NewPattern: String; Flags: TReplaceFlags): String;
var
SearchStr : String;
Patt : String;
Offset,P : integer;
ROffset : integer;
SLen : integer;
RLen : integer;
PLen : integer;
NLen : integer;
DSize : integer;
SingleCheck : Boolean;
begin
if length(s)=0 then begin
Result:='';
Exit;
end;
SingleCheck:=not (rfReplaceAll in Flags);
if rfIgnoreCase in Flags then begin
SearchStr:=AnsiUpperCase(S);
Patt:=AnsiUpperCase(OldPattern);
end else begin
SearchStr:=S;
Patt:=OldPattern;
end;
DSize:=Length(NewPattern)-Length(OldPattern);
Offset:=1;
ROffset:=1;
SLen:=Length(SearchStr);
RLen:=SLen;
NLen:=Length(NewPattern);
PLen:=Length(Patt);
if PLen=NLen then begin
Result:=S;
while Offset<SLen do begin
P:=PosEx(Patt,SearchStr,Offset);
if P=0 then begin
Break;
end else begin
Move(NewPattern[1],Result[P],NLen*SizeOf(Char));
inc(Offset,P+PLen-Offset);
if SingleCheck then Break;
end;
end;
end else begin
SetLength(Result,RLen);
while Offset<SLen do begin
P:=Pos(Patt,SearchStr,Offset);
if P=0 then begin
Break;
end else begin
Move(S[Offset],Result[ROffset],(P-Offset)*SizeOf(Char));
inc(ROffset,P-Offset);
if DSize>0 then begin
inc(Rlen,DSize);
if Length(Result)<RLen then begin
SetLength(Result,RLen+2048);
end;
end;
if NLen>0 then Move(NewPattern[1],Result[ROffset],NLen*SizeOf(Char));
inc(ROffset,NLen);
inc(Offset,P+PLen-Offset);
if SingleCheck then Break;
end;
end;
if (SLen-Offset+1)>0 then Move(S[Offset],Result[ROffset],(SLen-Offset+1)*SizeOf(Char));
inc(ROffset,SLen-Offset+1);
SetLength(Result,ROffset-1);
end;
end;
Function FileToStr(FileName: String): String;
var
f : File;
begin
if Pos(':\',FileName)=0 then begin
FileName:=ExtractFilePath(ParamStr(0))+'\'+FileName;
end;
AssignFile(f,FileName);
ReSet(f,1);
SetLength(Result,FileSize(f));
BlockRead(f,Result[1],FileSize(f));
CloseFile(f);
end;
type
TReplaceFunc = function(const ASourceText, APattern, ANewText: string; Flags: TReplaceFlags): string;
var
S : string;
Mode : TReplaceFlags;
Smode : string;
function TestReplace(OldPattern, NewPattern: String; AReplaceFunc: TReplaceFunc): string;
var
T : Cardinal;
I : integer;
Txt : string;
begin
try
T:=GetTickCount;
for i:=1 to 1000 do begin
Txt := AReplaceFunc(S, OldPattern, NewPattern, Mode);
if GetTickCount-T>10000 then break;
end;
T:=GetTickCount-T;
if i<1000 then begin
Result := '~'+IntToStr(trunc(T*1000/i))+' msec';
end else begin
Result := IntToStr(T)+' msec';
end;
Assert(StringReplace(S, OldPattern, NewPattern, Mode)=Txt,'Incorrect function result!')
except
on E: Exception do begin
Result:='Error: '+E.Message;
end;
end;
end;
procedure DoTests(OldPattern, NewPattern: String);
begin
Writeln('Replace "'+OldPattern+'" -> "'+NewPattern+'"');
Writeln('ReplaceSubstring_RTL - ' + TestReplace(OldPattern, NewPattern, StringReplace));
Writeln('ReplaceSubstring_rgreat - ' + TestReplace(OldPattern, NewPattern, ReplaceSubstring_rgreat));
Writeln('---------------');
end;
begin
s:=FileToStr('Book1.txt');
Mode:=[rfReplaceAll{,rfIgnoreCase}];
SMode:='[]';
if Mode=[rfReplaceAll] then SMode:='[rfReplaceAll]';
if Mode=[rfIgnoreCase] then SMode:='[rfIgnoreCase]';
if Mode=[rfReplaceAll,rfIgnoreCase] then SMode:='[rfReplaceAll,rfIgnoreCase]';
Writeln('1000 iterations. x86');
Writeln('---------------');
DoTests('Пьер','Петька');
DoTests(' ','!!');
ReadLn;
end.
unit XMLWriter; interface uses
Classes, SysUtils; type TXmlStandalone = (xsOmit, xsYes, xsNo); TXmlCloseTag = (xtNone, xtClose, xtSlashClose); TXMLWriter = class
private
FCapacity: LongInt;
FLength: Integer;
FBuffer: PChar;
procedure Grow;
public
constructor Create(const Standalone: TXmlStandalone);
destructor Destroy; override;
procedure WriteValue(const Buffer: PChar);
procedure OpenElement(const Name: PChar; const CloseTag: TXmlCloseTag);
procedure WriteElement(const Name, Value: PChar);
procedure WriteAttribute(const Name, Value: PChar; const CloseTag: TXmlCloseTag); overload;
procedure WriteBuffer(const Buffer: PChar);
procedure WriteChar(const Value: Char);
procedure CloseElement(const Name: PChar);
end; implementation const cOpenTag = '<';
cCloseTag = '>';
cSlash = '/';
cOpenSlashTag = '</';
cSlashCloseTag = '/>';
cSpace = ' ';
cEquality = '=';
cApostrophe = '"';
cEqualApos = '="';
cXml = '<?xml version="1.0" encoding="UTF-8" standalone="%s" ?>';
cStandalones : array [TXmlStandalone] of string = ('omit', 'yes', 'no'); { TXMLWriter } constructor TXMLWriter.Create(const Standalone: TXmlStandalone);
begin
FCapacity := 0;
FLength := 0; Grow;
// xml declarations
WriteBuffer(PChar(Format(cXml, [cStandalones[Standalone]])));
end; destructor TXMLWriter.Destroy;
begin
if FCapacity > 0 then
FreeMem(FBuffer);
FBuffer := nil;
inherited Destroy;
end; procedure TXMLWriter.Grow;
var
NewCapacity: Integer;
begin
NewCapacity := FCapacity + $200;
if FCapacity = 0 then
begin
GetMem(FBuffer, NewCapacity * SizeOf(Char))
end
else
begin
ReallocMem(FBuffer, NewCapacity * SizeOf(Char));
end;
FCapacity := NewCapacity;
end; procedure TXMLWriter.OpenElement(const Name: PChar; const CloseTag: TXmlCloseTag);
begin
// <
WriteChar(cOpenTag);
// name
WriteBuffer(Name);
// >
case CloseTag of
xtClose: WriteChar(cCloseTag);
xtSlashClose: WriteBuffer(cSlashCloseTag);
end;
end; procedure TXMLWriter.CloseElement(const Name: PChar);
begin
// </
WriteBuffer(cOpenSlashTag);
// name
WriteBuffer(Name);
// >
WriteChar(cCloseTag);
end; procedure TXMLWriter.WriteElement(const Name, Value: PChar);
begin
OpenElement(Name, xtClose);
if Value <> nil then
begin
// value
WriteValue(Value);
// </name>
CloseElement(Name);
end
else
// />
WriteBuffer(cSlashCloseTag);
end; procedure TXMLWriter.WriteAttribute(const Name, Value: PChar; const CloseTag: TXmlCloseTag);
begin
// space
WriteChar(cSpace);
// name
WriteBuffer(Name);
// ="
WriteBuffer(cEqualApos);
// value
WriteValue(Value);
// "
WriteChar(cApostrophe);
// >
case CloseTag of
xtClose: WriteChar(cCloseTag);
xtSlashClose: WriteBuffer(cSlashCloseTag);
end;
end; procedure TXMLWriter.WriteBuffer(const Buffer: PChar);
var
P: PChar;
begin
P := Buffer;
while P^ <> #0 do begin
(FBuffer + FLength)^ := P^;
Inc(FLength);
if FLength >= FCapacity then
Grow;
Inc(P);
end;
end; procedure TXMLWriter.WriteChar(const Value: Char);
begin
(FBuffer + FLength)^ := Value;
Inc(FLength);
if FLength >= FCapacity then
Grow;
end; procedure TXMLWriter.WriteValue(const Buffer: PChar);
const
clt = '%lt;';
cgt = '%gt;';
cmp = '&';
cqt = '"';
var
P: PChar;
n : Integer;
begin
P := Buffer;
while P^ <> #0 do
begin
case P^ of
'<':
begin
WriteBuffer(clt);
Inc(P);
end;
'>':
begin
WriteBuffer(cgt);
Inc(P);
end;
'&':
begin
WriteBuffer(cmp);
Inc(P);
end;
'"':
begin
WriteBuffer(cqt);
Inc(P);
end
else
begin
(FBuffer + FLength)^ := P^;
Inc(FLength);
if FLength = FCapacity then
Grow;
Inc(P);
end;
end
end;
end; end.
procedure TForm1.btn1Click(Sender: TObject);
const
c1:PChar = 'root';
c2:PChar = 'chs';
c3:PChar = 'i';
c4:PChar = 'chd';
c5:PChar = 'n'; var
xWriter : TXMLWriter;
i, j : Integer;
p : PChar;
begin
xWriter := TXMLWriter.Create(xsYes);
try
xWriter.OpenElement(c1, xtClose);
for i := 0 to 10000 do
begin
xWriter.OpenElement(c2, xtNone);
p := PChar(IntToStr(i));
xWriter.WriteAttribute(c3, p, xtClose); for j := 0 to 50 do
begin
xWriter.OpenElement(c4, xtNone);
p := PChar(IntToStr(j));
xWriter.WriteAttribute(c5, p, xtClose);
xWriter.CloseElement(c4);
end;
xWriter.CloseElement(c2);
end;
xWriter.CloseElement(c1); ShowMessage('ok');
finally
xWriter.Free;
end;
end;
unit XMLWriter; interface uses
Classes, SysUtils; type TXmlStandalone = (xsOmit, xsYes, xsNo); TXmlCloseTag = (xtNone, xtClose, xtSlashClose); TXMLWriter = class
private
FBuffer: PChar;
FCursor: PChar;
FLast: PChar;
procedure MoveCursor(Delta: Integer);
procedure Grow;
public
constructor Create(const Standalone: TXmlStandalone);
destructor Destroy; override;
procedure WriteValue(const pValue: PChar);
procedure OpenElement(const pName: PChar; const CloseTag: TXmlCloseTag);
procedure WriteElement(const pName, pValue: PChar);
procedure WriteAttribute(const pName, pValue: PChar; const CloseTag: TXmlCloseTag); overload;
procedure WriteBuffer(const pBuffer: PChar);
procedure WriteChar(const pValue: Char);
procedure CloseElement(const pName: PChar);
procedure CloseDocument;
procedure SaveToFile(const FileName: string);
procedure SaveToStream(const Stream: TStream);
property Buffer: PChar read FBuffer;
end; implementation uses Math, Windows; const cOpenTag: Char = '<';
cCloseTag: Char = '>';
cSlash: Char = '/';
cOpenSlashTag: PChar = '</';
cSlashCloseTag: PChar = '/>';
cSpace: Char = ' ';
cEquality: Char = '=';
cApostrophe: Char = '"';
cEqualApos: PChar = '="';
clt: PChar = '%lt;';
cgt: PChar = '%gt;';
cmp: PChar = '&';
cqt: PChar = '"'; cXml = '<?xml version="1.0" encoding="UTF-8" standalone="%s" ?>';
cStandalones: array [TXmlStandalone] of string = ('omit', 'yes', 'no'); { TXMLWriter } constructor TXMLWriter.Create(const Standalone: TXmlStandalone);
begin
// init mem
FBuffer := GlobalAllocPtr(HeapAllocFlags, $100);
FCursor := FBuffer;
FLast := FCursor + $100; // xml declarations
WriteBuffer(PChar(Format(cXml, [cStandalones[Standalone]])));
end; destructor TXMLWriter.Destroy;
begin
GlobalFreePtr(FBuffer);
FCursor := nil;
FLast := nil;
FBuffer := nil;
inherited Destroy;
end; procedure TXMLWriter.OpenElement(const pName: PChar;
const CloseTag: TXmlCloseTag);
begin
WriteChar(cOpenTag);
WriteBuffer(pName);
case CloseTag of
xtClose:
WriteChar(cCloseTag);
xtSlashClose:
WriteBuffer(cSlashCloseTag);
end;
end; procedure TXMLWriter.CloseElement(const pName: PChar);
begin
WriteBuffer(cOpenSlashTag);
WriteBuffer(pName);
WriteChar(cCloseTag);
end; procedure TXMLWriter.WriteElement(const pName, pValue: PChar);
begin
OpenElement(pName, xtClose);
if pValue <> nil then
begin
WriteValue(pValue);
CloseElement(pName);
end
else
WriteBuffer(cSlashCloseTag);
end; procedure TXMLWriter.WriteAttribute(const pName, pValue: PChar;
const CloseTag: TXmlCloseTag);
begin
WriteChar(cSpace);
WriteBuffer(pName);
WriteBuffer(cEqualApos);
WriteValue(pValue);
WriteChar(cApostrophe);
case CloseTag of
xtClose:
WriteChar(cCloseTag);
xtSlashClose:
WriteBuffer(cSlashCloseTag);
end;
end; procedure TXMLWriter.WriteBuffer(const pBuffer: PChar);
var
P: PChar;
begin
P := pBuffer;
while P^ <> #0 do
begin
FCursor^ := P^;
MoveCursor(1);
Inc(P);
end;
end; procedure TXMLWriter.WriteChar(const pValue: Char);
begin
FCursor^ := pValue;
MoveCursor(1);
end; procedure TXMLWriter.WriteValue(const pValue: PChar);
var
P: PChar;
n: Integer;
begin
P := pValue;
while P^ <> #0 do
begin
case P^ of
'<':
begin
WriteBuffer(clt);
Inc(P);
end;
'>':
begin
WriteBuffer(cgt);
Inc(P);
end;
'&':
begin
WriteBuffer(cmp);
Inc(P);
end;
'"':
begin
WriteBuffer(cqt);
Inc(P);
end
else
begin
FCursor^ := P^;
MoveCursor(1);
Inc(P);
end;
end
end;
end; procedure TXMLWriter.Grow;
var
Cursor, Capacity: Integer;
begin
Cursor := LongInt(FCursor - FBuffer);
Capacity := LongInt(FLast - FBuffer);
Capacity := Capacity + (Capacity div 4);
FBuffer := GlobalReallocPtr(FBuffer, Capacity, HeapAllocFlags);
FLast := FBuffer + Capacity;
FCursor := FBuffer + Cursor;
end; procedure TXMLWriter.MoveCursor(Delta: Integer);
begin
Inc(FCursor, Delta);
if FCursor = FLast then
Grow
end; procedure TXMLWriter.SaveToFile(const FileName: string);
var
FileStream: TFileStream;
begin
FileStream := TFileStream.Create(FileName, fmCreate);
try
SaveToStream(FileStream);
finally
FileStream.Free;
end;
end; procedure TXMLWriter.SaveToStream(const Stream: TStream);
var
DataString: UTF8String;
begin
DataString := UTF8Encode(Buffer);
Stream.Write(DataString[1], Length(DataString));
end; procedure TXMLWriter.CloseDocument;
var
Cursor: Integer;
Capacity: Integer;
begin
if FCursor < FLast then
begin
Cursor := LongInt(FCursor - FBuffer);
Capacity := (Cursor + $1FFF) and not $1FFF;
FBuffer := GlobalReallocPtr(FBuffer, Capacity, HeapAllocFlags);
FLast := FBuffer + Capacity;
FCursor := FBuffer + Cursor;
end;
FCursor^ := #0;
end; end.
procedure TForm1.btn1Click(Sender: TObject);
var
x : TXMLWriter;
i, j : Integer;
p : PChar;
tc : Integer;
begin
x := TXMLWriter.Create(xsYes);
try
tc := GetTickCount; x.OpenElement(c1, xtClose);
for i := 0 to 850254 do
begin
x.OpenElement(c2, xtNone);
x.WriteAttribute(c3, PChar(IntToStr(i)), xtClose); for j := 0 to 24 do
begin
x.OpenElement(c4, xtNone);
x.WriteAttribute(c5, PChar(IntToStr(j)), xtClose);
x.CloseElement(c4);
end; x.CloseElement(c2);
end;
x.CloseElement(c1);
x.CloseDocument; ShowMessage(IntToStr(GetTickCount - tc)); x.SaveToFile('c:\test.xml');
finally
x.Free;
end;
end;
type
Test = record
a: Int64;
end; var
Struct: Test; ...
Struct.a := 10;
for i := 0 to 10000000 - 1 do
begin
inc(Struct.a, 10 * 1);
inc(Struct.a, 10 * 2);
inc(Struct.a, 10 * 3);
inc(Struct.a, 10 * 4);
inc(Struct.a, 10 * 5);
end;
Value.SetInt64(10);
for i := 0 to 10000000 - 1 do
begin
Value.SetValuePlus(10 * 1);
Value.SetValuePlus(10 * 2);
Value.SetValuePlus(10 * 3);
Value.SetValuePlus(10 * 4);
Value.SetValuePlus(10 * 5);
end;
procedure SBox.free;
begin
case _Type of
SUInt8:
TByte := 0;
SUInt16:
TWord := 0;
SUInt32:
TCardinal := 0;
SUInt64:
TUInt64 := 0;
SInt8:
TShortInt := 0;
SInt16:
TSmallInt := 0;
SInt32:
TInteger := 0;
SInt64:
begin
Dispose(TInt64);
TInt64 := nil;
end;
SSingle:
TSingle := 0;
SDouble:
TDouble := 0;
SExtended:
begin
Dispose(TExtended);
TExtended := nil;
end;
SCurrency:
TCurrency := 0;
SPointer:
TPointer := nil;
end;
_Type := SNULL;
end;
unit ValueBox; interface uses Utils; const
SNULL = 0;
SString = 1;
SUInt8 = 2;
SUInt16 = 3;
SUInt32 = 4;
SUInt64 = 5;
SInt8 = 6;
SInt16 = 7;
SInt32 = 8;
SInt64 = 9;
SSingle = 10;
SDouble = 11;
SExtended = 12;
SCurrency = 13;
SPointer = 14; type
SBox = packed record
_Type: Byte; procedure StringSet(const value: string); inline; procedure StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string; const value5: string;
const value6: string; const value7: string; const value8: string;
const value9: string; const value10: string); overload; inline;
procedure StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string; const value5: string;
const value6: string; const value7: string; const value8: string;
const value9: string); overload; inline;
procedure StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string; const value5: string;
const value6: string; const value7: string; const value8: string);
overload; inline;
procedure StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string; const value5: string;
const value6: string; const value7: string); overload; inline;
procedure StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string; const value5: string;
const value6: string); overload; inline;
procedure StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string; const value5: string);
overload; inline;
procedure StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string); overload; inline;
procedure StringAdd(const value1: string; const value2: string;
const value3: string); overload; inline;
procedure StringAdd(const value1: string; const value2: string);
overload; inline;
procedure StringAdd(const value1: string); overload; inline; // Вернёт длину и строку только для строки
function StringLen(): integer; inline;
function StringGet(): UnicodeString; inline; // Вернёт длину и строку для каждого типа
function GetValueLen(): integer; inline;
function GetValueString(): UnicodeString; inline; procedure SetByte(value: Byte); inline;
procedure SetWord(value: Word); inline;
procedure SetCardinal(value: Cardinal); inline;
procedure SetUInt64(value: UInt64); inline;
procedure SetShortInt(value: ShortInt); inline;
procedure SetSmallInt(value: SmallInt); inline;
procedure SetInteger(value: integer); inline;
procedure SetInt64(value: Int64); inline;
procedure SetSingle(value: Single); inline;
procedure SetDouble(value: Double); inline;
procedure SetExtended(value: Extended); inline;
procedure SetCurrency(value: Currency); inline;
procedure SetPointer(value: Pointer); inline; procedure SetValue(value: Byte); overload; inline;
procedure SetValue(value: Word); overload; inline;
procedure SetValue(value: Cardinal); overload; inline;
procedure SetValue(value: UInt64); overload; inline;
procedure SetValue(value: ShortInt); overload; inline;
procedure SetValue(value: SmallInt); overload; inline;
procedure SetValue(value: integer); overload; inline;
procedure SetValue(value: Int64); overload; inline;
procedure SetValue(value: Single); overload; inline;
procedure SetValue(value: Double); overload; inline;
procedure SetValue(value: Extended); overload; inline;
procedure SetValue(value: Currency); overload; inline;
procedure SetValue(value: Pointer); overload; inline; function GetByte: Byte; inline;
function GetWord: Word; inline;
function GetCardinal: Cardinal; inline;
function GetUInt64: UInt64; inline;
function GetShortInt: ShortInt; inline;
function GetSmallInt: SmallInt; inline;
function GetInteger: integer; inline;
function GetInt64: Int64; inline;
function GetSingle: Single; inline;
function GetDouble: Double; inline;
function GetExtended: Extended; inline;
function GetCurrency: Currency; inline;
function GetPointer: Pointer; inline; function IsEqual(value: Byte): Boolean; overload; inline;
function IsEqual(value: Word): Boolean; overload; inline;
function IsEqual(value: Cardinal): Boolean; overload; inline;
function IsEqual(value: UInt64): Boolean; overload; inline;
function IsEqual(value: ShortInt): Boolean; overload; inline;
function IsEqual(value: SmallInt): Boolean; overload; inline;
function IsEqual(value: integer): Boolean; overload; inline;
function IsEqual(value: Int64): Boolean; overload; inline;
function IsEqual(value: Single): Boolean; overload; inline;
function IsEqual(value: Double): Boolean; overload; inline;
function IsEqual(value: Extended): Boolean; overload; inline;
function IsEqual(value: Currency): Boolean; overload; inline;
function IsEqual(value: Pointer): Boolean; overload; inline; function IsNULL: Boolean; inline;
function IsByte: Boolean; inline;
function IsWord: Boolean; inline;
function IsCardinal: Boolean; inline;
function IsUInt64: Boolean; inline;
function IsShortInt: Boolean; inline;
function IsSmallInt: Boolean; inline;
function IsInteger: Boolean; inline;
function IsInt64: Boolean; inline;
function IsSingle: Boolean; inline;
function IsDouble: Boolean; inline;
function IsExtended: Boolean; inline;
function IsCurrency: Boolean; inline;
function IsPointer: Boolean; inline; function GetType: Byte; inline; procedure SetNull; inline; procedure SetValuePlus(value: Byte); overload; inline;
procedure SetValuePlus(value: Word); overload; inline;
procedure SetValuePlus(value: Cardinal); overload; inline;
procedure SetValuePlus(value: UInt64); overload; inline;
procedure SetValuePlus(value: ShortInt); overload; inline;
procedure SetValuePlus(value: SmallInt); overload; inline;
procedure SetValuePlus(value: integer); overload; inline;
procedure SetValuePlus(value: Int64); overload; inline;
procedure SetValuePlus(value: Single); overload; inline;
procedure SetValuePlus(value: Double); overload; inline;
procedure SetValuePlus(value: Extended); overload; inline;
procedure SetValuePlus(value: Currency); overload; inline;
procedure SetValuePlus(value: Pointer); overload; inline; procedure SetValueMinus(value: Byte); overload; inline;
procedure SetValueMinus(value: Word); overload; inline;
procedure SetValueMinus(value: Cardinal); overload; inline;
procedure SetValueMinus(value: UInt64); overload; inline;
procedure SetValueMinus(value: ShortInt); overload; inline;
procedure SetValueMinus(value: SmallInt); overload; inline;
procedure SetValueMinus(value: integer); overload; inline;
procedure SetValueMinus(value: Int64); overload; inline;
procedure SetValueMinus(value: Single); overload; inline;
procedure SetValueMinus(value: Double); overload; inline;
procedure SetValueMinus(value: Extended); overload; inline;
procedure SetValueMinus(value: Currency); overload; inline;
procedure SetValueMinus(value: Pointer); overload; inline; procedure SetValueDIV(value: Byte); overload; inline;
procedure SetValueDIV(value: Word); overload; inline;
procedure SetValueDIV(value: Cardinal); overload; inline;
procedure SetValueDIV(value: UInt64); overload; inline;
procedure SetValueDIV(value: ShortInt); overload; inline;
procedure SetValueDIV(value: SmallInt); overload; inline;
procedure SetValueDIV(value: integer); overload; inline;
procedure SetValueDIV(value: Int64); overload; inline;
procedure SetValueDIV(value: Single); overload; inline;
procedure SetValueDIV(value: Double); overload; inline;
procedure SetValueDIV(value: Extended); overload; inline;
procedure SetValueDIV(value: Currency); overload; inline;
procedure SetValueDIV(value: Pointer); overload; inline; procedure SetValueMUL(value: Byte); overload; inline;
procedure SetValueMUL(value: Word); overload; inline;
procedure SetValueMUL(value: Cardinal); overload; inline;
procedure SetValueMUL(value: UInt64); overload; inline;
procedure SetValueMUL(value: ShortInt); overload; inline;
procedure SetValueMUL(value: SmallInt); overload; inline;
procedure SetValueMUL(value: integer); overload; inline;
procedure SetValueMUL(value: Int64); overload; inline;
procedure SetValueMUL(value: Single); overload; inline;
procedure SetValueMUL(value: Double); overload; inline;
procedure SetValueMUL(value: Extended); overload; inline;
procedure SetValueMUL(value: Currency); overload; inline;
procedure SetValueMUL(value: Pointer); overload; inline; procedure SetValueMOD(value: Byte); overload; inline;
procedure SetValueMOD(value: Word); overload; inline;
procedure SetValueMOD(value: Cardinal); overload; inline;
procedure SetValueMOD(value: UInt64); overload; inline;
procedure SetValueMOD(value: ShortInt); overload; inline;
procedure SetValueMOD(value: SmallInt); overload; inline;
procedure SetValueMOD(value: integer); overload; inline;
procedure SetValueMOD(value: Int64); overload; inline;
procedure SetValueMOD(value: Single); overload; inline;
procedure SetValueMOD(value: Double); overload; inline;
procedure SetValueMOD(value: Extended); overload; inline;
procedure SetValueMOD(value: Currency); overload; inline;
procedure SetValueMOD(value: Pointer); overload; inline; procedure SetValuePOW(value: Byte); overload; inline;
procedure SetValuePOW(value: Word); overload; inline;
procedure SetValuePOW(value: Cardinal); overload; inline;
procedure SetValuePOW(value: UInt64); overload; inline;
procedure SetValuePOW(value: ShortInt); overload; inline;
procedure SetValuePOW(value: SmallInt); overload; inline;
procedure SetValuePOW(value: integer); overload; inline;
procedure SetValuePOW(value: Int64); overload; inline;
procedure SetValuePOW(value: Single); overload; inline;
procedure SetValuePOW(value: Double); overload; inline;
procedure SetValuePOW(value: Extended); overload; inline;
procedure SetValuePOW(value: Currency); overload; inline;
procedure SetValuePOW(value: Pointer); overload; inline; procedure free; inline; case Byte of
SUInt8:
(TByte: Byte);
SUInt16:
(TWord: Word);
SUInt32:
(TCardinal: Cardinal);
SUInt64:
(TUInt64: UInt64);
SInt8:
(TShortInt: ShortInt);
SInt16:
(TSmallInt: SmallInt);
SInt32:
(TInteger: integer);
SInt64:
(TInt64: PInt64);
SSingle:
(TSingle: Single);
SDouble:
(TDouble: Double);
SExtended:
(TExtended: PExtended);
SCurrency:
(TCurrency: Currency);
SPointer:
(TPointer: Pointer);
SString:
(TStrBox: ^TByteArray);
end; implementation procedure SBox.SetByte(value: Byte);
begin
if _Type <> SUInt8 then
_Type := SUInt8;
TByte := value;
end; procedure SBox.SetWord(value: Word);
begin
if _Type <> SUInt16 then
_Type := SUInt16;
TWord := value;
end; procedure SBox.SetCardinal(value: Cardinal);
begin
if _Type <> SUInt32 then
_Type := SUInt32;
TCardinal := value;
end; procedure SBox.SetUInt64(value: UInt64);
begin
if _Type <> SUInt64 then
_Type := SUInt64;
TUInt64 := value;
end; procedure SBox.SetShortInt(value: ShortInt);
begin
if _Type <> SInt8 then
_Type := SInt8;
TShortInt := value;
end; procedure SBox.SetSmallInt(value: SmallInt);
begin
if _Type <> SInt16 then
_Type := SInt16;
TSmallInt := value;
end; procedure SBox.SetInteger(value: integer);
begin
if _Type <> SInt32 then
_Type := SInt32;
TInteger := value;
end; procedure SBox.SetInt64(value: Int64);
begin
if _Type = SInt64 then
TInt64^ := value
else if _Type = SExtended then
begin
Dispose(TExtended);
New(TInt64);
TInt64^ := value;
_Type := SInt64;
end
else
begin
New(TInt64);
TInt64^ := value;
_Type := SInt64;
end;
end; procedure SBox.SetSingle(value: Single);
begin
if _Type <> SSingle then
_Type := SSingle;
TSingle := value;
end; procedure SBox.SetDouble(value: Double);
begin
if _Type <> SDouble then
_Type := SDouble;
TDouble := value;
end; procedure SBox.SetExtended(value: Extended);
begin
if _Type = SExtended then
TExtended^ := value
else if _Type = SInt64 then
begin
Dispose(TInt64);
New(TExtended);
TExtended^ := value;
_Type := SExtended;
end
else
begin
New(TExtended);
TExtended^ := value;
_Type := SExtended;
end;
end; procedure SBox.SetCurrency(value: Currency);
begin
if _Type <> SCurrency then
_Type := SCurrency;
TCurrency := value;
end; procedure SBox.SetPointer(value: Pointer);
begin
if _Type <> SPointer then
_Type := SPointer;
TPointer := value;
end; procedure SBox.SetValue(value: Byte);
begin
SetByte(value);
end; procedure SBox.SetValue(value: Word);
begin
SetWord(value);
end; procedure SBox.SetValue(value: Cardinal);
begin
SetCardinal(value);
end; procedure SBox.SetValue(value: UInt64);
begin
SetUInt64(value);
end; procedure SBox.SetValue(value: ShortInt);
begin
SetShortInt(value);
end; procedure SBox.SetValue(value: SmallInt);
begin
SetSmallInt(value);
end; procedure SBox.SetValue(value: integer);
begin
SetInteger(value);
end; procedure SBox.SetValue(value: Int64);
begin
SetInt64(value);
end; procedure SBox.SetValue(value: Single);
begin
SetSingle(value);
end; procedure SBox.SetValue(value: Double);
begin
SetDouble(value);
end; procedure SBox.SetValue(value: Extended);
begin
SetExtended(value);
end; procedure SBox.SetValue(value: Currency);
begin
SetCurrency(value);
end; procedure SBox.SetValue(value: Pointer);
begin
SetPointer(value);
end; function SBox.IsEqual(value: Byte): Boolean;
begin
Result := GetByte = value;
end; function SBox.IsEqual(value: Word): Boolean;
begin
Result := GetWord = value;
end; function SBox.IsEqual(value: Cardinal): Boolean;
begin
Result := GetCardinal = value;
end; function SBox.IsEqual(value: UInt64): Boolean;
begin
Result := GetUInt64 = value;
end; function SBox.IsEqual(value: ShortInt): Boolean;
begin
Result := GetShortInt = value;
end; function SBox.IsEqual(value: SmallInt): Boolean;
begin
Result := GetSmallInt = value;
end; function SBox.IsEqual(value: integer): Boolean;
begin
Result := GetInteger = value;
end; function SBox.IsEqual(value: Int64): Boolean;
begin
Result := GetInt64 = value;
end; function SBox.IsEqual(value: Single): Boolean;
begin
Result := GetSingle = value;
end; function SBox.IsEqual(value: Double): Boolean;
begin
Result := GetDouble = value;
end; function SBox.IsEqual(value: Extended): Boolean;
begin
Result := GetExtended = value;
end; function SBox.IsEqual(value: Currency): Boolean;
begin
Result := GetCurrency = value;
end; function SBox.IsEqual(value: Pointer): Boolean;
begin
Result := GetPointer = value;
end; function SBox.IsByte: Boolean;
begin
Result := _Type = SUInt8;
end; function SBox.IsWord: Boolean;
begin
Result := _Type = SUInt16;
end; function SBox.IsCardinal: Boolean;
begin
Result := _Type = SUInt32;
end; function SBox.IsUInt64: Boolean;
begin
Result := _Type = SUInt64;
end; function SBox.IsShortInt: Boolean;
begin
Result := _Type = SInt8;
end; function SBox.IsSmallInt: Boolean;
begin
Result := _Type = SInt16;
end; function SBox.IsInteger: Boolean;
begin
Result := _Type = SInt32;
end; function SBox.IsInt64: Boolean;
begin
Result := _Type = SInt64;
end; function SBox.IsSingle: Boolean;
begin
Result := _Type = SSingle;
end; function SBox.IsDouble: Boolean;
begin
Result := _Type = SDouble;
end; function SBox.IsExtended: Boolean;
begin
Result := _Type = SExtended;
end; function SBox.IsCurrency: Boolean;
begin
Result := _Type = SCurrency;
end; function SBox.IsPointer: Boolean;
begin
Result := _Type = SPointer;
end; procedure SBox.SetNull;
begin
case _Type of
SUInt8:
TByte := 0;
SUInt16:
TWord := 0;
SUInt32:
TCardinal := 0;
SUInt64:
TUInt64 := 0;
SInt8:
TShortInt := 0;
SInt16:
TSmallInt := 0;
SInt32:
TInteger := 0;
SInt64:
TInt64^ := 0;
SSingle:
TSingle := 0;
SDouble:
TDouble := 0;
SExtended:
TExtended^ := 0;
SCurrency:
TCurrency := 0;
SPointer:
TPointer := nil;
end;
_Type := SNULL;
end; procedure SBox.StringSet(const value: string);
begin
if TStrBox = nil then
begin
New(TStrBox);
SetLength(TStrBox^, SizeOf(value));
end
else if PUnicodeString(@TStrBox^[0])^ = value then
Exit; if _Type <> SString then
_Type := SString; CopyArray(@TStrBox^[0], @value, System.TypeInfo(string), 1);
end; procedure SBox.StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string; const value5: string;
const value6: string; const value7: string; const value8: string;
const value9: string; const value10: string);
var
S: PUnicodeString;
begin
if _Type <> SString then
_Type := SString; if TStrBox = nil then
StringSet(''); S := PUnicodeString(@TStrBox^[0]);
S^ := S^ + value1;
S^ := S^ + value2;
S^ := S^ + value3;
S^ := S^ + value4;
S^ := S^ + value5;
S^ := S^ + value6;
S^ := S^ + value7;
S^ := S^ + value8;
S^ := S^ + value9;
S^ := S^ + value10;
end; procedure SBox.StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string; const value5: string;
const value6: string; const value7: string; const value8: string;
const value9: string);
var
S: PUnicodeString;
begin
if _Type <> SString then
_Type := SString; if TStrBox = nil then
StringSet(''); S := PUnicodeString(@TStrBox^[0]);
S^ := S^ + value1;
S^ := S^ + value2;
S^ := S^ + value3;
S^ := S^ + value4;
S^ := S^ + value5;
S^ := S^ + value6;
S^ := S^ + value7;
S^ := S^ + value8;
S^ := S^ + value9;
end; procedure SBox.StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string; const value5: string;
const value6: string; const value7: string; const value8: string);
var
S: PUnicodeString;
begin
if _Type <> SString then
_Type := SString; if TStrBox = nil then
StringSet(''); S := PUnicodeString(@TStrBox^[0]);
S^ := S^ + value1;
S^ := S^ + value2;
S^ := S^ + value3;
S^ := S^ + value4;
S^ := S^ + value5;
S^ := S^ + value6;
S^ := S^ + value7;
S^ := S^ + value8;
end; procedure SBox.StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string; const value5: string;
const value6: string; const value7: string);
var
S: PUnicodeString;
begin
if _Type <> SString then
_Type := SString; if TStrBox = nil then
StringSet(''); S := PUnicodeString(@TStrBox^[0]);
S^ := S^ + value1;
S^ := S^ + value2;
S^ := S^ + value3;
S^ := S^ + value4;
S^ := S^ + value5;
S^ := S^ + value6;
S^ := S^ + value7;
end; procedure SBox.StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string; const value5: string;
const value6: string);
var
S: PUnicodeString;
begin
if _Type <> SString then
_Type := SString; if TStrBox = nil then
StringSet(''); S := PUnicodeString(@TStrBox^[0]);
S^ := S^ + value1;
S^ := S^ + value2;
S^ := S^ + value3;
S^ := S^ + value4;
S^ := S^ + value5;
S^ := S^ + value6;
end; procedure SBox.StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string; const value5: string);
var
S: PUnicodeString;
begin
if _Type <> SString then
_Type := SString; if TStrBox = nil then
StringSet(''); S := PUnicodeString(@TStrBox^[0]);
S^ := S^ + value1;
S^ := S^ + value2;
S^ := S^ + value3;
S^ := S^ + value4;
S^ := S^ + value5;
end; procedure SBox.StringAdd(const value1: string; const value2: string;
const value3: string; const value4: string);
var
S: PUnicodeString;
begin
if _Type <> SString then
_Type := SString; if TStrBox = nil then
StringSet(''); S := PUnicodeString(@TStrBox^[0]);
S^ := S^ + value1;
S^ := S^ + value2;
S^ := S^ + value3;
S^ := S^ + value4;
end; procedure SBox.StringAdd(const value1: string; const value2: string;
const value3: string);
var
S: PUnicodeString;
begin
if _Type <> SString then
_Type := SString; if TStrBox = nil then
StringSet(''); S := PUnicodeString(@TStrBox^[0]);
S^ := S^ + value1;
S^ := S^ + value2;
S^ := S^ + value3;
end; procedure SBox.StringAdd(const value1: string; const value2: string);
var
S: PUnicodeString;
begin
if _Type <> SString then
_Type := SString; if TStrBox = nil then
StringSet(''); S := PUnicodeString(@TStrBox^[0]);
S^ := S^ + value1;
S^ := S^ + value2;
end; procedure SBox.StringAdd(const value1: string);
var
S: PUnicodeString;
begin
if _Type <> SString then
_Type := SString; if TStrBox = nil then
StringSet(''); S := PUnicodeString(@TStrBox^[0]);
S^ := S^ + value1;
end; function SBox.StringGet(): UnicodeString;
begin
if _Type = SString then
Exit(PUnicodeString(@TStrBox^[0])^);
Exit('');
end; function SBox.GetValueString(): UnicodeString;
begin case _Type of
SInt8:
Exit(Utils.IntToStr(TShortInt));
SInt16:
Exit(Utils.IntToStr(TSmallInt));
SUInt8:
Exit(Utils.IntToStr(TByte));
SUInt16:
Exit(Utils.IntToStr(TWord));
SUInt32:
Exit(Utils.IntToStr(TCardinal));
SUInt64:
Exit(Utils.IntToStr(TUInt64));
SString:
begin
if TStrBox = nil then
Exit(''); Exit(PUnicodeString(@TStrBox^[0])^);
end;
SInt32:
Exit(Utils.IntToStr(TInteger));
SInt64:
Exit(Utils.IntToStr(TInt64^));
SSingle:
Exit(FloatToStr(TSingle, DefaultFormatSettings));
SDouble:
Exit(FloatToStr(TDouble, DefaultFormatSettings));
SExtended:
Exit(FloatToStr(TExtended^, DefaultFormatSettings));
SCurrency:
Exit(FloatToStr(TCurrency, DefaultFormatSettings));
SPointer:
Exit('@Pointer(' + Utils.IntToStr(IntPtr(TPointer)) + ')');
else
Exit('');
end;
end; function SBox.StringLen(): integer;
var
S: PUnicodeString;
begin
if _Type = SString then
begin
if TStrBox <> nil then
begin
S := PUnicodeString(@TStrBox^[0]);
if S^ <> '' then
Exit(PInteger(PByte(S^) - 4)^);
end;
end;
Exit(0);
end; function SBox.GetValueLen(): integer;
begin
Result := PInteger(PByte(GetValueString()) - 4)^
end; function SBox.GetType: Byte;
begin
Result := _Type;
end; function SBox.IsNULL: Boolean;
begin
Result := _Type = SNULL;
end; function SBox.GetByte: Byte;
begin
case _Type of SUInt8:
Exit(TByte);
SUInt16:
Exit(TWord);
SUInt32:
Exit(TCardinal);
SUInt64:
Exit(TUInt64);
SInt8:
Exit(TShortInt);
SInt16:
Exit(TSmallInt);
SInt32:
Exit(TInteger);
SInt64:
Exit(TInt64^);
SSingle:
Exit(Byte(Round(TSingle)));
SDouble:
Exit(Byte(Round(TDouble)));
SExtended:
Exit(Byte(Round(TExtended^)));
SCurrency:
Exit(Byte(Round(TCurrency)));
SPointer:
Exit(IntPtr(TPointer));
end;
Exit(0);
end; function SBox.GetWord: Word;
begin
case _Type of SUInt8:
Exit(TByte);
SUInt16:
Exit(TWord);
SUInt32:
Exit(TCardinal);
SUInt64:
Exit(TUInt64);
SInt8:
Exit(TShortInt);
SInt16:
Exit(TSmallInt);
SInt32:
Exit(TInteger);
SInt64:
Exit(TInt64^);
SSingle:
Exit(Word(Round(TSingle)));
SDouble:
Exit(Word(Round(TDouble)));
SExtended:
Exit(Word(Round(TExtended^)));
SCurrency:
Exit(Word(Round(TCurrency)));
SPointer:
Exit(IntPtr(TPointer));
end;
Exit(0);
end; function SBox.GetCardinal: Cardinal;
begin
case _Type of SUInt8:
Exit(TByte);
SUInt16:
Exit(TWord);
SUInt32:
Exit(TCardinal);
SUInt64:
Exit(TUInt64);
SInt8:
Exit(TShortInt);
SInt16:
Exit(TSmallInt);
SInt32:
Exit(TInteger);
SInt64:
Exit(TInt64^);
SSingle:
Exit(Cardinal(Round(TSingle)));
SDouble:
Exit(Cardinal(Round(TDouble)));
SExtended:
Exit(Cardinal(Round(TExtended^)));
SCurrency:
Exit(Cardinal(Round(TCurrency)));
SPointer:
Exit(IntPtr(TPointer));
end;
Exit(0);
end; function SBox.GetUInt64: UInt64;
begin
case _Type of SUInt8:
Exit(TByte);
SUInt16:
Exit(TWord);
SUInt32:
Exit(TCardinal);
SUInt64:
Exit(TUInt64);
SInt8:
Exit(TShortInt);
SInt16:
Exit(TSmallInt);
SInt32:
Exit(TInteger);
SInt64:
Exit(TInt64^);
SSingle:
Exit(UInt64(Round(TSingle)));
SDouble:
Exit(UInt64(Round(TDouble)));
SExtended:
Exit(UInt64(Round(TExtended^)));
SCurrency:
Exit(UInt64(Round(TCurrency)));
SPointer:
Exit(IntPtr(TPointer));
end;
Exit(0);
end; function SBox.GetShortInt: ShortInt;
begin
case _Type of SUInt8:
Exit(TByte);
SUInt16:
Exit(TWord);
SUInt32:
Exit(TCardinal);
SUInt64:
Exit(TUInt64);
SInt8:
Exit(TShortInt);
SInt16:
Exit(TSmallInt);
SInt32:
Exit(TInteger);
SInt64:
Exit(TInt64^);
SSingle:
Exit(ShortInt(Round(TSingle)));
SDouble:
Exit(ShortInt(Round(TDouble)));
SExtended:
Exit(ShortInt(Round(TExtended^)));
SCurrency:
Exit(ShortInt(Round(TCurrency)));
SPointer:
Exit(IntPtr(TPointer));
end;
Exit(0);
end; function SBox.GetSmallInt: SmallInt;
begin
case _Type of SUInt8:
Exit(TByte);
SUInt16:
Exit(TWord);
SUInt32:
Exit(TCardinal);
SUInt64:
Exit(TUInt64);
SInt8:
Exit(TShortInt);
SInt16:
Exit(TSmallInt);
SInt32:
Exit(TInteger);
SInt64:
Exit(TInt64^);
SSingle:
Exit(SmallInt(Round(TSingle)));
SDouble:
Exit(SmallInt(Round(TDouble)));
SExtended:
Exit(SmallInt(Round(TExtended^)));
SCurrency:
Exit(SmallInt(Round(TCurrency)));
SPointer:
Exit(IntPtr(TPointer));
end;
Exit(0);
end; function SBox.GetInteger: integer;
begin
case _Type of SUInt8:
Exit(TByte);
SUInt16:
Exit(TWord);
SUInt32:
Exit(TCardinal);
SUInt64:
Exit(TUInt64);
SInt8:
Exit(TShortInt);
SInt16:
Exit(TSmallInt);
SInt32:
Exit(TInteger);
SInt64:
Exit(TInt64^);
SSingle:
Exit(integer(Round(TSingle)));
SDouble:
Exit(integer(Round(TDouble)));
SExtended:
Exit(integer(Round(TExtended^)));
SCurrency:
Exit(integer(Round(TCurrency)));
SPointer:
Exit(IntPtr(TPointer));
end;
Exit(0);
end; function SBox.GetInt64: Int64;
begin
case _Type of SUInt8:
Exit(TByte);
SUInt16:
Exit(TWord);
SUInt32:
Exit(TCardinal);
SUInt64:
Exit(TUInt64);
SInt8:
Exit(TShortInt);
SInt16:
Exit(TSmallInt);
SInt32:
Exit(TInteger);
SInt64:
Exit(TInt64^);
SSingle:
Exit(Int64(Round(TSingle)));
SDouble:
Exit(Int64(Round(TDouble)));
SExtended:
Exit(Int64(Round(TExtended^)));
SCurrency:
Exit(Int64(Round(TCurrency)));
SPointer:
Exit(IntPtr(TPointer));
end;
Exit(0);
end; function SBox.GetSingle: Single;
begin
case _Type of SUInt8:
Exit(TByte);
SUInt16:
Exit(TWord);
SUInt32:
Exit(TCardinal);
SUInt64:
Exit(TUInt64);
SInt8:
Exit(TShortInt);
SInt16:
Exit(TSmallInt);
SInt32:
Exit(TInteger);
SInt64:
Exit(TInt64^);
SSingle:
Exit(TSingle);
SDouble:
Exit(TDouble);
SExtended:
Exit(TExtended^);
SCurrency:
Exit(TCurrency);
SPointer:
Exit(IntPtr(TPointer));
end;
Exit(0);
end; function SBox.GetDouble: Double;
begin
case _Type of SUInt8:
Exit(TByte);
SUInt16:
Exit(TWord);
SUInt32:
Exit(TCardinal);
SUInt64:
Exit(TUInt64);
SInt8:
Exit(TShortInt);
SInt16:
Exit(TSmallInt);
SInt32:
Exit(TInteger);
SInt64:
Exit(TInt64^);
SSingle:
Exit(TSingle);
SDouble:
Exit(TDouble);
SExtended:
Exit(TExtended^);
SCurrency:
Exit(TCurrency);
SPointer:
Exit(IntPtr(TPointer));
end;
Exit(0);
end; function SBox.GetExtended: Extended;
begin
case _Type of SUInt8:
Exit(TByte);
SUInt16:
Exit(TWord);
SUInt32:
Exit(TCardinal);
SUInt64:
Exit(TUInt64);
SInt8:
Exit(TShortInt);
SInt16:
Exit(TSmallInt);
SInt32:
Exit(TInteger);
SInt64:
Exit(TInt64^);
SSingle:
Exit(TSingle);
SDouble:
Exit(TDouble);
SExtended:
Exit(TExtended^);
SCurrency:
Exit(TCurrency);
SPointer:
Exit(IntPtr(TPointer));
end;
Exit(0);
end; function SBox.GetCurrency: Currency;
begin
case _Type of SUInt8:
Exit(TByte);
SUInt16:
Exit(TWord);
SUInt32:
Exit(TCardinal);
SUInt64:
Exit(TUInt64);
SInt8:
Exit(TShortInt);
SInt16:
Exit(TSmallInt);
SInt32:
Exit(TInteger);
SInt64:
Exit(TInt64^);
SSingle:
Exit(TSingle);
SDouble:
Exit(TDouble);
SExtended:
Exit(TExtended^);
SCurrency:
Exit(TCurrency);
SPointer:
Exit(IntPtr(TPointer));
end;
Exit(0);
end; function SBox.GetPointer: Pointer;
begin
case _Type of SUInt8:
Exit(Pointer(TByte));
SUInt16:
Exit(Pointer(TWord));
SUInt32:
Exit(Pointer(TCardinal));
SUInt64:
Exit(Pointer(TUInt64));
SInt8:
Exit(Pointer(TShortInt));
SInt16:
Exit(Pointer(TSmallInt));
SInt32:
Exit(Pointer(TInteger));
SInt64:
Exit(Pointer(TInt64^));
SSingle:
Exit(Pointer(Round(TSingle)));
SDouble:
Exit(Pointer(Round(TDouble)));
SExtended:
Exit(Pointer(Round(TExtended^)));
SCurrency:
Exit(Pointer(Round(TCurrency)));
SPointer:
Exit(Pointer(TPointer));
end;
Exit(nil);
end; procedure SBox.SetValuePlus(value: Byte);
begin
case _Type of
SUInt8:
TByte := TByte + value;
SUInt16:
TWord := TWord + value;
SUInt32:
TCardinal := TCardinal + value;
SUInt64:
TUInt64 := TUInt64 + value;
SInt8:
TShortInt := TShortInt + value;
SInt16:
TSmallInt := TSmallInt + value;
SInt32:
TInteger := TInteger + value;
SInt64:
TInt64^ := TInt64^ + value;
SSingle:
TSingle := TSingle + value;
SDouble:
TDouble := TDouble + value;
SExtended:
TExtended^ := TExtended^ + value;
SCurrency:
TCurrency := TCurrency + value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) + (value));
else
SetByte(value);
end;
end; procedure SBox.SetValuePlus(value: Word);
begin
case _Type of
SUInt8:
TByte := TByte + value;
SUInt16:
TWord := TWord + value;
SUInt32:
TCardinal := TCardinal + value;
SUInt64:
TUInt64 := TUInt64 + value;
SInt8:
TShortInt := TShortInt + value;
SInt16:
TSmallInt := TSmallInt + value;
SInt32:
TInteger := TInteger + value;
SInt64:
TInt64^ := TInt64^ + value;
SSingle:
TSingle := TSingle + value;
SDouble:
TDouble := TDouble + value;
SExtended:
TExtended^ := TExtended^ + value;
SCurrency:
TCurrency := TCurrency + value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) + (value));
else
SetWord(value);
end;
end; procedure SBox.SetValuePlus(value: Cardinal);
begin
case _Type of
SUInt8:
TByte := TByte + value;
SUInt16:
TWord := TWord + value;
SUInt32:
TCardinal := TCardinal + value;
SUInt64:
TUInt64 := TUInt64 + value;
SInt8:
TShortInt := TShortInt + value;
SInt16:
TSmallInt := TSmallInt + value;
SInt32:
TInteger := TInteger + value;
SInt64:
TInt64^ := TInt64^ + value;
SSingle:
TSingle := TSingle + value;
SDouble:
TDouble := TDouble + value;
SExtended:
TExtended^ := TExtended^ + value;
SCurrency:
TCurrency := TCurrency + value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) + (value));
else
SetCardinal(value);
end;
end; procedure SBox.SetValuePlus(value: UInt64);
begin
case _Type of
SUInt8:
TByte := TByte + value;
SUInt16:
TWord := TWord + value;
SUInt32:
TCardinal := TCardinal + value;
SUInt64:
TUInt64 := TUInt64 + value;
SInt8:
TShortInt := TShortInt + value;
SInt16:
TSmallInt := TSmallInt + value;
SInt32:
TInteger := TInteger + value;
SInt64:
TInt64^ := TInt64^ + value;
SSingle:
TSingle := TSingle + value;
SDouble:
TDouble := TDouble + value;
SExtended:
TExtended^ := TExtended^ + value;
SCurrency:
TCurrency := TCurrency + value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) + (value));
else
SetUInt64(value);
end;
end; procedure SBox.SetValuePlus(value: ShortInt);
begin
case _Type of
SUInt8:
TByte := TByte + value;
SUInt16:
TWord := TWord + value;
SUInt32:
TCardinal := TCardinal + value;
SUInt64:
TUInt64 := TUInt64 + value;
SInt8:
TShortInt := TShortInt + value;
SInt16:
TSmallInt := TSmallInt + value;
SInt32:
TInteger := TInteger + value;
SInt64:
TInt64^ := TInt64^ + value;
SSingle:
TSingle := TSingle + value;
SDouble:
TDouble := TDouble + value;
SExtended:
TExtended^ := TExtended^ + value;
SCurrency:
TCurrency := TCurrency + value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) + (value));
else
SetShortInt(value);
end;
end; procedure SBox.SetValuePlus(value: SmallInt);
begin
case _Type of
SUInt8:
TByte := TByte + value;
SUInt16:
TWord := TWord + value;
SUInt32:
TCardinal := TCardinal + value;
SUInt64:
TUInt64 := TUInt64 + value;
SInt8:
TShortInt := TShortInt + value;
SInt16:
TSmallInt := TSmallInt + value;
SInt32:
TInteger := TInteger + value;
SInt64:
TInt64^ := TInt64^ + value;
SSingle:
TSingle := TSingle + value;
SDouble:
TDouble := TDouble + value;
SExtended:
TExtended^ := TExtended^ + value;
SCurrency:
TCurrency := TCurrency + value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) + (value));
else
SetSmallInt(value);
end;
end; procedure SBox.SetValuePlus(value: integer);
begin
case _Type of
SUInt8:
TByte := TByte + value;
SUInt16:
TWord := TWord + value;
SUInt32:
TCardinal := TCardinal + value;
SUInt64:
TUInt64 := TUInt64 + value;
SInt8:
TShortInt := TShortInt + value;
SInt16:
TSmallInt := TSmallInt + value;
SInt32:
TInteger := TInteger + value;
SInt64:
TInt64^ := TInt64^ + value;
SSingle:
TSingle := TSingle + value;
SDouble:
TDouble := TDouble + value;
SExtended:
TExtended^ := TExtended^ + value;
SCurrency:
TCurrency := TCurrency + value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) + (value));
else
SetInteger(value);
end;
end; procedure SBox.SetValuePlus(value: Int64);
begin
case _Type of
SUInt8:
TByte := TByte + value;
SUInt16:
TWord := TWord + value;
SUInt32:
TCardinal := TCardinal + value;
SUInt64:
TUInt64 := TUInt64 + value;
SInt8:
TShortInt := TShortInt + value;
SInt16:
TSmallInt := TSmallInt + value;
SInt32:
TInteger := TInteger + value;
SInt64:
TInt64^ := TInt64^ + value;
SSingle:
TSingle := TSingle + value;
SDouble:
TDouble := TDouble + value;
SExtended:
TExtended^ := TExtended^ + value;
SCurrency:
TCurrency := TCurrency + value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) + (value));
else
SetInt64(value);
end;
end; procedure SBox.SetValuePlus(value: Single);
begin
case _Type of
SUInt8:
SetSingle(TByte + value);
SUInt16:
SetSingle(TWord + value);
SUInt32:
SetSingle(TCardinal + value);
SUInt64:
SetSingle(TUInt64 + value);
SInt8:
SetSingle(TShortInt + value);
SInt16:
SetSingle(TSmallInt + value);
SInt32:
SetSingle(TInteger + value);
SInt64:
SetSingle(TInt64^ + value);
SSingle:
SetSingle(TSingle + value);
SDouble:
SetDouble(TDouble + value);
SExtended:
SetExtended(TExtended^ + value);
SCurrency:
SetCurrency(TCurrency + value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) + value));
else
SetSingle(value);
end;
end; procedure SBox.SetValuePlus(value: Double);
begin
case _Type of
SUInt8:
SetDouble(TByte + value);
SUInt16:
SetDouble(TWord + value);
SUInt32:
SetDouble(TCardinal + value);
SUInt64:
SetDouble(TUInt64 + value);
SInt8:
SetDouble(TShortInt + value);
SInt16:
SetDouble(TSmallInt + value);
SInt32:
SetDouble(TInteger + value);
SInt64:
SetDouble(TInt64^ + value);
SSingle:
SetSingle(TSingle + value);
SDouble:
SetDouble(TDouble + value);
SExtended:
SetExtended(TExtended^ + value);
SCurrency:
SetCurrency(TCurrency + value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) + value));
else
SetDouble(value);
end;
end; procedure SBox.SetValuePlus(value: Extended);
begin
case _Type of
SUInt8:
SetExtended(TByte + value);
SUInt16:
SetExtended(TWord + value);
SUInt32:
SetExtended(TCardinal + value);
SUInt64:
SetExtended(TUInt64 + value);
SInt8:
SetExtended(TShortInt + value);
SInt16:
SetExtended(TSmallInt + value);
SInt32:
SetExtended(TInteger + value);
SInt64:
SetExtended(TInt64^ + value);
SSingle:
SetSingle(TSingle + value);
SDouble:
SetDouble(TDouble + value);
SExtended:
SetExtended(TExtended^ + value);
SCurrency:
SetCurrency(TCurrency + value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) + value));
else
SetExtended(value);
end;
end; procedure SBox.SetValuePlus(value: Currency);
begin
case _Type of
SUInt8:
SetCurrency(TByte + value);
SUInt16:
SetCurrency(TWord + value);
SUInt32:
SetCurrency(TCardinal + value);
SUInt64:
SetCurrency(TUInt64 + value);
SInt8:
SetCurrency(TShortInt + value);
SInt16:
SetCurrency(TSmallInt + value);
SInt32:
SetCurrency(TInteger + value);
SInt64:
SetCurrency(TInt64^ + value);
SSingle:
SetSingle(TSingle + value);
SDouble:
SetDouble(TDouble + value);
SExtended:
SetExtended(TExtended^ + value);
SCurrency:
SetCurrency(TCurrency + value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) + value));
else
SetCurrency(value);
end;
end; procedure SBox.SetValuePlus(value: Pointer);
begin
case _Type of
SUInt8:
TByte := TByte + IntPtr(value);
SUInt16:
TWord := TWord + IntPtr(value);
SUInt32:
TCardinal := TCardinal + IntPtr(value);
SUInt64:
TUInt64 := TUInt64 + IntPtr(value);
SInt8:
TShortInt := TShortInt + IntPtr(value);
SInt16:
TSmallInt := TSmallInt + IntPtr(value);
SInt32:
TInteger := TInteger + IntPtr(value);
SInt64:
TInt64^ := TInt64^ + IntPtr(value);
SSingle:
TSingle := TSingle + IntPtr(value);
SDouble:
TDouble := TDouble + IntPtr(value);
SExtended:
TExtended^ := TExtended^ + IntPtr(value);
SCurrency:
TCurrency := TCurrency + IntPtr(value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) + IntPtr(IntPtr(value)));
else
SetPointer(value);
end;
end; procedure SBox.SetValueMinus(value: Byte);
begin
case _Type of
SUInt8:
TByte := TByte - value;
SUInt16:
TWord := TWord - value;
SUInt32:
TCardinal := TCardinal - value;
SUInt64:
TUInt64 := TUInt64 - value;
SInt8:
TShortInt := TShortInt - value;
SInt16:
TSmallInt := TSmallInt - value;
SInt32:
TInteger := TInteger - value;
SInt64:
TInt64^ := TInt64^ - value;
SSingle:
TSingle := TSingle - value;
SDouble:
TDouble := TDouble - value;
SExtended:
TExtended^ := TExtended^ - value;
SCurrency:
TCurrency := TCurrency - value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) - (value));
else
SetByte(value);
end;
end; procedure SBox.SetValueMinus(value: Word);
begin
case _Type of
SUInt8:
TByte := TByte - value;
SUInt16:
TWord := TWord - value;
SUInt32:
TCardinal := TCardinal - value;
SUInt64:
TUInt64 := TUInt64 - value;
SInt8:
TShortInt := TShortInt - value;
SInt16:
TSmallInt := TSmallInt - value;
SInt32:
TInteger := TInteger - value;
SInt64:
TInt64^ := TInt64^ - value;
SSingle:
TSingle := TSingle - value;
SDouble:
TDouble := TDouble - value;
SExtended:
TExtended^ := TExtended^ - value;
SCurrency:
TCurrency := TCurrency - value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) - (value));
else
SetWord(value);
end;
end; procedure SBox.SetValueMinus(value: Cardinal);
begin
case _Type of
SUInt8:
TByte := TByte - value;
SUInt16:
TWord := TWord - value;
SUInt32:
TCardinal := TCardinal - value;
SUInt64:
TUInt64 := TUInt64 - value;
SInt8:
TShortInt := TShortInt - value;
SInt16:
TSmallInt := TSmallInt - value;
SInt32:
TInteger := TInteger - value;
SInt64:
TInt64^ := TInt64^ - value;
SSingle:
TSingle := TSingle - value;
SDouble:
TDouble := TDouble - value;
SExtended:
TExtended^ := TExtended^ - value;
SCurrency:
TCurrency := TCurrency - value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) - (value));
else
SetCardinal(value);
end;
end; procedure SBox.SetValueMinus(value: UInt64);
begin
case _Type of
SUInt8:
TByte := TByte - value;
SUInt16:
TWord := TWord - value;
SUInt32:
TCardinal := TCardinal - value;
SUInt64:
TUInt64 := TUInt64 - value;
SInt8:
TShortInt := TShortInt - value;
SInt16:
TSmallInt := TSmallInt - value;
SInt32:
TInteger := TInteger - value;
SInt64:
TInt64^ := TInt64^ - value;
SSingle:
TSingle := TSingle - value;
SDouble:
TDouble := TDouble - value;
SExtended:
TExtended^ := TExtended^ - value;
SCurrency:
TCurrency := TCurrency - value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) - (value));
else
SetUInt64(value);
end;
end; procedure SBox.SetValueMinus(value: ShortInt);
begin
case _Type of
SUInt8:
TByte := TByte - value;
SUInt16:
TWord := TWord - value;
SUInt32:
TCardinal := TCardinal - value;
SUInt64:
TUInt64 := TUInt64 - value;
SInt8:
TShortInt := TShortInt - value;
SInt16:
TSmallInt := TSmallInt - value;
SInt32:
TInteger := TInteger - value;
SInt64:
TInt64^ := TInt64^ - value;
SSingle:
TSingle := TSingle - value;
SDouble:
TDouble := TDouble - value;
SExtended:
TExtended^ := TExtended^ - value;
SCurrency:
TCurrency := TCurrency - value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) - (value));
else
SetShortInt(value);
end;
end; procedure SBox.SetValueMinus(value: SmallInt);
begin
case _Type of
SUInt8:
TByte := TByte - value;
SUInt16:
TWord := TWord - value;
SUInt32:
TCardinal := TCardinal - value;
SUInt64:
TUInt64 := TUInt64 - value;
SInt8:
TShortInt := TShortInt - value;
SInt16:
TSmallInt := TSmallInt - value;
SInt32:
TInteger := TInteger - value;
SInt64:
TInt64^ := TInt64^ - value;
SSingle:
TSingle := TSingle - value;
SDouble:
TDouble := TDouble - value;
SExtended:
TExtended^ := TExtended^ - value;
SCurrency:
TCurrency := TCurrency - value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) - (value));
else
SetSmallInt(value);
end;
end; procedure SBox.SetValueMinus(value: integer);
begin
case _Type of
SUInt8:
TByte := TByte - value;
SUInt16:
TWord := TWord - value;
SUInt32:
TCardinal := TCardinal - value;
SUInt64:
TUInt64 := TUInt64 - value;
SInt8:
TShortInt := TShortInt - value;
SInt16:
TSmallInt := TSmallInt - value;
SInt32:
TInteger := TInteger - value;
SInt64:
TInt64^ := TInt64^ - value;
SSingle:
TSingle := TSingle - value;
SDouble:
TDouble := TDouble - value;
SExtended:
TExtended^ := TExtended^ - value;
SCurrency:
TCurrency := TCurrency - value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) - (value));
else
SetInteger(value);
end;
end; procedure SBox.SetValueMinus(value: Int64);
begin
case _Type of
SUInt8:
TByte := TByte - value;
SUInt16:
TWord := TWord - value;
SUInt32:
TCardinal := TCardinal - value;
SUInt64:
TUInt64 := TUInt64 - value;
SInt8:
TShortInt := TShortInt - value;
SInt16:
TSmallInt := TSmallInt - value;
SInt32:
TInteger := TInteger - value;
SInt64:
TInt64^ := TInt64^ - value;
SSingle:
TSingle := TSingle - value;
SDouble:
TDouble := TDouble - value;
SExtended:
TExtended^ := TExtended^ - value;
SCurrency:
TCurrency := TCurrency - value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) - (value));
else
SetInt64(value);
end;
end; procedure SBox.SetValueMinus(value: Single);
begin
case _Type of
SUInt8:
SetSingle(TByte - value);
SUInt16:
SetSingle(TWord - value);
SUInt32:
SetSingle(TCardinal - value);
SUInt64:
SetSingle(TUInt64 - value);
SInt8:
SetSingle(TShortInt - value);
SInt16:
SetSingle(TSmallInt - value);
SInt32:
SetSingle(TInteger - value);
SInt64:
SetSingle(TInt64^ - value);
SSingle:
SetSingle(TSingle - value);
SDouble:
SetDouble(TDouble - value);
SExtended:
SetExtended(TExtended^ - value);
SCurrency:
SetCurrency(TCurrency - value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) - value));
else
SetSingle(value);
end;
end; procedure SBox.SetValueMinus(value: Double);
begin
case _Type of
SUInt8:
SetDouble(TByte - value);
SUInt16:
SetDouble(TWord - value);
SUInt32:
SetDouble(TCardinal - value);
SUInt64:
SetDouble(TUInt64 - value);
SInt8:
SetDouble(TShortInt - value);
SInt16:
SetDouble(TSmallInt - value);
SInt32:
SetDouble(TInteger - value);
SInt64:
SetDouble(TInt64^ - value);
SSingle:
SetSingle(TSingle - value);
SDouble:
SetDouble(TDouble - value);
SExtended:
SetExtended(TExtended^ - value);
SCurrency:
SetCurrency(TCurrency - value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) - value));
else
SetDouble(value);
end;
end; procedure SBox.SetValueMinus(value: Extended);
begin
case _Type of
SUInt8:
SetExtended(TByte - value);
SUInt16:
SetExtended(TWord - value);
SUInt32:
SetExtended(TCardinal - value);
SUInt64:
SetExtended(TUInt64 - value);
SInt8:
SetExtended(TShortInt - value);
SInt16:
SetExtended(TSmallInt - value);
SInt32:
SetExtended(TInteger - value);
SInt64:
SetExtended(TInt64^ - value);
SSingle:
SetSingle(TSingle - value);
SDouble:
SetDouble(TDouble - value);
SExtended:
SetExtended(TExtended^ - value);
SCurrency:
SetCurrency(TCurrency - value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) - value));
else
SetExtended(value);
end;
end; procedure SBox.SetValueMinus(value: Currency);
begin
case _Type of
SUInt8:
SetCurrency(TByte - value);
SUInt16:
SetCurrency(TWord - value);
SUInt32:
SetCurrency(TCardinal - value);
SUInt64:
SetCurrency(TUInt64 - value);
SInt8:
SetCurrency(TShortInt - value);
SInt16:
SetCurrency(TSmallInt - value);
SInt32:
SetCurrency(TInteger - value);
SInt64:
SetCurrency(TInt64^ - value);
SSingle:
SetSingle(TSingle - value);
SDouble:
SetDouble(TDouble - value);
SExtended:
SetExtended(TExtended^ - value);
SCurrency:
SetCurrency(TCurrency - value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) - value));
else
SetCurrency(value);
end;
end; procedure SBox.SetValueMinus(value: Pointer);
begin
case _Type of
SUInt8:
TByte := TByte - IntPtr(value);
SUInt16:
TWord := TWord - IntPtr(value);
SUInt32:
TCardinal := TCardinal - IntPtr(value);
SUInt64:
TUInt64 := TUInt64 - IntPtr(value);
SInt8:
TShortInt := TShortInt - IntPtr(value);
SInt16:
TSmallInt := TSmallInt - IntPtr(value);
SInt32:
TInteger := TInteger - IntPtr(value);
SInt64:
TInt64^ := TInt64^ - IntPtr(value);
SSingle:
TSingle := TSingle - IntPtr(value);
SDouble:
TDouble := TDouble - IntPtr(value);
SExtended:
TExtended^ := TExtended^ - IntPtr(value);
SCurrency:
TCurrency := TCurrency - IntPtr(value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) - IntPtr(IntPtr(value)));
else
SetPointer(value);
end;
end; procedure SBox.SetValueDIV(value: Byte);
begin
case _Type of
SUInt8:
TByte := TByte div value;
SUInt16:
TWord := TWord div value;
SUInt32:
TCardinal := TCardinal div value;
SUInt64:
TUInt64 := TUInt64 div value;
SInt8:
TShortInt := TShortInt div value;
SInt16:
TSmallInt := TSmallInt div value;
SInt32:
TInteger := TInteger div value;
SInt64:
TInt64^ := TInt64^ div value;
SSingle:
TSingle := TSingle / value;
SDouble:
TDouble := TDouble / value;
SExtended:
TExtended^ := TExtended^ / value;
SCurrency:
TCurrency := TCurrency / value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) div (value));
else
SetByte(value);
end;
end; procedure SBox.SetValueDIV(value: Word);
begin
case _Type of
SUInt8:
TByte := TByte div value;
SUInt16:
TWord := TWord div value;
SUInt32:
TCardinal := TCardinal div value;
SUInt64:
TUInt64 := TUInt64 div value;
SInt8:
TShortInt := TShortInt div value;
SInt16:
TSmallInt := TSmallInt div value;
SInt32:
TInteger := TInteger div value;
SInt64:
TInt64^ := TInt64^ div value;
SSingle:
TSingle := TSingle / value;
SDouble:
TDouble := TDouble / value;
SExtended:
TExtended^ := TExtended^ / value;
SCurrency:
TCurrency := TCurrency / value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) div (value));
else
SetWord(value);
end;
end; procedure SBox.SetValueDIV(value: Cardinal);
begin
case _Type of
SUInt8:
TByte := TByte div value;
SUInt16:
TWord := TWord div value;
SUInt32:
TCardinal := TCardinal div value;
SUInt64:
TUInt64 := TUInt64 div value;
SInt8:
TShortInt := TShortInt div value;
SInt16:
TSmallInt := TSmallInt div value;
SInt32:
TInteger := TInteger div value;
SInt64:
TInt64^ := TInt64^ div value;
SSingle:
TSingle := TSingle / value;
SDouble:
TDouble := TDouble / value;
SExtended:
TExtended^ := TExtended^ / value;
SCurrency:
TCurrency := TCurrency / value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) div (value));
else
SetCardinal(value);
end;
end; procedure SBox.SetValueDIV(value: UInt64);
begin
case _Type of
SUInt8:
TByte := TByte div value;
SUInt16:
TWord := TWord div value;
SUInt32:
TCardinal := TCardinal div value;
SUInt64:
TUInt64 := TUInt64 div value;
SInt8:
TShortInt := TShortInt div value;
SInt16:
TSmallInt := TSmallInt div value;
SInt32:
TInteger := TInteger div value;
SInt64:
TInt64^ := TInt64^ div value;
SSingle:
TSingle := TSingle / value;
SDouble:
TDouble := TDouble / value;
SExtended:
TExtended^ := TExtended^ / value;
SCurrency:
TCurrency := TCurrency / value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) div (value));
else
SetUInt64(value);
end;
end; procedure SBox.SetValueDIV(value: ShortInt);
begin
case _Type of
SUInt8:
TByte := TByte div value;
SUInt16:
TWord := TWord div value;
SUInt32:
TCardinal := TCardinal div value;
SUInt64:
TUInt64 := TUInt64 div value;
SInt8:
TShortInt := TShortInt div value;
SInt16:
TSmallInt := TSmallInt div value;
SInt32:
TInteger := TInteger div value;
SInt64:
TInt64^ := TInt64^ div value;
SSingle:
TSingle := TSingle / value;
SDouble:
TDouble := TDouble / value;
SExtended:
TExtended^ := TExtended^ / value;
SCurrency:
TCurrency := TCurrency / value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) div (value));
else
SetShortInt(value);
end;
end; procedure SBox.SetValueDIV(value: SmallInt);
begin
case _Type of
SUInt8:
TByte := TByte div value;
SUInt16:
TWord := TWord div value;
SUInt32:
TCardinal := TCardinal div value;
SUInt64:
TUInt64 := TUInt64 div value;
SInt8:
TShortInt := TShortInt div value;
SInt16:
TSmallInt := TSmallInt div value;
SInt32:
TInteger := TInteger div value;
SInt64:
TInt64^ := TInt64^ div value;
SSingle:
TSingle := TSingle / value;
SDouble:
TDouble := TDouble / value;
SExtended:
TExtended^ := TExtended^ / value;
SCurrency:
TCurrency := TCurrency / value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) div (value));
else
SetSmallInt(value);
end;
end; procedure SBox.SetValueDIV(value: integer);
begin
case _Type of
SUInt8:
TByte := TByte div value;
SUInt16:
TWord := TWord div value;
SUInt32:
TCardinal := TCardinal div value;
SUInt64:
TUInt64 := TUInt64 div value;
SInt8:
TShortInt := TShortInt div value;
SInt16:
TSmallInt := TSmallInt div value;
SInt32:
TInteger := TInteger div value;
SInt64:
TInt64^ := TInt64^ div value;
SSingle:
TSingle := TSingle / value;
SDouble:
TDouble := TDouble / value;
SExtended:
TExtended^ := TExtended^ / value;
SCurrency:
TCurrency := TCurrency / value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) div (value));
else
SetInteger(value);
end;
end; procedure SBox.SetValueDIV(value: Int64);
begin
case _Type of
SUInt8:
TByte := TByte div value;
SUInt16:
TWord := TWord div value;
SUInt32:
TCardinal := TCardinal div value;
SUInt64:
TUInt64 := TUInt64 div value;
SInt8:
TShortInt := TShortInt div value;
SInt16:
TSmallInt := TSmallInt div value;
SInt32:
TInteger := TInteger div value;
SInt64:
TInt64^ := TInt64^ div value;
SSingle:
TSingle := TSingle / value;
SDouble:
TDouble := TDouble / value;
SExtended:
TExtended^ := TExtended^ / value;
SCurrency:
TCurrency := TCurrency / value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) div (value));
else
SetInt64(value);
end;
end; procedure SBox.SetValueDIV(value: Single);
begin
case _Type of
SUInt8:
SetSingle(TByte / value);
SUInt16:
SetSingle(TWord / value);
SUInt32:
SetSingle(TCardinal / value);
SUInt64:
SetSingle(TUInt64 / value);
SInt8:
SetSingle(TShortInt / value);
SInt16:
SetSingle(TSmallInt / value);
SInt32:
SetSingle(TInteger / value);
SInt64:
SetSingle(TInt64^ / value);
SSingle:
SetSingle(TSingle / value);
SDouble:
SetDouble(TDouble / value);
SExtended:
SetExtended(TExtended^ / value);
SCurrency:
SetCurrency(TCurrency / value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) / value));
else
SetSingle(value);
end;
end; procedure SBox.SetValueDIV(value: Double);
begin
case _Type of
SUInt8:
SetDouble(TByte / value);
SUInt16:
SetDouble(TWord / value);
SUInt32:
SetDouble(TCardinal / value);
SUInt64:
SetDouble(TUInt64 / value);
SInt8:
SetDouble(TShortInt / value);
SInt16:
SetDouble(TSmallInt / value);
SInt32:
SetDouble(TInteger / value);
SInt64:
SetDouble(TInt64^ / value);
SSingle:
SetSingle(TSingle / value);
SDouble:
SetDouble(TDouble / value);
SExtended:
SetExtended(TExtended^ / value);
SCurrency:
SetCurrency(TCurrency / value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) / value));
else
SetDouble(value);
end;
end; procedure SBox.SetValueDIV(value: Extended);
begin
case _Type of
SUInt8:
SetExtended(TByte / value);
SUInt16:
SetExtended(TWord / value);
SUInt32:
SetExtended(TCardinal / value);
SUInt64:
SetExtended(TUInt64 / value);
SInt8:
SetExtended(TShortInt / value);
SInt16:
SetExtended(TSmallInt / value);
SInt32:
SetExtended(TInteger / value);
SInt64:
SetExtended(TInt64^ / value);
SSingle:
SetSingle(TSingle / value);
SDouble:
SetDouble(TDouble / value);
SExtended:
SetExtended(TExtended^ / value);
SCurrency:
SetCurrency(TCurrency / value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) / value));
else
SetExtended(value);
end;
end; procedure SBox.SetValueDIV(value: Currency);
begin
case _Type of
SUInt8:
SetCurrency(TByte / value);
SUInt16:
SetCurrency(TWord / value);
SUInt32:
SetCurrency(TCardinal / value);
SUInt64:
SetCurrency(TUInt64 / value);
SInt8:
SetCurrency(TShortInt / value);
SInt16:
SetCurrency(TSmallInt / value);
SInt32:
SetCurrency(TInteger / value);
SInt64:
SetCurrency(TInt64^ / value);
SSingle:
SetSingle(TSingle / value);
SDouble:
SetDouble(TDouble / value);
SExtended:
SetExtended(TExtended^ / value);
SCurrency:
SetCurrency(TCurrency / value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) / value));
else
SetCurrency(value);
end;
end; procedure SBox.SetValueDIV(value: Pointer);
begin
case _Type of
SUInt8:
TByte := TByte div IntPtr(value);
SUInt16:
TWord := TWord div IntPtr(value);
SUInt32:
TCardinal := TCardinal div IntPtr(value);
SUInt64:
TUInt64 := TUInt64 div IntPtr(value);
SInt8:
TShortInt := TShortInt div IntPtr(value);
SInt16:
TSmallInt := TSmallInt div IntPtr(value);
SInt32:
TInteger := TInteger div IntPtr(value);
SInt64:
TInt64^ := TInt64^ div IntPtr(value);
SSingle:
TSingle := TSingle / IntPtr(value);
SDouble:
TDouble := TDouble / IntPtr(value);
SExtended:
TExtended^ := TExtended^ / IntPtr(value);
SCurrency:
TCurrency := TCurrency / IntPtr(value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) div IntPtr(IntPtr(value)));
else
SetPointer(value);
end;
end; procedure SBox.SetValueMUL(value: Byte);
begin
case _Type of
SUInt8:
TByte := TByte * value;
SUInt16:
TWord := TWord * value;
SUInt32:
TCardinal := TCardinal * value;
SUInt64:
TUInt64 := TUInt64 * value;
SInt8:
TShortInt := TShortInt * value;
SInt16:
TSmallInt := TSmallInt * value;
SInt32:
TInteger := TInteger * value;
SInt64:
TInt64^ := TInt64^ * value;
SSingle:
TSingle := TSingle * value;
SDouble:
TDouble := TDouble * value;
SExtended:
TExtended^ := TExtended^ * value;
SCurrency:
TCurrency := TCurrency * value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) * (value));
else
SetByte(value);
end;
end; procedure SBox.SetValueMUL(value: Word);
begin
case _Type of
SUInt8:
TByte := TByte * value;
SUInt16:
TWord := TWord * value;
SUInt32:
TCardinal := TCardinal * value;
SUInt64:
TUInt64 := TUInt64 * value;
SInt8:
TShortInt := TShortInt * value;
SInt16:
TSmallInt := TSmallInt * value;
SInt32:
TInteger := TInteger * value;
SInt64:
TInt64^ := TInt64^ * value;
SSingle:
TSingle := TSingle * value;
SDouble:
TDouble := TDouble * value;
SExtended:
TExtended^ := TExtended^ * value;
SCurrency:
TCurrency := TCurrency * value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) * (value));
else
SetWord(value);
end;
end; procedure SBox.SetValueMUL(value: Cardinal);
begin
case _Type of
SUInt8:
TByte := TByte * value;
SUInt16:
TWord := TWord * value;
SUInt32:
TCardinal := TCardinal * value;
SUInt64:
TUInt64 := TUInt64 * value;
SInt8:
TShortInt := TShortInt * value;
SInt16:
TSmallInt := TSmallInt * value;
SInt32:
TInteger := TInteger * value;
SInt64:
TInt64^ := TInt64^ * value;
SSingle:
TSingle := TSingle * value;
SDouble:
TDouble := TDouble * value;
SExtended:
TExtended^ := TExtended^ * value;
SCurrency:
TCurrency := TCurrency * value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) * (value));
else
SetCardinal(value);
end;
end; procedure SBox.SetValueMUL(value: UInt64);
begin
case _Type of
SUInt8:
TByte := TByte * value;
SUInt16:
TWord := TWord * value;
SUInt32:
TCardinal := TCardinal * value;
SUInt64:
TUInt64 := TUInt64 * value;
SInt8:
TShortInt := TShortInt * value;
SInt16:
TSmallInt := TSmallInt * value;
SInt32:
TInteger := TInteger * value;
SInt64:
TInt64^ := TInt64^ * value;
SSingle:
TSingle := TSingle * value;
SDouble:
TDouble := TDouble * value;
SExtended:
TExtended^ := TExtended^ * value;
SCurrency:
TCurrency := TCurrency * value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) * (value));
else
SetUInt64(value);
end;
end; procedure SBox.SetValueMUL(value: ShortInt);
begin
case _Type of
SUInt8:
TByte := TByte * value;
SUInt16:
TWord := TWord * value;
SUInt32:
TCardinal := TCardinal * value;
SUInt64:
TUInt64 := TUInt64 * value;
SInt8:
TShortInt := TShortInt * value;
SInt16:
TSmallInt := TSmallInt * value;
SInt32:
TInteger := TInteger * value;
SInt64:
TInt64^ := TInt64^ * value;
SSingle:
TSingle := TSingle * value;
SDouble:
TDouble := TDouble * value;
SExtended:
TExtended^ := TExtended^ * value;
SCurrency:
TCurrency := TCurrency * value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) * (value));
else
SetShortInt(value);
end;
end; procedure SBox.SetValueMUL(value: SmallInt);
begin
case _Type of
SUInt8:
TByte := TByte * value;
SUInt16:
TWord := TWord * value;
SUInt32:
TCardinal := TCardinal * value;
SUInt64:
TUInt64 := TUInt64 * value;
SInt8:
TShortInt := TShortInt * value;
SInt16:
TSmallInt := TSmallInt * value;
SInt32:
TInteger := TInteger * value;
SInt64:
TInt64^ := TInt64^ * value;
SSingle:
TSingle := TSingle * value;
SDouble:
TDouble := TDouble * value;
SExtended:
TExtended^ := TExtended^ * value;
SCurrency:
TCurrency := TCurrency * value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) * (value));
else
SetSmallInt(value);
end;
end; procedure SBox.SetValueMUL(value: integer);
begin
case _Type of
SUInt8:
TByte := TByte * value;
SUInt16:
TWord := TWord * value;
SUInt32:
TCardinal := TCardinal * value;
SUInt64:
TUInt64 := TUInt64 * value;
SInt8:
TShortInt := TShortInt * value;
SInt16:
TSmallInt := TSmallInt * value;
SInt32:
TInteger := TInteger * value;
SInt64:
TInt64^ := TInt64^ * value;
SSingle:
TSingle := TSingle * value;
SDouble:
TDouble := TDouble * value;
SExtended:
TExtended^ := TExtended^ * value;
SCurrency:
TCurrency := TCurrency * value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) * (value));
else
SetInteger(value);
end;
end; procedure SBox.SetValueMUL(value: Int64);
begin
case _Type of
SUInt8:
TByte := TByte * value;
SUInt16:
TWord := TWord * value;
SUInt32:
TCardinal := TCardinal * value;
SUInt64:
TUInt64 := TUInt64 * value;
SInt8:
TShortInt := TShortInt * value;
SInt16:
TSmallInt := TSmallInt * value;
SInt32:
TInteger := TInteger * value;
SInt64:
TInt64^ := TInt64^ * value;
SSingle:
TSingle := TSingle * value;
SDouble:
TDouble := TDouble * value;
SExtended:
TExtended^ := TExtended^ * value;
SCurrency:
TCurrency := TCurrency * value;
SPointer:
TPointer := Pointer(IntPtr(TPointer) * (value));
else
SetInt64(value);
end;
end; procedure SBox.SetValueMUL(value: Single);
begin
case _Type of
SUInt8:
SetSingle(TByte * value);
SUInt16:
SetSingle(TWord * value);
SUInt32:
SetSingle(TCardinal * value);
SUInt64:
SetSingle(TUInt64 * value);
SInt8:
SetSingle(TShortInt * value);
SInt16:
SetSingle(TSmallInt * value);
SInt32:
SetSingle(TInteger * value);
SInt64:
SetSingle(TInt64^ * value);
SSingle:
SetSingle(TSingle * value);
SDouble:
SetDouble(TDouble * value);
SExtended:
SetExtended(TExtended^ * value);
SCurrency:
SetCurrency(TCurrency * value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) * value));
else
SetSingle(value);
end;
end; procedure SBox.SetValueMUL(value: Double);
begin
case _Type of
SUInt8:
SetDouble(TByte * value);
SUInt16:
SetDouble(TWord * value);
SUInt32:
SetDouble(TCardinal * value);
SUInt64:
SetDouble(TUInt64 * value);
SInt8:
SetDouble(TShortInt * value);
SInt16:
SetDouble(TSmallInt * value);
SInt32:
SetDouble(TInteger * value);
SInt64:
SetDouble(TInt64^ * value);
SSingle:
SetSingle(TSingle * value);
SDouble:
SetDouble(TDouble * value);
SExtended:
SetExtended(TExtended^ * value);
SCurrency:
SetCurrency(TCurrency * value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) * value));
else
SetDouble(value);
end;
end; procedure SBox.SetValueMUL(value: Extended);
begin
case _Type of
SUInt8:
SetExtended(TByte * value);
SUInt16:
SetExtended(TWord * value);
SUInt32:
SetExtended(TCardinal * value);
SUInt64:
SetExtended(TUInt64 * value);
SInt8:
SetExtended(TShortInt * value);
SInt16:
SetExtended(TSmallInt * value);
SInt32:
SetExtended(TInteger * value);
SInt64:
SetExtended(TInt64^ * value);
SSingle:
SetSingle(TSingle * value);
SDouble:
SetDouble(TDouble * value);
SExtended:
SetExtended(TExtended^ * value);
SCurrency:
SetCurrency(TCurrency * value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) * value));
else
SetExtended(value);
end;
end; procedure SBox.SetValueMUL(value: Currency);
begin
case _Type of
SUInt8:
SetCurrency(TByte * value);
SUInt16:
SetCurrency(TWord * value);
SUInt32:
SetCurrency(TCardinal * value);
SUInt64:
SetCurrency(TUInt64 * value);
SInt8:
SetCurrency(TShortInt * value);
SInt16:
SetCurrency(TSmallInt * value);
SInt32:
SetCurrency(TInteger * value);
SInt64:
SetCurrency(TInt64^ * value);
SSingle:
SetSingle(TSingle * value);
SDouble:
SetDouble(TDouble * value);
SExtended:
SetExtended(TExtended^ * value);
SCurrency:
SetCurrency(TCurrency * value);
SPointer:
TPointer := Pointer(Round(IntPtr(TPointer) * value));
else
SetCurrency(value);
end;
end; procedure SBox.SetValueMUL(value: Pointer);
begin
case _Type of
SUInt8:
TByte := TByte * IntPtr(value);
SUInt16:
TWord := TWord * IntPtr(value);
SUInt32:
TCardinal := TCardinal * IntPtr(value);
SUInt64:
TUInt64 := TUInt64 * IntPtr(value);
SInt8:
TShortInt := TShortInt * IntPtr(value);
SInt16:
TSmallInt := TSmallInt * IntPtr(value);
SInt32:
TInteger := TInteger * IntPtr(value);
SInt64:
TInt64^ := TInt64^ * IntPtr(value);
SSingle:
TSingle := TSingle * IntPtr(value);
SDouble:
TDouble := TDouble * IntPtr(value);
SExtended:
TExtended^ := TExtended^ * IntPtr(value);
SCurrency:
TCurrency := TCurrency * IntPtr(value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) * IntPtr(IntPtr(value)));
else
SetPointer(value);
end;
end; procedure SBox.SetValueMOD(value: Byte);
begin
case _Type of
SUInt8:
TByte := TByte MOD value;
SUInt16:
TWord := TWord MOD value;
SUInt32:
TCardinal := TCardinal MOD value;
SUInt64:
TUInt64 := TUInt64 MOD value;
SInt8:
TShortInt := TShortInt MOD value;
SInt16:
TSmallInt := TSmallInt MOD value;
SInt32:
TInteger := TInteger MOD value;
SInt64:
TInt64^ := TInt64^ MOD value;
SSingle:
SetInt64(Round(TSingle) MOD value);
SDouble:
SetInt64(Round(TDouble) MOD value);
SExtended:
SetInt64(Round(TExtended^) MOD value);
SCurrency:
SetInt64(Round(TCurrency) MOD value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD (value));
else
SetByte(value);
end;
end; procedure SBox.SetValueMOD(value: Word);
begin
case _Type of
SUInt8:
TByte := TByte MOD value;
SUInt16:
TWord := TWord MOD value;
SUInt32:
TCardinal := TCardinal MOD value;
SUInt64:
TUInt64 := TUInt64 MOD value;
SInt8:
TShortInt := TShortInt MOD value;
SInt16:
TSmallInt := TSmallInt MOD value;
SInt32:
TInteger := TInteger MOD value;
SInt64:
TInt64^ := TInt64^ MOD value;
SSingle:
SetInt64(Round(TSingle) MOD value);
SDouble:
SetInt64(Round(TDouble) MOD value);
SExtended:
SetInt64(Round(TExtended^) MOD value);
SCurrency:
SetInt64(Round(TCurrency) MOD value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD (value));
else
SetWord(value);
end;
end; procedure SBox.SetValueMOD(value: Cardinal);
begin
case _Type of
SUInt8:
TByte := TByte MOD value;
SUInt16:
TWord := TWord MOD value;
SUInt32:
TCardinal := TCardinal MOD value;
SUInt64:
TUInt64 := TUInt64 MOD value;
SInt8:
TShortInt := TShortInt MOD value;
SInt16:
TSmallInt := TSmallInt MOD value;
SInt32:
TInteger := TInteger MOD value;
SInt64:
TInt64^ := TInt64^ MOD value;
SSingle:
SetInt64(Round(TSingle) MOD value);
SDouble:
SetInt64(Round(TDouble) MOD value);
SExtended:
SetInt64(Round(TExtended^) MOD value);
SCurrency:
SetInt64(Round(TCurrency) MOD value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD (value));
else
SetCardinal(value);
end;
end; procedure SBox.SetValueMOD(value: UInt64);
begin
case _Type of
SUInt8:
TByte := TByte MOD value;
SUInt16:
TWord := TWord MOD value;
SUInt32:
TCardinal := TCardinal MOD value;
SUInt64:
TUInt64 := TUInt64 MOD value;
SInt8:
TShortInt := TShortInt MOD value;
SInt16:
TSmallInt := TSmallInt MOD value;
SInt32:
TInteger := TInteger MOD value;
SInt64:
TInt64^ := TInt64^ MOD value;
SSingle:
SetInt64(Round(TSingle) MOD value);
SDouble:
SetInt64(Round(TDouble) MOD value);
SExtended:
SetInt64(Round(TExtended^) MOD value);
SCurrency:
SetInt64(Round(TCurrency) MOD value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD (value));
else
SetUInt64(value);
end;
end; procedure SBox.SetValueMOD(value: ShortInt);
begin
case _Type of
SUInt8:
TByte := TByte MOD value;
SUInt16:
TWord := TWord MOD value;
SUInt32:
TCardinal := TCardinal MOD value;
SUInt64:
TUInt64 := TUInt64 MOD value;
SInt8:
TShortInt := TShortInt MOD value;
SInt16:
TSmallInt := TSmallInt MOD value;
SInt32:
TInteger := TInteger MOD value;
SInt64:
TInt64^ := TInt64^ MOD value;
SSingle:
SetInt64(Round(TSingle) MOD value);
SDouble:
SetInt64(Round(TDouble) MOD value);
SExtended:
SetInt64(Round(TExtended^) MOD value);
SCurrency:
SetInt64(Round(TCurrency) MOD value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD (value));
else
SetShortInt(value);
end;
end; procedure SBox.SetValueMOD(value: SmallInt);
begin
case _Type of
SUInt8:
TByte := TByte MOD value;
SUInt16:
TWord := TWord MOD value;
SUInt32:
TCardinal := TCardinal MOD value;
SUInt64:
TUInt64 := TUInt64 MOD value;
SInt8:
TShortInt := TShortInt MOD value;
SInt16:
TSmallInt := TSmallInt MOD value;
SInt32:
TInteger := TInteger MOD value;
SInt64:
TInt64^ := TInt64^ MOD value;
SSingle:
SetInt64(Round(TSingle) MOD value);
SDouble:
SetInt64(Round(TDouble) MOD value);
SExtended:
SetInt64(Round(TExtended^) MOD value);
SCurrency:
SetInt64(Round(TCurrency) MOD value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD (value));
else
SetSmallInt(value);
end;
end; procedure SBox.SetValueMOD(value: integer);
begin
case _Type of
SUInt8:
TByte := TByte MOD value;
SUInt16:
TWord := TWord MOD value;
SUInt32:
TCardinal := TCardinal MOD value;
SUInt64:
TUInt64 := TUInt64 MOD value;
SInt8:
TShortInt := TShortInt MOD value;
SInt16:
TSmallInt := TSmallInt MOD value;
SInt32:
TInteger := TInteger MOD value;
SInt64:
TInt64^ := TInt64^ MOD value;
SSingle:
SetInt64(Round(TSingle) MOD value);
SDouble:
SetInt64(Round(TDouble) MOD value);
SExtended:
SetInt64(Round(TExtended^) MOD value);
SCurrency:
SetInt64(Round(TCurrency) MOD value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD (value));
else
SetInteger(value);
end;
end; procedure SBox.SetValueMOD(value: Int64);
begin
case _Type of
SUInt8:
TByte := TByte MOD value;
SUInt16:
TWord := TWord MOD value;
SUInt32:
TCardinal := TCardinal MOD value;
SUInt64:
TUInt64 := TUInt64 MOD value;
SInt8:
TShortInt := TShortInt MOD value;
SInt16:
TSmallInt := TSmallInt MOD value;
SInt32:
TInteger := TInteger MOD value;
SInt64:
TInt64^ := TInt64^ MOD value;
SSingle:
SetInt64(Round(TSingle) MOD value);
SDouble:
SetInt64(Round(TDouble) MOD value);
SExtended:
SetInt64(Round(TExtended^) MOD value);
SCurrency:
SetInt64(Round(TCurrency) MOD value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD (value));
else
SetInt64(value);
end;
end; procedure SBox.SetValueMOD(value: Single);
begin
case _Type of
SUInt8:
SetSingle(TByte MOD Round(value));
SUInt16:
SetSingle(TWord MOD Round(value));
SUInt32:
SetSingle(TCardinal MOD Round(value));
SUInt64:
SetSingle(TUInt64 MOD Round(value));
SInt8:
SetSingle(TShortInt MOD Round(value));
SInt16:
SetSingle(TSmallInt MOD Round(value));
SInt32:
SetSingle(TInteger MOD Round(value));
SInt64:
SetSingle(TInt64^ MOD Round(value));
SSingle:
SetSingle(Round(TSingle) MOD Round(value));
SDouble:
SetDouble(Round(TDouble) MOD Round(value));
SExtended:
SetExtended(Round(TExtended^) MOD Round(value));
SCurrency:
SetCurrency(Round(TCurrency) MOD Round(value));
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD Round(value));
else
SetSingle(value);
end;
end; procedure SBox.SetValueMOD(value: Double);
begin
case _Type of
SUInt8:
SetDouble(TByte MOD Round(value));
SUInt16:
SetDouble(TWord MOD Round(value));
SUInt32:
SetDouble(TCardinal MOD Round(value));
SUInt64:
SetDouble(TUInt64 MOD Round(value));
SInt8:
SetDouble(TShortInt MOD Round(value));
SInt16:
SetDouble(TSmallInt MOD Round(value));
SInt32:
SetDouble(TInteger MOD Round(value));
SInt64:
SetDouble(TInt64^ MOD Round(value));
SSingle:
SetSingle(Round(TSingle) MOD Round(value));
SDouble:
SetDouble(Round(TDouble) MOD Round(value));
SExtended:
SetExtended(Round(TExtended^) MOD Round(value));
SCurrency:
SetCurrency(Round(TCurrency) MOD Round(value));
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD Round(value));
else
SetDouble(value);
end;
end; procedure SBox.SetValueMOD(value: Extended);
begin
case _Type of
SUInt8:
SetExtended(TByte MOD Round(value));
SUInt16:
SetExtended(TWord MOD Round(value));
SUInt32:
SetExtended(TCardinal MOD Round(value));
SUInt64:
SetExtended(TUInt64 MOD Round(value));
SInt8:
SetExtended(TShortInt MOD Round(value));
SInt16:
SetExtended(TSmallInt MOD Round(value));
SInt32:
SetExtended(TInteger MOD Round(value));
SInt64:
SetExtended(TInt64^ MOD Round(value));
SSingle:
SetSingle(Round(TSingle) MOD Round(value));
SDouble:
SetDouble(Round(TDouble) MOD Round(value));
SExtended:
SetExtended(Round(TExtended^) MOD Round(value));
SCurrency:
SetCurrency(Round(TCurrency) MOD Round(value));
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD Round(value));
else
SetExtended(value);
end;
end; procedure SBox.SetValueMOD(value: Currency);
begin
case _Type of
SUInt8:
SetCurrency(TByte MOD Round(value));
SUInt16:
SetCurrency(TWord MOD Round(value));
SUInt32:
SetCurrency(TCardinal MOD Round(value));
SUInt64:
SetCurrency(TUInt64 MOD Round(value));
SInt8:
SetCurrency(TShortInt MOD Round(value));
SInt16:
SetCurrency(TSmallInt MOD Round(value));
SInt32:
SetCurrency(TInteger MOD Round(value));
SInt64:
SetCurrency(TInt64^ MOD Round(value));
SSingle:
SetSingle(Round(TSingle) MOD Round(value));
SDouble:
SetDouble(Round(TDouble) MOD Round(value));
SExtended:
SetExtended(Round(TExtended^) MOD Round(value));
SCurrency:
SetCurrency(Round(TCurrency) MOD Round(value));
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD Round(value));
else
SetCurrency(value);
end;
end; procedure SBox.SetValueMOD(value: Pointer);
begin
case _Type of
SUInt8:
TByte := TByte MOD IntPtr(value);
SUInt16:
TWord := TWord MOD IntPtr(value);
SUInt32:
TCardinal := TCardinal MOD IntPtr(value);
SUInt64:
TUInt64 := TUInt64 MOD IntPtr(value);
SInt8:
TShortInt := TShortInt MOD IntPtr(value);
SInt16:
TSmallInt := TSmallInt MOD IntPtr(value);
SInt32:
TInteger := TInteger MOD IntPtr(value);
SInt64:
TInt64^ := TInt64^ MOD IntPtr(value);
SSingle:
TSingle := Round(TSingle) MOD IntPtr(value);
SDouble:
TDouble := Round(TDouble) MOD IntPtr(value);
SExtended:
TExtended^ := Round(TExtended^) MOD IntPtr(value);
SCurrency:
TCurrency := Round(TCurrency) MOD IntPtr(value);
SPointer:
TPointer := Pointer(IntPtr(TPointer) MOD IntPtr(IntPtr(value)));
else
SetPointer(value);
end;
end; procedure SBox.SetValuePOW(value: Byte);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, value));
SUInt16:
SetExtended(Power(TWord, value));
SUInt32:
SetExtended(Power(TCardinal, value));
SUInt64:
SetExtended(Power(TUInt64, value));
SInt8:
SetExtended(Power(TShortInt, value));
SInt16:
SetExtended(Power(TSmallInt, value));
SInt32:
SetExtended(Power(TInteger, value));
SInt64:
SetExtended(Power(TInt64^, value));
SSingle:
SetExtended(Power(TSingle, value));
SDouble:
SetExtended(Power(TDouble, value));
SExtended:
SetExtended(Power(TExtended^, value));
SCurrency:
SetExtended(Power(TCurrency, value));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (value))));
else
SetByte(value);
end;
end; procedure SBox.SetValuePOW(value: Word);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, value));
SUInt16:
SetExtended(Power(TWord, value));
SUInt32:
SetExtended(Power(TCardinal, value));
SUInt64:
SetExtended(Power(TUInt64, value));
SInt8:
SetExtended(Power(TShortInt, value));
SInt16:
SetExtended(Power(TSmallInt, value));
SInt32:
SetExtended(Power(TInteger, value));
SInt64:
SetExtended(Power(TInt64^, value));
SSingle:
SetExtended(Power(TSingle, value));
SDouble:
SetExtended(Power(TDouble, value));
SExtended:
SetExtended(Power(TExtended^, value));
SCurrency:
SetExtended(Power(TCurrency, value));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (value))));
else
SetWord(value);
end;
end; procedure SBox.SetValuePOW(value: Cardinal);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, value));
SUInt16:
SetExtended(Power(TWord, value));
SUInt32:
SetExtended(Power(TCardinal, value));
SUInt64:
SetExtended(Power(TUInt64, value));
SInt8:
SetExtended(Power(TShortInt, value));
SInt16:
SetExtended(Power(TSmallInt, value));
SInt32:
SetExtended(Power(TInteger, value));
SInt64:
SetExtended(Power(TInt64^, value));
SSingle:
SetExtended(Power(TSingle, value));
SDouble:
SetExtended(Power(TDouble, value));
SExtended:
SetExtended(Power(TExtended^, value));
SCurrency:
SetExtended(Power(TCurrency, value));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (value))));
else
SetCardinal(value);
end;
end; procedure SBox.SetValuePOW(value: UInt64);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, value));
SUInt16:
SetExtended(Power(TWord, value));
SUInt32:
SetExtended(Power(TCardinal, value));
SUInt64:
SetExtended(Power(TUInt64, value));
SInt8:
SetExtended(Power(TShortInt, value));
SInt16:
SetExtended(Power(TSmallInt, value));
SInt32:
SetExtended(Power(TInteger, value));
SInt64:
SetExtended(Power(TInt64^, value));
SSingle:
SetExtended(Power(TSingle, value));
SDouble:
SetExtended(Power(TDouble, value));
SExtended:
SetExtended(Power(TExtended^, value));
SCurrency:
SetExtended(Power(TCurrency, value));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (value))));
else
SetUInt64(value);
end;
end; procedure SBox.SetValuePOW(value: ShortInt);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, value));
SUInt16:
SetExtended(Power(TWord, value));
SUInt32:
SetExtended(Power(TCardinal, value));
SUInt64:
SetExtended(Power(TUInt64, value));
SInt8:
SetExtended(Power(TShortInt, value));
SInt16:
SetExtended(Power(TSmallInt, value));
SInt32:
SetExtended(Power(TInteger, value));
SInt64:
SetExtended(Power(TInt64^, value));
SSingle:
SetExtended(Power(TSingle, value));
SDouble:
SetExtended(Power(TDouble, value));
SExtended:
SetExtended(Power(TExtended^, value));
SCurrency:
SetExtended(Power(TCurrency, value));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (value))));
else
SetShortInt(value);
end;
end; procedure SBox.SetValuePOW(value: SmallInt);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, value));
SUInt16:
SetExtended(Power(TWord, value));
SUInt32:
SetExtended(Power(TCardinal, value));
SUInt64:
SetExtended(Power(TUInt64, value));
SInt8:
SetExtended(Power(TShortInt, value));
SInt16:
SetExtended(Power(TSmallInt, value));
SInt32:
SetExtended(Power(TInteger, value));
SInt64:
SetExtended(Power(TInt64^, value));
SSingle:
SetExtended(Power(TSingle, value));
SDouble:
SetExtended(Power(TDouble, value));
SExtended:
SetExtended(Power(TExtended^, value));
SCurrency:
SetExtended(Power(TCurrency, value));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (value))));
else
SetSmallInt(value);
end;
end; procedure SBox.SetValuePOW(value: integer);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, value));
SUInt16:
SetExtended(Power(TWord, value));
SUInt32:
SetExtended(Power(TCardinal, value));
SUInt64:
SetExtended(Power(TUInt64, value));
SInt8:
SetExtended(Power(TShortInt, value));
SInt16:
SetExtended(Power(TSmallInt, value));
SInt32:
SetExtended(Power(TInteger, value));
SInt64:
SetExtended(Power(TInt64^, value));
SSingle:
SetExtended(Power(TSingle, value));
SDouble:
SetExtended(Power(TDouble, value));
SExtended:
SetExtended(Power(TExtended^, value));
SCurrency:
SetExtended(Power(TCurrency, value));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (value))));
else
SetInteger(value);
end;
end; procedure SBox.SetValuePOW(value: Int64);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, value));
SUInt16:
SetExtended(Power(TWord, value));
SUInt32:
SetExtended(Power(TCardinal, value));
SUInt64:
SetExtended(Power(TUInt64, value));
SInt8:
SetExtended(Power(TShortInt, value));
SInt16:
SetExtended(Power(TSmallInt, value));
SInt32:
SetExtended(Power(TInteger, value));
SInt64:
SetExtended(Power(TInt64^, value));
SSingle:
SetExtended(Power(TSingle, value));
SDouble:
SetExtended(Power(TDouble, value));
SExtended:
SetExtended(Power(TExtended^, value));
SCurrency:
SetExtended(Power(TCurrency, value));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (value))));
else
SetInt64(value);
end;
end; procedure SBox.SetValuePOW(value: Single);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, value));
SUInt16:
SetExtended(Power(TWord, value));
SUInt32:
SetExtended(Power(TCardinal, value));
SUInt64:
SetExtended(Power(TUInt64, value));
SInt8:
SetExtended(Power(TShortInt, value));
SInt16:
SetExtended(Power(TSmallInt, value));
SInt32:
SetExtended(Power(TInteger, value));
SInt64:
SetExtended(Power(TInt64^, value));
SSingle:
SetExtended(Power(TSingle, value));
SDouble:
SetExtended(Power(TDouble, value));
SExtended:
SetExtended(Power(TExtended^, value));
SCurrency:
SetExtended(Power(TCurrency, value));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (value))));
else
SetSingle(value);
end;
end; procedure SBox.SetValuePOW(value: Double);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, value));
SUInt16:
SetExtended(Power(TWord, value));
SUInt32:
SetExtended(Power(TCardinal, value));
SUInt64:
SetExtended(Power(TUInt64, value));
SInt8:
SetExtended(Power(TShortInt, value));
SInt16:
SetExtended(Power(TSmallInt, value));
SInt32:
SetExtended(Power(TInteger, value));
SInt64:
SetExtended(Power(TInt64^, value));
SSingle:
SetExtended(Power(TSingle, value));
SDouble:
SetExtended(Power(TDouble, value));
SExtended:
SetExtended(Power(TExtended^, value));
SCurrency:
SetExtended(Power(TCurrency, value));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (value))));
else
SetDouble(value);
end;
end; procedure SBox.SetValuePOW(value: Extended);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, value));
SUInt16:
SetExtended(Power(TWord, value));
SUInt32:
SetExtended(Power(TCardinal, value));
SUInt64:
SetExtended(Power(TUInt64, value));
SInt8:
SetExtended(Power(TShortInt, value));
SInt16:
SetExtended(Power(TSmallInt, value));
SInt32:
SetExtended(Power(TInteger, value));
SInt64:
SetExtended(Power(TInt64^, value));
SSingle:
SetExtended(Power(TSingle, value));
SDouble:
SetExtended(Power(TDouble, value));
SExtended:
SetExtended(Power(TExtended^, value));
SCurrency:
SetExtended(Power(TCurrency, value));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (value))));
else
SetExtended(value);
end;
end; procedure SBox.SetValuePOW(value: Currency);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, value));
SUInt16:
SetExtended(Power(TWord, value));
SUInt32:
SetExtended(Power(TCardinal, value));
SUInt64:
SetExtended(Power(TUInt64, value));
SInt8:
SetExtended(Power(TShortInt, value));
SInt16:
SetExtended(Power(TSmallInt, value));
SInt32:
SetExtended(Power(TInteger, value));
SInt64:
SetExtended(Power(TInt64^, value));
SSingle:
SetExtended(Power(TSingle, value));
SDouble:
SetExtended(Power(TDouble, value));
SExtended:
SetExtended(Power(TExtended^, value));
SCurrency:
SetExtended(Power(TCurrency, value));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (value))));
else
SetCurrency(value);
end;
end; procedure SBox.SetValuePOW(value: Pointer);
begin
case _Type of
SUInt8:
SetExtended(Power(TByte, IntPtr(value)));
SUInt16:
SetExtended(Power(TWord, IntPtr(value)));
SUInt32:
SetExtended(Power(TCardinal, IntPtr(value)));
SUInt64:
SetExtended(Power(TUInt64, IntPtr(value)));
SInt8:
SetExtended(Power(TShortInt, IntPtr(value)));
SInt16:
SetExtended(Power(TSmallInt, IntPtr(value)));
SInt32:
SetExtended(Power(TInteger, IntPtr(value)));
SInt64:
SetExtended(Power(TInt64^, IntPtr(value)));
SSingle:
SetExtended(Power(TSingle, IntPtr(value)));
SDouble:
SetExtended(Power(TDouble, IntPtr(value)));
SExtended:
SetExtended(Power(TExtended^, IntPtr(value)));
SCurrency:
SetExtended(Power(TCurrency, IntPtr(value)));
SPointer:
TPointer := Pointer(Round(Power(IntPtr(TPointer), (IntPtr(value)))));
else
SetPointer(value);
end;
end; procedure SBox.free;
begin
case _Type of
SUInt8:
TByte := 0;
SUInt16:
TWord := 0;
SUInt32:
TCardinal := 0;
SUInt64:
TUInt64 := 0;
SInt8:
TShortInt := 0;
SInt16:
TSmallInt := 0;
SInt32:
TInteger := 0;
SInt64:
begin
Dispose(TInt64);
TInt64 := nil;
end;
SSingle:
TSingle := 0;
SDouble:
TDouble := 0;
SExtended:
begin
Dispose(TExtended);
TExtended := nil;
end;
SCurrency:
TCurrency := 0;
SPointer:
TPointer := nil;
end;
_Type := SNULL;
end; initialization end.
TSimpleXmlWriter = class
Finished : boolean;
Buff : string;
RLock : boolean;
WLock : boolean;
Writer : ITask; procedure WriteToBuff(const Text: string); constructor Create(const AFileName: string);
destructor Destroy; override; procedure OpenElement(const Name: string; const CloseTag: TXmlCloseTag);
procedure CloseElement(const Name: string);
procedure WriteAttribute(const Name: string; const Value: Integer; const CloseTag: TXmlCloseTag);
end; constructor TSimpleXmlWriter.Create(const AFileName: string);
begin
Finished:=False;
Writer:=TTask.Create(procedure ()
var
xBuff : TBytes;
F : TFileStream;
begin
F:=TFileStream.Create(AFileName,fmCreate,fmShareDenyNone);
try
while not Finished or (length(Buff)>0) do begin
try
if RLock then Continue;
WLock:=True;
if RLock then Continue;
if length(Buff)>0 then begin
xBuff:=TEncoding.UTF8.GetBytes(Buff);
Buff:='';
WLock:=False;
F.Write(xBuff[0],length(xBuff));
end;
finally
WLock:=False;
end;
Sleep(1);
end;
finally
F.Free;
end;
end);
Writer.Start;
Buff:='<?xml version="1.0" encoding="UTF-8" standalone="yes" ?>';
end; destructor TSimpleXmlWriter.Destroy;
begin
Finished:=True;
TTask.WaitForAll([Writer]); inherited;
end; procedure TSimpleXmlWriter.OpenElement(const Name: string; const CloseTag: TXmlCloseTag);
begin
if CloseTag=xtClose then begin
WriteToBuff('<'+Name+'>');
end else begin
WriteToBuff('<'+Name);
end;
end; procedure TSimpleXmlWriter.CloseElement(const Name: string);
begin
WriteToBuff('</'+Name+'>');
end; procedure TSimpleXmlWriter.WriteAttribute(const Name: string; const Value: Integer; const CloseTag: TXmlCloseTag);
begin
if CloseTag=xtClose then begin
WriteToBuff(' '+Name+'="'+Value.ToString+'">');
end else begin
WriteToBuff(' '+Name+'="'+Value.ToString+'"');
end;
end; procedure TSimpleXmlWriter.WriteToBuff(const Text: string);
begin
RLock:=True;
while WLock do sleep(0);
Buff:=Buff+Text;
RLock:=False;
end;
TSimpleXmlWriter = class
procedure WriteToBuff(const Text: string); constructor Create(const AFileName: string);
destructor Destroy; override; procedure OpenElement(const Name: string; const CloseTag: TXmlCloseTag);
procedure CloseElement(const Name: string);
procedure WriteAttribute(const Name: string; const Value: Integer; const CloseTag: TXmlCloseTag);
end; constructor TSimpleXmlWriter.Create(const AFileName: string);
begin
end; destructor TSimpleXmlWriter.Destroy;
begin
end; procedure TSimpleXmlWriter.OpenElement(const Name: string; const CloseTag: TXmlCloseTag);
begin
if CloseTag=xtClose then begin
WriteToBuff('<'+Name+'>');
end else begin
WriteToBuff('<'+Name);
end;
end; procedure TSimpleXmlWriter.CloseElement(const Name: string);
begin
WriteToBuff('</'+Name+'>');
end; procedure TSimpleXmlWriter.WriteAttribute(const Name: string; const Value: Integer; const CloseTag: TXmlCloseTag);
begin
if CloseTag=xtClose then begin
WriteToBuff(' '+Name+'="'+Value.ToString+'">');
end else begin
WriteToBuff(' '+Name+'="'+Value.ToString+'"');
end;
end; procedure TSimpleXmlWriter.WriteToBuff(const Text: string);
begin
end;
unit myStrUtils; interface uses Windows, Classes, SysUtils; resourcestring
SFCreateErrorEx = 'Cannot create file "%s". %s';
SFOpenErrorEx = 'Cannot open file "%s". %s'; const
KB = Int64(1024);
MB = 1024*KB;
GB = 1024*MB; DEFAULT_BUFSIZE = 16*MB;
MIN_BUFSIZE = KB;
MAX_BUFSIZE = 16*MB; type
BigInt = Int64;
TBufferedFileStream = class(TStream)
private
FHandle : BigInt;
FFileSize : BigInt;
FFileOffset : BigInt;
FBuf : PByte;
FBufSize : BigInt;
FBufCount : BigInt;
FBufPos : BigInt;
FDirty : Boolean;
function GetPosition: Int64;
procedure SetPosition(const Value: Int64); protected
procedure SetSize(const NewSize: Int64); override;
function GetFileSize: BigInt;
procedure Init(BufSize: BigInt);
procedure ReadFromFile;
procedure WriteToFile;
public
constructor Create(const FileName: string; Mode: Word; BufferSize: BigInt); overload;
constructor Create(const FileName: string; Mode: Word; Rights: Cardinal; BufferSize: BigInt); overload;
destructor Destroy; override; procedure Flush;
function BigRead(var Buffer; Count: BigInt): BigInt; overload; function BigSeek(Offset: BigInt; Origin: Word): BigInt; overload;
function BigSeek(const Offset: Int64; Origin: TSeekOrigin): Int64; overload;
function BigWrite(const Buffer; Count: BigInt): BigInt; overload;
property FastSize : BigInt read FFileSize;
property Position: Int64 read GetPosition write SetPosition;
end; TCustomList = class(TList)
private
function GetStringItem(index: integer): AnsiString;
function GetItemLength(index: integer): integer;
protected
FFromPos: Int64;
FCurrentItemSize: integer;
FBuffer: Pointer;
FLastItem: Pointer;
FBufferSize: int64;
FItemsSize: int64;
FSorted: boolean;
FCurrentItem: Pointer;
FCurrentItemIndex: integer;
FStream: TBufferedFileStream;
procedure FreeBuffer;
function AllocateBuffer(const NewSize: BigInt): boolean;
procedure ClearBuffer;
procedure ScanBuffer;
public
constructor Create; overload;
destructor Destroy; override;
function LoadFromStream(const Stream: TBufferedFileStream; const AFromPos, AMaxLength: Int64): Int64;
function SaveToStream(const Stream: TBufferedFileStream; const AFromPos: Int64): Int64;
procedure Sort; overload;
function InitMergeList(const AFileName: string; const AMaxLength: int64): boolean;
procedure First;
function Next: boolean;
property CurrentItem: pointer read FCurrentItem;
property CurrentItemSize: integer read FCurrentItemSize;
property StringItem[index: integer]: AnsiString read GetStringItem;
property ItemLength[index: integer]: integer read GetItemLength;
property FromPos: Int64 read FFromPos;
property ItemsSize: Int64 read FItemsSize;
end; function CustomCompareBuffer(S1, S2: Pointer): Integer;
function CustomCompareList(S1, S2: Pointer): Integer;
function Min(const IntOne, IntTwo: BigInt): BigInt;
function MakeString(const APointer: Pointer; const ASize: integer): AnsiString;
function ScanBuf(const AByte: Byte; const APointer: Pointer): integer; implementation uses RTLConsts; function Min(const IntOne, IntTwo: BigInt): BigInt;
begin
if IntOne > IntTwo then
Result := IntTwo
else
Result := IntOne;
end; function MakeString(const APointer: Pointer; const ASize: integer): AnsiString;
begin
SetLength(Result, ASize);
if LongBool(ASize) then
System.Move(APointer^, Result[1], ASize);
end; function ScanBuf(const AByte: Byte; const APointer: Pointer): integer;
var i: integer;
b: byte;
begin
i := 0;
repeat
b := PByte(NativeInt(APointer)+i)^;
if b = AByte then exit(i)
else if b = 13 then break;
inc(i);
until false;
result := -1;
end; function CustomCompareBuffer(S1, S2: Pointer): Integer;
var i1, i2: integer; function CmpStr(const P1, P2: integer; const S1, S2: pointer): integer;
var i, l1, l2: integer;
b1, b2: integer;
begin
result := 0;
i := 0;
repeat
b1 := PByte(NativeInt(S1)+P1+i)^;
b2 := PByte(NativeInt(S2)+P2+i)^;
result := b1 - b2;
inc(i);
until (result <> 0) or (b1 = 13) or (b2 = 13);
end; function CmpInt(const P1, P2: integer; const S1, S2: pointer): integer;
var i: integer;
begin
i := 0;
result := P1 - P2;
while (result = 0) and (i < P2) and (i < P1) do begin
result := PByte(NativeInt(S1)+i)^-PByte(NativeInt(S2)+i)^;
inc(i);
end;
end; begin
i1 := ScanBuf(Ord('.'), S1);
i2 := ScanBuf(Ord('.'), S2);
result := CmpStr(i1+2, i2+2, S1, S2);
if result = 0 then
result := CmpInt(i1, i2, S1, S2);
end; function CustomCompareList(S1, S2: Pointer): Integer;
begin
result := CustomCompareBuffer(TCustomList(S1).CurrentItem, TCustomList(S2).CurrentItem);
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TBufferedFileStream.Init(BufSize: BigInt);
begin
FBufSize := BufSize;
if FBufSize < MIN_BUFSIZE then
FBufsize := MIN_BUFSIZE
else
if FBufSize > MAX_BUFSIZE then
FBufSize := MAX_BUFSIZE
else
if (FBufSize mod MIN_BUFSIZE) <> 0 then
FBufSize := DEFAULT_BUFSIZE;
GetMem(FBuf, FBufSize);
FFileSize := GetFileSize;
FBufCount := 0;
FFileOffset := 0;
FBufPos := 0;
FDirty := False;
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TBufferedFileStream.Create(const FileName: string; Mode: Word;
BufferSize: BigInt);
begin
Create(Filename, Mode, 0, BufferSize);
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TBufferedFileStream.Create(const FileName : string; Mode: Word;
Rights: Cardinal; BufferSize: BigInt);
begin
inherited Create;
FHandle := -1;
FBuf := nil;
if Mode = fmCreate then
begin
FHandle := FileCreate(FileName, Mode, Rights);
if FHandle < 0 then
raise EFCreateError.CreateResFmt(@SFCreateErrorEx,
[ExpandFileName(FileName),
SysErrorMessage(GetLastError)]);
end
else begin
FHandle := FileOpen(FileName, Mode);
if FHandle < 0 then
raise EFOpenError.CreateResFmt(@SFOpenErrorEx,
[ExpandFileName(FileName),
SysErrorMessage(GetLastError)]);
end;
Init(BufferSize);
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TBufferedFileStream.Destroy;
begin
if (FHandle >= 0) then begin
if FDirty then
WriteToFile;
FileClose(FHandle);
end;
if FBuf <> nil then
FreeMem(FBuf, FBufSize);
inherited Destroy;
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TBufferedFileStream.GetFileSize: BigInt;
var
OldPos : BigInt;
begin
OldPos := FileSeek(FHandle, Int64(0), soFromCurrent);
Result := FileSeek(FHandle, Int64(0), soFromEnd);
FileSeek(FHandle, OldPos, soFromBeginning);
if Result < 0 then
raise Exception.Create('Cannot determine correct file size');
end; function TBufferedFileStream.GetPosition: Int64;
begin
Result := BigSeek(Int64(0), soCurrent);
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TBufferedFileStream.ReadFromFile;
var
NewPos : BigInt;
begin
NewPos := FileSeek(FHandle, FFileOffset, soFromBeginning);
if (NewPos <> FFileOffset) then
raise Exception.Create('Seek before read from file failed');
FBufCount := FileRead(FHandle, FBuf^, FBufSize);
if FBufCount = -1 then
FBufCount := 0;
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TBufferedFileStream.WriteToFile;
var
NewPos : BigInt;
BytesWritten : BigInt;
begin
NewPos := FileSeek(FHandle, FFileOffset, soFromBeginning);
if (NewPos <> FFileOffset) then
raise Exception.Create('Seek before write to file failed');
BytesWritten := FileWrite(FHandle, FBuf^, FBufCount);
if (BytesWritten <> FBufCount) then
raise Exception.Create('Could not write to file');
FDirty := False;
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TBufferedFileStream.Flush;
begin
if FDirty and (FHandle >= 0) and (FBuf <> nil) then
WriteToFile;
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TBufferedFileStream.BigRead(var Buffer; Count: BigInt): BigInt;
var
Remaining : BigInt;
Copied : BigInt;
DestPos : BigInt;
begin
Result := 0;
if FHandle < 0 then Exit;
Remaining := Min(Count, FFileSize - (FFileOffset + FBufPos));
Result := Remaining;
if (Remaining > 0) then
begin
if (FBufCount = 0) then
ReadFromFile;
Copied := Min(Remaining, FBufCount - FBufPos);
Move(FBuf[FBufPos], TByteArray(Buffer)[0], Copied);
Inc(FBufPos, Copied);
Dec(Remaining, Copied);
DestPos := 0;
while Remaining > 0 do
begin
if FDirty then
WriteToFile;
FBufPos := 0;
Inc(FFileOffset, FBufSize);
ReadFromFile;
Inc(DestPos, Copied);
Copied := Min(Remaining, FBufCount - FBufPos);
Move(FBuf[FBufPos], TByteArray(Buffer)[DestPos], Copied);
Inc(FBufPos, Copied);
Dec(Remaining, Copied);
end;
end;
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TBufferedFileStream.BigWrite(const Buffer; Count: BigInt): BigInt;
var
Remaining : BigInt;
Copied : BigInt;
DestPos : BigInt;
begin
Result := 0;
if FHandle < 0 then Exit;
Remaining := Count;
Result := Remaining;
if (Remaining > 0) then begin
if (FBufCount = 0) and ((FFileOffset + FBufPos) <= FFileSize) then
ReadFromFile;
Copied := Min(Remaining, FBufSize - FBufPos);
Move(PByte(Buffer), FBuf[FBufPos], Copied);
FDirty := True;
Inc(FBufPos, Copied);
if (FBufCount < FBufPos) then begin
FBufCount := FBufPos;
FFileSize := FFileOffset + FBufPos;
end;
Dec(Remaining, Copied);
DestPos := 0;
while Remaining > 0 do begin
WriteToFile;
FBufPos := 0;
Inc(FFileOffset, FBufSize);
if (FFileOffset < FFileSize) then
ReadFromFile
else
FBufCount := 0;
Inc(DestPos, Copied);
Copied := Min(Remaining, FBufSize - FBufPos);
Move(TByteArray(Buffer)[DestPos], FBuf[0], Copied);
FDirty := True;
Inc(FBufPos, Copied);
if (FBufCount < FBufPos) then begin
FBufCount := FBufPos;
FFileSize := FFileOffset + FBufPos;
end;
Dec(Remaining, Copied);
end;
end;
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TBufferedFileStream.BigSeek(Offset: BigInt; Origin: Word): BigInt;
begin
Result := BigSeek(Int64(Offset), TSeekOrigin(Origin));
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TBufferedFileStream.BigSeek(const Offset: Int64; Origin: TSeekOrigin): Int64;
var
NewPos : BigInt;
NewFileOffset : BigInt;
begin
Result := 0;
if FHandle < 0 then Exit; if (Offset = 0) and (Origin = soCurrent) then begin
Result := FFileOffset + FBufPos;
Exit;
end; case Origin of
soBeginning : NewPos := Offset;
soCurrent : NewPos := (FFileOffset + FBufPos) + Offset;
soEnd : NewPos := FFileSize + Offset;
else
raise Exception.Create('Invalid seek origin');
end; if (NewPos < 0) then
NewPos := 0
else
if (NewPos > FFileSize) then
FFileSize := FileSeek(FHandle, NewPos - FFileSize, soFromEnd); NewFileOffset := (NewPos div FBufSize) * FBufSize; if (NewFileOffset <> FFileOffset) then begin
if FDirty then
WriteToFile;
FFileOffset := NewFileOffset;
FBufCount := 0;
end;
FBufPos := NewPos - FFileOffset;
Result := NewPos;
end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TBufferedFileStream.SetPosition(const Value: Int64);
begin
BigSeek(Int64(Value), soBeginning);
end; procedure TBufferedFileStream.SetSize(const NewSize: Int64);
begin
if FHandle < 0 then Exit;
BigSeek(NewSize, soFromBeginning);
if NewSize < FFileSize then
FFileSize := FileSeek(FHandle, NewSize, soFromBeginning);
{$IFDEF MSWINDOWS}
if not SetEndOfFile(FHandle) then
RaiseLastOSError;
{$ELSE}
if ftruncate(FHandle, Position) = -1 then
raise EStreamError(sStreamSetSize);
{$ENDIF}
end; { TCustomList } function TCustomList.AllocateBuffer(const NewSize: BigInt): boolean;
begin
result := false;
if LongBool(FBuffer) then begin
if FBufferSize <> NewSize then begin
FreeBuffer;
end else
exit(true);
end;
try
GetMem(FBuffer, NewSize);
FBufferSize := NewSize;
result := true;
except on E: EOutOfMemory do begin
result := false;
end;
end;
end; procedure TCustomList.ClearBuffer;
begin
FSorted := false;
FItemsSize := 0;
end; constructor TCustomList.Create;
begin
inherited;
end; destructor TCustomList.Destroy;
begin
FreeBuffer;
if LongBool(FStream) then
FStream.Free;
inherited;
end; procedure TCustomList.First;
begin
FCurrentItem := FBuffer;
end; procedure TCustomList.FreeBuffer;
begin
FSorted := false;
if LongBool(FBuffer) then begin
FreeMem(FBuffer, FBufferSize);
FBuffer := nil;
FBufferSize := 0;
FItemsSize := 0;
end;
end; function TCustomList.GetStringItem(index: integer): AnsiString;
begin
Result := MakeString(items[index], ItemLength[index]);
end; function TCustomList.InitMergeList(const AFileName: string; const AMaxLength: int64): boolean;
var pos: int64;
begin
FreeBuffer;
FStream := TBufferedFileStream.Create(AFileName, fmOpenRead+fmShareDenyWrite, 0);
pos := LoadFromStream(FStream, -1, AMaxLength);
result := pos > 0;
if result then begin
ScanBuffer;
result := Next;
end;
end; function TCustomList.GetItemLength(index: integer): integer;
begin
if (Index >=0) and (Index < Count) then begin
if Items[index] = FLastItem then
result := NativeInt(FBuffer)+FItemsSize-NativeInt(Items[index])
else begin
if FSorted then begin
result := ScanBuf(13, Items[index])+2
end else begin
result := NativeInt(Items[index+1])-NativeInt(Items[index])
end;
end;
end else
Error(@SListIndexError, Index);
end; function TCustomList.LoadFromStream(const Stream: TBufferedFileStream; const AFromPos, AMaxLength: Int64): Int64;
var CR: BigInt;
begin
result := 0;
FCurrentItem := nil;
FCurrentItemIndex := 0;
FCurrentItemSize := 0;
if AllocateBuffer(AMaxLength) then begin
if AFromPos <> -1 then
Stream.BigSeek(AFromPos, soFromBeginning);
result := Stream.BigRead(FBuffer^, FBufferSize);
if result > 0 then begin
cr := 0;
while PByte(NativeInt(FBuffer)+result-cr)^ <> 10 do
inc(cr);
result := result-cr+1;
Stream.BigSeek(-cr+1, soFromCurrent);
end;
end;
FSorted := false;
FFromPos := AFromPos;
FItemsSize := result;
end; function TCustomList.Next: boolean;
begin
if FCurrentItem = FLastItem then begin
result := LoadFromStream(FStream, -1, FBufferSize) > 0;
if result then begin
ScanBuffer;
FCurrentItem := FBuffer;
FCurrentItemSize := ItemLength[0];
end else begin
FCurrentItem := nil;
FCurrentItemSize := 0;
end;
end else if LongBool(FCurrentItem) then begin
inc(FCurrentItemIndex);
FCurrentItem := Items[FCurrentItemIndex];
FCurrentItemSize := ItemLength[FCurrentItemIndex];
result := true;
end else begin
FCurrentItem := FBuffer;
FCurrentItemSize := ItemLength[0];
result := true;
end;
if not Result then
FCurrentItemSize := 0;
end; function TCustomList.SaveToStream(const Stream: TBufferedFileStream; const AFromPos: Int64): Int64;
var i: integer;
begin
result := 0;
Stream.BigSeek(AFromPos, 0);
if FSorted then begin
for I := 0 to Count-1 do
Stream.BigWrite(Items[i]^, ItemLength[i]);
end else begin
Stream.BigWrite(FBuffer^, FItemsSize);
end;
FFromPos := AFromPos;
result := Stream.Position - AFromPos;
end; procedure TCustomList.ScanBuffer;
var StartIdx, EndIdx: bigInt;
begin
Clear;
if (not LongBool(FBuffer)) or (not LongBool(FItemsSize)) then exit; StartIdx := 0;
EndIdx := 0;
repeat
if PByte(NativeInt(FBuffer)+EndIdx)^ = 13 then begin
Add(PByte(NativeInt(FBuffer)+StartIdx));
while (PByte(NativeInt(FBuffer)+EndIdx)^ in [10, 13])
and (EndIdx < FItemsSize) do inc(EndIdx);
StartIdx := EndIdx;
end;
inc(EndIdx);
until EndIdx >= FItemsSize;
if Count > 0 then
FLastItem := Items[Count-1]
else
FLastItem := nil;
end; procedure TCustomList.Sort;
begin
ScanBuffer;
if Count < 2 then exit;
Sort(CustomCompareBuffer);
FSorted := true;
end; end. fmShareDenyNone不尝试阻止其他应用程序读取或写入文件。 fmShareDenyWrite其他应用程序可以打开文件进行读取但不能写入。
最新文章
- Context值和bool开关
- Java代码执行顺序(静态变量，非静态变量，静态代码块，代码块，构造函数)加载顺序
- TP框架,根据当前应用状态对应的配置文件
- Tomcat 开发web项目报Illegal access: this web application instance has been stopped already. Could not load [org.apache.commons.pool.impl.CursorableLinkedList$Cursor]. 错误
- Android网络编程系列 一 TCP/IP协议族
- 《如何将windows上的软件包或文件上传到linux服务上》
- 查看DB文件的空间使用情况
- 高斯拉普拉斯算子（Laplace of Gaussian）
- MULE-ET0 、 ET1、ET2、PT1、PT2
- 通过游戏认识 --- JQuery与原生JS的差异
- Java进阶(六)Java反射机制可恶问题NoSuchFieldException
- React开发环境搭建（react,babel,webpack webpack-dev-server)
- malloc(0)
- du -h排序
- react ref获取dom对象
- python第一百零二天-----第十七周作业
- tomcat多实例方案启动脚本
- WIN10 常用bug解决办法
- 详解 KDTree
- pyCharm运行python提示“please select a valid interpreter”