Category : BASIC Source Code
Archive   : QBFAQR01.ZIP
Filename : DOS.BAS

DECLARE SUB MSDOS ()
DECLARE SUB MSDOSX ()
DECLARE SUB GETDTA (DTA.SEG%, DTA.OFS%)
DECLARE SUB OPENFILE (F$, OMODE%, FHANDLE%)
DECLARE SUB CLOSEFILE (FHANDLE%)
DECLARE SUB WRITEFILE (FHANDLE%, BUF.SEG!, BUF.ADR!, BYTES%)
DECLARE SUB LSEEK (FHANDLE%, SMODE%, FLEN!)
DECLARE SUB GETFIRST (SEARCH$, ATTRIB%)
DECLARE SUB GETNEXT (NERR%)
' *********************************************************************
' * *
' * PROGRAM: DOS *
' * *
' * DESCRIPTION: DOS FUNCTIONS FOR QUICK BASIC *
' * *
' * *
' * 08/05/87 JOHN M. TAL *
' * ROLLINS MEDICAL/DENTAL SYSTEMS *
' * SOUTHFIELD, MI *
' * *
' * *
' *********************************************************************

' LAST EDIT: 08/05/87 PROGRAMMER: JMT

'$INCLUDE: 'QB.BI'

OPTION BASE 1
DEFDBL A-Z
DIM inreg%(10), outreg%(10)
COMMON SHARED inreg%(), outreg%(), ax%, bx%, cx%, dx%, DP%, si%, di%, FL%, ds%, es%

ax% = 1
bx% = 2
cx% = 3
dx% = 4
bp% = 5
si% = 6
di% = 7
FL% = 8
ds% = 9
es% = 10

DEF FNWORD% (N!)
' --------------------------------------------
' CONVERT A SINGLE PRECISION NUMBER 0 - 65535
' INTO EQUIVELANT WORD/INTEGER(%) FOR USE BY
' CALL INT86
' --------------------------------------------

IF N! > 32767 THEN
FNWORD% = N! - 65536
ELSE
FNWORD% = N!
END IF

END DEF ' FNWORD%

DEF FNWORD! (N%)
' --------------------------------------------
' CONVERT A WORD INTO SINGLE PRECISION
' NUMBER 0 - 65535
' --------------------------------------------

IF N% < 0 THEN
FNWORD! = N% + 32767
ELSE
FNWORD! = N%
END IF
END DEF ' FNWORD!

DEF FNSMOD% (N!, M!)
WHILE N! > M!
N! = N! - M!
WEND
FNSMOD% = FNWORD%(N!)
END DEF ' FNSMOD%


' &H00 PROGRAM TERMINATE
' &H01 KEYBOARD INPUT
' &H02 DISPLAY OUTPUT
' &H03 AUXILIARY INPUT
' &H04 AUXILIARY OUTPUT
' &H05 PRINTER OUTPUT
' &H06 DIRECT CONSOLE I/O
' &H07 DIRECT CONSOLE INPUT WITHOUT ECHO
' &H08 CONSOLE INPUT WITHOUT ECHO
' &H09 PRINT (DISPLAY) STRING
' &H00 PROGRAM TERMINATE
' &H01 KEYBOARD INPUT
' &H02 DISPLAY LIFEUP
' &H0A BUFFERED KEYBOARD INPUT
' &H0B CHECK STANDARD INPUT STATUS
' &H0C CLEAR KEYBOARD BUFFER AND INVOKE A KEYBOARD FUNCTION
' &H0D DISK RESET

' &H0F FCB OPEN FILE
' &H10 FCB CLOSE FILE
' &H11 FCB SEARCH FIRST FILE
' &H12 FCB SEARCH NEXT FILE
' &H13 FCB DELETE FILE
' &H14 FCB SEQUENTIAL READ
' &H15 FCB SEQUENTIAL WRITE
' &H16 FCB CREATE FILE
' &H17 FCB RENAME FILE

' &H10 FCB CLOSE FILE
' &H11 FCB SEARCH FIRS15 NDX
' &H1A SET DTA
' &H1B ALLOCATION TABKE INFORMATION / DEFAULT DRIVE
' &H1C ALLOCATION TABLE INFORMATION FOR SPECIFIC DEVICE / DRIVE INFO
' &H21 RANDOM READ
' &H22 RANDOM WRITE
' &H23 FCB FILE SIZE
' &H24 FCB SET RELATIVE RECORD FIELD
' &H25 SET INTERRUPT VECTOR
' &H26 CREATE NEW PROGRAM SEGMENT
' &H27 FCB RANDOM BLOCK READ
' &H28 FCB RANDOM BLOCK WRITE
' &H29 FCB PARSE FILENAME
' &H2A GET DATE
' &H2B SET DATE
' &H2C GET TIME
' &H2D SET TIME

