捐赠 | 广告 | 注册 | 发布 | 上传 | 关于我们    
  粤ICP备10103342号-1 DELPHI盒子 | 盒子文章 | 盒子问答悬赏 | 最新更新 | 盒子检索 | 下载中心 | 高级搜索    
  精品专区 | 繁體中文 | 奖励公告栏 | 直通车账号登陆 | 关闭GOOGLE广告 | 临时留言    
盒子资源分类
全部展开 - 全部合拢
盒子资源分类大树
QStrings v6.07.424 (快速处理字符串)
关键字：QStrings QMemory ShareQmm 字符串
来　自：转载,http://www.torry.net/
平　台：Win2k/XP/NT 下载所需：0 火柴
深浅度：高级 完成时间：2006/5/24
发布者：hackering 发布时间：2006/5/24
编辑器：DELPHI7 语　　种：ENGLISH
分　类：系统 下载浏览：2578/13061
加入到我的收藏
下载错误报错
登陆以后才能下载
 用户名：
 密　码：
自动登陆(30天有效)
无图片
Delphi的String处理程序，速度远远快于系统自带的，开发大型服务器必备pas。
Google
 
本站原创作品，未经作者许可，严禁任何方式转载；转载作品，如果侵犯了您的权益，请联系我们！
龙脉加密锁 15元起 Grid++Report 报表 申请支付@网
　相关文章
没有相关文章
相关评论
共有评论6条 当前显示最后6条评论
liu55721 2006/5/25 7:25:29
这是干什么用的.
wyb_star 2006/5/25 10:49:12
这是最后一个版本，已经多年不更新了，要说处理速度还是fastcode最快，连delphi 2006都使用它的代码，而且还当做软件卖点，感觉borland技术实力真的是不行了，居然把使用第三方代码所带来的效率提升当做自已的最大卖点。
hackering 2006/5/25 14:00:23
您说的是这个吗？
==========
比世界上最快的替换函数还要快的替换函数 

//不是我写的，摘自fastcode的代码
//速度比当初DreamTiger写的世界上最快的替换函数速度更快，而这个不是汇编的，并且同delphi的StringReplace参数和功能上完全兼容，

unit FastcodeAnsiStringReplace;

interface

{$UNDEF RangeCheck}
{$IFOPT R+}
{$R-}
{$DEFINE RangeCheck}
{$ENDIF}
{$UNDEF OverflowCheck}
{$IFOPT Q+}
{$Q-}
{$DEFINE OverflowCheck}
{$ENDIF}

{$DEFINE AllowLengthShortcut}

uses
SysUtils;
function AnsiStringReplaceFastcodePascal(const S, OldPattern, NewPattern: AnsiString;
Flags: TReplaceFlags): AnsiString;

implementation

var
UppercaseLookUp : array[Char] of Char;

procedure SetUppercaseLookUp;
var
S : AnsiString;
I : Integer;
begin
SetLength(S, 256);
for I := 0 to 255 do
PChar(Integer(S)+I)^ := Char(I);
S := AnsiUpperCase(S);
Move(S[1], UppercaseLookUp, 256);
end; {SetUppercaseLookUp}

function AnsiUpperCase(const S : AnsiString) : AnsiString;
var
Len : Integer;
PRes : PChar;
begin
{$IFDEF AllowLengthShortcut}
Len := 0;
if S <> '' then
Len := PCardinal(Cardinal(S)-4)^;
{$ELSE}
Len := Length(S);
{$ENDIF}
SetLength(Result, Len);
PRes := Pointer(Integer(Result)-1);
while Len > 0 do
begin
PRes[Len] := UppercaseLookUp[S[Len]];
Dec(Len);
end;
end; {AnsiUpperCase}

procedure Move(const Source; var Dest; Count : Integer);
var
S, D : Cardinal;
Temp, C, I : Integer;
L : PInteger;
begin
S := Cardinal(@Source);
D := Cardinal(@Dest);
if S = D then
Exit;
if Count <= 4 then
case Count of
1 : PByte(@Dest)^ := PByte(S)^;
2 : PWord(@Dest)^ := PWord(S)^;
3 : if D > S then
begin
PByte(Integer(@Dest)+2)^ := PByte(S+2)^;
PWord(@Dest)^ := PWord(S)^;
end
else
begin
PWord(@Dest)^ := PWord(S)^;
PByte(Integer(@Dest)+2)^ := PByte(S+2)^;
end;
4 : PInteger(@Dest)^ := PInteger(S)^
else Exit; {Count <= 0}
end
else
if D > S then
begin
Temp := PInteger(S)^;
I := Integer(@Dest);
C := Count - 4;
L := PInteger(Integer(@Dest) + C);
Inc(S, C);
repeat
L^ := PInteger(S)^;
if Count <= 8 then
Break;
Dec(Count, 4);
Dec(S, 4);
Dec(L);
until False;
PInteger(I)^ := Temp;
end
else
begin
C := Count - 4;
Temp := PInteger(S + Cardinal(C))^;
I := Integer(@Dest) + C;
L := @Dest;
repeat
L^ := PInteger(S)^;
if Count <= 8 then
Break;
Dec(Count, 4);
Inc(S, 4);
Inc(L);
until False;
PInteger(I)^ := Temp;
end;
end; {Move}

