(*----------------------------------------------------------------------*) (* PIBDIR.PAS --- MSDOS Directory Routines for Turbo Pascal *) (*----------------------------------------------------------------------*) (* *) (* Author: Philip R. Burns *) (* Version: 1.0 (January,1985) *) (* 2.0 (June,1985) *) (* 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 (312) 882 4145 *) (* or Ron Fox's BBS (312) 940 6496. *) (* *) (* 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 *) (* Dir_Get_Free_Space *) (* Dir_Set_File_Date_And_Time *) (* *) (*----------------------------------------------------------------------*) (*----------------------------------------------------------------------*) (* 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; CONST Dir_Attr_Read_Only = 1; Dir_Attr_Hidden = 2; Dir_Attr_System = 4; Dir_Attr_Volume_Label = 8; Dir_Attr_Subdirectory = 16; Dir_Attr_Archive = 32; (*----------------------------------------------------------------------*) (* 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 ):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 *); (*----------------------------------------------------------------------*) (* Dir_Get_Free_Space --- Find Next File Matching Given Specs *) (*----------------------------------------------------------------------*) FUNCTION Dir_Get_Free_Space ( Drive : CHAR ) : REAL; (*----------------------------------------------------------------------*) (* *) (* Function: Dir_Get_Free_Space *) (* *) (* Purpose: Gets amount of available space on a drive *) (* *) (* Calling Sequence: *) (* *) (* FSpace := Dir_Get_Free_Space ( Drive : CHAR ) : REAL; *) (* *) (* Drive --- Drive letter for which to get free space *) (* Fspace --- Returned number of bytes of free space *) (* *) (* Calls: *) (* *) (* MsDos *) (* *) (* Remarks: *) (* *) (* If the free space can't be found, -1 is returned. *) (* This is most likely to happen if an unformatted or wrongly *) (* formatted disk is to be checked. *) (* *) (*----------------------------------------------------------------------*) VAR Dir_Reg : RegPack; Clusters : REAL; Sectors : REAL; Bytes : REAL; BEGIN (* Dir_Get_Free_Space *) (* Request drive information *) Dir_Reg.DL := ORD(UpCase( Drive )) - ORD('A') + 1; Dir_Reg.AH := $36; MsDos( Dir_Reg ); (* Compute free space *) WITH Dir_Reg DO BEGIN Sectors := AX; Clusters := BX; Bytes := CX; IF AX = $FFFF THEN Dir_Get_Free_Space := -1.0 ELSE Dir_Get_Free_Space := Clusters * Bytes * Sectors; END; END (* Dir_Get_Free_Space *); (*----------------------------------------------------------------------*) (* Dir_Set_File_Date_And_Time -- Set file date and time stamp *) (*----------------------------------------------------------------------*) FUNCTION Dir_Set_File_Date_And_Time( File_Handle: INTEGER; File_Date : INTEGER; File_Time : INTEGER ) : INTEGER; (*----------------------------------------------------------------------*) (* *) (* Function: Dir_Set_File_Date_And_Time *) (* *) (* Purpose: Sets file time and date stamp *) (* *) (* Calling Sequence: *) (* *) (* Error := Dir_Set_File_Date_And_Time( File_Handle: INTEGER; *) (* File_Date : INTEGER; *) (* File_Time : INTEGER ): *) (* INTEGER; *) (* *) (* File_Handle --- File handle of file to set time/date on *) (* File_Date --- File date in packed DOS form *) (* File_Time --- File time in packed DOS form *) (* Error --- DOS error return code *) (* *) (* Calls: *) (* *) (* MsDos *) (* *) (*----------------------------------------------------------------------*) VAR Dir_Reg : RegPack; BEGIN (* Dir_Set_File_Date_And_Time *) (* Set up parameters to DOS call *) WITH Dir_Reg DO BEGIN Cx := File_Time; Dx := File_Date; Bx := File_Handle; Ah := $57; Al := 1; END; (* Set date and time *) MsDos( Dir_Reg ); (* Check for bad return *) IF ( Carry_Flag AND Dir_Reg.Flags ) = 0 THEN Dir_Set_File_Date_And_Time := 0 ELSE Dir_Set_File_Date_And_Time := Dir_Reg.Ax; END (* Dir_Set_File_Date_And_Time *); (*----------------------------------------------------------------------*) (* Dir_Get_File_Date_And_Time -- Get file date and time stamp *) (*----------------------------------------------------------------------*) FUNCTION Dir_Get_File_Date_And_Time( File_Handle: INTEGER; VAR File_Date : INTEGER; VAR File_Time : INTEGER ) : INTEGER; (*----------------------------------------------------------------------*) (* *) (* Function: Dir_Get_File_Date_And_Time *) (* *) (* Purpose: Gets file time and date stamp *) (* *) (* Calling Sequence: *) (* *) (* Error := Dir_Get_File_Date_And_Time( File_Handle: INTEGER;*) (* VAR File_Date : INTEGER;*) (* File_Time : INTEGER *) (* ): INTEGER; *) (* *) (* File_Handle --- File handle of file to set time/date on *) (* File_Date --- File date in packed DOS form *) (* File_Time --- File time in packed DOS form *) (* Error --- DOS error return code *) (* *) (* Calls: *) (* *) (* MsDos *) (* *) (*----------------------------------------------------------------------*) VAR Dir_Reg : RegPack; BEGIN (* Dir_Get_File_Date_And_Time *) (* Set up parameters to DOS call *) WITH Dir_Reg DO BEGIN Bx := File_Handle; Ah := $57; Al := 0; END; (* Get date and time *) MsDos( Dir_Reg ); (* Check for bad return *) IF ( Carry_Flag AND Dir_Reg.Flags ) = 0 THEN BEGIN Dir_Get_File_Date_And_Time := 0; File_Time := Dir_Reg.Cx; File_Date := Dir_Reg.Dx; END ELSE BEGIN Dir_Get_File_Date_And_Time := Dir_Reg.Ax; File_Time := 0; File_Date := 0; END; END (* Dir_Get_File_Date_And_Time *);