'**** HEADER ************************************************************
'DOSLIB.PF3
' Altered to show UK time format - 06/12/94

'This program is the CONFIDENTIAL and PROPRIETARY property of Applied
'Resource Technologies, Inc.  Any unauthorized use, reproduction or
'transfer of this program is strictly prohibited.  This is an unpublished
'work, and is subject to limited distribution and restricted disclosure
'only.  ALL RIGHTS RESERVED.

'Copyright (c) 1990-1991 Applied Resource Technologies, Inc.
'2305 Cedar Springs Road, Suite 150, Dallas, Texas 75201 U.S.A.
'Voice: (214) 855-0449  FAX: (214) 969-7506  BBS: (214) 855-1347

'Description: DOS system level functions

'    Revision: 1.04 (02/25/91)
                    ' enhanced pathname to allow for 63 characters max
                    ' certified SmartWare II V1.5 compatibility
'                   (02/28/91)
                    ' rewrote all DOS function calls to use REAL mode
                    ' conventions for setting buffers and calling
                    ' interrupts, i.e. LOW BUFFER, REALPTR, and REAL
                    ' interrupt.
'**** FUNCTION DECLARATIONS *********************************************
'core
public   setattrib()                 '  sets file attributes
public   getattrib()                 '  gets file attributes
public   diskleft()                  '  remaining drive space in bytes
public   eqlist()                    '  returns type of device installed
public   filedatime()                '  returns file date / time
public   filesize()                  '  returns file size in bytes
public   chkbits()                   '  parses two byte register to 16 bits
public   dosdrive()                  '  returns default DOS disk drive
public   setsysdate()                '  set DOS system date
public   setsystime()                '  set DOS system time

global   dosfparse()                 '  parse file and path

'**** VARIABLE DECLARATIONS *********************************************
'library
public ptstr ptval currlib
'core
'**** CODE **************************************************************

MAIN
local ptpsl
ptpsl = "doslib"
'screen clear box scrheight-3 1 scrheight-3 scrwidth 0 0 no-border
'screen print scrheight-3 1 bginvpleasing bgstandard \
'             "Pop-Tools(tm)"&upper(ptpsl)& \
'             "(Copyright 1990-1991 Applied Resource Technologies, Inc.)"

if currlib = 0
     currlib = ptpsl
     lock module currlib
else
     if chr(32)|lower(currlib)|chr(32) !! chr(32)|ptpsl|chr(32)
          currlib = currlib & ptpsl
     end if
end if
if ptstr = 0
     ptstr = NULL
     lock module ptstr
end if
if ptval = 0
     ptval = BLANK
     lock module ptval
end if
END MAIN


function getattrib(f)
local fbuff cf attr seg off err errstr set dptr
if len(f) > 63
     return (-4)
end if
if dosfparse(f) < 0
     return (-3)
end if
ptstr = NULL
f = str(f)
low buffer fbuff sizeof "64S"
pack fbuff "S"  f
realptr into dptr from dosptr(fbuff)
off = offsetof(dptr)
seg = segmentof(dptr)
setreg(dx,off)
setreg(ds,seg)
setreg(ax,0x4300)
real interrupt 0x21
cf = getreg(flags)
attr = getreg(cx)
err = getreg(ax)
if bitand(cf,2^0) > 0
     errstr = case err (1,-1)(2,-2)(3,-3)(5,-5) else -9
     '-1,"function code invalid"
     '-2,"file not found"
     '-3,"path / file doesn't exist"
     '-5,"attribute can't be changed"
     '-9 "unknown error"
     return (errstr)
else
   if bitand(attr,2^0) > 0
      ptstr = ptstr | "r"
   end if
   if bitand(attr,2^1) > 0
      ptstr = ptstr | "h"
   end if
   if bitand(attr,2^2) > 0
      ptstr = ptstr | "s"
   end if
   if bitand(attr,2^5) > 0
      ptstr = ptstr | "a"
   end if
   if bitand(attr,2^7) > 0
      ptstr = ptstr | "m"
   end if
   return (0)
end if
end function  'getattr()


function setattrib(f,atstr)
local fbuff cf seg off err errstr set i c dptr
if len(f) > 63
     return (-4)
end if
if dosfparse(f) < 0
     return (-3)
