home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / directry / dirlist.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-06-13  |  6.4 KB  |  187 lines
  1. program DirList;
  2. {$C-}
  3.  
  4. { DirList version 1.1 -- last updated 6/13/87 by Alexander Morris       }
  5. {                                                                       }
  6. { This Program will display a Directory Listing including all System,   }
  7. { Hidden, and Read Only files, along with the File Attribute Status,    }
  8. { including Archive Status.                                             }
  9. {                                                                       }
  10. {                               v1.0 written by David W. Terry  4/29/85 }
  11. {       Last updated by Alexander Morris 6/13/87 -- corrected many bugs }
  12.  
  13. type
  14.   fwstring = string[255];
  15.   str2  = string[2];
  16.   str6  = string[6];
  17.   str9  = string[9];
  18.   str15 = string[15];
  19.   FileList = array[1..1024] of record
  20.                Name: string[13];
  21.                Attrib: byte;
  22.                Size: real;
  23.                Date,Time: str9;
  24.                end;
  25.   regpack  = record
  26.                ax,bx,cx,dx,bp,si,di,ds,es,flags:integer
  27.                end;
  28. var
  29.   line: fwstring;
  30.   List: filelist;
  31.   FileMask: str15;
  32.   X,total: byte;
  33.   recpack: regpack;
  34.   Hidden,System,ReadOnly,Normal,Archive,Dircty: boolean;
  35.   ss,dd,t: string[30];
  36.   i:integer;
  37.  
  38. const
  39.   H ='Hidden '; S ='System '; R ='Read Only '; N ='Normal '; A ='Archive '; D ='Dir';
  40.   HN='------ '; SN='------ '; RN='--------- '; NN='------ '; AN='------- '; DN='---';
  41.  
  42. procedure FastWrite(stringfld:fwstring; fgatt,bgatt,cursor:integer);
  43. {substitute any Quick Screen Write Procedure for this. All output has
  44.   already been converted to strings}
  45. begin
  46.   TextColor(fgatt);
  47.   TextBackGround(bgatt);
  48.   if cursor=1 then Write(stringfld) else
  49.     if cursor=2 then Writeln(stringfld);
  50. end;
  51.  
  52. procedure Directory(FileMask: str15; var List: FileList; var Total: byte);
  53. var Dta: string[44];
  54.  
  55. function FileSize: real;           { decypher the File's Size in Bytes }
  56. var Size: real;
  57.     Byte1,Byte2,Byte3,Byte4: byte;
  58. begin
  59.   Byte1:=ord(copy(dta,28,1));
  60.   Byte2:=ord(copy(dta,27,1));
  61.   Byte3:=ord(copy(dta,29,1));
  62.   Byte4:=ord(copy(dta,30,1));
  63.   Size:=Byte1 shl 8+Byte2;
  64.   if Size<0 then Size:=Size+65536.0;   { adjust for negative values }
  65.   Size:=(Byte3 shl 8+Byte4)*256.0+Size;
  66.   FileSize:=Size;
  67.   end;  { filesize }
  68.  
  69. function FileDate: str9;         { decypher the File's Date Stamp }
  70. var Day,Month,Year: str2;
  71.     Temp: integer;
  72.     Byte1,Byte2: byte;
  73. begin
  74.   Byte1:=ord(copy(dta,25,1));
  75.   Byte2:=ord(copy(dta,26,1));
  76.   str(Byte1 and 31:2,Day);
  77.   Temp:=(Byte1 shr 5) and 7+(Byte2 and 1) shl 3;
  78.   str(Temp:2,Month);
  79.   str((Byte2 shr 1)+80:2,Year);
  80.   if Day[1]=' ' then Day[1]:='0';
  81.   if Year[1]=' ' then Year[1]:='0';
  82.   FileDate:=Month+'-'+Day+'-'+Year;
  83.   end;  { filedate }
  84.  
  85. function FileTime: str6;            { decypher the File's Time Stamp }
  86. var Hour,Min: str2;
  87.     Temp: integer;
  88.     AmPm: char;
  89.     Byte1,Byte2: byte;
  90. begin
  91.   Byte1:=ord(copy(dta,23,1));
  92.   Byte2:=ord(copy(dta,24,1));
  93.   Temp:=(Byte1 shr 5) and 7+(Byte2 and 7) shl 3;
  94.   str(Temp:2,Min);
  95.   Temp:=Byte2 shr 3;
  96.   if Temp<13 then AmPm:='a' else begin
  97.     Temp:=Temp-12;
  98.     AmPm:='p';
  99.     end;
  100.   if Temp = 0 then Temp := 12;
  101.   str(Temp:2,Hour);
  102.   if Min[1]=' ' then Min[1]:='0';
  103.   FileTime:=Hour+':'+Min+AmPm;
  104.   end;  { filetime }
  105.  
  106. procedure FillRecord(RecNo: byte);        { fill List.[RecNo] with file info }
  107. begin
  108.   with List[RecNo] do begin
  109.     Name:=copy(Dta,31,13);
  110.     i := Pos(chr(0),Name);
  111.     if i <> 0 then Delete(Name,i,length(name));
  112.     repeat if length(name)<13 then name:=name+' '; until length(name)=13;
  113.     Attrib:=ord(copy(Dta,22,1));
  114.     Size:=FileSize;
  115.     Date:=FileDate;
  116.     Time:=FileTime;
  117.     dd:=FileDate;
  118.     t:=FileTime;
  119.     if (Name[1]<>'.') and (pos('.',Name)<>0) then begin        { line up the }
  120.       while pos('.',Name)<9 do insert(' ',Name,pos('.',Name)); { file ext.   }
  121.       Name[pos('.',Name)]:=' ';
  122.       end;
  123.     end;
  124.   end;  { fillrecord }
  125.  
  126. procedure FillDirList;
  127. begin
  128.   Total:=1;
  129.   FillRecord(Total);
  130.   repeat
  131.     recpack.Ax:=$4f shl 8;
  132.     MsDos(recpack);
  133.     if (recpack.Ax<>18) and (recpack.Ax<>2) then begin
  134.       Total:=Total+1;
  135.       FillRecord(Total);
  136.       end;                        { repeat filling until no more }
  137.     until (recpack.flags and 1)<>0;     { files are found              }
  138.  end;  { filldirlist }
  139.  
  140. begin  { Directory }
  141.   Total:=0;
  142.   Dta:='                                           ';
  143.   FileMask:=FileMask+#0;
  144.   with recpack do begin                        { First, Set aside the DTA    }
  145.     Ax:=$1a shl 8;                             { or Data Transfer Area,      }
  146.     Ds:=Seg(Dta); Dx:=Ofs(Dta)+1;              { call $1A then call $4E to   }
  147.     MsDos(recpack);                            { find the First Match. Set   }
  148.     Ax:=$4e shl 8;                             { set Cx to 23 to include all }
  149.     Ds:=Seg(FileMask); Dx:=Ofs(FileMask)+1;    { hidden files. Then up above }
  150.     Cx:=23;                                    { call $4F to find subsequent }
  151.     MsDos(recpack);                            { matches, filling List.      }
  152.     if (flags and 1)=0 then FillDirList;
  153.     end;
  154.   end;  { directory }
  155.  
  156. begin
  157.   FileMask := '';
  158.   if ParamCount=1 then FileMask:=ParamStr(1);
  159.   TextColor(White);
  160.   if FileMask = '' then begin
  161.     Write('Dir mask: ');
  162.     readln(FileMask);
  163.    end;
  164.   Directory(FileMask,List,Total);                { if available             }
  165.   for X:=1 to total do
  166.     with List[X] do begin
  167.       Normal:=True; Hidden:=False; System:=False; ReadOnly:=False; Archive:=False; Dircty:=False;
  168.       if Attrib<>0 then Normal:=False;
  169.       if (Attrib and  1)= 1 then ReadOnly:=True;    { determine Attribute }
  170.       if (Attrib and  2)= 2 then Hidden:=  True;    { Meanings            }
  171.       if (Attrib and  4)= 4 then System:=  True;
  172.       if (Attrib and 16)=16 then Dircty:=  True;
  173.       if (Attrib and 32)=32 then Archive:= True;
  174.       Str(size:6:0,ss);
  175.       line := Name+ss+' '+date+' '+time+'  ';
  176.       FastWrite(line,15,0,1);
  177.       if Normal   then FastWrite(N,15,0,1) else FastWrite(NN,15,0,1);
  178.       if Archive  then FastWrite(A,15,0,1) else FastWrite(AN,15,0,1);
  179.       if ReadOnly then FastWrite(R,15,0,1) else FastWrite(RN,15,0,1);
  180.       if Hidden   then FastWrite(H,15,0,1) else FastWrite(HN,15,0,1);
  181.       if System   then FastWrite(S,15,0,1) else FastWrite(SN,15,0,1);
  182.       if Dircty   then FastWrite(D,15,0,1) else FastWrite(DN,15,0,1);
  183.       writeln;
  184.       end;
  185.   writeln; writeln('Total Number of files: ',Total);
  186.   end.
  187.