delphi并行压缩
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 Items: array of array of T; private FCount: int64; function GetElements(n: int64): T; procedure SetElements(n: int64; const Value: T); procedure SetCount(const Value: int64); public procedure Clear; property Elements[n: int64]: T read GetElements write SetElements; default; property Count: int64 read FCount write SetCount; end; |
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其他应用程序可以打开文件进行读取但不能写入。