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.