end if
errstr = 0
set = 0
for i = 1 to len(atstr)
   c = lower(mid(atstr,i,1))
   set = set + case c ("m",128)("a",32)("s",4)("h",2)("r",1) else 0
end for
f = str(f)
low buffer fbuff sizeof "64S"
pack fbuff "S"  f
realptr into dptr from dosptr(fbuff)
off = offsetof(dptr)
seg = segmentof(dptr)
setreg(ds,seg)
setreg(dx,off)
setreg(cx,set)
setreg(ax,0x4301)
real interrupt 0x21
cf = getreg(flags)
err = getreg(ax)
if bitand(cf,2^0) > 0
     errstr = case err (1,-1)(2,-2)(3,-3)(5,-5) else -9
     '-1,"function code invalid"
     '-2,"file not found"
     '-3,"path / file doesn't exist"
     '-5,"access denied"
     '-9 "unknown error"
     return (errstr)
end if
return (errstr)
end function  'setattr()


function diskleft(d)
local rax rbx rcx rdx rsi rdi rds res bytes hstr r
ptval = BLANK
r = 0
d = lower (left(d,1))
hstr = case d ("a",0x0001)("b",0x0002)("c",0x0003)("d",0x0004)("e",0x0005) \
              ("f",0x0006)("g",0x0007)("h",0x0008)("i",0x0009)("j",0x000A) \
              ("k",0x000B)("l",0x000C)("m",0x000D)("n",0x000E)("o",0x000F) \
              ("p",0x0010)("q",0x0011)("r",0x0012)("s",0x0013)("t",0x0014) \
              ("u",0x0015)("v",0x0016)("w",0x0017)("x",0x0018)("y",0x0019) \
              ("z",0x001A) else -1
if hstr = -1
     r = -1
else
     setreg(ax,0x3600)
     setreg(dx,hstr)
     real interrupt 0x21
     rax = getreg(ax)
     rbx = getreg(bx)
     rcx = getreg(cx)
     rdx = getreg(dx)
     if rax = 65535
          r = -2
     else
          ptval = rax*rbx*rcx
     end if
end if
return (r)
end function   'diskleft()


function eqlist(eq)
local axr bp bit[16] vid fdd mcp rs lp eqlst i r c le
ptstr = NULL

eq = lower(trim(eq))
le =len(eq)
if le = 0
     return (-1)
else
     for c=1 to le
          if "vfspm" ! mid(eq,c,1)
          else
               return (-2)
          end if
     end for
end if
r = 0
real interrupt 0x11
axr = getreg(ax)
for bp = 0 to 15
   if bitand(axr,2^bp) > 0
      bit[bp+1] = "1"
   else
      bit[bp+1] = "0"
   end if
end for
' test video mode
vid = case bit[6]|bit[5] ("00","Unk") \
                         ("01","40C") \
                         ("10","80C") \
                         ("11","80M")
' test presence, and number, of floppy disk drives
fdd = case bit[1]|bit[8]|bit[7] ("100","1") \
                               ("101","2") \
                               ("110","3") \
                               ("111","4") \
                               else "0"
' test for math coprocessor
mcp = case bit[2] ("0","N")("1","Y")
' test for serial ports
rs = case bit[12]|bit[11]|bit[10] ("000","0") \
                                  ("001","1") \
                                  ("010","2") \
                                  ("011","3") \
                                  ("100","4") \
                                  ("101","5") \
                                  ("110","6") \
                                  ("111","7")
' test for parallel ports
lp = case bit[16]|bit[15] ("00","0") \
                          ("01","1") \
                          ("10","2") \
                          ("11","3")
for i = 1 to len(eq)
     eqlst = eqlst & case lower(mid(eq,i,1)) ("v",vid) \
                                             ("s",rs) \
                                             ("p",lp) \
                                             ("m",mcp) \
                                             ("f",fdd) \
                                             else "NULL"
end for
if len(trim(eqlst)) > 0
     ptstr = (trim(eqlst))
else
     r = -3
end if
return (r)
end function  'eqlist()


function filedatime(fname)
local seg off fbuff cf fh dstr tstr dd mm yy hh min dptr
if len(fname) > 63
     return (-4)
end if
if dosfparse(fname) < 0
     return (-1)
