{*******************************************************}
{                                                       }
{         (C) 1991-2003  Sun World Library          }
{         http://uafo.ru/msg/homepage/swe/swe.html      }
{                                                       }
{         Directory Unit              12.2003           }
{                                                       }
{*******************************************************}
unit UDir;

interface

Uses Classes;

type
TDirRec   = class (TObject)
             Attr: word;
             Time: Longint;
             Size: Longint;
             Name: string[255];   (* string[12] *)
           end;

TDirList = class(TList)
  Path       : string;            (* исследуемый каталог       *)
  SDiv       : string;            (* разделить информационной части и ссылки *)
//Count      : integer;           (* общее число имен в списке файлов        *)
  CountDir_s : integer;           (* число директорий в списке *)
(*------------------------------------*)
(* элементы для форматирования вывода *)
(*------------------------------------*)
  LSN        : integer;           (* длина поля имени          *)
  LSNC       : integer;           (* длина поля имени после коррекции *)
  LSE        : integer;           (* длина поля расширения     *)
  LSD        : integer;           (* длина поля даты (=17)     *)
  LSZ        : integer;           (* длина поля размера файла  *)
  LBlank     : integer;           (* пробелов до разделителя   *)
  DirBeg0    : integer;           (* рекомендуемая позиция разделителя *)
                                  (*       копируется из Ed.ctx.DirBeg *)
  DirBeg     : integer;           (* конечная позиция разделителя      *)
(*------------------------------------*)
(* элементарные операции              *)
(*------------------------------------*)
procedure SWAP(I,J:integer);      (* переставить 2 элемента       *)
function Get(I:integer):TDirRec;  (* получить запись нужного типа *)
procedure Done;                   (* освободить память            *)
(*------------------------------------*)
(* ОСНОВНОЕ ДЕЙСТВИЕ ОБЪЕКТА          *)
(*------------------------------------*)
procedure Collect(aPath:string);  (* занести в список файлы, соотв-щие Path *)
(*------------------------------------*)
(* выборка и сортировка               *)
(*------------------------------------*)
procedure GetDir_s;       (* выбрать директории среди файлов и посчитать их *)
procedure LQuickSort(L, R: Integer);
procedure SortFiles(I1,I2:integer);
procedure SortInsideExt;
procedure DefaultSort;            (* по расширениям *)
(*------------------------------------*)
(* подготовка к форматированию строк  *)
(*------------------------------------*)
procedure CalcLen_s;
procedure CorrectLen_s;
procedure FindDirBeg(S:string);
(*------------------------------------*)
(* результаты в строковом виде        *)
(*------------------------------------*)
function GetStr(I:integer):string;(* получить строку, соответствующую записи I*)
function GetStr0:string;          (* получить 0-вую строку             *)
function GetStrPath:string;       (* получить строку с именем каталога *)
function GetStrTotal:string;      (* -''- со статистикой               *)

  end;  (* TDirList *)


(*=====================================================*)
(*             Экспортируемые процедуры                *)
(*  (которые должны входить в модуль обработки строк   *)
(*                     или в модуль утилит)            *)
(*=====================================================*)

//function left(S:string;N:integer):string;    (* аналог ф-ии из Бэйсика *)
//function right(S:string;N:integer):string;   (* аналог ф-ии из Бэйсика *)
function rightfrom(S:string;N:integer):string; (* копировать ОТ позиции N *)
function posR(T,S:string):integer; (* pos справа налево *)
procedure Warn(S:string);
function GetFullCurrentPath:string;


implementation

uses Windows,SysUtils,Forms{,UUtil,swStr,UEd,swFile};

(*----------------------------------------------------------*)
(*  для организации сортировки                              *)
(*----------------------------------------------------------*)
type LessFunc = function(X, Y: pointer): Boolean;
var  Less: LessFunc;

(*----------------------------------------------------------*)
(*  функции со строками                                     *)
(*----------------------------------------------------------*)
const
  MonthStr: array[1..12] of string[3] = (
    'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
    'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');

function StrUpCase(S:string):string;
var I:Integer;
begin
  StrUpCase := '';
  If S = '' Then Exit;
  For I := 1 To Length(S) Do S[I] := UpCase(S[I]);
  StrUpCase := S;
end;

function IntStr(I:longint;D:integer):string; (* целое - в сторку (D цифр) *)
  var S : string;
  begin Str(I:D,S); IntStr:=S end;

function NumStr(N, D: integer):string; (* целое - в строку с ведущими нулями *)
begin
  SetLength(Result,D);
  while D > 0 do begin
    NumStr[D] := Chr(N mod 10 + Ord('0'));
    N := N div 10;
    Dec(D);
  end;
end;

(* вписать строку S в поле длинной L1, добавив пробелы справа *)
function JustL(S:string;L1:integer):string;
var L,I : integer;
begin
  L := Length(S);
  if L > L1 then begin S := copy(S,1,L1-1); S := S + '*' end;
  for I := 1 to L1-L do S := S + ' ';
  JustL := S;
end;

(* вписать строку S в поле длинной L1, добавив пробелы слева *)
function JustR(S:string;L1:integer):string;
var L,I : integer;
begin
  L := Length(S);
  if L > L1 then begin S := copy(S,2,L1); S := '*' + S; end;
  for I := 1 to L1-L do S := ' ' + S;
  JustR := S;
end;

(* PosP('1','12345123',3) => 7 *)
function posP(T:string;S:string;P1:integer):integer;  (* pos от позиции P1 *)
var P : integer;
begin
  if P1 < 1 then P1 := 1; (* строка нач-ся с первого, а не с 0-ого символа *)
  P:=System.pos(T,Copy(S,P1,length(S)-P1+1));
  if P>0 then PosP:=P+P1-1 else PosP:=0;
end; (* PosP *)

function posR(T,S:string):integer; (* pos справа налево *)
var P1,P2 : integer;
begin
  P2 := 0; P1 := System.pos(T,S);
  while P1 > 0 do begin
    P2 := P2 + P1; P1 := System.pos(T,copy(S,P2+1,length(S)-P2));
  end;
  Result := P2;
end;

function left(S:string;N:integer):string; (* аналог ф-ии из Бэйсика *)
var L : integer;
begin
  L := length(S);
  if N > L then N := L;
  if N <= 0 then result := '' else result := copy(S,1,N);
end;

function right(S:string;N:integer):string; (* аналог ф-ии из Бэйсика *)
var L : integer;
begin
  L := length(S);
  if N > L then N := L;
  if N <= 0 then result := '' else result := copy(S,L-N+1,N);
end;

function rightfrom(S:string;N:integer):string; (* копировать ОТ позиции N *)
var L : integer;
begin
  L := length(S);
  if N > L then result := '' else result := copy(S,N,L-N+1);
end;

(*----------------------------------------------------------*)
(*  обработка строк с именами или атрибутами файлов         *)
(*----------------------------------------------------------*)

function AddBackSlashForce(Path:string):string;
(* работает для существующих каталогов             *)
(* проверяет, что Path - именно каталог, а не файл *)
var F : file;
 Attr : word;
begin
  if Path[Length(Path)] <> '\' then
  begin
    Assign(F, Path);
    Attr := FileGetAttr(Path);    // ф-я зависит от ПЛАТФОРМЫ
//  GetFAttr(F, Attr);
//  if (DosError = 0) and (Attr and Directory <> 0) then
    if (Attr and faDirectory <> 0) then
      Path := Path + '\';
  end;
  Result := Path;
end;

function GetFullCurrentPath:string;
var S : string;
begin
  S := SysUtils.GetCurrentDir;   //'';     (* текущий каталог *)
  S := ExpandUNCFileName(S);
  Result := AddBackSlashForce(S);
end;

(* разбить имя файла на имя и расширение *)
procedure GetNamExt(const Nam:string;var NS,ES:string);
begin
  if (Nam = '.') or (Nam = '..') then begin
    NS := Nam; ES := '';
  end
  else begin
    ES := ExtractFileExt(Nam);
    NS := Copy(Nam,1,Length(Nam)-Length(ES));
    if ES <> '' then ES := Copy(ES,2,Length(ES)-1);
  end;
end;

(* преобразовать в строку дату/время созданияч файла *)
function FileTimeToS15(fTim:longint):string; (* длина строки 15 символов*)
var T: TDateTime;                            (* "DD-mmm-YY HH:MM" *)
   TT: TSystemTime;
begin
  T := FileDateToDateTime(fTim);
  DateTimeToSystemTime(T,TT);
  Result := IntStr(TT.wDay,2)+'-'+         // 3
            MonthStr[TT.wMonth]+'-'+       // 4
            NumStr(TT.wYear mod 100, 2)+   // 2
            IntStr(TT.wHour,3)+':'+        // 4
            NumStr(TT.wMinute,2);          // 2  =  15
end;

(*----------------------------------------------------------*)
(* Сообщение об ошибке                                      *)
(*----------------------------------------------------------*)
procedure Warn(S:string);
var W : PChar;
begin
  W := StrNew(PChar('W:'+S));
  Application.MessageBox
    (W,'Предупреждение или Напоминание',MB_OK {or MB_TASKMODAL});
  StrDispose(W);
end;

(*----------------------------------------------------------*)
(*  сортировка                                              *)
(*----------------------------------------------------------*)

(* $F+  директива, необходимая в ТурбоПаскале ------*)

function LessName(X, Y: pointer): Boolean;
begin LessName := StrUpCase(TDirRec(X).Name) < StrUpCase(TDirRec(Y).Name); end;

function LessExt(X, Y: pointer): Boolean;
var EX,EY : string;
begin
  EX := ExtractFileExt(TDirRec(X).Name);
  EY := ExtractFileExt(TDirRec(Y).Name);
  LessExt := StrUpCase(EX) < StrUpCase(EY);
end;

function LessSize(X, Y: pointer): Boolean;
begin LessSize := TDirRec(X).Size < TDirRec(Y).Size; end;

function LessTime(X, Y: pointer): Boolean;
begin LessTime := TDirRec(X).Time > TDirRec(Y).Time; end;

(* $F-  --------------------------------------------*)

procedure TDirList.LQuickSort(L, R: Integer);
var
  I, J: Integer;
  X   : TDirRec;
begin
  I := L;
  J := R;
  X := Get((L + R) div 2);
  repeat
    while Less(Get(I), X) do Inc(I);
    while Less(X, Get(J)) do Dec(J);
    if I <= J then
    begin
      SWAP(I,J);
      Inc(I);
      Dec(J);
    end;
  until I > J;
  if L < J then LQuickSort(L, J);
  if I < R then LQuickSort(I, R);
end;


(*------------------------------------*)
(* элементарные операции              *)
(*------------------------------------*)

function TDirList.Get(I:integer):TDirRec;
begin Result := TDirRec(Items[I]); end;

procedure TDirList.SWAP(I,J:integer);
var P : pointer;
begin P := Items[I]; Items[I] := Items[J]; Items[J] := P end;

procedure TDirList.Done;
var D : TDirRec;
    I : integer;
begin
  Path := '';
  for I := Self.Count downto 1 do begin
    D := TDirRec(Items[I-1]);
    D.Name := '';  (* освобождаем память, занятую строкой *)
    D.Free;
  end;
  Self.Free;
end;

(*------------------------------------*)
(* ОСНОВНОЕ ДЕЙСТВИЕ ОБЪЕКТА          *)
(*------------------------------------*)

procedure TDirList.Collect(aPath:string);
var F : TSearchRec;
    D : TDirRec;
    DosError : integer;
    PathTpl : string;
begin
  (* проверить существование каталога *)
  if Not DirectoryExists(aPath) then begin
    WARN('DirList.Collect: Path <'+aPath+'> Not found!');
    Exit;
  end;
  PathTpl := Path + '*.*';  (* шаблон поиска для FindFirst/FindNext *)
  if Count <> 0 then Done;  (* "забыть" предыдущую коллекцию файлов *)
  Path := aPath; SDiv := '!----!';
  DirBeg0 := 59; DirBeg := DirBeg0;
  DosError := FindFirst(PathTpl, faReadOnly + faDirectory + faArchive, F);
  while (DosError = 0) do
  begin
    D := TDirRec.Create;
    D.Attr := F.Attr;
    D.Time := F.Time;
    D.Size := F.Size;
    D.Name := F.Name;
    Add(D);
    DosError := FindNext(F);
  end;
  FindClose(F);
  CalcLen_s;     (* рассчитать длины полей вывода *)
  CorrectLen_s;  (* скорректировать, чтобы всё красиво размещалось *)
end;

(*------------------------------------*)
(* выборка и сортировка               *)
(*------------------------------------*)

procedure TDirList.GetDir_s;(* выбрать директории среди файлов и посчитать их *)
var I : integer;
    D : TDirRec;
begin
  CountDir_s := -1;
  for I:=0 to Count-1 do begin
    D := Get(I);
    if ((D.Attr and faDirectory) <> 0) then begin
      inc(CountDir_s); SWAP(CountDir_s,I);
    end;
  end;
  inc(CountDir_s);
end; (* GetDir_s *)

procedure TDirList.SortFiles(I1,I2:integer);
begin
  if (I1 < I2) and (@Less <> nil) then LQuickSort(I1, I2);
end;

procedure TDirList.SortInsideExt;
  (* в пределах одинаковых расширений имен
     отсортировать файлы по именам *)
var
  P,I1,I2,J1,J2 : integer;
  EX,EY : string; // : ExtStr;
  D1,D2 : TDirRec;
begin
  Less := LessName;
  I1 := CountDir_s;
  I2 := Count-1;             (* последний индекс в массиве Dir *)
  if (I2-I1)>1  then begin
    J1:=I1;
    repeat
      J2:=J1;
      D1 := Get(J1);
      EX := ExtractFileExt(D1.Name);
      repeat
        inc(J2);
        D2 := Get(J2);
        EY := ExtractFileExt(D2.Name);
      until ((EX<>EY) or (J2>=I2));
      SortFiles(J1,J2-1);
      J1:=J2;
    until (J2>=I2);
  end;
end; (* SortInsideExt *)

procedure TDirList.DefaultSort;
begin
  GetDir_s;               (* выбрать директории среди файлов и посчитать их *)
  Less := LessName;
  SortFiles(0,CountDir_s-1); (* отсортировать директории по именам      *)
  Less := LessExt;
  SortFiles(CountDir_s,Count-1); (* отсортировать файлы по расширениям имен *)
  SortInsideExt;                 (* в пределах одинаковых расширений имен
                                              отсортировать файлы по именам *)
end;

(*------------------------------------*)
(* подготовка к форматированию строк  *)
(*------------------------------------*)

procedure TDirList.FindDirBeg(S:string);
var P1,P2 : integer; QDone : boolean;
begin
  P1 := Pos('!',S); QDone := (P1 > 0);
  while Not QDone do begin
    P2 := PosP('!',S,P1+1);
    if P2 = 0 then begin
      WARN('В DIR - файле не найден разделитель "!----!" в строке'+
           chr(10)+S);
      QDone := true;
    end;
    if P2 - P1 = 5 then begin
      DirBeg0 := P1; DirBeg := P1; QDone := true;
    end
    else P1 := P2;
  end;
//WARN('DirBeg='+IntToStr(DirBeg));
end;

procedure TDirList.CalcLen_s;
var
  D : TDirRec;
  I : integer;
  N,E,SZ : string;
function GetSZ:string;
  begin
    if D.Attr and faDirectory <> 0
    then Result :='(DIR)'
    else Result :=IntToStr(D.Size);
  end;
begin
  LSN := 0;
  LSE := 0;
  LSZ := 0;
  for I := 0 to Count-1 do begin (* 1-ый проход - определяем ширины полей *)
    D := Get(I);
    GetNamExt(D.Name,N,E); (* N - имя, E - расширение     *)
    SZ := GetSZ;           (* SZ - размер или слово "DIR" *)
    if LSN < Length(N)  then LSN := Length(N);
    if LSE < Length(E)  then LSE := Length(E);
    if LSZ < Length(SZ) then LSZ := Length(SZ);
  end;
  LSD := 15;
  LSNC := LSN;
  LBlank := 1;   (* LBlank кол-во пробелов от конца записи до !----! *)
end;

procedure TDirList.CorrectLen_s;
begin
  if (Length(Path)+2) > (DirBeg - 1) then DirBeg := Length(Path)+3;

  if LSN + LSE + LSZ + LSD + 5 > (DirBeg - 1)
  then LSNC   := DirBeg + 1 - 1 - LSE - LSZ - LSD - 5
  else LBlank := DirBeg + 1 - (LSN + LSE + LSZ + LSD + 5);
end;

(*------------------------------------*)
(* результаты в строковом виде        *)
(*------------------------------------*)

function TDirList.GetStr(I:integer):string;
var
  D : TDirRec;
  S,N,E,SZ,ST,SLink,PathParent : string;
  J : integer;
begin
  D := Get(I);
  GetNamExt(D.Name,N,E);
  if D.Attr and faDirectory <> 0
    then SZ :='(DIR)'
    else SZ :=IntToStr(D.Size);
  ST := FileTimeToS15(D.Time);

  if D.Attr and faDirectory <> 0 then begin
    if (D.Name='.') then SLink := ''; {,PathNam,'micros.dir');}
    if (D.Name='..') then begin
      J:=length(Path)-1;
      while Path[J]<>'\' do Dec(J);
      PathParent:=Copy(Path,1,J);
      SLink  := PathParent+'micros.dir';
    end;
    if ((D.Name<>'.') and (D.Name<>'..')) then
      SLink := Path+D.Name+'\micros.dir';
  end
  else SLink := Path+D.Name;

  S := JustL(N,LSNC)+' '+JustL(E,LSE)+' '+JustR(SZ,LSZ)+' '
       +JustL(ST,LSD+LBlank)+SDiv
       +SLink;
  Result := S;
end;

function TDirList.GetStr0:string;
var S : string; I : integer;
begin
  S := '';
  for I := 1 to DirBeg-1 do S := S + ':';
  Result := S + SDiv;
end;

function TDirList.GetStrPath:string;
begin Result := '  '+JustL(Path,DirBeg-3)+SDiv; end;

function TDirList.GetStrTotal:string;
var Total : longint; I : integer; S : string;
begin
  Total := 0;
  for I := 0 to Count-1 do Inc(Total, Get(I).Size);
  S := ' '+IntToStr(Count)+' files, '+IntToStr(Total)+' bytes, '+
       IntToStr(DiskFree(Ord(Path[1])-64))+' bytes free';
  Result := JustL(S,DirBeg-1)+SDiv;
end;

end.