Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB15.ZIP/DIRECTRY.PAS

Pascal/Delphi Source File | 1985-07-31 | 20.0 KB | 654 lines

{                 *****     Directories From Turbo     *****

   Written By:  Drew Letcher                                3/23/85
                Iowa Software Associates
                104 Hawkeye Ct.
                Iowa City, IA  52240
                [phone]

   This program gives example routines for accessing the DOS 2.1 directories,
   and examples for switching drives and directories in Turbo programs, for
   reading and setting a files attribute byte, for getting a disk's space
   information, and for accessing the command line when running Turbo programs.
   The file itself is a ready to compile/run Turbo program that gives a
   directory listing and some disk status information.

   All these routines use the Turbo MSDOS() function which accesses the DOS
   software interrupt 21h, see section B.2.2 in the Turbo manual.  The
   functions used inside this interrupt are as follows:

         get first directory entry               4Eh
         get next directory entry                4Fh
         get the Disk Transfer Address           2Fh
          ( where DOS returns info to you )
         get drive total/free space              36h

         default drive designator                19h
         change default drive                    0Eh

         get current directory                   47h
         make a directory                        39h
         remove a directory                      3Ah
         change directory                        3Bh

         get/set a files attributes              43h


   This program has redundant declarations and does things in a straight
   forward so as to make these routines easily understandable and
   transportable to your own programs.  For other information see the DOS
   Technical Reference Manual, or any of the good books availble on the
   DOS programmers' level.
}

{.pa}

PROGRAM  DirectoriesFromTurbo;
{  ***  set compiler directives  ***  }
{  Appendix E of the TurboPascal manual  }

{$B+}  {  set con/term as standard I/O device  }
{$C+}  {  use of ^C and ^S during standard I/O  }
{$I+}  {  disk I/O error checking  }
{$R-}  {  array index range checking  }
{$V+}  {  type checking of string parameters }
{$U+}  {  user interrupt with ^C  }
{$K+}  {  check stack space for variables during procedure calls }


TYPE
   path           =  string[ 64 ];
   name           =  string[ 13 ];
   directoryinfo  =  RECORD
                     filename    :  name;
                     size        :  real;
                     time        :  string[ 8 ];
                     date        :  string[ 8 ];
                     attribute   :  string[ 7 ];
                     END;

   memoryaddress  =  ( segment, offset );
   address        =  ARRAY[ memoryaddress ] OF integer;
   directorytype  =  string[ 64 ];
   drivedesignator     =  string[ 2 ];


VAR
   Searchname     :  name;
   DirEntry       :  directoryinfo;
   DirFlag        :  boolean;
   Directory      :  directorytype;
   DirSize,
   TotalSpace,
   FreeSpace      :  real;
   Drive          :  integer;

{ end Main routine declarations  }
{.pa}


PROCEDURE  CheckCommandLine( VAR SearchName  :  name );

