'===========================================================================
' Subject: SOME COLLECTED FILE ROUTINES       Date: 09-14-97 (21:42)       
'  Author: Tommi Utriainen                    Code: QB, PDS                
'  Origin: tomppa@pcuf.fi                   Packet: DOS.ABC
'===========================================================================
'
'               Some fileroutines v 1.0 collected by TMP Software 1994
'                                               Tommi Utriainen
'
' ** To work with QB, Replace SSEG with VARSEG, and CHDRIVE with CHDIR


DECLARE FUNCTION ShowFileAttributes$ (Attributes%)
DECLARE FUNCTION GetFileSize& (File$)
DECLARE FUNCTION GetFileAttr% (NameFile$)
DECLARE FUNCTION GetFileDate$ (File$)
DECLARE FUNCTION GetFirstFile$ (FileSpec$, attr%)
DECLARE FUNCTION GetNextFile$ ()
DECLARE FUNCTION CrlfErase$ (instring$)
DECLARE FUNCTION exename$ ()
DECLARE FUNCTION freediskspace& (dr$)
DECLARE FUNCTION llcase$ (s$)
DECLARE FUNCTION strtok$ (Srce$, Delim$)
DECLARE FUNCTION timeslices% ()
DECLARE FUNCTION uucase$ (s$)
DEFINT A-Z
' $INCLUDE: 'qbx.bi'    ' or qb.bi for QB users.

REDIM Sislu$(200)


CLS


PRINT GetFirstFile$("*.*", 63) '; TAB(20); GetFileDate$("*.*")

T = 1
DO
Sislu$(T) = GetNextFile$
T = T + 1
'REDIM PRESERVE Sislu$(T + 1)
LOOP UNTIL Sislu$(T - 1) = ""
T = T - 1


FOR a = 1 TO T - 1
PRINT Sislu$(a); TAB(20); GetFileDate$(Sislu$(a)); " "; ShowFileAttributes$(GetFileAttr%(Sislu$(a))); " "; GetFileSize&(Sislu$(a))
NEXT
PRINT "Directory contais"; T; "files"

'PRINT exename$
'PRINT freediskspace&("E")

REM $DYNAMIC
FUNCTION CrlfErase$ (instring$)

   ' Look for line-feed characters and
   ' remove any found:
   DO
	  LnFd = INSTR(instring$, CHR$(10))

	  IF LnFd THEN
   instring$ = LEFT$(instring$, LnFd - 1) + MID$(instring$, LnFd + 1)
	  END IF

   LOOP WHILE LnFd

   DO
	  ENTER = INSTR(instring$, CHR$(13)) ' enter poisto
	  IF ENTER THEN
   instring$ = LEFT$(instring$, ENTER - 1) + MID$(instring$, ENTER + 1)
	  END IF
   LOOP WHILE ENTER

CrlfErase$ = instring$



END FUNCTION

FUNCTION exename$
DIM regs AS RegTypeX
tmp$ = ""
 ' returns exe name and path

regs.ax = &H6200
CALL InterruptX(&H21, regs, regs)

DEF SEG = regs.bx
DEF SEG = PEEK(&H2C) + PEEK(&H2D) * 256

byte = 0
DO
 IF PEEK(byte) = 0 THEN
  IF PEEK(byte + 1) = 0 THEN
   byte = byte + 2
   EXIT DO
  END IF
 END IF
   byte = byte + 1
LOOP
IF PEEK(byte) = 1 THEN
 byte = byte + 2
 DO WHILE PEEK(byte)
 tmp$ = tmp$ + CHR$(PEEK(byte))
 byte = byte + 1
 LOOP
 exename$ = tmp$
END IF

END FUNCTION

DEFSNG A-Z
FUNCTION freediskspace& (dr$)
'Define registers.
DIM regs AS RegType

Curd$ = CURDIR$
CHDRIVE dr$
 
'Get current drive info; set up input and do system call.
regs.ax = &H1900
CALL Interrupt(&H21, regs, regs)
 
'Convert drive info to readable form.
Drive$ = CHR$((regs.ax AND &HFF) + 65) + ":"
 
'Get disk free space; set up input values and do system call.
regs.ax = &H3600
regs.dx = ASC(UCASE$(Drive$)) - 64
CALL Interrupt(&H21, regs, regs)
 
'Decipher the results.
SectorsInCluster = regs.ax
BytesInSector = regs.cx
IF regs.dx >= 0 THEN
		ClustersInDrive = regs.dx
ELSE
		ClustersInDrive = regs.dx + 65536
END IF
IF regs.bx >= 0 THEN
		ClustersAvailable = regs.bx
