home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / sampler / 02 / zd_etc / zd.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-02-09  |  6.1 KB  |  318 lines
  1. {*ZD.PAD of ZD - Copyright 1988 by Pradeep Arora}
  2. (*$M 1024,0,32000*)
  3. (*$R-,S-,I-,F-,B-*)
  4. (*$DEFINE IBM*)
  5. program    SuperDirectory;
  6.  
  7. uses    Dos
  8. {$IFDEF IBM}
  9.     , Crt
  10. {$ENDIF}
  11.     ;
  12.  
  13. procedure    Beep;
  14. begin
  15. {$IFDEF IBM}
  16.     Sound(600);
  17.     Delay(100);
  18.     NoSound;
  19. {$ENDIF}
  20. end;        {*Beep()*}
  21.  
  22. (*$F+*)
  23. function    CmpStr(var S1, S2) : integer; external;
  24. {$L CMPSTR.OBJ}
  25.  
  26. procedure    UcaseStr(var S); external;
  27. {$L    UCASESTR.OBJ}
  28. (*$F-*)
  29.  
  30. const
  31.     Cright : string[36] = '(C) Copyright 1988 by Pradeep Arora.';
  32. type
  33.     Str12 = string[12];
  34.     Str8 = string[8];
  35.     Str3 = string[3];
  36.  
  37. procedure    Extract(var MaskStr : SearchRec; var Ns : Str8; var Es : Str3);
  38. var
  39.     P : byte;
  40. begin
  41.     with MaskStr do
  42.     begin
  43.         P := Pos('.', Name);
  44.         if (P = 0) then
  45.         begin
  46.             Ns := Name;
  47.             Es := '';
  48.         end
  49.         else
  50.         begin
  51.             Ns := Copy(Name, 1, pred(P));
  52.             Es := Copy(Name, succ(P), 3);
  53.         end;
  54.     end;
  55. end;        {*Extract()*}
  56.  
  57. type
  58.     CTypes = (Normal, Ext, SubDir, Others);
  59.     Color = record
  60.         Fg, Bg : Byte;
  61.     end;
  62. const
  63.     MAX_FILES = 256;
  64.     DEF_MASK = '*.*';
  65.     Start : string[7] = '*START*';    {start of patch area}
  66. {$IFDEF IBM}
  67.     Colors : array[CTypes] of Color = (
  68.         (Fg : LightGray; Bg : Black),    {normal}
  69.         (Fg : Yellow; Bg : Black),    {extension}
  70.         (Fg : Black; Bg : LightGray),    {subdirs}
  71.         (Fg : Black; Bg : LightGray)    {others}
  72.     );
  73. {$ENDIF}
  74.  
  75. procedure    CleanupMask(var S : String);
  76. var
  77.     SLen : byte absolute S;
  78.     SR : SearchRec;
  79.     I : byte;
  80.     SaveS : String;
  81. label
  82.     NotDir;
  83. begin
  84.     if (SLen = 0) then
  85.         Exit;
  86.     UcaseStr(S);
  87.     if (Pos('*', S) <> 0) OR (Pos('?', S) <> 0) then
  88.         goto NotDir;
  89.     FindFirst(S, Directory, SR);
  90.     if (DosError = 0) AND (SR.Attr = Directory) then
  91.     begin    {subdirectory, like ZD .. / ZD ..\A / ZD A etc.}
  92.         S := S + '\' + DEF_MASK;
  93.         Exit;
  94.     end;
  95. NotDir:
  96.     if (SLen = 1) OR ( (SLen = 2) AND (S[2] = ':') ) then
  97.         S := S + DEF_MASK
  98.     else
  99.     begin
  100.         I := SLen;
  101.         while (I > 0) AND (S[I] <> '\') do
  102.             Dec(I);
  103.         SaveS := S;
  104.         if (I > 0) then
  105.             Delete(SaveS, 1, I);
  106.         if Pos('.', SaveS) = 0 then
  107.             S := S + DEF_MASK;
  108.     end; {if..else..}
  109. end;        {*CleanupMask()*}
  110.  
  111. var
  112.     LastE : Str3;
  113.     MaskStr : string;
  114.     MaskStrLen : byte absolute MaskStr;
  115.     A : array[1..MAX_FILES] of SearchRec;
  116.     NRead : integer;
  117.     Map : array[1..MAX_FILES] of integer;
  118.  
  119. procedure    LoadFNs;
  120. var
  121.     SR : SearchRec;
  122. begin
  123.     FindFirst(MaskStr, (AnyFile AND NOT(VolumeID)), SR);
  124.     while (DosError = 0) do
  125.     begin
  126.         if (SR.Name <> '.') AND (SR.Name <> '..') then
  127.         if (NRead < MAX_FILES) then
  128.         begin
  129.             Inc(NRead);
  130.             A[NRead] := SR;
  131.         end
  132.         else
  133.         begin
  134.             write('** too many files **');
  135.             Exit;    {too many files}
  136.         end;
  137.         FindNext(SR);
  138.     end;
  139. end;        {*LoadFNs()*}
  140.  
  141. function    CompareFN(var X, Y : SearchRec) : integer;
  142. var
  143.     ThisN, CompN : String[8];
  144.     ThisE, CompE : String[3];
  145.     CE : integer;
  146. begin
  147.     Extract(X, ThisN, ThisE);
  148.     Extract(Y, CompN, CompE);
  149.     CE := CmpStr(ThisE, CompE);
  150.     if (CE <> 0) then
  151.         CompareFN := CE
  152.     else
  153.         CompareFN := CmpStr(ThisN, CompN);
  154. end;        {*CompareFN()*}
  155.  
  156. procedure    SortFNs;
  157. var
  158.     Gap, Bound, Exchanges, Lower, Upper, Temp, I : integer;
  159. begin
  160.     {** We have NRead members in array A[] to sort by rearranging the
  161.         order indicated by Map[] array **}
  162.     {set up initial mappings}
  163.     for I := 1 to NRead do
  164.         Map[I] := I;
  165.     {sort using shell sort}
  166.     Gap := NRead;
  167.     while (Gap > 1) do
  168.     begin
  169.         Gap := Gap DIV 2;
  170.         Bound := NRead - Gap;
  171.         repeat
  172.             Exchanges := 0;
  173.             for Lower := 1 to Bound do
  174.             begin
  175.                 Upper := Lower + Gap;
  176.                 if (CompareFN(A[Map[Lower]], A[Map[Upper]]) > 0) then
  177.                 begin
  178.                     Temp := Map[Lower];
  179.                     Map[Lower] := Map[Upper];
  180.                     Map[Upper] := Temp;
  181.                     Inc(Exchanges);
  182.                 end;
  183.             end; {for..}
  184.         until Exchanges <= 0;
  185.     end; {while..}
  186. end;        {*SortFNs()*}
  187.  
  188. procedure    WriteFNs;
  189. var
  190.     ThisN : Str12;    {labels}
  191.     LastE, ThisE : Str3;
  192.     Ft : CTypes;
  193.     Ai, Ct : Word;
  194.     Total : LongInt;
  195. begin
  196.     Total := 0;
  197.     LastE := #00#00#00;
  198.     Ct := 0;
  199.     for Ai := 1 to NRead do
  200.     begin
  201.         with A[Map[Ai]] do
  202.         begin
  203.             Inc(Total, Size);    {inc total size}
  204.             Extract(A[map[Ai]], ThisN, ThisE);    {name & ext}
  205.             if (ThisE <> LastE) AND (ThisE <> '') then
  206.             begin    {a new ext, write it out}
  207.                 LastE := ThisE;
  208. {$IFDEF IBM}
  209.                 TextColor(Colors[Ext].Fg);
  210.                 TextBackground(Colors[Ext].Bg);
  211. {$ELSE}
  212.                 write(#174);
  213. {$ENDIF}
  214.                 write(ThisE);
  215. {$IFDEF IBM}
  216.                 write(' ');
  217. {$ELSE}
  218.                 write(#175);
  219. {$ENDIF}
  220.             end;
  221.             {** find type of this file **}
  222.             if (Attr AND Directory <> 0) then
  223.                 Ft := SubDir
  224.             else
  225.             begin
  226.                 Inc(Ct);
  227.                 if (Attr = $00) OR ((Attr AND Archive) <> 0) then
  228.                     Ft := Normal
  229.                 else
  230.                     Ft := Others;
  231.             end;
  232. {$IFDEF IBM}
  233.             TextColor(Colors[Ft].Fg);
  234.             TextBackground(Colors[Ft].Bg);
  235. {$ENDIF}
  236.             write(ThisN, ' ');
  237.         end; {with A[Ai]..}
  238.     end; {for Ai..}
  239. {$IFDEF IBM}
  240.     LowVideo;
  241. {$ENDIF}
  242.     if (Ct <> 0) then
  243.         write('(', Total shr 10, 'K in ', Ct, ' files)');
  244. end;        {*WriteFNs()*}
  245.  
  246. var
  247. {$IFDEF IBM}
  248.     SaveAttr : Word;
  249.     SaveM : Integer;
  250. {$ELSE}
  251.     OutBuf : array[1..4000] of char;
  252. {$ENDIF}
  253.     W1, W2, W3, W4 : Word;
  254.     Dir : String;
  255.     Drive : byte;
  256. label
  257.     EndPgm;
  258. begin
  259. {$IFDEF IBM}
  260.     SaveAttr := TextAttr;
  261.     SaveM := LastMode;
  262. {$ELSE}
  263.     SetTextBuf(Output, OutBuf);
  264. {$ENDIF}
  265.  
  266.     Drive := 0;    {default}
  267.     if (ParamCount > 0) then
  268.     begin
  269.         MaskStr := ParamStr(1);
  270.         if (MaskStrLen >= 2) AND (MaskStr[2] = ':') then
  271.             Drive := ord(upcase(MaskStr[1])) - ord('A') + 1;
  272.         CleanupMask(MaskStr);
  273.     end
  274.     else
  275.     begin
  276.         MaskStr := DEF_MASK;
  277.     end;
  278.  
  279.     write(#254);
  280.     GetDate(W1, W2, W3, W4);
  281.     write(W2, '/', W3, '/', W1-1900);
  282.     GetTime(W1, W2, W3, W4);
  283.     write(' ', W1, ':', W2);
  284.     write(#254);
  285.  
  286.     GetDir(Drive, Dir);
  287.     if (IOResult <> 0) then
  288.     begin
  289.         Beep;
  290.         goto EndPgm;
  291.     end;
  292.     write(Dir, ' ');
  293.     write(DiskSize(Drive) shr 10, '-');
  294.     if (IOResult <> 0) then
  295.     begin
  296.         Beep;
  297.         goto EndPgm;
  298.     end;
  299.     write( (DiskSize(Drive) - DiskFree(Drive)) shr 10, '=');
  300.     write(DiskFree(Drive) shr 10, 'K'#254);
  301.  
  302.     NRead := 0;
  303.     LoadFNs;
  304.     SortFNs;
  305.     WriteFNs;
  306.  
  307. EndPgm:
  308.  
  309. {$IFDEF IBM}
  310.     TextAttr := SaveAttr;
  311.     (**NormVideo;**)
  312.     (**TextMode(SaveM);**clears the screen**)
  313.     writeln; write('    ');
  314. {$ENDIF}
  315. end.
  316.  
  317. {*----- end of ZD.PAS of ZD -----}
  318.