(*
This can be used for Streams OR files. Set AStream parameter to nil
if passing a FileName.
Usage:
Scan a Stream:
ScanIt('texttofind', False, MyMemoryStream);
Scan a File:
ScanIt('texttofind', False, nil, 'c:\mytextfile.txt');
*)
function ScanIt(
const forString:
String;
caseSensitive: Boolean;
AStream: TStream;
AFilename: TFileName = '
'): LongInt;
{
returns position of string in stream or file,
returns -1 if not found
}
const
BufferSize= $8001;
{ 32K+1 bytes }
var
pBuf, pend, pScan, pPos : Pchar;
bytesRemaining: Integer;
bytesToRead: Integer;
SearchFor: Pchar;
filesize: LongInt;
fsTemp: TFileStream;
begin
Result := -1;
{ assume failure }
if (Length(forString) = 0)
or
((AStream <>
nil)
and (AStream.Size = 0))
and
((AStream =
nil)
and (Length(AFilename) = 0))
then
Exit;
SearchFor :=
nil;
pBuf :=
nil;
{ open file as binary, 1 byte recordsize }
if not Assigned(AStream)
then
begin
fsTemp := TFileStream.Create(AFilename, fmOpenRead
or fmShareDenyWrite);
try
Result := ScanIt(forString, caseSensitive, fsTemp);
finally
fsTemp.free;
end;
end
else
begin
try { allocate memory for buffer and pchar search string }
SearchFor := StrAlloc(Length(forString)+1);
StrPCopy(SearchFor, forString);
if not caseSensitive
then { convert to upper case }
AnsiUpper(SearchFor);
GetMem(pBuf, BufferSize);
filesize := AStream.Size;
bytesRemaining := filesize;
pPos :=
nil;
while bytesRemaining > 0
do
begin
{ calc how many bytes to read this round }
if bytesRemaining >= BufferSize
then
bytesToRead := Pred(BufferSize)
else
bytesToRead := bytesRemaining;
AStream.ReadBuffer(pBuf^, bytesToRead);
{ read a buffer full and zero-terminate the buffer }
pend := @pBuf[ bytesToRead ];
pend^:= #0;
{ scan the buffer. Problem: buffer may contain #0 chars! So we
treat it as a concatenation of zero-terminated strings. }
pScan := pBuf;
while pScan < pend
do
begin
if not caseSensitive
then { convert to upper case }
AnsiUpper(pScan);
pPos := StrPos(pScan, SearchFor);
{ search for substring }
if pPos <>
nil then { Found it! }
begin
Result := fileSize - bytesRemaining +
LongInt(pPos) - LongInt(pBuf);
break;
end;
pScan := Strend(pScan);
Inc(pScan);
end;
if pPos <>
nil then
break;
bytesRemaining := bytesRemaining - bytesToRead;
if bytesRemaining > 0
then
begin
{ no luck in this buffers load. We need to handle the case of
the search string spanning two chunks of file now. We simply
go back a bit in the file and read from there, thus inspecting
some characters twice
}
AStream.Seek(-Length(forString), soFromCurrent);
bytesRemaining := bytesRemaining + Length(forString);
end;
end;
{ while }
finally
if SearchFor <>
nil then StrDispose(SearchFor);
if pBuf <>
nil then FreeMem(pBuf, BufferSize);
end;
end;
end;
{ ScanIt }
type
TFontType = (tftOpenType, tftTrueType, tftRaster);
function GetFontType(AFontFileName:
String): TFontType;
var
fs: TFileStream;
begin
Result := tftRaster;
fs := TFileStream.Create(AFontFileName, fmOpenRead);
try
fs.Position := 0;
// OpenType fonts have this signature in them
if ScanIt('
DSIG', False, fs) > 0
then
begin
Result := tftOpenType;
end
else
begin
Result := tftTrueType;
end;
finally
fs.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
case GetFontType('
c:\Windows\Fonts\Amerigo Bold BT.TTF')
of
tftOpenType:
begin
ShowMessage('
OpenType');
end;
tftTrueType:
begin
ShowMessage('
TrueType');
end;
end;
end;