end if
ptstr = NULL
low buffer fbuff sizeof "64S"
pack fbuff "S"  fname
realptr into dptr from dosptr(fbuff)
off = offsetof(dptr)
seg = segmentof(dptr)
setreg(ds,seg)
setreg(dx,off)
setreg(ax,0x3D00)
real interrupt 0x21
cf = getreg(flags)
fh = getreg(ax)
if bitand(cf,1)
     return (case fh (2,-1) else -2)
end if
setreg(bx,fh)
setreg(ax,0x5700)
real interrupt 0x21
if bitand(cf,1)
     return (-3)
end if
tstr = getreg(cx)
dstr = getreg(dx)
dd   = right("0"|str(bitand(dstr,31)),2)
mm   = right("0"|str(bitand(dstr,480)/32),2)
yy   = str(int(dstr/512)+80)
min  = right("0"|str(bitand(tstr,2016)/32),2)
hh   = right("0"|str(int(tstr/2048)),2)
setreg(ax,0x3E00)
real interrupt 0x21
if bitand(cf,1)
     return (-4)
end if
' ptstr = (mm|"/"|dd|"/"|yy & hh|":"|min)
ptstr = (dd|"/"|mm|"/"|yy & hh|":"|min)
return (0)
end function   'filedatime()


function filesize(f)
local r fn
if len(f) > 63
     return (-4)
end if
if dosfparse(f) < 0
     return (-1)
end if
ptval = BLANK
r = 0
if file(f)=FALSE
     r = -1
else
     error off
     for fn = 20 to 1 step -1
          clearerror
          fopen f as fn options 12
          r = cerror
          if r = 0
               exit for
          else
               r = -2
          end if
          milli-wait 10
     end for
     error on
end if
if r = 0
     fseek fn EOF
     fposition fn into ptval
     fclose fn
end if
return (r)
end function  'filesize()


function chkbits(g_reg,d)
local bit[1] bp stat lsum hsum lsh hsh binstr strp bitv scns reg r_str r
local fg bg
r = 0
fg = fgstandard
bg = bgstandard
ptstr = NULL
r_str = case g_reg (0,"AX")(1,"BX")(2,"CX")(3,"DX")(4,"SI")(5,"DI")(6,"DS") \
                  (7,"ES")(8,"FLAGS") else NULL
if r_str = NULL
     r = -1
else
     reg = getreg(g_reg)
     if cerror <> 0
          r = -2
     else
          redimension bit[16]
          bp = 0
          strp = 16
          lsum = 0
          hsum = 0
          binstr = ""
          while bp <= 15
             bitv = bitand(reg,2^bp)
             if bitv > 0
                bit[bp+1] = "Y"
             else
                bit[bp+1] = "N"
             end if
             bp=bp+1
             binstr = case bit[bp] ("Y","1")("N","0") | str(binstr)
             strp=strp-1
          end while
          ptstr = binstr
          if d = 1
               hsum=int(reg/256)
               lsum=mod(reg,256)
               lsh = right("0"|str(hex(lsum)),2)
               hsh = right("0"|str(hex(hsum)),2)
               screen save 1 1 scrheight scrwidth scns
               screen clear fg bg no-border
               screen print  2  3 fg bg  "Pop-Tools - chkbits()"
               screen print  4  3 fg bg  "displaying: "&upper(r_str)
               screen print  4 35 fg bg  "Bit 0" & str(bit[1])
               screen print  5 35 fg bg  "Bit 1" & str(bit[2])
               screen print  6 35 fg bg  "Bit 2" & str(bit[3])
               screen print  7 35 fg bg  "Bit 3" & str(bit[4])
               screen print  8 35 fg bg  "Bit 4" & str(bit[5])
               screen print  9 35 fg bg  "Bit 5" & str(bit[6])
               screen print 10 35 fg bg  "Bit 6" & str(bit[7])
               screen print 11 35 fg bg  "Bit 7" & str(bit[8])
               screen print 13  3 fg bg  "Low register sum for"&r_str&"  :"
               screen print 13 35 fg bg  str(lsum) & "("|lsh|"h)"
               screen print 14  3 fg bg  "High register sum for"&r_str&" :"
               screen print 14 35 fg bg  str(hsum) & "("|hsh|"h)"
               screen print 15  3 fg bg  "The 16bit register sum    :"
               screen print 15 35 fg bg  str(reg) & "("|hsh|lsh|"h)"
               screen print 16  3 fg bg  "The binary register sum   :"
               screen print 16 35 fg bg  str(binstr)
               screen print 17 32 fg bg  "msb^              ^lsb"
               screen print 18 34 fg bg  "15              0"
               screen print  4 46 fg bg  "Bit  8" & str(bit[9])
               screen print  5 46 fg bg  "Bit  9" & str(bit[10])
               screen print  6 46 fg bg  "Bit 10" & str(bit[11])
               screen print  7 46 fg bg  "Bit 11" & str(bit[12])
               screen print  8 46 fg bg  "Bit 12" & str(bit[13])
               screen print  9 46 fg bg  "Bit 13" & str(bit[14])
               screen print 10 46 fg bg  "Bit 14" & str(bit[15])
               screen print 11 46 fg bg  "Bit 15" & str(bit[16])
               message "Press any key to exit"
               screen shortrestore scns
          end if
     end if
