[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]
{ Turbo Pascal File Viewer Object }
uses Dos, Crt;
const
PrintSet: set of $20..$7E = [ $20..$7E ];
ExtenSet: set of $80..$FE = [ $80..$FE ];
NoPrnSet: set of $09..$0D = [ $09, $0A, $0D ];
type
CharType = ( Unknown, Ascii, Hex );
DataBlock = array[1..256] of byte;
Viewer = object
XOrg, YOrg,
LineLen, LineCnt, BlockCount : integer;
FileName : string;
FileType : CharType;
procedure FileOpen( Fn : string;
X1, Y1, X2, Y2 : integer );
function TestBlock( FileBlock : DataBlock;
Count : integer ): CharType;
procedure ListHex( FileBlock : DataBlock;
Count, Ofs : integer );
procedure ListAscii( FileBlock : DataBlock;
Count : integer );
end;
Finder = object( Viewer )
procedure Search( Fn, SearchStr : string;
X1, Y1, X2, Y2 : integer );
end;
procedure Finder.Search;
var
VF : file; Result1, Result2 : word;
BlkOfs, i, j, SearchLen : integer;
SearchArray : array[1..128] of byte;
EndFlag, BlkDone, SearchResult : boolean;
FileBlock1, FileBlock2, ResultArray : DataBlock;
begin
BlockCount := 0;
XOrg := X1;
YOrg := Y1;
LineLen := X2;
LineCnt := Y2;
FileType := Unknown;
SearchLen := ord( SearchStr[0] );
for i := 1 to Searchlen do
SearchArray[i] := ord( SearchStr[i] );
for i := 1 to sizeof( ResultArray ) do
ResultArray[i] := $00;
assign( VF, Fn );
{$I-} reset( VF, 1 ); {$I+}
if IOresult = 0 then
begin
EndFlag := false;
BlkDone := false;
SearchResult := false;
BlockRead( VF, FileBlock2, sizeof( FileBlock2 ), Result2 );
EndFlag := Result2 <> sizeof( FileBlock2 );
repeat
FileBlock1 := FileBlock2;
Result1 := Result2;
FileBlock2 := ResultArray;
if not EndFlag then
begin
BlockRead( VF, FileBlock2, sizeof( FileBlock2 ), Result2 );
inc( BlockCount );
EndFlag := Result2 <> sizeof( FileBlock2 );
end else BlkDone := True;
for i := 1 to Result1 do
begin
if SearchArray[1] = FileBlock1[i] then
begin
BlkOfs := i-1;
SearchResult := true;
for j := 1 to SearchLen do
begin
if i+j-1 <= Result1 then
begin
if SearchArray[j] = FileBlock1[i+j-1] then
ResultArray[j] := FileBlock1[i+j-1] else
begin
SearchResult := false;
j := SearchLen;
end;
end else
if SearchArray[j] = FileBlock2[i+j-257] then
ResultArray[j] := FileBlock2[i+j-257] else
begin
SearchResult := false;
j := SearchLen;
end;
end;
if SearchResult then
begin
for j := SearchLen+1 to sizeof( ResultArray ) do
if i+j-1 <= Result1
then ResultArray[j] := FileBlock1[i+j-1]
else ResultArray[j] := FileBlock2[i+j-257];
i := Result1;
end;
end;
end;
until BlkDone or SearchResult;
if SearchResult then
begin
writeln( 'Search string found in file block ', BlockCount,
' beginning at byte offset ', BlkOfs, ' ...' );
writeln;
if FileType = Unknown then
FileType := TestBlock( ResultArray,
sizeof( ResultArray ) );
case FileType of
Hex : ListHex( ResultArray, sizeof( ResultArray ), BlkOfs );
Ascii : ListAscii( ResultArray, sizeof( ResultArray ) );
end;
end else writeln( '"', SearchStr, '" not found in ', FN );
close( VF );
window( 1, 1, 80, 25 );
end else writeln( Fn, ' invalid file name!' );
end;
procedure Viewer.FileOpen;
var
VF : file; Ch : char;
Result, CrtX, CrtY : word;
EndFlag : boolean;
FileBlock : DataBlock;
begin
BlockCount := 0;
XOrg := X1;
YOrg := Y1;
LineLen := X2;
LineCnt := Y2;
FileType := Unknown;
assign( VF, Fn );
{$I-} reset( VF, 1 ); {$I+}
if IOresult = 0 then
begin
window( X1, Y1, X1+X2-1, Y1+Y2-1 );
writeln;
EndFlag := false;
repeat
BlockRead( VF, FileBlock, sizeof( FileBlock ), Result );
inc( BlockCount );
EndFlag := Result <> sizeof( FileBlock );
if FileType = Unknown then
FileType := TestBlock( FileBlock, Result );
case FileType of
Hex : ListHex( FileBlock, Result, 0 );
Ascii : ListAscii( FileBlock, Result );
end;
if not EndFlag then
begin
CrtX := WhereX; CrtY := WhereY;
if WhereY = LineCnt then
begin writeln;
dec( CrtY ); end;
gotoxy( 1, 1 ); clreol;
write(' Viewing: ', FN );
gotoxy( 1, LineCnt ); clreol;
write(' Press (+) to continue, (Enter) to exit: ');
Ch := ReadKey; EndFlag := Ch <> '+';
gotoxy( 1, LineCnt ); clreol;
gotoxy( CrtX, CrtY );
end;
until EndFlag;
close( VF );
sound( 440 ); delay( 100 );
sound( 220 ); delay( 100 ); nosound;
window( 1, 1, 80, 25 );
end else writeln( Fn, ' invalid file name!' );
end;
function Viewer.TestBlock;
var
i : integer;
begin
FileType := Ascii;
for i := 1 to Count do
if not FileBlock[i] in NoPrnSet+PrintSet then
FileType := Hex;
TestBlock := FileType;
end;
procedure Viewer.ListHex;
const
HexStr: string[16] = '0123456789ABCDEF';
var
i, j, k : integer;
begin
k := 1;
repeat
write(' ');
j := (BlockCount-1) * sizeof( FileBlock ) + ( k - 1 ) + Ofs;
for i := 3 downto 0 do
write( HexStr[ j shr (i*4) AND $0F + 1 ] );
write(': ');
for i := 1 to 16 do
begin
if k <= Count then
write( HexStr[ FileBlock[k] shr 4 + 1 ],
HexStr[ FileBlock[k] AND $0F + 1 ], ' ' )
else write( ' ' );
inc( k );
if( i div 4 = i / 4 ) then write(' ');
end;
for i := k-16 to k-1 do
if i <= Count then
if FileBlock[i] in PrintSet+ExtenSet
then write( chr( FileBlock[i] ) )
else write('.');
writeln;
until k >= Count;
end;
procedure Viewer.ListAscii;
var
i : integer;
begin
for i := 1 to Count do
begin
write( chr( FileBlock[i] ) );
if WhereX > LineLen then writeln;
if WhereY >= LineCnt then
begin
writeln;
gotoxy( 1, LineCnt-1 );
end;
end;
end;
{=============== end Viewer object ==============}
var
FileFind : Finder;
begin
clrscr;
FileFind.Search( 'D:\TP\EXE\search.EXE', { file to search }
'Press any key', { search string }
1, 1, 80, 25 ); { display window }
gotoxy( 1, 25 ); clreol;
write( 'Press any key to continue: ');
while not KeyPressed do;
end.
[Back to TEXTFILE SWAG index] [Back to Main SWAG index] [Original]