function Pos(const SubStr : AnsiString; const Str : AnsiString) : Integer;
var
StrLen, SubLen, Remainder : Integer;
PStr, PSub, PMax : PChar;
FirstChar : Char;
begin;
Result := 0;
{$IFDEF AllowLengthShortcut}
if Str = '' then Exit;
if SubStr = '' then Exit;
StrLen := PCardinal(Cardinal(Str ) - 4)^;
SubLen := PCardinal(Cardinal(SubStr) - 4)^;
{$ELSE}
SubLen := Length(SubStr);
StrLen := Length(Str);
{$ENDIF}
if (SubLen = 0) then
Exit;
if (SubLen > StrLen) then
Exit;
PSub := Pointer(SubStr);
PStr := Pointer(Str); {Search Start Position}
PMax := PStr + StrLen - SubLen; {Maximum Start Position}
FirstChar := PSub^;
if SubLen = 1 then
repeat {Single Character Saarch}
if PStr^ = FirstChar then
begin
Result := PStr + 1 - Pointer(Str);
Exit;
end;
if PStr[1] = FirstChar then
begin
if PStr < PMax then
Result := PStr + 2 - Pointer(Str);
Exit;
end;
Inc(PStr, 2);
until PStr > PMax
else
begin {Multi-Character Search}
Dec(SubLen, 2); {Characters to Check after Match}
repeat
if PStr^ = FirstChar then
begin
Remainder := SubLen;
while True do
begin
if (PSub[Remainder ] <> PStr[Remainder ])
or (PSub[Remainder+1] <> PStr[Remainder+1]) then
Break; {No Match}
Dec(Remainder, 2);
if Remainder < 0 then
begin
Result := PStr + 1 - Pointer(Str);
Exit;
end;
end;
end;
if PStr[1] = FirstChar then
begin
Remainder := SubLen;
while True do
begin
if (PSub[Remainder ] <> PStr[Remainder+1])
or (PSub[Remainder+1] <> PStr[Remainder+2]) then
Break; {No Match}
Dec(Remainder, 2);
if Remainder < 0 then
begin
if PStr < PMax then
Result := PStr + 2 - Pointer(Str);
Exit;
end;
end;
end;
Inc(PStr, 2);
until PStr > PMax;
end;
end; {Pos}

function PosEx(const SubStr : AnsiString; const Str : AnsiString;
const StartPos : Cardinal) : Integer;
var
StrLen, SubLen, Remainder : Integer;
PStr, PSub, PMax : PChar;
FirstChar : Char; {First Character of SubStr}
begin;
Result := 0;
{$IFDEF AllowLengthShortcut}
if Str = '' then Exit;
if SubStr = '' then Exit;
StrLen := PCardinal(Cardinal(Str ) - 4)^;
SubLen := PCardinal(Cardinal(SubStr) - 4)^;
{$ELSE}
SubLen := Length(SubStr);
StrLen := Length(Str);
{$ENDIF}
if (SubLen = 0) then
Exit;
PSub := Pointer(SubStr);
PStr := Pointer(Str);
PMax := PStr + StrLen - SubLen; {Maximum Start Position}
{The following 3 Lines are the only Difference between Pos and PosEx}
Inc(PStr, StartPos - 1);
if PStr > PMax then
Exit;
FirstChar := PSub^;
if SubLen = 1 then
repeat {Single Character Saarch}
if PStr^ = FirstChar then
begin
Result := PStr + 1 - Pointer(Str);
Exit;
end;
if PStr[1] = FirstChar then
begin
if PStr < PMax then {Within Valid Range}
Result := PStr + 2 - Pointer(Str);
Exit;
end;
Inc(PStr, 2);
until PStr > PMax
else
begin {Multi-Character Search}
Dec(SubLen, 2); {Characters to Check after Match}
repeat
if PStr^ = FirstChar then
begin
Remainder := SubLen;
while True do
begin
if (PSub[Remainder ] <> PStr[Remainder ])
or (PSub[Remainder+1] <> PStr[Remainder+1]) then
Break; {No Match}
Dec(Remainder, 2);
if Remainder < 0 then
begin {First Char already Checked}
Result := PStr + 1 - Pointer(Str);
Exit;
end;
end;
end;
if PStr[1] = FirstChar then
begin
Remainder := SubLen;
while True do
begin
if (PSub[Remainder ] <> PStr[Remainder+1])
or (PSub[Remainder+1] <> PStr[Remainder+2]) then
Break; {No Match}
Dec(Remainder, 2);
if Remainder < 0 then
begin {First Char already Checked}
if PStr < PMax then {Within Valid Range}
Result := PStr + 2 - Pointer(Str);
Exit;
end;
end;
end;
Inc(PStr, 2);
until PStr > PMax;
end;
end; {PosEx}