{  The commandline is located at CSeg:$0080 and contains everything after
   the program name that you type to invoke a Turbo program, including the
   space right after the program name.  If you want to use the command line
   save it right away.  The maximum length of the command line is 127
   characters.  The length of the command line is at CSeg:$0080, and the
   actual string starts at CSeg:$0081.  So a string variable will automatically
   be set to the length of the line typed in by a user.  }


   VAR
      I          :  integer;
      TempLine   :  string[ 30 ];
      ComLine    :  string[ 30 ] ABSOLUTE CSeg:$0080;

   BEGIN
   IF Length( ComLine ) = 0 THEN
      BEGIN
      SearchName := '????????.???' + chr(0);    {  will search for all files  }
      END
   ELSE     { search for files matching the filename in the command line,
              this routine doesn't check for a path name or expand asteriks.  }
      BEGIN
      TempLine := ComLine;
      WHILE TempLine[ 1 ] = ' ' DO
         Delete( TempLine, 1, 1 );

      I := 0;
      WHILE ( I < 13 ) AND ( TempLine[ I ] <> chr(0) ) DO
         BEGIN
         I := I + 1;
         SearchName[ I ] := UpCase( TempLine[ I ] );
         {  does grab chr(0) as the last character  }
         END;
      END;  {  Else  }
   END;  {  **  Procedure CheckCommandLine  **  }
{.pa}


FUNCTION  DefaultDrive  :  drivedesignator;
{ returns the default drive designator.   e.g.  A:  }

   TYPE
      registertype  =  RECORD
                       AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : integer;
                       END;

   VAR
      Registers  :  registertype;

   BEGIN
   WITH  Registers  DO
      BEGIN
      AX := $19 shl 8;
      MSDOS( Registers );                  { return AX = 0 is drive A, etc. }
      DefaultDrive := Chr( 65 + Lo( AX ) ) + ':';
      END;
   END;  {  **  Function DefaultDrive  **  }


PROCEDURE  ChangeDefaultDrive(  DriveLetter  :  drivedesignator  );
{  parameter can be:  a, A, a:, or A:   where "a" can be any valid
   drive letter.  }

   TYPE
      registertype  =  RECORD
                       AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : integer;
                       END;

   VAR
      Registers  :  registertype;

   BEGIN
   WITH Registers DO
      BEGIN
      AX := $0E shl 8;
      DX := Ord( UpCase( DriveLetter[ 1 ] ) ) - 65;     {  A: is 0, etc.  }
      MSDOS( Registers );
      IF DX < 0 THEN  writeln( 'Invalid Drive Designator', DriveLetter );
      END;
   END;  {  **  Procedure  ChangeDefaultDrive  **  }
{.pa}


PROCEDURE  GetCurrentDirectory( VAR CurrentDirectory  :  directorytype );
{  gets the path name of the current directory, doesn't include the drive
   designator.   The routine gives DOS a 64 byte location in memory in
   which to store the path.  }

   TYPE
      registertype  =  RECORD
                       AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : integer;
                       END;

   VAR
      Registers  :  registertype;
      I,
      Value,
      CurDirSeg,
      CurDirOfs  :  integer;

   BEGIN

   CurDirSeg := Seg( CurrentDirectory );
   CurDirOfs := Ofs( CurrentDirectory );
   WITH Registers DO
      BEGIN
      AX := $47 shl 8;
      DX := 0;
      DS := CurDirSeg;
      SI := CurDirOfs + 1;
      MSDOS( Registers );
      END;  {  With  }

   CurrentDirectory := '';
   I := 1;
   Value := Mem[ CurDirSeg : CurDirOfs + I ];
   WHILE ( I <= 64 ) AND ( Value > 33 ) AND ( Value < 128 ) DO
      BEGIN
      Mem[ CurDirSeg : CurDirOfs ] := Mem[ CurDirSeg : CurDirOfs ] + 1;
      I := I + 1;
      Value := Mem[ CurDirSeg : CurDirOfs + I ];
      END;
   CurrentDirectory := '\' + CurrentDirectory;
   END;  {  **  Procedure GetCurrentDirectory  **  }
{.pa}


FUNCTION  ChangeDirectory( VAR NewDirectory : directorytype ) : boolean;
{  The directory path can contain the drive on which to change the
   directory.  }

   TYPE
      registertype  =  RECORD
                       AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : integer;
                       END;

   VAR
      Registers  :  registertype;

   BEGIN
   WITH Registers DO
      BEGIN
      AX := $3B shl 8;
      DS := Seg( NewDirectory );
      DX := Ofs( NewDirectory ) +1;
      MSDOS( Registers );
      IF AX = 5 THEN
         BEGIN
         ChangeDirectory := false;
         writeln( 'Change Directory Failed - Bad Directory Path' );
         END
      ELSE
         ChangeDirectory := true;
      END;  {  With  }
   END;  {  **  Function ChangeDirectory  **  }


{.pa}
FUNCTION  MakeDirectory( VAR NewDirectory : directorytype ) : boolean;
   TYPE
      registertype  =  RECORD
                       AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : integer;
                       END;
   VAR
      Registers  :  registertype;

   BEGIN
   WITH Registers DO
      BEGIN
      AX := $39 shl 8;
      DS := Seg( NewDirectory );
      DX := Ofs( NewDirectory ) +1;
      MSDOS( Registers );
      IF AX = 5 THEN
         BEGIN
         MakeDirectory := false;
         writeln( 'Make Directory Failed - Bad or Existing Directory Path' );
         END
      ELSE
         MakeDirectory := true;
      END;  {  With  }
   END;  {  **  Function MakeDirectory **  }


FUNCTION  RemoveDirectory( VAR Directory : directorytype ) : boolean;
   TYPE
      registertype  =  RECORD
                       AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : integer;
                       END;
   VAR
      Registers  :  registertype;

   BEGIN
   WITH Registers DO
      BEGIN
      AX := $3A shl 8;
      DS := Seg( Directory );
      DX := Ofs( Directory ) +1;
      MSDOS( Registers );
      IF AX = 5 THEN
         BEGIN
         RemoveDirectory := false;
         writeln( 'Remove Directory Failed - Bad or Non-empty Directory Path' );
         END
      ELSE
         RemoveDirectory := true;
      END;  {  With  }
   END;  {  **  Function RemoveDirectory **  }
{.pa}


PROCEDURE  GetAttrib(      PathName   :  path;      {  full path name  }
                       VAR Attribute  :  integer );

   TYPE
      registertype  =  RECORD
                       AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : integer;
                       END;

   VAR
      Registers  :  registertype;

   BEGIN
   WITH Registers DO
      BEGIN
      AX := $43 shl 8 + 0;
      DS := Seg( PathName );
      DX := Ofs( PathName ) + 1;
      MSDOS( Registers );
      Attribute := CX;
      END;  {  With  }
   END;  {  **  Procedure GetAttrib  **  }

{  Attribute byte values:
                           0  -  normal read/write
                           1  -  read only
                           2  -  hidden
                           4  -  system file
                           8  -  volume label entry
                          16  -  directory entry
                          32  -  bit = 0 - Archived,
                                     = 1 - not archived  }


PROCEDURE  SetAttrib(  PathName   :  path;      {  full path name  }
                       Attribute  :  integer );

   TYPE
      registertype  =  RECORD
                       AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : integer;
                       END;

   VAR
      Registers  :  registertype;

   BEGIN
   WITH Registers DO
      BEGIN
      AX := $43 shl 8 + 1;
      DS := Seg( PathName );
      DX := Ofs( PathName ) + 1;
      CX := Attribute;
      MSDOS( Registers );
      IF AX = 3 THEN
         writeln( AX, ' Path Not Found or Attribute Already Set' );
      IF AX = 5 THEN
         writeln( AX, ' Access Denied for File Type' );
      END;  {  With  }
   END;  {  **  Procedure SetAttrib  **  }
{.pa}


FUNCTION   GetDriveSpace(     Drive       : integer;
                          VAR TotalSpace,
                              FreeSpace   : real      ) : boolean;

   TYPE
      registertype  =  RECORD
                       AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : integer;
                       END;

   VAR
      Registers          :  registertype;
      TotalClusters,
      FreeClusters,
      SectorsPerCluster,
      BytesPerSector     :  real;

   BEGIN
   WITH Registers DO
      BEGIN
      AX := $36 shl 8;
      DX := Drive;
      MSDOS( Registers );
      IF AX = $FFFF THEN
         BEGIN
         GetDriveSpace := false;
         writeln( 'Invalid Drive Designator' );
         END
      ELSE
         BEGIN
         GetDriveSpace := true;
         TotalClusters := DX;
         FreeClusters := BX;
         SectorsPerCluster := AX;
         BytesPerSector := CX;
         TotalSpace := TotalClusters * SectorsPerCluster * BytesPerSector;
         FreeSpace := FreeClusters * SectorsPerCluster * BytesPerSector;
         END;
      END;  {  With  }
   END;  {  **  Function GetDriveSpace  **  }
{.pa}


PROCEDURE  GetDirEntry( VAR SearchName  :  name;
                        VAR DirEntry    :  directoryinfo;
                        VAR DirFlag     :  boolean        );


{  Passes the next directory entry back to the calling routine.  IF DirFlag
   is false Directory will get the first directory entry,  if it is true
   Directory will get the next directory entry.  If there are no more
   directory entries, Directory will set the value of DirFlag to false.
   Thus, DirFlag must be set when calling Directory, and you must check
   DirFlag upon returning.  }

   TYPE
      registertype  =  RECORD
                       AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : integer;
                       END;
      memoryaddress  =  ( segment, offset );
      address        =  ARRAY[ memoryaddress ] OF integer;


   VAR
     registers  :  registertype;


   PROCEDURE  GetDTA( VAR DTA : address );
   {  get the Disk Transfer Address where DOS will return the directory
      information.   }

      TYPE
         registertype  =  RECORD
                          AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags : integer;
                          END;

      VAR
         Registers  :  registertype;

      BEGIN
      WITH Registers DO
         BEGIN
         AX := $2F shl 8;
         MSDOS( Registers );
         DTA[ segment ] := ES;
         DTA[ offset ] := BX;
         END;
      END;  {  **  Procedure GetDTA  **  }
{.pa}


   PROCEDURE  GetEntryFromDTA( VAR DirEntry : directoryinfo );

   {  GetEntry gets the directory info from the Disk Transfer Area in
      memory as follows:

          DTA address +        Contents
              21                 attribute
              22-23              creation time
              24-25              creation date
              26-27              low bytes file size
              28-29              high bytes file size
              30-42              filename, upto 13 bytes terminated by chr(0)

   }

      VAR
         registers       :  registertype;
         DTA             :  address;
         DTAseg,
         DTAofs,
         I,
         Temp            :  integer;
         Hour, Min, Sec,
         Month, Day      :  string[ 2 ];
         Year            :  string[ 4 ];

      BEGIN
         GetDTA( DTA );
         DTAseg := DTA[ segment ];
         DTAofs := DTA[ offset ];

         WITH DirEntry DO
            BEGIN
            {  get the attribute byte  }
            attribute := '.......';
            Temp := Mem[ DTAseg : DTAofs + 21 ];
            IF ( Temp AND 223 ) = 0 THEN
               attribute := 'RW.....';                { regular Read/Write }
            IF ( Temp AND 1 ) = 1 THEN
               Insert( 'R', attribute, 1 );           { Read only file }
            IF ( Temp AND 2 ) = 2 THEN
               Insert( 'H', attribute, 3 );           { Hidden file }
            IF ( Temp AND 4 ) = 4 THEN
               Insert( 'S', attribute, 4 );           { System file }
            IF ( Temp AND 8 ) = 8 THEN
               Insert( 'V', attribute, 5 );           { root Volume label }
            IF ( Temp AND 16 ) = 16 THEN
               Insert( 'D', attribute, 6 );           { subDirectory }
            IF ( Temp AND 32 ) = 0 THEN
               Insert( 'A', attribute, 7 );           { Archived }
{.pa}
            {  get the creation time  }
            Temp := Mem[ DTAseg : DTAofs + 23 ];
            str( ( Temp shr 3 ):2, Hour );
            Temp := 8 * ( Temp AND 3 );
            Temp := Temp + ( Mem[ DTAseg : DTAofs + 22 ] shr 5 );
            str( Temp, Min );
            IF Length( Min ) < 2 THEN
               Min := '0' + Min;
            Temp := Mem[ DTAseg : DTAofs + 22 ];
            str( ( ( Temp AND 31 ) * 2 ):2, Sec );
            time := Hour + ':' + Min;           { who cares about seconds? }

            {  get the creation date }
            Temp := Mem[ DTAseg : DTAofs + 25 ];
            str( ( 80 + ( Temp shr 1 ) ):2, Year );
            Temp := 8 * ( Temp AND 1 );
            Temp := Temp + ( Mem[ DTAseg : DTAofs + 24 ] shr 5 );
            str( Temp:2, Month );
            Temp := Mem[ DTAseg : DTAofs + 24 ];
            str( ( Temp AND 31 ), Day );
            IF Length( Day ) < 2 THEN
               Day := '0' + Day;
            date := Month + '-' + Day + '-' + Year;


            {  get the filesize }
            size := 0;
            size := Mem[ DTAseg : DTAofs + 26 ];
            size := size + Mem[ DTAseg : DTAofs + 27 ] * 256.0;
            size := size + Mem[ DTAseg : DTAofs + 28 ] * 65536.0;
            size := size + Mem[ DTAseg : DTAofs + 29 ] * 16777200.0;

            {  get the filename and store in DirEntry  }
            filename := '';
            I := 30;
            Temp := Mem[ DTAseg : DTAofs + I ];
            WHILE ( I <= 41 ) AND ( Temp <> 0 ) DO
               BEGIN
               filename := filename + chr( Temp );
               I := I + 1;
               Temp := Mem[ DTAseg : DTAofs + I ];
               END;  {  While  }
           END;  {  With  }
      END;   {  ***  Procedure GetEntry  ***  }
{.pa}

   BEGIN   {  *****  Directory Routine  *****  }
      WITH Registers DO
         BEGIN
         IF DirFlag = false THEN      {  get the first directory entry  }
            BEGIN
            DirFlag := true;
            DS := Seg( SearchName );
            DX := Ofs( SearchName ) + 1;
            CX := 31;
            AX := $4E shl 8;
            MSDOS( Registers );
            GetEntryFromDTA( DirEntry );
            END
         ELSE                          {  else get the next directory entry  }
            BEGIN                      {  DOS remembers the last file        }
            AX := $4F shl 8;           {  searched for.                      }
            MSDOS( Registers );
            IF AX = 0 THEN             {  AX returns 0 as long as there are }
               GetEntryFromDTA( DirEntry )       {  more directory entries. }
            ELSE
               DirFlag := false;
            END;  {  Outer If  }

         END;  {  With Registers  }
   END;  {  ***  Procedure  Directory  ***  }


PROCEDURE  FormatFilename(  VAR  Filename  :  name  );

VAR
   LengthName,
   TrailingBlanks,
   I, J             :  integer;

BEGIN
   LengthName := Length( Filename );
   TrailingBlanks := 12 - LengthName;
   I := 1;
   WHILE ( I < 9 ) AND ( I < LengthName ) DO
      BEGIN
      IF ( FileName[ I ] = '.' ) THEN
         BEGIN
         FOR J := I TO 8 DO
            Insert( ' ', Filename, J );
         I := 9;
         END;
      I := I + 1;
      END;  {  While  }

   FOR I := Length( Filename ) TO 12 DO
      Filename := Filename + ' ';
END;  {  **  Procedure FormatFilename  **  }
{.pa}


{  **  Main routine declarations  **  }

VAR
  NumberFiles    :  integer;
  Attribute      :  integer;
  PathName       :  path;
  DriveLetter   :  drivedesignator;

{  **  end Main routine declarations  **  }


BEGIN  {  **  Main Routine  **  }

CheckCommandLine( SearchName );

DriveLetter := DefaultDrive;
GetCurrentDirectory( Directory );
writeln( 'Current Directory: ', DriveLetter, Directory );
writeln;

DirFlag := false;                  {  get the first directory entry  }
GetDirEntry( SearchName, DirEntry, DirFlag );

NumberFiles := 0;
DirSize := 0;
WHILE  DirFlag = true DO
   BEGIN
   WITH DirEntry DO
      BEGIN
      FormatFilename( filename );
      writeln( filename:12, size:10:0, attribute:10, date:12, time:10 );
      IF attribute[ 1 ] = 'R' THEN  NumberFiles := NumberFiles + 1;
      DirSize := DirSize + size;
      GetDirEntry( SearchName, DirEntry, DirFlag );
      END;  {  With  }
   END;  {  While  }

{  get drive total / free space   }
Drive := 0;  {  current drive  }
IF GetDriveSpace( Drive, TotalSpace, FreeSpace ) THEN
   BEGIN
   writeln;
   writeln( TotalSpace:8:0, '  Bytes Total Disk Space' );
   writeln( FreeSpace:8:0,  '  Bytes Free' );
   writeln( DirSize:8:0,    '  Bytes This Listing in ',
            NumberFiles:3,  ' Files'                      );
   END;
END.