ELSE
		ClustersAvailable = regx.bx + 65536
END IF

CHDRIVE Curd$

freediskspace& = ClustersAvailable * SectorsInCluster * BytesInSector
END FUNCTION

REM $STATIC
DEFINT A-Z
FUNCTION GetFileAttr% (FileN$)

'
' return file type
'
'  Attr%
'
'  0 files only
'  1 read only
'  2 hidden
'  4 system
'  8 volume label
'  16 subdirectory name / file(?)
'  32 archive


DIM InRegs AS RegTypeX, OutRegs AS RegTypeX

		' Operation% = 0 takes Attributes%
		'                = 1 set

		Attributes% = 0
		Operation% = 0

		InRegs.cx = Attributes%
		InRegs.ax = &H4300 + Operation%

		 File$ = FileN$ + CHR$(0)

		 InRegs.ds = SSEG(File$) ' Load DS:DX with
		 InRegs.dx = SADD(File$) ' address of Spec$
		 CALL InterruptX(&H21, InRegs, OutRegs) ' CALL DOS
		GetFileAttr% = OutRegs.cx

END FUNCTION

REM $DYNAMIC
DEFSNG A-Z
FUNCTION GetFileDate$ (File$)

DIM InRegs AS RegTypeX, OutRegs AS RegTypeX

' Get [DTA] address
InRegs.ax = &H2F00
CALL InterruptX(&H21, InRegs, OutRegs)
dtasegment% = OutRegs.es
dtaoffset% = OutRegs.bx

NameFile$ = File$ + CHR$(0)
InRegs.ds = SSEG(NameFile$)
InRegs.dx = SADD(NameFile$)
InRegs.cx = 63
InRegs.ax = &H4E00
CALL InterruptX(&H21, InRegs, OutRegs)

IF OutRegs.flags AND 1 THEN
		GetFileDate$ = ""
		EXIT FUNCTION
END IF

DEF SEG = dtasegment%

matchoffset% = dtaoffset% + &H16

kello1$ = CHR$(PEEK(matchoffset% + 0))
kello2$ = CHR$(PEEK(matchoffset% + 1))
pvm1$ = CHR$(PEEK(matchoffset% + 2))
pvm2$ = CHR$(PEEK(matchoffset% + 3))

'matchoffset% = dtaoffset% + 29
'match$ = ""
'FOR i% = 1 TO 13
'        newchar$ = CHR$(PEEK(matchoffset% + i%))
'        IF newchar$ = CHR$(0) THEN EXIT FOR
'        match$ = match$ + newchar$
'NEXT

DEF SEG

aika% = CVI(kello1$ + kello2$)
sek = 0
IF (aika% AND 1) = 1 THEN sek = sek + 1           '0
IF (aika% AND 2) = 2 THEN sek = sek + 2           '1
IF (aika% AND 4) = 4 THEN sek = sek + 4           '2
IF (aika% AND 8) = 8 THEN sek = sek + 8           '3
IF (aika% AND 16) = 16 THEN sek = sek + 16        '4
sek = sek * 2
min = 0
IF (aika% AND 32) = 32 THEN min = min + 1
IF (aika% AND 64) = 64 THEN min = min + 2
IF (aika% AND 128) = 128 THEN min = min + 4
IF (aika% AND 256) = 256 THEN min = min + 8
IF (aika% AND 512) = 512 THEN min = min + 16
IF (aika% AND 1024) = 1024 THEN min = min + 32
hh = 0
IF (aika% AND 2048) = 2048 THEN hh = hh + 1
IF (aika% AND 4096) = 4096 THEN hh = hh + 2
IF (aika% AND 8192) = 8192 THEN hh = hh + 4
IF (aika% AND 16384) = 16384 THEN hh = hh + 8
IF (aika% AND 32768) = 32768 THEN hh = hh + 16
' P„iv„
pvm% = CVI(pvm1$ + pvm2$)
pv = 0
IF (pvm% AND 1) = 1 THEN pv = pv + 1
IF (pvm% AND 2) = 2 THEN pv = pv + 2
IF (pvm% AND 4) = 4 THEN pv = pv + 4
IF (pvm% AND 8) = 8 THEN pv = pv + 8
IF (pvm% AND 16) = 16 THEN pv = pv + 16
' Kuukausi
kk = 0
IF (pvm% AND 32) = 32 THEN kk = kk + 1
IF (pvm% AND 64) = 64 THEN kk = kk + 2
IF (pvm% AND 128) = 128 THEN kk = kk + 4
IF (pvm% AND 256) = 256 THEN kk = kk + 8
' Vuosi
vv = 0
IF (pvm% AND 512) = 512 THEN vv = vv + 1
IF (pvm% AND 1024) = 1024 THEN vv = vv + 2
IF (pvm% AND 2048) = 2048 THEN vv = vv + 4
IF (pvm% AND 4096) = 4096 THEN vv = vv + 8
IF (pvm% AND 8192) = 8192 THEN vv = vv + 16
IF (pvm% AND 16384) = 16384 THEN vv = vv + 32
IF (pvm% AND 32768) = 32768 THEN vv = vv + 64
vv = 1980 + vv