' &H31 TERMINATE AND STAY RESIDENT
' &H33 CONTROL BREAK CHECK
' &H35 GET VECTOR

' &H38 COUNTRY DEPENDENT INFORMATION

' &H44 I/O CONTROL FOR DEVICES (IOCTL)
' &H45 DUPLICATE A FILE HANDLE (DUP)
' &H46 FORCE A DUPLICATE OF A HANDLE (FORCDUP)

' &H48 ALLOCATE MEMORY
' &H49 FREE ALLOCATED MEMORY
' &H50 MODIFY ALLOCATED MEMORY BLOCKS (SETBLOCK)
' &H4B LOAD OR EXECUTE A PROGRAM (EXEC)
' &H4C TERMINATE A PROCESS (EXIT)
' &H4D GET RETURN CODE OF A SUBPROCESS (WAIT)

' &H56 RENAME A FILE
' &H57 GET/SET A FILES DATE AND TIME

' &H5A CREATE UNIQUE FILE
' &H5B CREATE NEW FILE
' &H5C LOCK/UNLOCK FILE ACCESS

' --- NETWORK SUPPORT ---
' &H5E00 GET MACHINE NAME
' &H5E02 SET PRINTER SETUP
' &H5E03 GET PRINTER SETUP
' &H5F02 GET REDIRECTION LIST ENTRY
' &H5F03 REDIRECT DEVICE
' &H5F04 CANCEL REDIRECTION

' &H62 GET PROGRAM SEGMENT PREFIX ADDRESS (PSP)
' &H65 GET EXTENDED COUNTRY INFORMATION
' &H66 GET/SET GLOBAL CODE PAGE (CHARACTER SET)
' &H67 SET HANDLE COUNT
' &H68 COMMIT FILE

'**************************************************************************

PRINT

SUB CHMOD (F$, ATTRIB%, FUNC%) STATIC
inreg%(ax%) = &H4300 + FUNC%
F$ = F$ + CHR$(0)
inreg%(dx%) = SADD(F$)
inreg%(ds%) = -1 ' QUICK BASIC'S DATA SEGMENT
inreg%(cx%) = ATTRIB%
CALL MSDOSX
IF (outreg%(FL%) AND 1) = 1 THEN ' CARRY SET = ERROR
RES% = outreg%(ax%)
ELSE
RES% = 0
ATTRIB% = outreg%(cx%) ' ATTRIB RETURNED IF FUNCTION IS GETTING
END IF
END SUB

SUB CHNGDIR (F$, RES%) STATIC
inreg%(ax%) = &H3B00
F$ = F$ + CHR$(0)
inreg%(dx%) = SADD(F$)
inreg%(ds%) = -1 ' QUICK BASIC'S DATA SEGMENT
CALL MSDOSX
IF (outreg%(FL%) AND 1) = 1 THEN ' CARRY SET = ERROR
RES% = outreg%(ax%)
ELSE
RES% = 0
END IF
END SUB

SUB CLOSEFILE (FHANDLE%) STATIC
inreg%(ax%) = &H3E00 ' CLOSE FILE
inreg%(bx%) = FHANDLE%
CALL INT86OLD(&H21, VARPTR(inreg%(ax%)), VARPTR(outreg%(ax%)))
END SUB

SUB CREAT (F$, ATTRIB%) STATIC
inreg%(ax%) = &H3C00
F$ = F$ + CHR$(0)
inreg%(dx%) = SADD(F$)
inreg%(ds%) = -1 ' QUICK BASIC'S DATA SEGMENT
CALL MSDOSX
IF (outreg%(FL%) AND 1) = 1 THEN ' CARRY SET = ERROR
RES% = outreg%(ax%)
ELSE
RES% = 0
END IF
END SUB

SUB CURDRIVE (DRIVE%) STATIC
inreg%(ax%) = &H1900
CALL MSDOS
DRIVE% = outreg%(ax%) MOD 256
END SUB

SUB DIRFILE (FIRST%, SEARCH$, FOUND$) STATIC

' CALL DIRFILE(1,"*.BAS",FOUND$) INITS SEARCH$ AND RETURNS FIRST FOUND$
' CALL DIRFILE(2,"*.BAS",FOUND$) USE ANY VALUE OTHER THAN 1 TO GET NEXT
' ANY CALL CAN RETURN "EOF"
' WHICH MEANS NO MORE FILES
'

FOUND$ = ""
IF FIRST% = 1 THEN
' GET DTA
CALL GETDTA(DTA.SEG%, DTA.OFS%)

