Program QuickExtendedDirectory;

  {Directory listing with attributes and age of file in days shown.
   See Procedure DisplaySyntax for instructions and command line switches.
   This program is intentionally designed to work and look as much like the
   Dos DIR command as possible, except it displays the following additional
   information:  1) The file attribute, where 'R' means read-only, 'S'
   means system, 'H' means hidden, and 'A' means the archive bit is set.
   2) The age of the file in days.  Its default (opposite of DIR) is paged
   mode, wherein it stops every screenful and waits for a keypress.
   This may be changed with the /p switch.  It also, like DIR, defaults
   to a one file per line format.  This may be changed with the /w
   switch, but no age in days is shown in this mode.

                                  Placed in the public domain

                                  Rick Housh
                                  CIS PIN 72466,212
   }


Uses Dos, Crt;

const
  drive = ' drive ';
  tab   = '        ';

var
  Fname, DirStr   : string;
  i, j, DriveNo   : byte;
  Fblock          : SearchRec;
  WholeName       : string[12];
  ch, DName       : string[1];
  Count           : word;
  DSize           : longint;
  Double, Paging,
  DirFound, FirstTime  : boolean;

  Procedure DisplaySyntax;      { Help, called with QDIR/H }
      begin
        WriteLn('QDIR : Quick Extended directory program.'#13#10);
        WriteLn(
        'Usage: QDIR [ filename.ext ] [ /w ] [ /p ] [ /h ]');
        WriteLn(Tab,'  (Default filename.ext = "*.*")'#13#10);
        WriteLn(
 'Shows: FileName, Attributes (Read only, Hidden, System, Archive, Directory),');
        WriteLn(
       '       Size, Date & Time of last write, and Age of file in days.');
        WriteLn(
        #13#10'Switches:  /w : Two per line, w/o time or age of file.');
        WriteLn(Tab,'   /p : NO pause between screens.');
        WriteLn(Tab,'   /h : This text.'#13#10);
        Halt;
      end;

  Procedure UpString(var Strg: String);
    {Upcases a string.  Syntax is Upstring(whatever)}
    {AnyString is String}

    begin
      inline
      ($C4/$BE/Strg/
       $26/$8A/$0D/
       $FE/$C1/
       $FE/$C9/
       $74/$13/
       $47/
       $26/$80/$3D/$61/
       $72/$F5/
       $26/$80/$3D/$7A/
       $77/$EF/
       $26/$80/$2D/$20/
       $EB/$E9);
    end; {Inline Procedure UpString}

  Function GetKey : char;
    var ch : char;
    Begin
      Inline(
                     {; Function GetKey : Char}
                     {; Clears the keyboard buffer then waits until}
                     {; a key is struck.  If the key is a special, e.g.}
                     {; function key, goes back and reads the next}
                     {; byte in the keyboard buffer.  Thus does}
                     {; nothing special with function keys.}
      $B4/$0C        {       MOV  AH,$0C      ;Set up to clear buffer}
      /$B0/$08       {       MOV  AL,8        ;then to get a char}
      /$CD/$21       {SPCL:  INT  $21         ;Call DOS}
      /$3C/$00       {       CMP  AL,0        ;If it's a 0 byte}
      /$75/$04       {       JNZ  CHRDY       ;is spec., get second byte}
      /$B4/$08       {       MOV  AH,8        ;else set up for another}
      /$EB/$F6       {       JMP  SHORT SPCL  ;and get it}
      /$88/$46/<CH   {CHRDY: MOV  <CH[BP],AL  ;else put into function return}
       );
      GetKey := Ch;
    end; {Inline function GetKey}


  Procedure ShowIt;   { Does most of the work in displaying info }

  const

  WeekDay: array[0..6] of String[9] = ('Sunday','Monday','Tuesday',
                               'Wednesday','Thursday','Friday','Saturday');

  MonthName:array[1..12] of String[9] = ('January','February','March','April',
                                   'May','June','July','August','September',
                                   'October','November','December');

  var
      x               : byte;
      Kind            : string[4];
      Date, Time      : string[8];
      st1, st2, st3   : string[2];
      DT              : DateTime;
      y, dy, m, DayOfWeek : word;
      DayFromZero, LeapYearDays,
      CurrDay, FileDay, DifferenceInDays : LongInt;

    begin
      UnpackTime(FBlock.Time,DT);          { Make file intelligible }
      GetDate(y, m, dy, DayOfWeek);        { And file date }
      x := Fblock.Attr;                    { Ready to check file attribute}
      If x AND $40 <> 0 then               { If bit 6 set file is device }
        Begin                              { So tell em, and exit }
          WriteLn(FName,' is a Device'#13#10);
          Halt;
        end;                               { Initialize attribute string }
      Kind := '    ';
      If x AND $01 <> 0 then Kind[1] := 'R';  { If read-only }
      If x AND $02 <> 0 then Kind[2] := 'H';  { If hidden    }
      If x AND $04 <> 0 then Kind[3] := 'S';  { If system    }
      If x AND $20 <> 0 then Kind[4] := 'A';  { If archive bit set }
      Str(DT.Month:3,St1);                    { Move month # into string }
      Str(DT.Day:2,St2);                      { and day # }
      If St2[1] = ' ' then St2[1] := '0';     { If leading space make it '0'}
      Str(DT.Year - 1900:2,St3);              { Last two digits of yr to st3}
      Date := st1 + '-' + st2 + '-' + st3 + ' '; { and format date string }
      If not Double then                      { If doing full info }
         begin                                { Then show file create time}
           Str(DT.Hour:2,st1);
           Str(DT.Min:2,st2);
           If st2[1] = ' ' then st2[1] := '0';
           Str(DT.Sec:2,st3);
           If St3[1] = ' ' then st3[1] := '0';
           Time := St1 + ':' + St2 + ':' + st3 + '  ';

           { The following code calculates the age of the file (in days)
             by first calculating the current number of days from
             January 1, 0 A.D. for the current date (machine date),
             then the number of days from 1/1/00 to the date of
             the file, then subtracting the file age from the current
             age.  If the file date is later then the current date
             the message 'FUTURE DATE', instead of the number of
             days is displayed.  This routine makes the necessary
             adjustments for leap years, even the 4000 year adjust-
             ment not covered by the Gregorian calendar rules, but
             indicated necessary by the mathematics of the thing.}

           DayFromZero := ( 365 * y ) + (31 * Pred(m)) + Dy ;
           If m > 2 then DayFromZero := DayFromZero - Trunc(0.4 * m + 2.3)
                else if m < 2 then dec(y);
           LeapYearDays := (y div 4) - (y div 100)
                + (y div 400) - (y div 4000);
           CurrDay := DayFromZero + LeapYearDays ;

           DayFromZero :=( 365 * DT.Year) + (31 * Pred(DT.Month) + DT.Day);
           If DT.Month > 2 then
              DayFromZero := DayFromZero - trunc(0.4 * DT.Month + 2.3)
                else if DT.Month < 2 then Dec(DT.Year);
           LeapYearDays := (y div 4) - (y div 100)
             + (y div 400) - (y div 4000);
           FileDay := DayFromZero + LeapYearDays ;

           DifferenceInDays := (CurrDay - FileDay);
         end;

      { If the program has just started Write the current date and time}

      If FirstTime then Write(
        Tab,Weekday[DayOfWeek],'  ',MonthName[m]:2,',',
        ' ',dy:2,',',' ',y:4,#13#10#10);
      FirstTime := False;
      If not Double then Write('    ');  { Leading spaces for 1 line/file}
      Write(WholeName);                  { First write filename }
      Write(' ',Kind);                   { then attribute }
                                         { Write filesize, unless it's }
                                         { a directory }
      If x AND $10 <> 0 then Write(
          '  <DIR> ') else Write(Fblock.Size:7,' ');
      Write(Date);                          { Show file date }
      If not Double then Write('  ',Time);  { and time, if not short form}
      If not Double then                    { If long form show age in days}
        begin
          If (DifferenceInDays < 0) then
            Write  ('     FUTURE DATE')
          else
            begin
              Write('     Age ',DifferenceinDays:5);
              Write(' day');
              If (DifferenceInDays) <> 1 then Write('s');
            end;
          end;
      Inc(Count);
      If Double then  { If short form and 1st on line make tab }
         begin        { If short form and 2nd on line do CR, LF }
           if odd(Count) then Write(Tab) else WriteLn;
         end
           else WriteLn;
       If Paging then      { If the /p switch is on }
         begin             { and screen is full, stop, ask for keypress }
           If (Double and (Count mod 46 = 0)) or
              (not Double and (Count mod 23 = 0)) then
             begin
               Write('Press any key to continue ...');
               ch := GetKey;
               WriteLn;
             end;
         end;
    end; {Procedure Showit}

  Procedure CheckForDosError;   { Its name is its motto }
    const
      nf = ' not found';
    var
      d : integer;

    begin
      d := DosError;            { Get DOS error number }
      DosError := 0;            { and reset DosError }
      If d = 0 then Exit;       { If no error, exit }
      Case d of                 { otherwise display nature of error }
          2 : Write('File',nf);
          3 : Write('Invalid path');
         18 : Write('File',nf);
        152 : Write('Drive ',Dname,' not ready');
        156 : Write('Disk seek error on ',Dname);
        162 : Write('General failure on',drive,Dname);
        else Write('DOS Error #',d);
      end; {Case}
(*    { Uncomment out the next if you want error in hexidecimal }
      Write('  DOS Error =  ',d,' Decimal  ');
      Case D of
          2 : Write  ('2');
          3 : Write  ('3');
         18 : Write ('12');
        152 : Write ('98');
        156 : Write ('9C');
        162 : Write ('A2');
      end; {Case}
      If D in [2,3,18,152,156,162] then Write(' Hexadecimal');
*)
      WriteLn;
      Halt(d);   { Exit with DOS errorlevel set }
    end; {Procedure CheckForDosError}

  Procedure GetParms;  { Gets the command and formats everything to }
                       { work as much like DIR as possible }
    var
      x     : Byte;
      Parm  : Array[ 1..3 ] of String;
      IsDir : Boolean;
    Begin
      Fname    := '';
      DirStr   := '';
      x        := 0;
      for i := 1 to 3 do
        begin
            If Paramcount > 0 then
              begin
                Parm[i] := ParamStr(i);
                UpString(Parm[i]);
              end
               else
              Parm[i] := '';
        end;
      Fname := Parm[1];
      Double := False;
      For i := 1 to 3 do if Pos('/H',Parm[i]) <> 0 then DisPlaySyntax;
      For i := 1 to 3 do if Pos('/W',Parm[i]) <> 0 then Double := True;
      For i := 1 to 3 do if Pos('/P',Parm[i]) <> 0 then Paging := False;
      i := Pos('/',Fname);
      If i <> 0 then Delete(Fname,i,Length(Fname));
      If Fname = '' then Fname := '*.*';
      begin
      If not (Pos(':',Fname) in [0,2]) then
        begin
          WriteLn(#13#10'Invalid parameter'#13#10);
          Halt(1);
        end;
      If Pos(':',Fname) = 0 then             {If default drive}
        begin                                    {strip leading if current}
          If Pos('\',Fname) = 1 then Delete(Fname,1,1);
          If (Pos('.*',Fname) = 1) or (Pos('.?',Fname) = 1)
              then Fname := '*' + Fname;
          GetDir(0,DirStr);                      {get current WITH drive}
          If Pos('..',Fname) = 1 then
           begin
             DirStr := Copy(DirStr,1,3);
             Fname :=  '*.*';
           end;
          If Pos('\',DirStr) <> Length(DirStr) then DirStr := DirStr + '\';
          Fname := DirStr + Fname;               {tack curr dir on front}
          x := Ord(Fname[1]);                    {get drive number}
          If x > $60 then x := x - $60 else x := x - $40; {and fix it}
        end
          else
        begin
          x := ord(Fname[1]);                         {get drive number}
          If x > $60 then x := x - $60 else x := x - $40; {and fix it}
          GetDir(x,DirStr);                            {get that current dir}
          If (Pos(':\',Fname) <> 2)  then
           begin
            If Pos('\',DirStr) <> Length(DirStr) then DirStr := DirStr + '\';
            Delete(Fname,1,2);
            Fname := DirStr + Fname;
           end;
        end;
     end;

     DriveNo := x;
     DName := Fname[1];
     If Pos('\',Fname) <> 3 then Insert('\',Fname,3);
     DirFound := False;
     Dsize := DiskFree(DriveNo);
     If DSize = -1 then   { Diskfree returns $0FFFF if drive invalid }
                          { but NO DosError and IOResult = 0 }
       begin
          WriteLn(#13#10,'Invalid drive ',Dname,':');
          Halt(15);  { Invalid drive error number in errorlevel }
       end;
     DirFound := True;
     IsDir := False;
     i := Length(Fname);
     If (i > 3) and (Fname[i] = '\') then Delete(Fname,i,1);
     If Length(Fname) = 3 then Fname := Fname + '*.*';
     x := 0;
     If ((Pos('?',Fname) = 0) and (Pos('*',Fname) = 0))
        then
       begin
         Fblock.attr := 0;
         FindFirst(Fname,$3f,Fblock);
         x := Fblock.Attr;
       end;
     if ((x AND $10) <> 0) then IsDir := True;
     If not IsDir and (Pos('.',Fname) = 0) then Fname := Fname + '.*';
     ch := copy(Fname,Length(Fname),1);
     If ((ch <> '*') and (ch <> '?')) and IsDir
        then if (Copy(Fname,Length(Fname),1) <> '\')
           then Fname := Fname + '\';
     ch := copy(Fname,Length(Fname),1);
     If (ch = '\') then FName := Fname + '*.*';
     DosError := 0;                           {Clear any test errors}
   end; {Procedure GetParms}

  Procedure FixName;   { Format filename and fill with spaces }
                       { between name and extension for display }
    Begin
        WholeName := FBlock.Name;
        i := Pos('.',WholeName);
        j := Length(WholeName);
        If i = 1 then
          begin
            If (WholeName = '.') then WholeName :=   '.            ';
            If (WholeName = '..') then WholeName :=  '..           ';
            Exit;
          end;
        If i > 0 then
          begin
            Delete(WholeName,i,1);
            for j := i to 9 do Insert(' ',WholeName,i);
            for j := Length(WholeName) to 12 do
               WholeName := Wholename + ' ';
          end
           else
          for j := i to 12 do WholeName := WholeName + ' ';
      end;  {Procedure FixName}

  Procedure MainLoop;
        Begin
          FixName;
          Showit;
          FindNext(Fblock);
        end;

begin  {Main Program}
    Count := 0;                         { Initialize global variables }
    DosError := 0;
    FirstTime := True;
    Paging := True;
    GetParms;                           { Read the command line }
    WriteLn;
    Inc(Count);                          { Counter for screen and # files }
    FindFirst(DName + ':\*.*',$8,Fblock);{ Get disk label and display if any}
    If DosError <> 0 then WriteLn(
    ' Volume in',drive,Dname,' has no label')
       else
    WriteLn( ' Volume in',drive,Dname,' is ',FBlock.Name);
    Inc(Count);
    WriteLn(' Directory of ',Fname);
    Inc(Count);
    WriteLn;
    Inc(Count);
    FindFirst(Fname,$17,Fblock);
    CheckForDosError;
    While DosError = 0 do MainLoop;
    If Odd(Count) and Double then WriteLn;  { Program is over.  Clean up, }
    Write(Count - 4:5,' file(s)     ');     { We counted four extra lines }
                                            { adjust and show # files found}
    WriteLn(DSize ,' bytes free on',drive,DName); { Show free space and end}
end. {Main Program}