aika$ = STRING$(2 - LEN(LTRIM$(STR$(hh))), "0") + LTRIM$(STR$(hh)) + ":" + STRING$(2 - LEN(LTRIM$(STR$(min))), "0") + LTRIM$(STR$(min)) + "." + STRING$(2 - LEN(LTRIM$(STR$(sek))), "0") + LTRIM$(STR$(sek))

pvm$ = STRING$(2 - LEN(LTRIM$(STR$(pv))), "0") + LTRIM$(STR$(pv)) + "." + STRING$(2 - LEN(LTRIM$(STR$(kk))), "0") + LTRIM$(STR$(kk)) + "." + RIGHT$(STR$(vv), 2)

GetFileDate$ = pvm$ + " " + aika$

END FUNCTION

REM $STATIC
DEFINT A-Z
FUNCTION GetFileSize& (File$)


'
' Palauttaa tiedoston koon:
'


DIM InRegs AS RegTypeX, OutRegs AS RegTypeX

' Get [DTA] address
InRegs.ax = &H2F00
CALL InterruptX(&H21, InRegs, OutRegs)
dtasegment% = OutRegs.es
dtaoffset% = OutRegs.bx

NameFile$ = File$ + CHR$(0)
InRegs.ds = SSEG(NameFile$)
InRegs.dx = SADD(NameFile$)
InRegs.cx = 63
InRegs.ax = &H4E00
CALL InterruptX(&H21, InRegs, OutRegs)

IF OutRegs.flags AND 1 THEN
		GetFileSize& = -1
		EXIT FUNCTION
END IF

DEF SEG = dtasegment%

matchoffset% = dtaoffset% + 27

attr% = PEEK(dtaoffset% + 21)

Sz1$ = CHR$(PEEK(matchoffset% + 0)) ' low word
Sz2$ = CHR$(PEEK(matchoffset% + 1))
Sz3$ = CHR$(PEEK(matchoffset% + 2)) ' high word    - miten yhdistet„„n?
Sz4$ = CHR$(PEEK(matchoffset% + 3))

DEF SEG

' Palauttaa nyt attribuutin

GetFileSize& = attr% '

'GetFileSize& = CVL(Sz3$ + Sz4$ + Sz1$ + Sz2$)



END FUNCTION

DEFSNG A-Z
FUNCTION GetFirstFile$ (FileSpec$, attr%)

'  Attr%
'
'  0 pelk„t filet
'  1 read only
'  2 hidden
'  4 system
'  8 volume label
'  16 subdirectory name / file(?)
'  32 archive



DIM inregsx AS RegTypeX, outregsx AS RegTypeX

inregsx.ax = &H2F00

CALL InterruptX(&H21, inregsx, outregsx)

dtasegment% = outregsx.es
dtaoffset% = outregsx.bx

NameFile$ = FileSpec$ + CHR$(0)

inregsx.ds = SSEG(NameFile$)
inregsx.dx = SADD(NameFile$)
inregsx.cx = attr%
inregsx.ax = &H4E00

CALL InterruptX(&H21, inregsx, outregsx)

IF outregsx.flags AND 1 THEN
		GetFirstFile$ = ""
		EXIT FUNCTION
END IF

DEF SEG = dtasegment%
matchoffset% = dtaoffset% + 29
match$ = ""
FOR i = 1 TO 13
newchar$ = CHR$(PEEK(matchoffset% + i))
IF newchar$ = CHR$(0) THEN EXIT FOR
match$ = match$ + newchar$
NEXT i

DEF SEG
GetFirstFile$ = match$





END FUNCTION

FUNCTION GetNextFile$

DIM inregsx AS RegTypeX, outregsx AS RegTypeX

inregsx.ax = &H2F00

CALL InterruptX(&H21, inregsx, outregsx)

dtasegment% = outregsx.es
dtaoffset% = outregsx.bx

inregsx.ax = &H4F00
CALL InterruptX(&H21, inregsx, outregsx)

