13.4. Каталоги

Упражнение 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.