unit SEARCH;
interface
uses dos,utils;
type shortstr=string[9];
type extstring=string[4];
type numbers=1..12;
type pntstring=^string;
type TResult=object
private
pntarr:array[1..11] of pntstring;
str_num:numbers;
all_num:byte;
allow:boolean;
files:^text;
procedure init;
function records(fpath:string;max:byte;show:boolean):boolean;
public
function findname(num:numbers):string;
procedure destroy;
end;
const any='.**';
const sfile='.*';
const sfolder='';
function SuperSearch(name:shortstr;dir:string;const stype:extstring;max:byte;show:boolean;var PResult:TResult):boolean;
implementation
type search_array=array[1..28] of searchrec;
procedure TResult.init;
var i:numbers;
disk:char;
begin
allow:=true;
if all_num>1 then exit;
for i:=1 to 11 do pntarr[i]:=nil;
str_num:=1;
all_num:=1;
if fileExists('C:\*.*') then disk:='C'
else if fileExists('A:\*.*') then disk:='A'
else
begin
allow:=false;
exit;
end;
new(files);
assign(files^,disk+':\files.txt');
rewrite(files^);
end;
function TResult.records(fpath:string;max:byte;show:boolean):boolean;
begin
if all_num< max then
begin
if str_num< 10 then records:=true
else if allow then records:=true
else records:=false;
end
else
begin
records:=false;
if all_num>max then exit;
end;
if show then writeln(all_num,': ',fpath)
else
begin
if str_num< 12 then
begin
new(pntarr[str_num]);
pntarr[str_num]^:=fpath;
inc(str_num);
end
else writeln(files^,fpath);
end;
inc(all_num);
end;
function TResult.findname(num:numbers):string;
var i:byte;
name:string;
begin
if num>=all_num then findname:=''
else
begin
if num< 12 then findname:=pntarr[num]^
else
begin
reset(files^);
for i:=1 to num-11 do
readln(files^,name);
findname:=name;
end;
end;
end;
procedure TResult.destroy;
var i:byte;
begin
for i:=1 to str_num-1 do dispose(pntarr[i]);
{$I-}
erase(files^);
{$I+}
dispose(files);
str_num:=1;
all_num:=1;
end;
function SuperSearch(name:shortstr;dir:string;const stype:extstring;max:byte;show:boolean;var PResult:TResult):boolean;
var searcharr:^search_array;
srch:searchrec;
n_pos:pointer;
extmask:extstring;
namemask:shortstr;
find_folder,uni:boolean;
disk:'C'..'Z';
i:byte;
label ONE_DIR,NEXT;
function no_name(substr,str:shortstr):byte;
begin
no_name:=1;
end;
function Upper_name(name:string):shortstr;
begin
UpString(name);
Upper_name:=name;
end;
function write_result:boolean;
procedure check_end;
begin
SuperSearch:=true;
if PResult.records(dir+'\'+srch.name,max,show)
then write_result:=true
else write_result:=false;
end;
begin
if (stype=sfolder) and (srch.size=0) then check_end
else if namemask< >'*' then
begin
if stype=any then check_end
else if srch.size< >0 then check_end;
end
else
if (strCont(name,copy(srch.name,1,pos('.',srch.name)-1))) or
((n_pos=@no_name) and (strCont('.',srch.name))) then
if stype=any then check_end
else if srch.size< >0 then check_end;
end;
begin
SuperSearch:=false;
if dir< >'' then
begin
if byte(dir[0])=1 then dir:=dir+':'
else if (dir[byte(dir[0])]='\') or (dir[byte(dir[0])]='\') then
dec(dir[0]);
if not fileExists(dir+'\*.*') then exit;
uni:=true;
disk:='Z';
end
else disk:='C';
if stype=any then extmask:='.*'
else if (stype[1]='.') or (stype=sfolder) then extmask:=stype
else exit;
name:=Upper_name(name);
if name[1]='*' then
begin
namemask:='*';
if byte(name[0])=1 then n_pos:=@no_name
else n_pos:=@StrCont;
delete(name,1,1);
end
else
begin
n_pos:=@StrCont;
namemask:=name;
end;
PResult.init;
if not show then inc(max,PResult.all_num-1);
if (max>255) or (max=0) then max:=255;
new(searcharr);
i:=1;
if disk='Z' then goto ONE_DIR;
for disk:='C' to 'Z' do
begin
findfirst(disk+':\*.*',anyfile,srch);
if doserror=0 then dir:=disk+':'
else if disk>'G' then exit
else continue;
uni:=true;
ONE_DIR:
repeat
find_folder:=false;
if uni then
begin
findfirst(dir+'\*',anyfile,searcharr^[i]);
if (byte(dir[0])>2) and (doserror=0) then
begin
findnext(searcharr^[i]);
findnext(searcharr^[i]);
end;
while (doserror=0) and (searcharr^[i].size< >0) do findnext(searcharr^[i]);
if doserror=0 then find_folder:=true;
findfirst(dir+'\'+namemask+extmask,anyfile,srch);
while doserror=0 do
begin
asm
PUSH SS
LEA AX,name
PUSH AX
PUSH SS
LEA AX,srch.nameins
PUSH AX
CALL n_pos
OR AX,AX
JE NEXT
end;
if not write_result then exit;
NEXT:
findnext(srch);
end;
if find_folder then
begin
dir:=dir+'\'+searcharr^[i].name;
inc(i);
end
else if i< >1 then
begin
uni:=false;
dec(dir[0],byte(searcharr^[i-1].name[0])+1);
dec(i);
end
else break;
continue;
end;
findnext(searcharr^[i]);
if doserror=0 then
begin
dir:=dir+'\'+searcharr^[i].name;
uni:=true;
inc(i);
end
else if i< >1 then
begin
dec(dir[0],byte(searcharr^[i-1].name[0])+1);
dec(i);
end
else break;
until false;
if disk='Z' then exit;
end;
end;
end.