' MAKE SURE SET TO BASIC SEGMENTS
DEF SEG

ATTRIB% = 0
CALL GETFIRST(SEARCH$, ATTRIB%)

IF ATTRIB% <> -1 THEN ' NO FILES
DEF SEG = DTA.SEG%
I% = DTA.OFS% + 30
B% = PEEK(I%)
WHILE (I% < DTA.OFS% + 42) AND (B% <> 0)
FOUND$ = FOUND$ + CHR$(B%)
I% = I% + 1
B% = PEEK(I%)
WEND
ELSE
FOUND$ = "EOF"
END IF

ELSE ' NOT FIRST CALL

CALL GETNEXT(NERR%)

IF NERR% = 0 THEN
DEF SEG = DTA.SEG%
I% = DTA.OFS% + 30
B% = PEEK(I%)
WHILE (I% < DTA.OFS% + 42) AND (B% <> 0)
FOUND$ = FOUND$ + CHR$(B%)
I% = I% + 1
B% = PEEK(I%)
WEND

ELSE ' LAST FILE
FOUND$ = "EOF"
END IF


END IF


END SUB

SUB GETCURDIR (BUFFER$, DRIVE%) STATIC
inreg%(ax%) = &H4700
inreg%(si%) = SADD(BUFFER$) ' BUFFER$ = 64 BYTES
inreg%(ds%) = -1 ' QUICK BASICS DATA SEGMENT
inreg%(dx%) = DRIVE%
CALL MSDOSX
IF (outreg%(FL%) AND 1) = 1 THEN ' CARRY SET
DRIVE% = -1
END IF
END SUB

SUB GETDISKFREE (DRIVE%, DFREE!, DMAX!) STATIC
inreg%(ax%) = &H3600
inreg%(dx%) = DRIVE%
CALL MSDOS
AVAIL.CL! = FNWORD!(outreg%(bx%))
CL.DRIVE! = FNWORD!(outreg%(dx%))
BYTE.SEC! = FNWORD!(outreg%(cx%))
SEC.P.CL! = FNWORD!(outreg%(ax%))
IF SEC.P.CL! = &HFFFF THEN ' INVALID DRIVE
DFREE! = -1
DMAX! = -1
ELSE
DFREE! = AVAIL.CL! * SEC.P.CL! * BYTE.SEC!
DMAX! = CL.DRIVE! * SEC.P.CL! * BYTE.SEC!
END IF
END SUB

SUB GETDOSV (MAJOR%, MINOR%) STATIC
inreg%(ax%) = &H3000
CALL MSDOS
MAJOR% = outreg%(ax%) MOD 256
MINOR% = outreg%(ax%) \ 256
END SUB

SUB GETDTA (DTA.SEG%, DTA.OFS%) STATIC

' &H25 SET INTERRU34 NDX FIELD
inreg%(ax%) = &H2F00
CALL MSDOSX
DTA.SEG% = outreg%(es%)
DTA.OFS% = outreg%(bx%)
END SUB

SUB GETFIRST (SEARCH$, ATTRIB%) STATIC
inreg%(ax%) = &H4E00
inreg%(cx%) = ATTRIB% ' ATTRIBUTE
SEARCH$ = SEARCH$ + CHR$(0)
inreg%(dx%) = SADD(SEARCH$)
inreg%(ds%) = -1
CALL MSDOSX
IF (outreg%(FL%) AND 1) = 1 THEN
ATTRIB% = -1
END IF
END SUB

SUB GETNEXT (NERR%) STATIC
inreg%(ax%) = &H4F00
CALL MSDOS
IF (outreg%(FL%) AND 1) = 1 THEN
NERR% = outreg%(ax%)
ELSE
NERR% = 0
END IF
END SUB

SUB GETVERIFY (VER%) STATIC
inreg%(ax%) = &H5400
CALL MSDOS
VER% = outreg%(ax%) MOD 256
END SUB

SUB GETXERROR (EXERR!, ERCLASS%, SUGGACT%, LOCUS%) STATIC
inreg%(ax%) = &H5900
inreg%(bx%) = 0 ' DOS 3.00 TO 3.30
CALL MSDOS
EXERR! = FNWORD!(outreg%(ax%))
ERCLASS% = outreg%(bx%) \ 256
SUGACT% = outreg%(bx%) MOD 256
LOCUS% = outreg%(cx%) \ 256
END SUB

SUB LSEEK (FHANDLE%, SMODE%, FLEN!) STATIC
inreg%(ax%) = &H4200 + SMODE% ' AH = &H42, AL = SMODE%/SEEK MODE
inreg%(cx%) = INT(FLEN! / 65536)
inreg%(dx%) = FNSMOD%(FLEN!, 65536)
inreg%(bx%) = FHANDLE%
CALL INT86OLD(&H21, VARPTR(inreg%(ax%)), VARPTR(outreg%(ax%)))
END SUB