end if
return (r)
end function   'chkbits()


function dosdrive()
local axr dd r
ptstr = NULL
r = 0
error off
clearerror
setreg(ax,0x1900)
real interrupt 0x21
axr = getreg(ax)
dd = mod(axr,256)+1
error on
if lerror <> 0
     r = -1
else
     ptstr = mid("abcdefghijklmnopqrstuvwxyz",dd,1)|":"
end if
return (r)
end function  'dosdrive()


function setsysdate(newdate)
'------------------------------------------------------------------
'newdate  = passed date in any acceptable SW2 date format
'yyyy     = year(newdate)      accepts 1980-2099
'dd       = day(newdate)
'mm       = month(newdate)
'axreg    = to store ax register result
'dxreg    = to calculate dx(low) and dx(high) register values
'------------------------------------------------------------------
local yyyy dd mm axreg dxreg

if iserr(date2(newdate))=TRUE
     return (-1)
else
     yyyy = year(newdate)
     if yyyy < 1980 or yyyy > 2099
          return (-2)
     else
          dd   = day(newdate)
          mm   = month(newdate)
          dxreg = (mm*256)+dd
          setreg(ax,0x2B00)
          setreg(cx,yyyy)
          setreg(dx,dxreg)
          real interrupt 0x21
          axreg = getreg(ax)
          if bitand(axreg,0xFF) = 0 'mask off ah to check al for success
               return (0)
          else
               return (-3)    ' al <> 0 is a failure
          end if
     end if
end if
end function 'setsysdate()


function setsystime(newtime)
'------------------------------------------------------------------
'newtime  = passed time in SW2 TIME24 format ("0-23:0-59:0-59")
'hh       = year(newdate)      accepts 1980-2099
'mm       = day(newdate)
'ss       = month(newdate)
'axreg    = to store ax register result
'cxreg    = to calculate ch and cl register values
'dxreg    = to calculate dh and dl register values
'------------------------------------------------------------------
local hh mm ss axreg cxreg dxreg

hh = value(left(newtime,2))
mm = value(mid(newtime,4,2))
ss = value(right(newtime,2))
if iserr(seconds(newtime))=TRUE    'should catch any bad time, but not
                                   'an AM/PM time format, which will give
                                   'incorrect results if PM. Must be 24
                                   'hour time format
     return (-1)
elseif hh > 23                     'range of hours
     return (-2)
elseif mm > 59                     'range of minutes
     return (-3)
elseif ss > 59                     'range of seconds
     return (-4)
else
     cxreg = (hh*256)+mm
     dxreg = ss*256
     setreg(ax,0x2D00)
     setreg(cx,cxreg)
     setreg(dx,dxreg)
     real interrupt 0x21
     axreg = getreg(ax)
     if bitand(axreg,0xFF) = 0     'mask off ah to check al for success
          return (0)
     else
          return (-5)         ' al <> 0 is a failure
     end if
end if
end function 'setsystime()



FUNCTION dosfparse(pf)
local j l f p c r
ptstr = NULL
l = len(pf)
if l > 0
     for j = l to 0 step -1
          c = mid(pf,j,1)
          if c="/" or c=":" or c="\"
               p = left(pf,j)
               f = mid(pf,j+1)
               exit for
          end if
     end for
     if j = -1
          ptstr = pf
          r = 0
     else
          if f = null
               r = -1              'path found but not a filename
          else
               ptstr = f&p
          end if
     end if
else
     r = -2                        'no data passed for evaluation
end if
return (r)
END FUNCTION   'fileparse()