const
MaxStrLen = Cardinal(MaxInt) - (16 * 1024) - 16;

{Replace All Occurances - Ignoring Case}
function AnsiStringReplaceAllIC(const Src, Old, New : AnsiString) : AnsiString;
var
SourceString, SearchString : AnsiString;
SrcLen, OldLen, NewLen, Found, Start, ResultLen, Count : Cardinal;
PSrc, PNew, PRes : PChar;
LengthCanGrow : Boolean;
begin
{$IFDEF AllowLengthShortcut}
SrcLen := 0;
if (Src <> '') then
SrcLen := PCardinal(Cardinal(Src)-4)^;
OldLen := 0;
if (Old <> '') then
OldLen := PCardinal(Cardinal(Old)-4)^;
{$ELSE}
SrcLen := Length(Src);
OldLen := Length(Old);
{$ENDIF}
if (OldLen = 0) or (SrcLen < OldLen) then
begin
if SrcLen = 0 then
Result := '' {Needed for Non-Nil Zero Length Strings}
else
Result := Src
end
else
begin
SourceString := AnsiUpperCase(Src);
SearchString := AnsiUpperCase(Old);
Found := Pos(SearchString, SourceString);
if Found <> 0 then
begin {First Match Found}
{$IFDEF AllowLengthShortcut}
NewLen := 0;
if (New <> '') then
NewLen := PCardinal(Cardinal(New)-4)^;
{$ELSE}
NewLen := Length(New); 
{$ENDIF}
LengthCanGrow := False;
if NewLen > OldLen then
begin {Set Initial Result Length - May be Adjusted Later}
if (SrcLen > 8*1024) {Skip DIV and 64-Bit Math if Possible}
and (Int64(NewLen div OldLen) * Int64(SrcLen) > 64*1024*1024) then
begin {Large - Initally Allocate Space for First Replace Only}
ResultLen := SrcLen - OldLen + NewLen;
if ResultLen > MaxStrLen then
Error(reOutOfMemory);
LengthCanGrow := True;
end
else
begin {Allocate Enough Space for Maximum Possible Replacements}
ResultLen := SrcLen
+ (((SrcLen - Found + 1) div OldLen) * (NewLen - OldLen));
end;
end
else
ResultLen := SrcLen; {Final Result Length will be <= Src Length}
SetLength(Result, ResultLen);
PNew := Pointer(New);
PSrc := Pointer(Src);
PRes := Pointer(Result);
Start := 1;
repeat
if Found <> Start then
begin
Count := Found - Start;
Move(PSrc^, PRes^, Count);
Inc(PSrc, Count);
Inc(PRes, Count);
end;
if NewLen = 1 then
PRes^ := PNew^ {Optimize Single Byte Move}
else
Move(PNew^, PRes^, NewLen);
Inc(PRes, NewLen);
Inc(PSrc, OldLen);
Start := Found + OldLen;
if Start > SrcLen then
Break;
Found := PosEx(SearchString, SourceString, Start);
if Found <> 0 then
if LengthCanGrow then
begin {Grow Result Length}
Inc(ResultLen, NewLen - OldLen);
if ResultLen > MaxStrLen then
Error(reOutOfMemory);
SetLength(Result, ResultLen);
PRes := Pointer(Result);
end;
until Found = 0;
Count := SrcLen - Start + 1;
Move(PSrc^, PRes^, Count);
Inc(Count, Cardinal(PRes) - Cardinal(Result));
if Count <> ResultLen then
SetLength(Result, Count); {Correct Result Length if Necessary}
end
else {No Matches Found}
Result := Src
end;
end; {AnsiStringReplaceAllIC}