IF outregsx.flags AND 1 THEN
		GetNextFile$ = ""
		EXIT FUNCTION
END IF

DEF SEG = dtasegment%
matchoffset% = dtaoffset% + 29
match$ = ""
FOR i = 1 TO 13
newchar$ = CHR$(PEEK(matchoffset% + i))
 IF newchar$ = CHR$(0) THEN EXIT FOR
match$ = match$ + newchar$
NEXT i

DEF SEG
GetNextFile$ = match$




END FUNCTION

REM $DYNAMIC
DEFINT A-X
FUNCTION llcase$ (s$)

3451 IF INSTR(s$, "™") THEN MID$(s$, INSTR(s$, "™"), 1) = "”": GOTO 3451
3452 IF INSTR(s$, "Ž") THEN MID$(s$, INSTR(s$, "Ž"), 1) = "„": GOTO 3452
3453 IF INSTR(s$, "") THEN MID$(s$, INSTR(s$, ""), 1) = "”": GOTO 3453

llcase$ = LCASE$(s$)

END FUNCTION

REM $STATIC
DEFINT Y-Z
SUB MonoMem2Scr (x%) STATIC


IF x% = 0 THEN
 REDIM MemPic(80 * 25 * 2)
DEF SEG = &HB000
		FOR T% = 0 TO 80 * 25 * 2
		MemPic(T%) = PEEK(T%)
		NEXT
DEF SEG
END IF
IF x% = 1 THEN
DEF SEG = &HB000
		FOR T% = 0 TO 80 * 25 * 2
		POKE T%, MemPic(T%)
		NEXT
DEF SEG
		ERASE MemPic
END IF


END SUB

FUNCTION ShowFileAttributes$ (Attributes%)

lin$ = ""
		IF Attributes% = 0 THEN
				lin$ = "None"
		END IF
		IF (Attributes% AND 1) = 1 THEN
				lin$ = lin$ + "Read-only  "
		END IF
		IF (Attributes% AND 2) = 2 THEN
				lin$ = lin$ + "Hidden  "
		END IF
		IF (Attributes% AND 4) = 4 THEN
				lin$ = lin$ + "System  "
		END IF
		IF (Attributes% AND 8) = 8 THEN
				lin$ = lin$ + "Volume label  "
		END IF
		IF (Attributes% AND 16) = 16 THEN
				lin$ = lin$ + "<DIR>  "
		END IF
		IF (Attributes% AND 32) = 32 THEN
				lin$ = lin$ + "Archive  "
		END IF
ShowFileAttributes$ = lin$
END FUNCTION

REM $DYNAMIC
FUNCTION strtok$ (Srce$, Delim$)
STATIC Start%, SaveStr$

   ' If first call, make a copy of the string.
   IF Srce$ <> "" THEN
	  Start% = 1: SaveStr$ = Srce$
   END IF

   BegPos% = Start%: Ln% = LEN(SaveStr$)
   ' Look for start of a token (character that isn't delimiter).
   WHILE BegPos% <= Ln% AND INSTR(Delim$, MID$(SaveStr$, BegPos%, 1)) <> 0
	  BegPos% = BegPos% + 1
   WEND
   ' Test for token start found.
   IF BegPos% > Ln% THEN
	  strtok$ = "": EXIT FUNCTION
   END IF
   ' Find the end of the token.
   EndPos% = BegPos%
   WHILE EndPos% <= Ln% AND INSTR(Delim$, MID$(SaveStr$, EndPos%, 1)) = 0
	  EndPos% = EndPos% + 1
   WEND
   strtok$ = MID$(SaveStr$, BegPos%, EndPos% - BegPos%)
   ' Set starting point for search for next token.
   Start% = EndPos%

END FUNCTION

FUNCTION timeslices%

DIM regs AS RegType

regs.ax = &H1680
'CALL interruptx(&H2F, inregsx, outregsx)
CALL Interrupt(&H2F, regs, regs)

IF (regs.ax AND 255) = 0 THEN
		timeslices = TRUE
		ELSE
		timeslices = FALSE
END IF
		
END FUNCTION

FUNCTION uucase$ (s$)

7451 IF INSTR(s$, "”") THEN MID$(s$, INSTR(s$, "”"), 1) = "™": GOTO 7451
7452 IF INSTR(s$, "„") THEN MID$(s$, INSTR(s$, "„"), 1) = "Ž": GOTO 7452
7453 IF INSTR(s$, "†") THEN MID$(s$, INSTR(s$, "†"), 1) = "": GOTO 7453

uucase$ = UCASE$(s$)

END FUNCTION