SUB MAKEDIR (F$, RES%) STATIC
inreg%(ax%) = &H3900
F$ = F$ + CHR$(0)
inreg%(dx%) = SADD(F$)
inreg%(ds%) = -1 'QUICK BASIC'S DATA SEGMENT
CALL MSDOSX
IF (outreg%(FL%) AND 1) = 1 THEN ' CARRY SET = ERROR
RES% = outreg%(ax%)
ELSE
RES% = 0
END IF
END SUB

SUB MSDOS STATIC
CALL INT86OLD(&H21, VARPTR(inreg%(ax%)), VARPTR(outreg%(ax%)))
END SUB

SUB MSDOSX STATIC
CALL INT86XOLD(&H21, VARPTR(inreg%(ax%)), VARPTR(outreg%(ax%)))
END SUB

SUB OPENFILE (F$, OMODE%, FHANDLE%) STATIC
inreg%(ax%) = &H3D00 + OMODE% ' AH = &H3D, AL = OMODE%
F$ = F$ + CHR$(0)
inreg%(dx%) = SADD(F$)
inreg%(ds%) = -1
CALL INT86XOLD(&H21, VARPTR(inreg%(ax%)), VARPTR(outreg%(ax%)))
IF (outreg%(FL%) AND 1) <> 1 THEN ' CARRY NOT SET
FHANDLE% = outreg%(ax%)
ELSE
FHANDLE% = -1
END IF
END SUB

SUB READFILE (FHANDLE%, BUF.SEG!, BUF.ADR!, BYTES%) STATIC
' CALL READFILE(FHANDLE%,-1,SADD(BUFFER$),255)
inreg%(ax%) = &H3F00 ' READ FROM FILE
inreg%(bx%) = FHANDLE%
inreg%(ds%) = FNWORD%(BUF.SEG!)
inreg%(dx%) = FNWORD%(BUF.ADR!)
inreg%(cx%) = BYTES%
CALL INT86XOLD(&H21, VARPTR(inreg%(ax%)), VARPTR(outreg%(ax%)))
END SUB

SUB REMDIR (F$, RES%) STATIC
inreg%(ax%) = &H3A00
F$ = F$ + "0"
inreg%(dx%) = SADD(F$)
inreg%(ds%) = -1 'QUICK BASIC'S DATA SEGMENT
CALL MSDOSX
IF (outreg%(FL%) AND 1) = 1 THEN ' CARRY SET = ERROR
RES% = outreg%(ax%)
ELSE
RES% = 0
END IF
END SUB

SUB SELDISK (DRIVE%) STATIC
inreg%(ax%) = &HE00 + DRIVE%
END SUB

' ------ SPECIAL CONGLOMERATES OF ABOVE FUNCTIONS --------
SUB TRUNCFILE (F$, FLEN!) STATIC
' TRUNCATATES FILE (F$) AT LENGTH (FLEN!)
CALL OPENFILE(F$, 2, FHANDLE%)
IF FHANDLE% <> -1 THEN
CALL LSEEK(FHANDLE%, 0, FLEN!)
IF (outreg%(FL%) AND 1) <> 1 THEN ' CARRY NOT SET
CALL WRITEFILE(FHANDLE%, -1, 0, 0)
END IF
CALL CLOSEFILE(FHANDLE%)
END IF
END SUB

SUB UNLINK (F$) STATIC
inreg%(ax%) = &H4100
F$ = F$ + CHR$(0)
inreg%(dx%) = SADD(F$)
inreg%(ds%) = -1 ' QUICK BASIC'S DATA SEGMENT
CALL MSDOSX
IF (outreg%(FL%) AND 1) = 1 THEN ' CARRY SET = ERROR
RES% = outreg%(ax%)
ELSE
RES% = 0
END IF
END SUB

SUB VERIFY (VSWITCH%) STATIC
inreg%(ax%) = &H2E + VSWITCH%
CALL MSDOS
END SUB

SUB WRITEFILE (FHANDLE%, BUF.SEG!, BUF.ADR!, BYTES%) STATIC

inreg%(ax%) = &H4000 ' WRITE TO FILE
inreg%(bx%) = FHANDLE%
inreg%(cx%) = BYTES% ' TRUNCATE FILE
inreg%(dx%) = FNWORD%(BUF.ADR!)
inreg%(ds%) = FNWORD%(BUF.SEG!)
CALL INT86XOLD(&H21, VARPTR(inreg%(ax%)), VARPTR(outreg%(ax%)))
END SUB