{Replace All Occurances - Case Sensitive}
function AnsiStringReplaceAllCS(const Src, Old, New : AnsiString) : AnsiString;
var
SrcLen, OldLen, NewLen, Found, Start, ResultLen, Count : Cardinal;
PSrc, PNew, PRes : PChar;
LengthCanGrow : Boolean;
begin
{$IFDEF AllowLengthShortcut}
SrcLen := 0;
if (Src <> '') then
SrcLen := PCardinal(Cardinal(Src)-4)^;
OldLen := 0;
if (Old <> '') then
OldLen := PCardinal(Cardinal(Old)-4)^;
{$ELSE}
SrcLen := Length(Src);
OldLen := Length(Old);
{$ENDIF}
if (OldLen = 0) or (SrcLen < OldLen) then
begin
if SrcLen = 0 then
Result := '' {Needed for Non-Nil Zero Length Strings}
else
Result := Src
end
else
begin
Found := Pos(Old, Src);
if Found <> 0 then
begin {First Match Found}
{$IFDEF AllowLengthShortcut}
NewLen := 0;
if (New <> '') then
NewLen := PCardinal(Cardinal(New)-4)^;
{$ELSE}
NewLen := Length(New);
{$ENDIF}
LengthCanGrow := False;
if NewLen > OldLen then
begin {Set Initial Result Length - May be Adjusted Later}
if (SrcLen > 8*1024) {Skip DIV and 64-Bit Math if Possible}
and (Int64(NewLen div OldLen) * Int64(SrcLen) > 64*1024*1024) then
begin {Large - Initally Allocate Space for First Replace Only}
ResultLen := SrcLen - OldLen + NewLen;
if ResultLen > MaxStrLen then
Error(reOutOfMemory);
LengthCanGrow := True;
end
else
begin {Allocate Enough Space for Maximum Possible Replacements}
ResultLen := SrcLen
+ (((SrcLen - Found + 1) div OldLen) * (NewLen - OldLen));
end;
end
else
ResultLen := SrcLen; {Final Result Length will be <= Src Length}
SetLength(Result, ResultLen);
PNew := Pointer(New);
PSrc := Pointer(Src);
PRes := Pointer(Result);
Start := 1;
repeat 
if Found <> Start then
begin
Count := Found - Start;
Move(PSrc^, PRes^, Count);
Inc(PSrc, Count);
Inc(PRes, Count);
end;
if NewLen = 1 then
PRes^ := PNew^ {Optimize Single Byte Move}
else
Move(PNew^, PRes^, NewLen);
Inc(PRes, NewLen);
Inc(PSrc, OldLen);
Start := Found + OldLen;
if Start > SrcLen then
Break;
Found := PosEx(Old, Src, Start);
if Found <> 0 then
if LengthCanGrow then
begin {Grow Result Length}
Inc(ResultLen, NewLen - OldLen);
if ResultLen > MaxStrLen then
Error(reOutOfMemory);
SetLength(Result, ResultLen);
PRes := Pointer(Result);
end;
until Found = 0;
Count := SrcLen - Start + 1;
Move(PSrc^, PRes^, Count);
Inc(Count, Cardinal(PRes) - Cardinal(Result));
if Count <> ResultLen then
SetLength(Result, Count); {Correct Result Length if Necessary}
end
else {No Matches Found}
Result := Src
end;
end; {AnsiStringReplaceAllCS}

{Replace First Occurance Only - Ignoring Case}
function AnsiStringReplace1stIC(const Src, Old, New : AnsiString) : AnsiString;
var
SourceString, SearchString : AnsiString;
SrcLen, OldLen, NewLen, Found, ResultLen : Cardinal;
PSrc, PNew, PRes : PChar;
begin
{$IFDEF AllowLengthShortcut}
SrcLen := 0;
if (Src <> '') then
SrcLen := PCardinal(Cardinal(Src)-4)^;
OldLen := 0;
if (Old <> '') then
OldLen := PCardinal(Cardinal(Old)-4)^;
{$ELSE}
SrcLen := Length(Src);
OldLen := Length(Old);
{$ENDIF}
if (OldLen = 0) or (SrcLen < OldLen) then
begin
if SrcLen = 0 then
Result := '' {Needed for Non-Nil Zero Length Strings}
else
Result := Src
end
else
begin
SourceString := AnsiUpperCase(Src);
SearchString := AnsiUpperCase(Old);
Found := Pos(SearchString, SourceString);
if Found <> 0 then
begin {Match Found}
{$IFDEF AllowLengthShortcut}
NewLen := 0;
if (New <> '') then
NewLen := PCardinal(Cardinal(New)-4)^;
{$ELSE}
NewLen := Length(New);
{$ENDIF}
ResultLen := SrcLen - OldLen + NewLen;
if ResultLen > MaxStrLen then
Error(reOutOfMemory);
SetLength(Result, ResultLen);
Dec(Found);
PNew := Pointer(New);
PSrc := Pointer(Src);
PRes := Pointer(Result);
if NewLen = OldLen then
begin 
Move(PSrc^, PRes^, SrcLen);
Inc(PRes, Found);
Move(PNew^, PRes^, NewLen);
end
else
begin
Move(PSrc^, PRes^, Found);
Inc(PRes, Found);
Inc(PSrc, Found + OldLen);
if NewLen <> 0 then
begin
Move(PNew^, PRes^, NewLen);
Inc(PRes, NewLen);
end;
Move(PSrc^, PRes^, SrcLen - Found - OldLen);
end;
end
else {No Matches Found}
Result := Src
end;
end; {AnsiStringReplace1stIC}

