Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PIBTERM.ZIP/PIBDIR.PAS

Pascal/Delphi Source File | 1987-11-25 | 28.8 KB | 604 lines

(*----------------------------------------------------------------------*)
(*        DIRMAN.PAS --- MSDOS Directory Routines for Turbo Pascal      *)
(*----------------------------------------------------------------------*)
(*                                                                      *)
(*  Author:  Philip R. Burns                                            *)
(*  Date:    January, 1985                                              *)
(*  Version: 1.0                                                        *)
(*  Systems: For MS-DOS on IBM PCs and close compatibles only.          *)
(*           Note:  I have checked these on Zenith 151s under           *)
(*                  MSDOS 2.1 and IBM PCs under PCDOS 2.0.              *)
(*                                                                      *)
(*  Needs:   Global types from GLOBTYPE.PAS.                            *)
(*                                                                      *)
(*  History: Original with me.                                          *)
(*                                                                      *)
(*           Suggestions for improvements or corrections are welcome.   *)
(*           Please leave messages on Gene Plantz's BBS [phone]  *)
(*           or Ron Fox's BBS [phone].                           *)
(*                                                                      *)
(*           If you use this code in your own programs, please be nice  *)
(*           and give proper credit.                                    *)
(*                                                                      *)
(*----------------------------------------------------------------------*)
(*                                                                      *)
(*  Routines:                                                           *)
(*                                                                      *)
(*      Convert_AsciiZ_To_String                                        *)
(*      Convert_String_To_AsciiZ                                        *)
(*      Dir_Get_Default_Drive                                           *)
(*      Dir_Set_Default_Drive                                           *)
(*      Dir_Get_Current_Path                                            *)
(*      Dir_Set_Current_Path                                            *)
(*      Dir_Set_Disk_Transfer_Address                                   *)
(*      Dir_Delete_File                                                 *)
(*      Dir_Count_Drives                                                *)
(*      Dir_Convert_Time                                                *)
(*      Dir_Convert_Date                                                *)
(*      Dir_Find_First_File                                             *)
(*      Dir_Find_Next_File                                              *)
(*                                                                      *)
(*----------------------------------------------------------------------*)

(*----------------------------------------------------------------------*)
(*                  Map of MsDos Directory Entry                        *)
(*----------------------------------------------------------------------*)

Type

   Directory_Record = Record
                         Filler    : Array[1..21] Of Byte;
                         File_Attr : Byte;
                         File_Time : Integer;
                         File_Date : Integer;
                         File_Size : Array[1..2] Of Integer;
                         File_Name : Array[1..80] Of Char;
                      End;

(*----------------------------------------------------------------------*)
(*   Convert_AsciiZ_To_String -- Convert Ascii Z string to Turbo String *)
(*----------------------------------------------------------------------*)

Procedure Convert_AsciiZ_To_String( Var S: AnyStr );

(*                                                                      *)
(*     Procedure:  Convert_AsciiZ_To_String                             *)
(*                                                                      *)
(*     Purpose:    Convert Ascii Z string to Turbo String               *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Convert_AsciiZ_To_String( Var S: AnyStr );                    *)
(*                                                                      *)
(*           S --- Ascii Z string to be turned into Turbo string        *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        None                                                          *)
(*                                                                      *)
(*     Remarks:                                                         *)
(*                                                                      *)
(*        The string S is assumed to have already received the Ascii Z  *)
(*        string in its [1]st thru [l]th locations.                     *)
(*        This routine searches for the 0-character marking the end of  *)
(*        the string and changes the Turbo string length (in S[0]) to   *)
(*        reflect the actual string length.                             *)

Var
   I: Integer;

Begin (* Convert_AsciiZ_To_String *)

   I := 1;
   While( S[I] <> CHR(0) ) Do I := I + 1;

   S[0] := CHR( I - 1 );

End   (* Convert_AsciiZ_To_String *);

(*----------------------------------------------------------------------*)
(*   Convert_String_To_AsciiZ -- Convert Turbo string to Ascii Z String *)
(*----------------------------------------------------------------------*)

Procedure Convert_String_To_AsciiZ( Var S: AnyStr );

(*                                                                      *)
(*     Procedure:  Convert_String_To_AsciiZ                             *)
(*                                                                      *)
(*     Purpose:    Convert Turbo string to ascii Z string               *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Convert_String_To_AsciiZ( Var S: AnyStr );                    *)
(*                                                                      *)
(*           S --- Turbo string to be turned into Ascii Z string        *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        None                                                          *)
(*                                                                      *)

Begin (* Convert_String_To_AsciiZ *)

   S := S + CHR( 0 );

End   (* Convert_String_To_AsciiZ *);

(*----------------------------------------------------------------------*)
(*     Dir_Get_Current_Path -- Get current directory path name          *)
(*----------------------------------------------------------------------*)

Function Dir_Get_Current_Path( Drive         : Char;
                               Var Path_Name : AnyStr ) : Integer;

(*                                                                      *)
(*     Function:   Dir_Get_Current_Path                                 *)
(*                                                                      *)
(*     Purpose:    Gets text of current directory path name             *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Iok := Dir_Get_Current_Path( Drive : Char;                    *)
(*                                     Var Path_Name : AnyStr ) :       *)
(*                                     Integer;                         *)
(*                                                                      *)
(*           Drive      --- Drive to look on                            *)
(*           Path_Name  --- returned current path name                  *)
(*                                                                      *)
(*           Iok        --- 0 if all went well, else DOS return code    *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        MsDos                                                         *)
(*        Convert_String_To_AsciiZ                                      *)
(*                                                                      *)

Var
   Dir_Reg: RegPack;

Begin (* Dir_Get_Current_Path *)

    Dir_Reg.Ah := $47;
    Dir_Reg.Ds := SEG( Path_Name[1] );
    Dir_Reg.Si := OFS( Path_Name[1] );
    Dir_Reg.Dl := ORD( UpCase( Drive ) ) - ORD( '@' );

    MsDos( Dir_Reg );

    If ( Carry_Flag AND Dir_Reg.Flags ) = 0 Then
       Begin
          Dir_Get_Current_Path := 0;
          Convert_AsciiZ_To_String( Path_Name );
       End
    Else
       Dir_Get_Current_Path := Dir_Reg.Ax;

End   (* Dir_Get_Current_Path *);

(*----------------------------------------------------------------------*)
(*     Dir_Set_Current_Path -- Set current directory path name          *)
(*----------------------------------------------------------------------*)

Function Dir_Set_Current_Path( Path_Name : AnyStr ) : Integer;

(*                                                                      *)
(*     Function:   Dir_Set_Current_Path                                 *)
(*                                                                      *)
(*     Purpose:    Sets new current directory path name                 *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Iok := Dir_Set_Current_Path( Path_Name : AnyStr ) :           *)
(*                                     Integer;                         *)
(*                                                                      *)
(*           Path_Name  --- New current path name                       *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        MsDos                                                         *)
(*        Convert_AsciiZ_To_String                                      *)
(*                                                                      *)

Var
   Dir_Reg: RegPack;
   I      : Integer;

Begin (* Dir_Set_Current_Path *)

   Convert_String_To_AsciiZ( Path_Name );

   Dir_Reg.Ah := $3B;
   Dir_Reg.Ds := SEG( Path_Name[1] );
   Dir_Reg.Dx := OFS( Path_Name[1] );

   MsDos( Dir_Reg );

   If ( Carry_Flag AND Dir_Reg.Flags ) = 0 Then
      Dir_Set_Current_Path := 0
   Else
      Dir_Set_Current_Path := Dir_Reg.Ax;

End   (* Dir_Set_Current_Path *);


(*----------------------------------------------------------------------*)
(*     Dir_Set_Disk_Transfer_Address --- Set DMA address for disk I/O   *)
(*----------------------------------------------------------------------*)

Procedure Dir_Set_Disk_Transfer_Address( Var DMA_Buffer );

(*                                                                      *)
(*     Procedure:  Dir_Set_Disk_Transfer_Address                        *)
(*                                                                      *)
(*     Purpose:    Sets DMA address for disk transfers                  *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Dir_Set_Disk_Transfer_Address( Var DMA_Buffer );              *)
(*                                                                      *)
(*           DMA_Buffer --- direct memory access buffer                 *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        MsDos                                                         *)
(*                                                                      *)

Var
   Dir_Reg: RegPack;

Begin (* Dir_Set_Disk_Transfer_Address *)

   Dir_Reg.Ax := $1A00;
   Dir_Reg.Ds := SEG( DMA_Buffer );
   Dir_Reg.Dx := OFS( DMA_Buffer );

   MsDos( Dir_Reg );

End   (* Dir_Set_Disk_Transfer_Address *);

(*----------------------------------------------------------------------*)
(*            Dir_Set_Default_Drive --- Set Default Drive               *)
(*----------------------------------------------------------------------*)

Procedure Dir_Set_Default_Drive( Drive: Char );

(*                                                                      *)
(*     Procedure:  Dir_Set_Default_Drive                                *)
(*                                                                      *)
(*     Purpose:    Sets default drive for disk I/O                      *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Dir_Set_Default_Drive( Drive : Char );                        *)
(*                                                                      *)
(*           Drive --- letter of default drive                          *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        MsDos                                                         *)
(*                                                                      *)

Var
   Dir_Reg: RegPack;

Begin  (* Dir_Set_Default_Drive *)

   Dir_Reg.Ah := $0E;
   Dir_Reg.Dl := ORD( UpCase( Drive ) ) - ORD( 'A' );

   MsDos( Dir_Reg );

End   (* Dir_Set_Default_Drive *);


(*----------------------------------------------------------------------*)
(*            Dir_Get_Default_Drive --- Get Default Drive               *)
(*----------------------------------------------------------------------*)

Function Dir_Get_Default_Drive: Char;

(*                                                                      *)
(*     Function:  Dir_Get_Default_Drive                                 *)
(*                                                                      *)
(*     Purpose:   Gets default drive for disk I/O                       *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Def_Drive := Dir_Get_Default_Drive : Char;                    *)
(*                                                                      *)
(*           Def_Drive --- Letter of default drive                      *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        MsDos                                                         *)
(*                                                                      *)

Var
   Dir_Reg: RegPack;

Begin  (* Dir_Get_Default_Drive *)

   Dir_Reg.Ah := $19;

   MsDos( Dir_Reg );

   Dir_Get_Default_Drive := CHR( Dir_Reg.Al + ORD( 'A' ) );

End   (* Dir_Get_Default_Drive *);

(*----------------------------------------------------------------------*)
(*            Dir_Delete_File --- Delete A File                         *)
(*----------------------------------------------------------------------*)

Function Dir_Delete_File( File_Name : AnyStr ) : Integer;

(*                                                                      *)
(*     Function:  Dir_Delete_File                                       *)
(*                                                                      *)
(*     Purpose:   Deletes file in current directory                     *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Ideleted := Dir_Delete_File( File_Name : AnyStr ): Integer;   *)
(*                                                                      *)
(*           File_Name --- name of file to delete                       *)
(*           Ideleted  --- 0 if delete goes OK, else MSDOS return code  *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        MsDos                                                         *)
(*        Convert_String_To_AsciiZ                                      *)
(*                                                                      *)

Var
   Dir_Reg: RegPack;

Begin  (* Dir_Delete_File *)

   Convert_String_To_AsciiZ( File_Name );

   Dir_Reg.Ah := $41;
   Dir_Reg.Ds := SEG( File_Name[1] );
   Dir_Reg.Dx := OFS( File_Name[1] );

   MsDos( Dir_Reg );

   If ( Carry_Flag AND Dir_Reg.Flags ) = 0 Then
      Dir_Delete_File := 0
   Else
      Dir_Delete_File := Dir_Reg.Ax;

End   (* Dir_Delete_File *);

(*----------------------------------------------------------------------*)
(*            Dir_Count_Drives --- Count number of drives in system     *)
(*----------------------------------------------------------------------*)

Function Dir_Count_Drives : Integer;

(*                                                                      *)
(*     Function:  Dir_Count_Drives                                      *)
(*                                                                      *)
(*     Purpose:   Finds number of installed DOS drives                  *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        ndrives := Dir_Count_Drives : Integer;                        *)
(*                                                                      *)
(*           ndrives --- number of drives in system                     *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        MsDos                                                         *)
(*                                                                      *)

Var
   Dir_Reg: RegPack;

Begin  (* Dir_Count_Drives *)

   Dir_Reg.Ah := $19;

   MsDos( Dir_Reg );

   Dir_Reg.Ah := $0E;
   Dir_Reg.Dl := Dir_Reg.Al;

   MsDos( Dir_Reg );

   Dir_Count_Drives := Dir_Reg.Al;

End   (* Dir_Count_Drives *);


(*----------------------------------------------------------------------*)
(*            Dir_Convert_Time --- Convert directory creation time      *)
(*----------------------------------------------------------------------*)

Procedure Dir_Convert_Time ( Time : Integer; Var S_Time : AnyStr );

(*                                                                      *)
(*     Procedure: Dir_Convert_Time                                      *)
(*                                                                      *)
(*     Purpose:   Convert creation time from directory to characters.   *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Dir_Convert_Time( Time       : Integer;                       *)
(*                          Var S_Time : AnyStr ) : Integer;            *)
(*                                                                      *)
(*           Time   --- time as read from directory                     *)
(*           S_Time --- converted time in hh:mm:ss                      *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        STR                                                           *)
(*                                                                      *)

Var
   HH : String[2];
   MM : String[2];
   SS : String[2];

Begin (* Dir_Convert_Time *)

   STR( ( Time SHR 11 ):2 , HH );
   If HH[1] = ' ' Then HH[1] := '0';

   STR( ( ( Time AND $07E0 ) SHR 5 ):2 , MM );
   If MM[1] = ' ' Then MM[1] := '0';

   STR( ( Time AND $001F ):2 , SS );
   If SS[1] = ' ' Then SS[1] := '0';

   S_Time := HH + ':' + MM + ':' + SS;

End  (* Dir_Convert_Time *);

(*----------------------------------------------------------------------*)
(*            Dir_Convert_Date --- Convert directory creation date      *)
(*----------------------------------------------------------------------*)

Procedure Dir_Convert_Date ( Date : Integer; Var S_Date : AnyStr );

(*                                                                      *)
(*     Procedure: Dir_Convert_Date                                      *)
(*                                                                      *)
(*     Purpose:   Convert creation date from directory to characters.   *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Dir_Convert_Date( Date       : Integer;                       *)
(*                          Var S_Date : AnyStr ) : Integer;            *)
(*                                                                      *)
(*           Date   --- date as read from directory                     *)
(*           S_Date --- converted date in yy/mm/dd                      *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        STR                                                           *)
(*                                                                      *)

Var
   YY : String[2];
   MM : String[2];
   DD : String[2];

Begin (* Dir_Convert_Date *)

   STR( ( 80 + ( Date SHR 9 ) ) : 2 , YY );

   STR( ( ( Date AND $01E0 ) SHR 5 ):2 , MM );
   If MM[1] = ' ' Then MM[1] := '0';

   STR( ( Date AND $001F ):2 , DD );
   If DD[1] = ' ' Then DD[1] := '0';

   S_Date := YY + '/' + MM + '/' + DD;

End  (* Dir_Convert_Date *);

(*----------------------------------------------------------------------*)
(*   Dir_Find_First_File --- Find First File Matching Given Specs       *)
(*----------------------------------------------------------------------*)

Function Dir_Find_First_File(     File_Pattern: AnyStr;
                              Var First_File  : Directory_Record  ):
                              Integer;

(*                                                                      *)
(*     Function:   Dir_Find_First_File                                  *)
(*                                                                      *)
(*     Purpose:    Find first file in directory matching specs          *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Iok := Dir_Find_First_File(     File_Pattern: AnyStr;         *)
(*                                    Var First_File  :                 *)
(*                                        Directory_Record ): Integer;  *)
(*                                                                      *)
(*           File_Pattern --- File pattern to look for.                 *)
(*           First_File   --- First file matching specs.                *)
(*           Iok          --- 0 if file found, else MsDos return code.  *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        Dir_Set_Disk_Transfer_Address                                 *)
(*        MsDos                                                         *)
(*                                                                      *)
(*     Remarks:                                                         *)
(*                                                                      *)
(*        The file pattern can be any standard MSDOS file pattern,      *)
(*        including wildcards.  For a complete directory list, enter    *)
(*        '*.*' as the pattern.   Use routine 'Dir_Find_Next_File'      *)
(*        to get the remaining files.                                   *)
(*                                                                      *)

Var
   Dir_Reg: RegPack;

Begin (* Find_First_File *)

   Dir_Set_Disk_Transfer_Address( First_File );

   Convert_String_To_AsciiZ( File_Pattern );

   Dir_Reg.Ds := SEG( File_Pattern[1] );
   Dir_Reg.Dx := OFS( File_Pattern[1] );
   Dir_Reg.Ax := $4E00;
   Dir_Reg.Cx := $FF;

   MsDos( Dir_Reg );

   If ( Carry_Flag AND Dir_Reg.Flags ) = 0 Then
      Dir_Find_First_File := 0
   Else
      Dir_Find_First_File := Dir_Reg.Ax;

End   (* Find_First_File *);


(*----------------------------------------------------------------------*)
(*     Dir_Find_Next_File  --- Find Next File Matching Given Specs      *)
(*----------------------------------------------------------------------*)

Function Dir_Find_Next_File ( Var Next_File : Directory_Record ) : Integer;

(*                                                                      *)
(*     Function:   Dir_Find_Next_File                                   *)
(*                                                                      *)
(*     Purpose:    Finds next file in directory matching specs          *)
(*                                                                      *)
(*     Calling Sequence:                                                *)
(*                                                                      *)
(*        Iok := Dir_Find_Next_File ( Var Next_File :                   *)
(*                                        Directory_Record ) : Integer; *)
(*                                                                      *)
(*           Next_File    --- Next file matching specs.                 *)
(*           Iok          --- Returned as 0 if file found, else MsDos   *)
(*                            return code indicating error.             *)
(*                                                                      *)
(*     Calls:                                                           *)
(*                                                                      *)
(*        MsDos                                                         *)
(*        Dir_Set_Disk_Transfer_Address                                 *)
(*                                                                      *)

Var
   Dir_Reg : RegPack;

Begin (* Find_Next_File  *)

   Dir_Set_Disk_Transfer_Address( Next_File );

   Dir_Reg.Ax := $4F00;

   MsDos( Dir_Reg );

   If ( Carry_Flag AND Dir_Reg.Flags ) = 0 Then
      Dir_Find_Next_File := 0
   Else
      Dir_Find_Next_File := Dir_Reg.Ax;

End   (* Find_Next_File  *);