home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-387-Vol-3of3.iso
/
h
/
htmix20.zip
/
FF.ZIP
/
TFF.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1992-07-12
|
9KB
|
344 lines
program TurboFileFind;
{┌──────────────────────────────── INFO ────────────────────────────────────┐}
{│ File : TFF.PAS │}
{│ Author : Harald Thunem │}
{│ Purpose : Another File Find clone. │}
{│ Updated : July 10 1992 │}
{└──────────────────────────────────────────────────────────────────────────┘}
{────────────────────────── Compiler directives ─────────────────────────────}
{$A+ Word align data }
{$B- Short-circuit Boolean expression evaluation }
{$E- Disable linking with 8087-emulating run-time library }
{$G+ Enable 80286 code generation }
{$R- Disable generation of range-checking code }
{$S- Disable generation of stack-overflow checking code }
{$V- String variable checking }
{$X- Disable Turbo Pascal's extended syntax }
{$N+ 80x87 code generation }
{$D- Disable generation of debug information }
{────────────────────────────────────────────────────────────────────────────}
uses Dos,
Crt,
Strings;
const StartNum = 4;
var DeleteList,
ScreenPause,
SaveList,
CopyList : boolean;
MainDir,Dir : DirStr;
Name : NameStr;
Ext : ExtStr;
SearchFile,
SaveFilename: string;
TargetDrive : char;
NumItems : word;
TotalSize : longint;
f : text;
procedure ShowOptions;
begin
WriteLn;
WriteLn('Program : TFF -- Turbo File Finder');
WriteLn('Author : Harald Thunem');
WriteLn('Purpose : Find files and optionally copy or erase them');
WriteLn('Updated : July 10 1992');
WriteLn;
WriteLn('Usage : TFF [D:]SearchFile [/h /? /p /d /cDrive /fSavefile');
WriteLn;
WriteLn(' SearchFile may contain wildcards ("*.pas","nu*.?xe")');
WriteLn(' /h,/? - Shows this help');
WriteLn(' /p - Pause for each screen');
WriteLn(' /d - Delete all found files');
WriteLn(' /c - Copy files to Drive');
WriteLn(' /f - Save search info to file Savefile');
WriteLn;
WriteLn('Returns : Directory Name Size Date [Co Er XX YY]');
WriteLn(' Directory - Where the file was found');
WriteLn(' Name - File name');
WriteLn(' Size - File size');
WriteLn(' Date - File date');
WriteLn(' Co - If file was copied successfully');
WriteLn(' XX - If file was not copied');
WriteLn(' Er - If file was erased successfully');
WriteLn(' YY - If file was not erased');
Halt(1);
end;
procedure GetCommands;
var i: byte;
s: string;
s2: string[2];
begin
CopyList := false;
SaveList := false;
DeleteList := false;
ScreenPause := false;
SearchFile := '';
SaveFilename := '';
TargetDrive := 'C';
SearchFile := '*.*';
GetDir(0,MainDir);
MainDir := Copy(MainDir,1,2);
if ParamCount=0 then
ShowOptions;
if ParamCount>0 then
for i := 1 to ParamCount do
begin
s := UpcaseStr(ParamStr(i));
s2 := Copy(s,1,2);
if (s='/?') or (s='/H') then ShowOptions
else if s='/D' then DeleteList:=true
else if s='/P' then ScreenPause:=true
else if s2='/F' then
begin
SaveList := true;
SaveFilename := Copy(s,3,Length(s)-2);
if SaveFilename = '' then
SaveList := false;
end
else if s2='/C' then
begin
CopyList := true;
TargetDrive := s[3];
end
else SearchFile := s;
end;
if Pos(':',SearchFile)>0 then
begin
MainDir := SearchFile[1]+':';
Delete(SearchFile,1,2);
end;
if SearchFile[1]='\' then Delete(SearchFile,1,1);
end;
function AddDots(s: string): string;
begin
if Length(s)>3 then
Insert('.',s,Length(s)-2);
if Length(s)>7 then
Insert('.',s,Length(s)-6);
AddDots := s;
end;
function DateStr(Time: longint): string;
var DT: DateTime;
s1,s2: string;
begin
s1 := '';
s2 := '';
UnpackTime(Time,DT);
s1 := StrL(DT.Month);
if Length(s1)=1 then s1:='0'+s1;
s2 := StrL(Dt.Day);
if Length(s2)=1 then s2:='0'+s2;
s1 := s1 + '.' + s2;
s2 := StrL(Dt.Year);
s1 := s1 + '.' + s2;
DateStr := s1;
end;
procedure QuitProgram;
begin
GoToXY(1,WhereY);
ClrEol;
WriteLn('─────────────────────────────────────────────────────────────────────────');
WriteLn(NumItems-StartNum,' matches found, occupying ',AddDots(StrL(TotalSize)),' bytes');
if SaveList then
begin
WriteLn(f);
WriteLn(f,'─────────────────────────────────────────────────────────────────────────');
WriteLn(f,NumItems-StartNum,' matches found, occupying ',AddDots(StrL(TotalSize)),' bytes');
Close(f);
end;
Halt(1);
end;
function DeleteFile(Name: PathStr): boolean;
var DF: file;
B : boolean;
begin
{$I-}
Assign(DF,Name);
Reset(DF);
{$I+}
B := IOResult=0;
if B then
begin
Close(DF);
Erase(DF);
end;
DeleteFile := B;
end;
function CopyFile(FromName: PathStr; Size: longint; TargetDrive: char): boolean;
var FromF,ToF : file;
ToName : PathStr;
NumRead,
NumWritten: word;
Buffer : array[1..2048] of char;
DriveSize : longint;
DriveNum : byte;
CopyOK : boolean;
begin
DriveNum := Ord(TargetDrive)-64;
DriveSize := DiskSize(DriveNum);
if DriveSize<Size then
begin
CopyFile := false;
Exit;
end;
FSplit(FromName,Dir,Name,Ext);
ToName := TargetDrive+':\'+Name+Ext;
{$I-}
Assign(FromF,FromName);
Reset(FromF,1);
{$I+}
CopyOK := IOResult=0;
if CopyOK then
begin
Assign(ToF,ToName);
ReWrite(ToF,1);
repeat
BlockRead(FromF,Buffer,
SizeOf(Buffer),NumRead);
BlockWrite(ToF,Buffer,NumRead,NumWritten);
until (NumRead = 0) or
(NumWritten <> NumRead);
Close(FromF);
Close(ToF);
end;
CopyFile := CopyOK;
end;
procedure ProceedItem(MainDir: DirStr; S: SearchRec);
var s1,s2: string;
Ch : char;
CopyOK: boolean;
begin
{ Write directory }
if S.Attr and Directory=Directory then
begin
GoToXY(1,WhereY);
ClrEol;
Write(MainDir+S.Name);
Exit;
end;
{ Write files }
Inc(NumItems);
TotalSize := TotalSize + S.Size;
FSplit(S.Name,Dir,Name,Ext);
while Length(Name)<8 do
Name := Name+' ';
while Length(Ext)<4 do
Ext := Ext+' ';
s1 := Name+Ext;
s2 := StrL(S.Size);
s2 := AddDots(s2);
while Length(s2)<11 do
s2 := ' '+s2;
s1 := s1 + s2;
s2 := ' '+DateStr(S.Time);
s1 := s1 + s2;
CopyOK := true;
if CopyList then
if CopyFile(MainDir+S.Name,S.Size,TargetDrive) then
s1 := s1 + ' Co'
else begin
s1 := s1 + ' YY';
CopyOK := false;
end;
if DeleteList then
if CopyOK then
if DeleteFile(MainDir+S.Name) then
s1 := s1 + ' Er'
else s1 := s1 + ' XX';
GoToXY(40,WhereY);
WriteLn(s1);
if SaveList then
begin
while Length(s1)<76 do
s1 := ' '+s1;
Delete(s1,1,Length(MainDir));
s1 := MainDir+s1;
WriteLn(f,s1);
end;
if NumItems mod 24 = 0 then
if ScreenPause then
begin
Write('Press any key...[Esc to quit]');
Ch := ReadKey;
GoToXY(1,WhereY);
ClrEol;
if Ch=#27 then QuitProgram;
end;
end;
procedure Search(MainDir: DirStr; SearchFile: string);
var S: SearchRec;
Attr: byte;
FoundFile: boolean;
begin
FoundFile := false;
MainDir := MainDir + '\';
{ Search for files }
Attr := Hidden+SysFile+ReadOnly+Archive;
FindFirst(MainDir+SearchFile,Attr,S);
while DosError = 0 do
begin
ProceedItem(MainDir,S);
FindNext(S);
end;
{ Search for sub-directories }
Attr := Directory;
FindFirst(MainDir+'*.*',Attr,S);
while DosError = 0 do
begin
if (S.Attr and Attr <>0) and (S.Name[1]<>'.') and (S.Name[1]<>'..') then
begin
ProceedItem(MainDir,S);
Search(MainDir+S.Name,SearchFile);
end;
FindNext(S);
end;
end;
begin
NumItems := StartNum;
TotalSize := 0;
WriteLn('TFF 2.0 Written by H.Thunem');
GetCommands;
WriteLn('Directory File Size Date');
WriteLn('─────────────────────────────────────────────────────────────────────────');
if SaveList then
begin
Assign(f,SaveFilename);
ReWrite(f);
WriteLn(f,'TFF 2.0 Written by H.Thunem');
WriteLn(f,'Directory File Size Date');
WriteLn(f,'─────────────────────────────────────────────────────────────────────────');
end;
Search(MainDir,SearchFile);
QuitProgram;
end.