Каталоги
Упражнение 13.28. Напишите аналог команды ls -l.
uses linux,strings,sysutils; (*для системных вызовов Linux и работы со строками PChar*)
function ctime(var time_t:longint):pchar;cdecl;external 'c';
function gettype(t:word):char;forward; (*тип объекта ф.с. в формате команды ls*)
(*тип объекта ф.с. в формате команды ls*)
function gettype(t:word):char;
begin
if S_ISDIR(t) then (*проверка на каталог*)
gettype:='d'
else
if S_ISREG(t) then (*проверка на обычный файл*)
gettype:='-'
else
if S_ISBLK(t) then (*проверка на блочное устройство*)
gettype:='b'
else
if S_ISCHR(t) then (*проверка на символьное устройство*)
gettype:='c'
else
if S_ISFIFO(t) then (*проверка на именованный программный канал*)
gettype:='p'
else
if S_ISLNK(t) then (*проверка на сиволическую ссылку*)
gettype:='l'
else
gettype:='?';
end;
function getrights(r:word):string;
var
u, (*права для владельца*)
g, (*права для группы*)
o, (*права для всех остальных*)
s, (*специальные права*)
i:integer;
res:string; (*права в символьной форме*)
const
o7777=(1 shl 12)-1; (*восьмеричная константа = все 12 бит прав заданы *)
o10 =8; (*010 *)
o100 =64; (*0100 *)
o1000=512; (*01000*)
symrights:array [0..7] of string=( (*базовые комбинации прав в символьной форме*)
'---', (*0 = 000*)
'--x', (*1 = 001*)
'-w-', (*2 = 010*)
'-wx', (*3 = 011*)
'r--', (*4 = 100*)
'r-x', (*5 = 101*)
'rw-', (*6 = 110*)
'rwx' (*7 = 111*)
);
spec='tss'; (*массив специальных прав доступа*)
begin
(*обрезаем старшие биты, не относящиеся к правам доступа (тип файла и т.п.)*)
r:=r and o7777;(*восьмеричная константа 10000-1==1*8^4-1==1*(2^3)^4-1==2^12-1 *)
(* выделяем числовые права для владельца, группы, остальных + специальные*)
o:=r mod o10;
s:=r div o1000;
u:=(r div o100) mod o10;
g:=(r mod o100) div o10;
res:=symrights[u]+symrights[g]+symrights[o];(*формируем символьыне права из базовых троек*)
for i:=1 to 3 do (*цикл проверки наличия чпециальных прав*)
if s and (1 shl (i-1)) <> 0 then (*если право установлено*)
if res[12-3*i]='x' then (*если есть обычное право на выполнение*)
res[12-3*i]:=spec[i] (*заносим маленькую букву*)
else
res[12-3*i]:=upcase(spec[i]); (*иначе - большую*)
getrights:=res; (*возвращаем результат - 9-символьное представление 12-битных прав*)
end;
var
d:^TDir; (*указатель на запись для работы с каталогом*)
elem:^Dirent; (*указатель на запись, хранящую один элекмент каталога*)
tekkat, (*строка для хранения имени каталога*)
fullpath (*полный путь к элементу каталога*)
:array [0..1000] of char;
st:stat; (*для хранения информации о файле или каталоге*)
begin
if paramcount=0 then (*если в командной строке не указан каталог*)
strcopy(tekkat,'.') (*то в качестве каталога используем текущий*)
else
tekkat:=paramstr(1); (*иначе используем каталог из командной строки*)
if not access(pchar(tekkat),F_OK or R_OK) then (*F_OK - проверка сущестования объекта ф.с.*)
begin
writeln('Каталог ', tekkat, ' не существует или недоступен для чтения'); (*диагностика*)
halt(1); (*возврат в предыдущую программу*)
end;
if not fstat(pchar(tekkat),st) then (*попытка получения информации о файле или каталоге*)
begin
writeln('Ошибка получения информации о каталоге ', tekkat); (*диагностика*)
halt(1); (*возврат в предыдущую программу*)
end;
if not S_ISDIR(st.mode) then (*проверка на каталог*)
begin
writeln(tekkat, ' - не каталог'); (*диагностика*)
halt(1); (*возврат в предыдущую программу*)
end;
d:=opendir(tekkat); (*попытка открытия каталога для чтения*)
if d=nil then (*если попытка не удалась*)
begin
writeln(' Ошибка вызова opendir для каталога ', tekkat); (*диагностика*)
halt(1); (*возврат в предыдущую программу*)
end;
elem:=readdir(d); (*попытка чтения элемента каталога*)
while elem<>nil do
begin
(*формирование полного имени элемента каталога*)
strcopy(fullpath,tekkat); (*копируем имя текущего каталога в начало полного имени*)
if strcomp(tekkat,'/')<>0 then(*если текущий каталог - не корневой*)
begin
if fullpath[strlen(fullpath)-1]='/' then (*если в конце имени каталога слэш*)
fullpath[strlen(fullpath)-1]:=#0; (*заменяем его признаком конца строки*)
strcat(fullpath,'/'); (*добавляем после имени каталога слэш-разделитель*)
end;
strcat(fullpath,elem^.name); (*и имя элемента каталога*)
if not fstat(pchar(fullpath),st) then (*попытка получения информации о файле или каталоге*)
begin
writeln('Ошибка получения информации о ', fullpath); (*диагностика*)
continue; (*возврат в предыдущую программу*)
end;
{gmtime_r(st.mtime,mytm);}
writeln(gettype(st.mode),getrights(st.mode),st.nlink:5,
' ',st.size:10,' ',ctime(st.mtime), elem^.name); (*вывод имени элемента каталога*)
elem:=readdir(d); (*попытка чтения элемента каталога*)
end;
closedir(d); (*закрытие открытого opendir каталога*)
end.
Упражнение 13.29. Составьте аналог команды vdir.
uses linux,strings,sysutils;
function getname(uid:integer):string;
const w='/etc/passwd';
var ts,nam1,namb1:string;
tx:text;
begin
assign(tx,w);
reset(tx);
while not EOF (tx) do
begin
readln(tx,ts);
uid:=pos(':',ts);
nam1:=copy(ts,1,uid-1);
delete(ts,1,uid);
uid:=pos(':',ts);
delete(ts,1,uid);
namb1:=copy(ts,1,uid-1);
if namb1='500' then
write(nam1)
end;
close(tx);
getname:=nam1;
end;
function getgroup(gid:integer):string;
const q='/etc/group';
var ts,nam,namb:string;
t:text;
begin
assign(t,q);
reset(t);
while not EOF (t) do
begin
readln(t,ts);
gid:=pos(':',ts);
nam:=copy(ts,1,gid-1);
delete(ts,1,gid);
gid:=pos(':',ts);
delete(ts,1,gid);
namb:=copy(ts,1,gid-1);
if namb='500' then
write(nam);
end;
close(t);
getgroup:=nam;
end;
function gettype(mode:integer):char;
begin
if S_ISREG(mode) then
gettype:='-'
else
if S_ISDIR(mode) then
gettype:='d'
else
if S_ISCHR(mode) then
gettype:='c'
else
if S_ISBLK(mode) then
gettype:='b'
else
if S_ISFIFO(mode) then
gettype:='p'
else
gettype:='l';
end;
function getrights(mode:integer):string;
const
sympr:array [0..7] of string=(
'---', {0}
'--x', {1}
'-w-', {2}
'-wx', {3}
'r--', {4}
'r-x', {5}
'rw-', {6}
'rwx' {7}
);
specsympr:array [0..7] of string=(
'---', {0}
'--t', {1}
'-s-', {2}
'-st', {3}
's--', {4}
's-t', {5}
'ss-', {6}
'sst' {7}
);
var
s,u,g,o,i:integer;
res:string;
begin
mode:=mode and octal(7777);
u:=(mode div octal(100)) mod octal(10);
g:=(mode mod octal(100)) div octal(10);
o:=mode mod octal(10);
s:=mode div octal(1000);
res:=sympr[u]+sympr[g]+sympr[o];
for i:=1 to 3 do
if specsympr[s][i]<>'-' then
begin
if res[3*i]='-' then
res[3*i]:=upcase(specsympr[s][i])
else
res[3*i]:=specsympr[s][i];
end;
getrights:=res;
end;
var
d:PDIR;
el:pdirent;
st:stat;
res:integer;
dt:tdatetime;
polniypath,name:array [0..2000] of char;
begin
if paramcount = 0 then
name:='.'
else
name:=paramstr(1);
d:=opendir(name);
if d=nil then
begin
writeln('Ошибка открытия текущего каталога');
halt(0);
end;
el:=readdir(d);
while el<>nil do
begin
polniypath:=name;
if strcomp(name,'/')=0 then
strcat(polniypath,el^.name)
else
begin
if name[strlen(name)-1]<>'/' then
strcat(polniypath,'/');
strcat(polniypath,el^.name);
end;
if not fstat(pchar(polniypath),st) then
writeln('Ошибка вызова stat для ',polniypath)
else
begin
{writeln(polniypath,' ',s.size);}
dt:=filedatetodatetime(st.mtime);
write(gettype(st.mode),getrights(st.mode),st.nlink:5,
getname(st.uid),' ',getgroup(st.gid),st.size:10,' ',datetimetostr(dt),' ' );
writeln(el^.name);
end;
el:=readdir(d);
end;
closedir(d);
end.
Упражнение 13.30. Напишите упрощенный аналог команды ls, распечатывающий содержимое текущего каталога (файла с именем ".") без сортировки имен по алфавиту. Предусмотрите чтение каталога, чье имя задается как аргумент программы. Имена "." и ".." не выдавать.
uses linux,strings,sysutils,crt;
{$linklib c}
type
plong=^longint;
function ctime(r:plong):pchar;cdecl;external;
function strchr(s:string;c:char):boolean;
var
i:integer;
begin
for i:=1 to length(s) do
if s[i]=c then
begin
strchr:=true;
exit;
end;
strchr:=false;
end;
function getall(w:string;uid:integer):string;
{const w='/etc/passwd';}
var ts,nam1,namb1:string;
tx:text;
d:integer;
begin
assign(tx,w);
reset(tx);
while not EOF (tx) do
begin
readln(tx,ts);
d:=pos(':',ts);
nam1:=copy(ts,1,d-1);
delete(ts,1,d+2);
d:=pos(':',ts);
{delete(ts,1,d);}
namb1:=copy(ts,1,d-1);
val(namb1,d);
{writeln('имя = ',nam1,', номер=',namb1);}
if d=uid then
break;
end;
close(tx);
getall:=nam1;
end;
function getname(uid:integer):string;
begin
getname:=getall('/etc/passwd',uid);
end;
function getgroup(gid:integer):string;
begin
getgroup:=getall('/etc/group',gid);
end;
function gettype(mode:integer):char;
begin
if S_ISREG(mode) then
gettype:='-'
else
if S_ISDIR(mode) then
gettype:='d'
else
if S_ISCHR(mode) then
gettype:='c'
else
if S_ISBLK(mode) then
gettype:='b'
else
if S_ISFIFO(mode) then
gettype:='p'
else
gettype:='l';
end;
function getrights(mode:integer):string;
const
sympr:array [0..7] of string=(
'---', {0}
'--x', {1}
'-w-', {2}
'-wx', {3}
'r--', {4}
'r-x', {5}
'rw-', {6}
'rwx' {7}
);
specsympr:array [0..7] of string=(
'---', {0}
'--t', {1}
'-s-', {2}
'-st', {3}
's--', {4}
's-t', {5}
'ss-', {6}
'sst' {7}
);
var
s,u,g,o,i:integer;
res:string;
begin
mode:=mode and octal(7777);
u:=(mode div octal(100)) mod octal(10);
g:=(mode mod octal(100)) div octal(10);
o:=mode mod octal(10);
s:=mode div octal(1000);
res:=sympr[u]+sympr[g]+sympr[o];
for i:=1 to 3 do
if specsympr[s][i]<>'-' then
begin
if res[3*i]='-' then
res[3*i]:=upcase(specsympr[s][i])
else
res[3*i]:=specsympr[s][i];
end;
getrights:=res;
end;
procedure obhod(name:pchar);
var
d:PDIR;
el:pdirent;
st:stat;
res:integer;
dt:tdatetime;
polniypath,datetime:array [0..2000] of char;
i,k:integer;
begin
d:=opendir(name);
if d=nil then
begin
writeln('Ошибка открытия каталога ',name);
exit;
end;
i:=0;
el:=readdir(d);
while el<>nil do
begin
polniypath:=name;
if strcomp(name,'/')=0 then
strcat(polniypath,el^.name)
else
begin
if name[strlen(name)-1]<>'/' then
strcat(polniypath,'/');
strcat(polniypath,el^.name);
end;
if not fstat(pchar(polniypath),st) then
writeln(' Ошибка вызова stat для ',polniypath)
else
begin
(*
strcopy(datetime,ctime(@st.mtime)+4);
datetime[12]:=#0;
write(gettype(st.mode),getrights(st.mode),st.nlink:5,' ',
getname(st.uid):10,' ',getgroup(st.gid):10,' ',st.size:10,' ',datetime,' ' );
*)
if(gettype(st.mode)='d') then
textcolor(9);
if(gettype(st.mode)='-') and strchr(getrights(st.mode),'x') then
textcolor(lightgreen);
if(gettype(st.mode)='p') then
textcolor(brown);
if(gettype(st.mode)='l') then
textcolor(lightblue);
if (gettype(st.mode)='c') or (gettype(st.mode)='b') then
textcolor(yellow);
write(el^.name);
for k:=strlen(el^.name) to 15 do
write(' ');
textcolor(7);
end;
el:=readdir(d);
inc(i);
if(i mod 5=0)then writeln;
end;
closedir(d);
if(i mod 5<>0)then writeln;
end;
var
name:array [0..2000] of char;
begin
if paramcount = 0 then
name:='.'
else
name:=paramstr(1);
obhod(name);
end.
Упражнение 13.31. Напишите программу удаления файлов и каталогов, заданных в командной строке. Программа должна удалять каталоги рекурсивно и отказываться удалять файлы устройств.
uses linux,strings,sysutils,crt;
{$linklib c}
type
plong=^longint;
function gettype(mode:integer):char;
begin
if S_ISREG(mode) then
gettype:='-'
else
if S_ISDIR(mode) then
gettype:='d'
else
if S_ISCHR(mode) then
gettype:='c'
else
if S_ISBLK(mode) then
gettype:='b'
else
if S_ISFIFO(mode) then
gettype:='p'
else
gettype:='l';
end;
function obhod(name:pchar):boolean;
var
flag:boolean;
d:PDIR;
el:pdirent;
st:stat;
res:integer;
polniypath:array [0..2000] of char;
begin
flag:=true;
d:=opendir(name);
if d=nil then
begin
writeln('Ошибка открытия каталога ',name);
exit;
end;
el:=readdir(d);
while el<>nil do
begin
polniypath:=name;
if strcomp(name,'/')=0 then
strcat(polniypath,el^.name)
else
begin
if name[strlen(name)-1]<>'/' then
strcat(polniypath,'/');
strcat(polniypath,el^.name);
end;
if not fstat(pchar(polniypath),st) then
writeln('Ошибка вызова stat для ',polniypath)
else
begin
if not (gettype(st.mode) in ['b','c','d']) then
begin
writeln('Стираю файл ',polniypath);
//unlink(polniypath);
if not unlink(polniypath) then
begin
writeln('невозможно стереть файл ',polniypath);
flag:=false;(*ошибка удаления файла - нельзя будет стереть каталог*)
end;
end;
end;
el:=readdir(d);
end;
closedir(d);
d:=opendir(name);
el:=readdir(d);
while el<>nil do
begin
polniypath:=name;
if strcomp(name,'/')=0 then
strcat(polniypath,el^.name)
else
begin
if name[strlen(name)-1]<>'/' then
strcat(polniypath,'/');
strcat(polniypath,el^.name);
end;
if not fstat(pchar(polniypath),st) then
writeln('Ошибка вызова stat для ',polniypath)
else
begin
if (gettype(st.mode)='d') and
(strcomp(el^.name,'.')<>0) and
(strcomp(el^.name,'..')<>0) then
begin
writeln('Переход в каталог ',polniypath);
if not obhod(polniypath) then
flag:=false;
end;
end;
el:=readdir(d);
end;
closedir(d);
if not flag then
writeln('Каталог ',name,
' не будет стерт, т.к. в нем не удалось стереть часть файлов или каталогов')
else
begin
{$i-}
rmdir(name);
if ioresult <> 0 then
begin
writeln('Ошибка удаления каталога ',name);
flag:=false;
end;
end;
writeln('Для каталога ',name, ' получен ',flag);
obhod:=flag;
end;
var
name:array [0..2000] of char;
begin
if paramcount<>0 then
begin
name:=paramstr(1);
obhod(name);
end
else
writeln('С особой осторожностью используйте: ',paramstr(0),' удаляемый каталог');
end.
Упражнение 13.32. Напишите функцию рекурсивного обхода дерева подкаталогов и печати имен всех файлов в нем с выдачей атрибутов в форме команды ls -l.
uses linux,strings,sysutils;
{$linklib c}
type
plong=^longint;
function ctime(r:plong):pchar;cdecl;external;
function getall(w:string;uid:integer):string;
{const w='/etc/passwd';}
var ts,nam1,namb1:string;
tx:text;
d:integer;
begin
assign(tx,w);
reset(tx);
while not EOF (tx) do
begin
readln(tx,ts);
d:=pos(':',ts);
nam1:=copy(ts,1,d-1);
delete(ts,1,d+2);
d:=pos(':',ts);
{delete(ts,1,d);}
namb1:=copy(ts,1,d-1);
val(namb1,d);
{writeln('имя = ',nam1,', номер=',namb1);}
if d=uid then
break;
end;
close(tx);
getall:=nam1;
end;
function getname(uid:integer):string;
begin
getname:=getall('/etc/passwd',uid);
end;
function getgroup(gid:integer):string;
begin
getgroup:=getall('/etc/group',gid);
end;
function gettype(mode:integer):char;
begin
if S_ISREG(mode) then
gettype:='-'
else
if S_ISDIR(mode) then
gettype:='d'
else
if S_ISCHR(mode) then
gettype:='c'
else
if S_ISBLK(mode) then
gettype:='b'
else
if S_ISFIFO(mode) then
gettype:='p'
else
gettype:='l';
end;
function getrights(mode:integer):string;
const
sympr:array [0..7] of string=(
'---', {0}
'--x', {1}
'-w-', {2}
'-wx', {3}
'r--', {4}
'r-x', {5}
'rw-', {6}
'rwx' {7}
);
specsympr:array [0..7] of string=(
'---', {0}
'--t', {1}
'-s-', {2}
'-st', {3}
's--', {4}
's-t', {5}
'ss-', {6}
'sst' {7}
);
var
s,u,g,o,i:integer;
res:string;
begin
mode:=mode and octal(7777);
u:=(mode div octal(100)) mod octal(10);
g:=(mode mod octal(100)) div octal(10);
o:=mode mod octal(10);
s:=mode div octal(1000);
res:=sympr[u]+sympr[g]+sympr[o];
for i:=1 to 3 do
if specsympr[s][i]<>'-' then
begin
if res[3*i]='-' then
res[3*i]:=upcase(specsympr[s][i])
else
res[3*i]:=specsympr[s][i];
end;
getrights:=res;
end;
procedure obhod(name:pchar);
var
d:PDIR;
el:pdirent;
st:stat;
res:integer;
dt:tdatetime;
polniypath,datetime:array [0..2000] of char;
begin
d:=opendir(name);
if d=nil then
begin
writeln('Ошибка открытия каталога ',name);
exit;
end;
el:=readdir(d);
while el<>nil do
begin
polniypath:=name;
if strcomp(name,'/')=0 then
strcat(polniypath,el^.name)
else
begin
if name[strlen(name)-1]<>'/' then
strcat(polniypath,'/');
strcat(polniypath,el^.name);
end;
if not fstat(pchar(polniypath),st) then
writeln(' Ошибка вызова stat для ',polniypath)
else
begin
strcopy(datetime,ctime(@st.mtime)+4);
datetime[12]:=#0;
write(gettype(st.mode),getrights(st.mode),st.nlink:5,' ',
getname(st.uid):10,' ',getgroup(st.gid):10,' ',st.size:10,' ',datetime,' ' );
writeln(el^.name);
end;
el:=readdir(d);
end;
closedir(d);
d:=opendir(name);
el:=readdir(d);
while el<>nil do
begin
polniypath:=name;
if strcomp(name,'/')=0 then
strcat(polniypath,el^.name)
else
begin
if name[strlen(name)-1]<>'/' then
strcat(polniypath,'/');
strcat(polniypath,el^.name);
end;
if not fstat(pchar(polniypath),st) then
writeln('Ошибка вызова stat для ',polniypath)
else
begin
if S_ISDIR(st.mode) then
begin
if (strcomp(el^.name,'.')<>0) and (strcomp(el^.name,'..')<>0) then
begin
writeln;
writeln(polniypath,':');
obhod(polniypath);
end;
end;
end;
el:=readdir(d);
end;
closedir(d);
end;
var
name:array [0..2000] of char;
begin
if paramcount = 0 then
name:='.'
else
name:=paramstr(1);
obhod(name);
end.
Упражнение 13.33. Напишите программу удаления каталога, которая удаляет все файлы в нем и, рекурсивно, все его подкаталоги.
uses linux,strings,sysutils,crt;
{$linklib c}
type
plong=^longint;
function gettype(mode:integer):char;
begin
if S_ISREG(mode) then
gettype:='-'
else
if S_ISDIR(mode) then
gettype:='d'
else
if S_ISCHR(mode) then
gettype:='c'
else
if S_ISBLK(mode) then
gettype:='b'
else
if S_ISFIFO(mode) then
gettype:='p'
else
gettype:='l';
end;
function obhod(name:pchar):boolean;
var
flag:boolean;
d:PDIR;
el:pdirent;
st:stat;
res:integer;
polniypath:array [0..2000] of char;
begin
flag:=true;
d:=opendir(name);
if d=nil then
begin
writeln('Ошибка открытия каталога ',name);
exit;
end;
el:=readdir(d);
while el<>nil do
begin
polniypath:=name;
if strcomp(name,'/')=0 then
strcat(polniypath,el^.name)
else
begin
if name[strlen(name)-1]<>'/' then
strcat(polniypath,'/');
strcat(polniypath,el^.name);
end;
if not fstat(pchar(polniypath),st) then
writeln('Ошибка вызова stat для ',polniypath)
else
begin
if not (gettype(st.mode) = 'd') then
begin
writeln('Стираю файл ',polniypath);
//unlink(polniypath);
if not unlink(polniypath) then
begin
writeln('невозможно стереть файл ',polniypath);
flag:=false;(*ошибка удаления файла - нельзя будет стереть каталог*)
end;
end;
end;
el:=readdir(d);
end;
closedir(d);
d:=opendir(name);
el:=readdir(d);
while el<>nil do
begin
polniypath:=name;
if strcomp(name,'/')=0 then
strcat(polniypath,el^.name)
else
begin
if name[strlen(name)-1]<>'/' then
strcat(polniypath,'/');
strcat(polniypath,el^.name);
end;
if not fstat(pchar(polniypath),st) then
writeln('Ошибка вызова stat для ',polniypath)
else
begin
if (gettype(st.mode)='d') and
(strcomp(el^.name,'.')<>0) and
(strcomp(el^.name,'..')<>0) then
begin
writeln('Переход в каталог ',polniypath);
if not obhod(polniypath) then
flag:=false;
end;
end;
el:=readdir(d);
end;
closedir(d);
if not flag then
writeln('Каталог ',name,
' не будет стерт, т.к. в нем не удалось стереть часть файлов или каталогов')
else
begin
{$i-}
rmdir(name);
if ioresult <> 0 then
begin
writeln('Ошибка удаления каталога ',name);
flag:=false;
end;
end;
writeln('Для каталога ',name, ' получен ',flag);
obhod:=flag;
end;
var
name:array [0..2000] of char;
begin
if paramcount<>0 then
begin
name:=paramstr(1);
obhod(name);
end
else
writeln('С особой осторожностью используйте: ',paramstr(0),' удаляемый каталог');
end.
