home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / QDIR.ZIP / QDIR.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1993-01-04  |  15.9 KB  |  411 lines
  1. Program QuickExtendedDirectory;
  2.  
  3.   {Directory listing with attributes and age of file in days shown.
  4.    See Procedure DisplaySyntax for instructions and command line switches.
  5.    This program is intentionally designed to work and look as much like the
  6.    Dos DIR command as possible, except it displays the following additional
  7.    information:  1) The file attribute, where 'R' means read-only, 'S'
  8.    means system, 'H' means hidden, and 'A' means the archive bit is set.
  9.    2) The age of the file in days.  Its default (opposite of DIR) is paged
  10.    mode, wherein it stops every screenful and waits for a keypress.
  11.    This may be changed with the /p switch.  It also, like DIR, defaults
  12.    to a one file per line format.  This may be changed with the /w
  13.    switch, but no age in days is shown in this mode.
  14.  
  15.                                   Placed in the public domain
  16.  
  17.                                   Rick Housh
  18.                                   CIS PIN 72466,212
  19.    }
  20.  
  21.  
  22. Uses Dos, Crt;
  23.  
  24. const
  25.   drive = ' drive ';
  26.   tab   = '        ';
  27.  
  28. var
  29.   Fname, DirStr   : string;
  30.   i, j, DriveNo   : byte;
  31.   Fblock          : SearchRec;
  32.   WholeName       : string[12];
  33.   ch, DName       : string[1];
  34.   Count           : word;
  35.   DSize           : longint;
  36.   Double, Paging,
  37.   DirFound, FirstTime  : boolean;
  38.  
  39.   Procedure DisplaySyntax;      { Help, called with QDIR/H }
  40.       begin
  41.         WriteLn('QDIR : Quick Extended directory program.'#13#10);
  42.         WriteLn(
  43.         'Usage: QDIR [ filename.ext ] [ /w ] [ /p ] [ /h ]');
  44.         WriteLn(Tab,'  (Default filename.ext = "*.*")'#13#10);
  45.         WriteLn(
  46.  'Shows: FileName, Attributes (Read only, Hidden, System, Archive, Directory),');
  47.         WriteLn(
  48.        '       Size, Date & Time of last write, and Age of file in days.');
  49.         WriteLn(
  50.         #13#10'Switches:  /w : Two per line, w/o time or age of file.');
  51.         WriteLn(Tab,'   /p : NO pause between screens.');
  52.         WriteLn(Tab,'   /h : This text.'#13#10);
  53.         Halt;
  54.       end;
  55.  
  56.   Procedure UpString(var Strg: String);
  57.     {Upcases a string.  Syntax is Upstring(whatever)}
  58.     {AnyString is String}
  59.  
  60.     begin
  61.       inline
  62.       ($C4/$BE/Strg/
  63.        $26/$8A/$0D/
  64.        $FE/$C1/
  65.        $FE/$C9/
  66.        $74/$13/
  67.        $47/
  68.        $26/$80/$3D/$61/
  69.        $72/$F5/
  70.        $26/$80/$3D/$7A/
  71.        $77/$EF/
  72.        $26/$80/$2D/$20/
  73.        $EB/$E9);
  74.     end; {Inline Procedure UpString}
  75.  
  76.   Function GetKey : char;
  77.     var ch : char;
  78.     Begin
  79.       Inline(
  80.                      {; Function GetKey : Char}
  81.                      {; Clears the keyboard buffer then waits until}
  82.                      {; a key is struck.  If the key is a special, e.g.}
  83.                      {; function key, goes back and reads the next}
  84.                      {; byte in the keyboard buffer.  Thus does}
  85.                      {; nothing special with function keys.}
  86.       $B4/$0C        {       MOV  AH,$0C      ;Set up to clear buffer}
  87.       /$B0/$08       {       MOV  AL,8        ;then to get a char}
  88.       /$CD/$21       {SPCL:  INT  $21         ;Call DOS}
  89.       /$3C/$00       {       CMP  AL,0        ;If it's a 0 byte}
  90.       /$75/$04       {       JNZ  CHRDY       ;is spec., get second byte}
  91.       /$B4/$08       {       MOV  AH,8        ;else set up for another}
  92.       /$EB/$F6       {       JMP  SHORT SPCL  ;and get it}
  93.       /$88/$46/<CH   {CHRDY: MOV  <CH[BP],AL  ;else put into function return}
  94.        );
  95.       GetKey := Ch;
  96.     end; {Inline function GetKey}
  97.  
  98.  
  99.   Procedure ShowIt;   { Does most of the work in displaying info }
  100.  
  101.   const
  102.  
  103.   WeekDay: array[0..6] of String[9] = ('Sunday','Monday','Tuesday',
  104.                                'Wednesday','Thursday','Friday','Saturday');
  105.  
  106.   MonthName:array[1..12] of String[9] = ('January','February','March','April',
  107.                                    'May','June','July','August','September',
  108.                                    'October','November','December');
  109.  
  110.   var
  111.       x               : byte;
  112.       Kind            : string[4];
  113.       Date, Time      : string[8];
  114.       st1, st2, st3   : string[2];
  115.       DT              : DateTime;
  116.       y, dy, m, DayOfWeek : word;
  117.       DayFromZero, LeapYearDays,
  118.       CurrDay, FileDay, DifferenceInDays : LongInt;
  119.  
  120.     begin
  121.       UnpackTime(FBlock.Time,DT);          { Make file intelligible }
  122.       GetDate(y, m, dy, DayOfWeek);        { And file date }
  123.       x := Fblock.Attr;                    { Ready to check file attribute}
  124.       If x AND $40 <> 0 then               { If bit 6 set file is device }
  125.         Begin                              { So tell em, and exit }
  126.           WriteLn(FName,' is a Device'#13#10);
  127.           Halt;
  128.         end;                               { Initialize attribute string }
  129.       Kind := '    ';
  130.       If x AND $01 <> 0 then Kind[1] := 'R';  { If read-only }
  131.       If x AND $02 <> 0 then Kind[2] := 'H';  { If hidden    }
  132.       If x AND $04 <> 0 then Kind[3] := 'S';  { If system    }
  133.       If x AND $20 <> 0 then Kind[4] := 'A';  { If archive bit set }
  134.       Str(DT.Month:3,St1);                    { Move month # into string }
  135.       Str(DT.Day:2,St2);                      { and day # }
  136.       If St2[1] = ' ' then St2[1] := '0';     { If leading space make it '0'}
  137.       Str(DT.Year - 1900:2,St3);              { Last two digits of yr to st3}
  138.       Date := st1 + '-' + st2 + '-' + st3 + ' '; { and format date string }
  139.       If not Double then                      { If doing full info }
  140.          begin                                { Then show file create time}
  141.            Str(DT.Hour:2,st1);
  142.            Str(DT.Min:2,st2);
  143.            If st2[1] = ' ' then st2[1] := '0';
  144.            Str(DT.Sec:2,st3);
  145.            If St3[1] = ' ' then st3[1] := '0';
  146.            Time := St1 + ':' + St2 + ':' + st3 + '  ';
  147.  
  148.            { The following code calculates the age of the file (in days)
  149.              by first calculating the current number of days from
  150.              January 1, 0 A.D. for the current date (machine date),
  151.              then the number of days from 1/1/00 to the date of
  152.              the file, then subtracting the file age from the current
  153.              age.  If the file date is later then the current date
  154.              the message 'FUTURE DATE', instead of the number of
  155.              days is displayed.  This routine makes the necessary
  156.              adjustments for leap years, even the 4000 year adjust-
  157.              ment not covered by the Gregorian calendar rules, but
  158.              indicated necessary by the mathematics of the thing.}
  159.  
  160.            DayFromZero := ( 365 * y ) + (31 * Pred(m)) + Dy ;
  161.            If m > 2 then DayFromZero := DayFromZero - Trunc(0.4 * m + 2.3)
  162.                 else if m < 2 then dec(y);
  163.            LeapYearDays := (y div 4) - (y div 100)
  164.                 + (y div 400) - (y div 4000);
  165.            CurrDay := DayFromZero + LeapYearDays ;
  166.  
  167.            DayFromZero :=( 365 * DT.Year) + (31 * Pred(DT.Month) + DT.Day);
  168.            If DT.Month > 2 then
  169.               DayFromZero := DayFromZero - trunc(0.4 * DT.Month + 2.3)
  170.                 else if DT.Month < 2 then Dec(DT.Year);
  171.            LeapYearDays := (y div 4) - (y div 100)
  172.              + (y div 400) - (y div 4000);
  173.            FileDay := DayFromZero + LeapYearDays ;
  174.  
  175.            DifferenceInDays := (CurrDay - FileDay);
  176.          end;
  177.  
  178.       { If the program has just started Write the current date and time}
  179.  
  180.       If FirstTime then Write(
  181.         Tab,Weekday[DayOfWeek],'  ',MonthName[m]:2,',',
  182.         ' ',dy:2,',',' ',y:4,#13#10#10);
  183.       FirstTime := False;
  184.       If not Double then Write('    ');  { Leading spaces for 1 line/file}
  185.       Write(WholeName);                  { First write filename }
  186.       Write(' ',Kind);                   { then attribute }
  187.                                          { Write filesize, unless it's }
  188.                                          { a directory }
  189.       If x AND $10 <> 0 then Write(
  190.           '  <DIR> ') else Write(Fblock.Size:7,' ');
  191.       Write(Date);                          { Show file date }
  192.       If not Double then Write('  ',Time);  { and time, if not short form}
  193.       If not Double then                    { If long form show age in days}
  194.         begin
  195.           If (DifferenceInDays < 0) then
  196.             Write  ('     FUTURE DATE')
  197.           else
  198.             begin
  199.               Write('     Age ',DifferenceinDays:5);
  200.               Write(' day');
  201.               If (DifferenceInDays) <> 1 then Write('s');
  202.             end;
  203.           end;
  204.       Inc(Count);
  205.       If Double then  { If short form and 1st on line make tab }
  206.          begin        { If short form and 2nd on line do CR, LF }
  207.            if odd(Count) then Write(Tab) else WriteLn;
  208.          end
  209.            else WriteLn;
  210.        If Paging then      { If the /p switch is on }
  211.          begin             { and screen is full, stop, ask for keypress }
  212.            If (Double and (Count mod 46 = 0)) or
  213.               (not Double and (Count mod 23 = 0)) then
  214.              begin
  215.                Write('Press any key to continue ...');
  216.                ch := GetKey;
  217.                WriteLn;
  218.              end;
  219.          end;
  220.     end; {Procedure Showit}
  221.  
  222.   Procedure CheckForDosError;   { Its name is its motto }
  223.     const
  224.       nf = ' not found';
  225.     var
  226.       d : integer;
  227.  
  228.     begin
  229.       d := DosError;            { Get DOS error number }
  230.       DosError := 0;            { and reset DosError }
  231.       If d = 0 then Exit;       { If no error, exit }
  232.       Case d of                 { otherwise display nature of error }
  233.           2 : Write('File',nf);
  234.           3 : Write('Invalid path');
  235.          18 : Write('File',nf);
  236.         152 : Write('Drive ',Dname,' not ready');
  237.         156 : Write('Disk seek error on ',Dname);
  238.         162 : Write('General failure on',drive,Dname);
  239.         else Write('DOS Error #',d);
  240.       end; {Case}
  241. (*    { Uncomment out the next if you want error in hexidecimal }
  242.       Write('  DOS Error =  ',d,' Decimal  ');
  243.       Case D of
  244.           2 : Write  ('2');
  245.           3 : Write  ('3');
  246.          18 : Write ('12');
  247.         152 : Write ('98');
  248.         156 : Write ('9C');
  249.         162 : Write ('A2');
  250.       end; {Case}
  251.       If D in [2,3,18,152,156,162] then Write(' Hexadecimal');
  252. *)
  253.       WriteLn;
  254.       Halt(d);   { Exit with DOS errorlevel set }
  255.     end; {Procedure CheckForDosError}
  256.  
  257.   Procedure GetParms;  { Gets the command and formats everything to }
  258.                        { work as much like DIR as possible }
  259.     var
  260.       x     : Byte;
  261.       Parm  : Array[ 1..3 ] of String;
  262.       IsDir : Boolean;
  263.     Begin
  264.       Fname    := '';
  265.       DirStr   := '';
  266.       x        := 0;
  267.       for i := 1 to 3 do
  268.         begin
  269.             If Paramcount > 0 then
  270.               begin
  271.                 Parm[i] := ParamStr(i);
  272.                 UpString(Parm[i]);
  273.               end
  274.                else
  275.               Parm[i] := '';
  276.         end;
  277.       Fname := Parm[1];
  278.       Double := False;
  279.       For i := 1 to 3 do if Pos('/H',Parm[i]) <> 0 then DisPlaySyntax;
  280.       For i := 1 to 3 do if Pos('/W',Parm[i]) <> 0 then Double := True;
  281.       For i := 1 to 3 do if Pos('/P',Parm[i]) <> 0 then Paging := False;
  282.       i := Pos('/',Fname);
  283.       If i <> 0 then Delete(Fname,i,Length(Fname));
  284.       If Fname = '' then Fname := '*.*';
  285.       begin
  286.       If not (Pos(':',Fname) in [0,2]) then
  287.         begin
  288.           WriteLn(#13#10'Invalid parameter'#13#10);
  289.           Halt(1);
  290.         end;
  291.       If Pos(':',Fname) = 0 then             {If default drive}
  292.         begin                                    {strip leading if current}
  293.           If Pos('\',Fname) = 1 then Delete(Fname,1,1);
  294.           If (Pos('.*',Fname) = 1) or (Pos('.?',Fname) = 1)
  295.               then Fname := '*' + Fname;
  296.           GetDir(0,DirStr);                      {get current WITH drive}
  297.           If Pos('..',Fname) = 1 then
  298.            begin
  299.              DirStr := Copy(DirStr,1,3);
  300.              Fname :=  '*.*';
  301.            end;
  302.           If Pos('\',DirStr) <> Length(DirStr) then DirStr := DirStr + '\';
  303.           Fname := DirStr + Fname;               {tack curr dir on front}
  304.           x := Ord(Fname[1]);                    {get drive number}
  305.           If x > $60 then x := x - $60 else x := x - $40; {and fix it}
  306.         end
  307.           else
  308.         begin
  309.           x := ord(Fname[1]);                         {get drive number}
  310.           If x > $60 then x := x - $60 else x := x - $40; {and fix it}
  311.           GetDir(x,DirStr);                            {get that current dir}
  312.           If (Pos(':\',Fname) <> 2)  then
  313.            begin
  314.             If Pos('\',DirStr) <> Length(DirStr) then DirStr := DirStr + '\';
  315.             Delete(Fname,1,2);
  316.             Fname := DirStr + Fname;
  317.            end;
  318.         end;
  319.      end;
  320.  
  321.      DriveNo := x;
  322.      DName := Fname[1];
  323.      If Pos('\',Fname) <> 3 then Insert('\',Fname,3);
  324.      DirFound := False;
  325.      Dsize := DiskFree(DriveNo);
  326.      If DSize = -1 then   { Diskfree returns $0FFFF if drive invalid }
  327.                           { but NO DosError and IOResult = 0 }
  328.        begin
  329.           WriteLn(#13#10,'Invalid drive ',Dname,':');
  330.           Halt(15);  { Invalid drive error number in errorlevel }
  331.        end;
  332.      DirFound := True;
  333.      IsDir := False;
  334.      i := Length(Fname);
  335.      If (i > 3) and (Fname[i] = '\') then Delete(Fname,i,1);
  336.      If Length(Fname) = 3 then Fname := Fname + '*.*';
  337.      x := 0;
  338.      If ((Pos('?',Fname) = 0) and (Pos('*',Fname) = 0))
  339.         then
  340.        begin
  341.          Fblock.attr := 0;
  342.          FindFirst(Fname,$3f,Fblock);
  343.          x := Fblock.Attr;
  344.        end;
  345.      if ((x AND $10) <> 0) then IsDir := True;
  346.      If not IsDir and (Pos('.',Fname) = 0) then Fname := Fname + '.*';
  347.      ch := copy(Fname,Length(Fname),1);
  348.      If ((ch <> '*') and (ch <> '?')) and IsDir
  349.         then if (Copy(Fname,Length(Fname),1) <> '\')
  350.            then Fname := Fname + '\';
  351.      ch := copy(Fname,Length(Fname),1);
  352.      If (ch = '\') then FName := Fname + '*.*';
  353.      DosError := 0;                           {Clear any test errors}
  354.    end; {Procedure GetParms}
  355.  
  356.   Procedure FixName;   { Format filename and fill with spaces }
  357.                        { between name and extension for display }
  358.     Begin
  359.         WholeName := FBlock.Name;
  360.         i := Pos('.',WholeName);
  361.         j := Length(WholeName);
  362.         If i = 1 then
  363.           begin
  364.             If (WholeName = '.') then WholeName :=   '.            ';
  365.             If (WholeName = '..') then WholeName :=  '..           ';
  366.             Exit;
  367.           end;
  368.         If i > 0 then
  369.           begin
  370.             Delete(WholeName,i,1);
  371.             for j := i to 9 do Insert(' ',WholeName,i);
  372.             for j := Length(WholeName) to 12 do
  373.                WholeName := Wholename + ' ';
  374.           end
  375.            else
  376.           for j := i to 12 do WholeName := WholeName + ' ';
  377.       end;  {Procedure FixName}
  378.  
  379.   Procedure MainLoop;
  380.         Begin
  381.           FixName;
  382.           Showit;
  383.           FindNext(Fblock);
  384.         end;
  385.  
  386. begin  {Main Program}
  387.     Count := 0;                         { Initialize global variables }
  388.     DosError := 0;
  389.     FirstTime := True;
  390.     Paging := True;
  391.     GetParms;                           { Read the command line }
  392.     WriteLn;
  393.     Inc(Count);                          { Counter for screen and # files }
  394.     FindFirst(DName + ':\*.*',$8,Fblock);{ Get disk label and display if any}
  395.     If DosError <> 0 then WriteLn(
  396.     ' Volume in',drive,Dname,' has no label')
  397.        else
  398.     WriteLn( ' Volume in',drive,Dname,' is ',FBlock.Name);
  399.     Inc(Count);
  400.     WriteLn(' Directory of ',Fname);
  401.     Inc(Count);
  402.     WriteLn;
  403.     Inc(Count);
  404.     FindFirst(Fname,$17,Fblock);
  405.     CheckForDosError;
  406.     While DosError = 0 do MainLoop;
  407.     If Odd(Count) and Double then WriteLn;  { Program is over.  Clean up, }
  408.     Write(Count - 4:5,' file(s)     ');     { We counted four extra lines }
  409.                                             { adjust and show # files found}
  410.     WriteLn(DSize ,' bytes free on',drive,DName); { Show free space and end}
  411. end. {Main Program}