unit Searches;
(*-----------------------------------------------------------------------------*
| Components TSearch & TFileSearch |
| Version: 2.2 |
| Last Update: 10 June 2004 |
| Compilers: Delphi 3 - Delphi 7 |
| Author: Angus Johnson - angusj-AT-myrealbox-DOT-com |
| Copyright: © 2001 -2004 Angus Johnson |
| |
| Description: Delphi implementation of the |
| Boyer-Moore-Horspool search algorithm. |
*-----------------------------------------------------------------------------*)
//10.06.04: Added support for widestring searches
interface
uses
windows, sysutils, classes;
type
TBaseSearch = class(TComponent)
private
fPos : pchar;
fEnd : pchar;
fPattern : string;
fPatLen : integer;
fPatInitialized : boolean;
fCaseSensitive : boolean;
JumpShift : integer;
Shift : array[#0..#255] of integer;
CaseBlindTable : array[#0..#255] of char;
procedure InitPattern;
procedure MakeCaseBlindTable;
procedure SetCaseSensitive(CaseSens: boolean);
procedure SetPattern(const Pattern: string);
procedure SetWsPattern(const WsPattern: widestring);
function FindCaseSensitive: integer;
function FindCaseInsensitive: integer;
protected
fStart : pchar;
fDataLength : integer;
procedure ClearData;
procedure SetData(Data: pchar; DataLength: integer); virtual;
public
constructor Create(aowner: tcomponent); override;
destructor Destroy; override;
//The following Find functions return the 0 based offset of Pattern
//else POSITION_EOF (-1) if the Pattern is not found ...
function FindFirst: integer;
function FindNext: integer;
function FindFrom(StartPos: integer): integer;
//To simplify searching for widestring patterns -
//assign the WsPattern property instead of the Pattern property
property WsPattern: widestring write SetWsPattern;
property Data: pchar read fStart;
property DataSize: integer read fDataLength;
published
property CaseSensitive: boolean read fCaseSensitive write SetCaseSensitive;
property Pattern: string read fPattern write SetPattern;
end;
TSearch = class(TBaseSearch)
public
//Changes visibility of base SetData() method to public ...
//Note: TSearch does NOT own the data. To avoid the overhead of
//copying it, it just gets a pointer to it.
procedure SetData(Data: pchar; DataLength: integer); override;
end;
TFileSearch = class(TBaseSearch)
private
fFilename: string;
procedure SetFilename(const Filename: string);
procedure Closefile;
public
destructor Destroy; override;
published
//Assigning 'Filename' creates a memory map of the named file.
//This memory mapping will be closed when either the Filename property is
//assigned to '' or the FileSearch object is destroyed.
property Filename: string read fFilename write SetFilename;
end;
procedure Register;
const
POSITION_EOF = -1;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TSearch, TFileSearch]);
end;
//------------------------------------------------------------------------------
// TBaseSearch methods ...
//------------------------------------------------------------------------------
procedure TBaseSearch.MakeCaseBlindTable;
var
i: char;
begin
for i:= #0 to #255 do
CaseBlindTable[i]:= ansilowercase(i)[1];
end;
//------------------------------------------------------------------------------
constructor TBaseSearch.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fStart := nil;
fPattern := '';
fPatLen := 0;
MakeCaseBlindTable;
fCaseSensitive := false; //Default to case insensitive searches.
fPatInitialized := false;
end;
//------------------------------------------------------------------------------
destructor TBaseSearch.Destroy;
begin
ClearData;
inherited Destroy;
end;
//------------------------------------------------------------------------------
procedure TBaseSearch.ClearData;
begin
fStart := nil;
fPos := nil;
fEnd := nil;
fDataLength := 0;
end;
//------------------------------------------------------------------------------
procedure TBaseSearch.SetPattern(const Pattern: string);
begin
if fPattern = Pattern then exit;
fPattern := Pattern;
fPatLen := length(Pattern);
fPatInitialized := false;
end;
//------------------------------------------------------------------------------
procedure TBaseSearch.SetWsPattern(const WsPattern: widestring);
begin
fPatLen := length(WsPattern)*2;
fPatInitialized := false;
if fPatLen = 0 then exit;
SetString(fPattern, pchar(pointer(WsPattern)), fPatLen);
end;
//------------------------------------------------------------------------------
procedure TBaseSearch.SetData(Data: pchar; DataLength: integer);
begin
ClearData;
if (Data = nil) or (DataLength < 1) then exit;
fStart := Data;
fDataLength := DataLength;
fEnd := fStart + fDataLength;
end;
//------------------------------------------------------------------------------
procedure TBaseSearch.SetCaseSensitive(CaseSens: boolean);
begin
if fCaseSensitive = CaseSens then exit;
fCaseSensitive := CaseSens;
fPatInitialized := false;
end;
//------------------------------------------------------------------------------
procedure TBaseSearch.InitPattern;
var
j: integer;
i: char;
begin
if fPatLen = 0 then exit;
for i := #0 to #255 do Shift[i]:= fPatLen;
if fCaseSensitive then
begin
for j := 1 to fPatLen-1 do
Shift[fPattern[j]]:= fPatLen - j;
JumpShift := Shift[fPattern[fPatLen]];
Shift[fPattern[fPatLen]] := 0;
end else
begin
for j := 1 to fPatLen-1 do
Shift[CaseBlindTable[fPattern[j]]]:= fPatLen - j;
JumpShift := Shift[CaseBlindTable[fPattern[fPatLen]]];
Shift[CaseBlindTable[fPattern[fPatLen]]] := 0;
end;
fPatInitialized := true;
end;
//------------------------------------------------------------------------------
function TBaseSearch.FindFirst: integer;
begin
fPos := fStart+fPatLen-1;
result := FindNext;
end;
//------------------------------------------------------------------------------
function TBaseSearch.FindFrom(StartPos: integer): integer;
begin
if StartPos < fPatLen-1 then //ie: StartPos must never be less than fPatLen-1
fPos := fStart+fPatLen-1 else
fPos := fStart+StartPos;
result := FindNext;
end;
//------------------------------------------------------------------------------
function TBaseSearch.FindNext: integer;
begin
if not fPatInitialized then InitPattern;
if (fPatLen = 0) or (fPatLen >= fDataLength) or (fPos >= fEnd) then
begin
fPos := fEnd;
result := POSITION_EOF;
exit;
end;
if fCaseSensitive then
result := FindCaseSensitive else
result := FindCaseInsensitive;
end;
//------------------------------------------------------------------------------
function TBaseSearch.FindCaseSensitive: integer;
var
i: integer;
j: pchar;
begin
result:= POSITION_EOF;
while fPos < fEnd do
begin
i := Shift[fPos^]; //test last character first
if i <> 0 then //last char does not match
inc(fPos,i)
else
begin //last char matches at least
i := 1;
j := fPos - fPatLen;
while (i < fPatLen) and (fPattern[i] = (j+i)^) do inc(i);
if (i = fPatLen) then
begin
result:= fPos-fStart-fPatLen+1;
inc(fPos,fPatLen);
break; //FOUND!
end
else
inc(fPos,JumpShift);
end;
end;
end;
//------------------------------------------------------------------------------
function TBaseSearch.FindCaseInsensitive: integer;
var
i: integer;
j: pchar;
begin
result:= POSITION_EOF;
while fPos < fEnd do
begin
i := Shift[CaseBlindTable[fPos^]]; //test last character first
if i <> 0 then //last char does not match
inc(fPos,i)
else
begin //last char matches at least
i := 1;
j := fPos - fPatLen;
while (i < fPatLen) and
(CaseBlindTable[fPattern[i]] = CaseBlindTable[(j+i)^]) do inc(i);
if (i = fPatLen) then
begin
result:= fPos-fStart-fPatLen+1;
inc(fPos,fPatLen);
break; //FOUND!
end
else
inc(fPos,JumpShift);
end;
end;
end;
//------------------------------------------------------------------------------
// TSearch methods ...
//------------------------------------------------------------------------------
procedure TSearch.SetData(Data: pchar; DataLength: integer);
begin
inherited; //changes visibility of base method from protected to public
end;
//------------------------------------------------------------------------------
// TFileSearch methods ...
//------------------------------------------------------------------------------
destructor TFileSearch.Destroy;
begin
CloseFile;
inherited Destroy;
end;
//------------------------------------------------------------------------------
procedure TFileSearch.SetFilename(const Filename: string);
var
filehandle: integer;
filemappinghandle: thandle;
size, highsize: integer;
begin
if (csDesigning in ComponentState) then
begin
fFilename := Filename;
exit;
end;
CloseFile;
if (Filename = '') or not FileExists(Filename) then exit;
filehandle := sysutils.FileOpen(Filename, fmopenread or fmsharedenynone);
if filehandle = 0 then exit; //error
size := GetFileSize(filehandle, @highsize);
if (size <= 0) or (highsize <> 0) then //nb: files >2 gig not supported
begin
CloseHandle(filehandle);
exit;
end;
filemappinghandle :=
CreateFileMapping(filehandle, nil, page_readonly, 0, 0, nil);
if GetLastError = error_already_exists then filemappinghandle := 0;
if filemappinghandle <> 0 then
SetData(MapViewOfFile(filemappinghandle,file_map_read,0,0,0),size);
if fStart <> nil then fFilename := Filename;
CloseHandle(filemappinghandle);
CloseHandle(filehandle);
end;
//------------------------------------------------------------------------------
procedure TFileSearch.CloseFile;
begin
if (csDesigning in ComponentState) then exit;
if (fStart <> nil) then UnmapViewOfFile(fStart);
fFilename := '';
ClearData;
end;
//------------------------------------------------------------------------------
end.