{Replace First Occurance Only - Case Sensitive}
function AnsiStringReplace1stCS(const Src, Old, New : AnsiString) : AnsiString;
var
SrcLen, OldLen, NewLen, Found, ResultLen : Cardinal;
PSrc, PNew, PRes : PChar;
begin
{$IFDEF AllowLengthShortcut}
SrcLen := 0;
if (Src <> '') then
SrcLen := PCardinal(Cardinal(Src)-4)^;
OldLen := 0;
if (Old <> '') then
OldLen := PCardinal(Cardinal(Old)-4)^;
{$ELSE}
SrcLen := Length(Src);
OldLen := Length(Old);
{$ENDIF}
if (OldLen = 0) or (SrcLen < OldLen) then
begin
if SrcLen = 0 then
Result := '' {Needed for Non-Nil Zero Length Strings}
else
Result := Src
end
else
begin
Found := Pos(Old, Src);
if Found <> 0 then
begin {Match Found}
{$IFDEF AllowLengthShortcut}
NewLen := 0;
if (New <> '') then
NewLen := PCardinal(Cardinal(New)-4)^;
{$ELSE}
NewLen := Length(New);
{$ENDIF}
ResultLen := SrcLen - OldLen + NewLen;
if ResultLen > MaxStrLen then
Error(reOutOfMemory);
SetLength(Result, ResultLen);
Dec(Found);
PNew := Pointer(New);
PSrc := Pointer(Src);
PRes := Pointer(Result);
if NewLen = OldLen then
begin
Move(PSrc^, PRes^, SrcLen);
Inc(PRes, Found);
Move(PNew^, PRes^, NewLen);
end
else
begin
Move(PSrc^, PRes^, Found);
Inc(PRes, Found);
Inc(PSrc, Found + OldLen);
if NewLen <> 0 then
begin
Move(PNew^, PRes^, NewLen);
Inc(PRes, NewLen);
end;
Move(PSrc^, PRes^, SrcLen - Found - OldLen);
end;
end
else {No Matches Found}
Result := Src
end;
end; {AnsiStringReplace1stCS}

//Author: John O'Harrow
//Optimized for: All
//Instructionset(s): IA32
//Original Name: AnsiStringReplaceJOH_PAS

function AnsiStringReplaceFastcodePascal(const S, OldPattern, NewPattern: AnsiString;
Flags: TReplaceFlags): AnsiString;
type
TReplaceFunction = function(const Src, Old, New : AnsiString) : AnsiString;
const
StringReplaceFunction : array[0..3] of TReplaceFunction =
(AnsiStringReplace1stCS, AnsiStringReplaceAllCS,
AnsiStringReplace1stIC, AnsiStringReplaceAllIC);
begin
Result := StringReplaceFunction[PByte(@Flags)^](S, OldPattern, NewPattern);
end;

{$IFDEF RangeCheck}
{$R+}
{$UNDEF RangeCheck}
{$ENDIF}
{$IFDEF OverflowCheck}
{$Q+}
{$UNDEF OverflowCheck}
{$ENDIF}

initialization

SetUppercaseLookUp;
end.
fly_phoenix 2006/5/26 15:02:31
To:hackering 
FastCode V0.3 测试的结果没比原来的快，QMemory和fastmm比较过吗？
fwjindream 2006/5/26 15:19:40
有没有经过测试 呢.
稳定性如何呢.
kinneng 2006/5/29 0:08:18
没用了，凡是有 ^ PChar 的代码，Delphi.net是通不过编译的，虽然有变通替代方法，但是速度更慢。
我要发表评论 查看全部评论
 
  DELPHI盒子版权所有 技术支持:深圳市麟瑞科技有限公司 1999-2024 V4.01 粤ICP备10103342号-1 更新RSS列表