'**** HEADER ************************************************************
'FILELIB.PF3
'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: File management

'**** FUNCTION DECLARATIONS *********************************************
'library
'core
public   chkfname()
public   filemove()          'moves files to new directory w/ remove
public   vlibif()            'loads function library if not loaded
public   vunlibif()          'unloads function library if loaded
public   increment()         'increments a text file stored value
public   remove()            'deletes specified file
public   unique()            'returns unique file name
public   fileparse()           'parses path and filename
global   flchkstr()          'used by vlibif()/vunlibif() to check currlib
                             'variable against lib file in question
global   fldelstr()          'used by vunlibif() to remove unloaded function
                             'library from currlib
global   getdrive()          'used by filemove() when path does not include
                             'the drive letter
'**** VARIABLE DECLARATIONS *********************************************
'library
public ptstr   'general return for string data
public ptval   'general return for numeric data
public currlib 'loaded function library string group
'core
'**** CODE **************************************************************

MAIN
local ptpsl
ptpsl = "filelib"
'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 vlibif(pf,m)
local e p f xpf
'-------------------------------------
'p         = datapath  (as "\dir\subdir\")
'f         = library name  (as "lib.ext")
'e         = error var
'm         = mode "f" = from file, "i" = in-memory
'-------------------------------------
'requires  flchkstr() fileparse()
'-------------------------------------
'returns   0 = success
'         <0 = error
'         -1 = lib.ext not found
'         -2 = unable to load
'         -3 = mode parameter not "i" or "f"
'-------------------------------------

if file(pf) = TRUE
     currlib = lower(currlib)
     if fileparse(pf) = 0
          xpf = ptstr
          f = lower(group(xpf,1))
          p = group(xpf,2)
          ptstr = null
     else
          return (-1)
     end if
     error off
     clearerror
     if flchkstr(f,currlib) = FALSE
          if m == "i"
               load pf in-memory
               if cerror = 0
                    if flchkstr(f,currlib) = FALSE
                         currlib = currlib & f
                    end if
               end if
          elseif m == "f"
               load pf from-file
               if cerror = 0
                    if flchkstr(f,currlib) = FALSE
                         currlib = currlib & f
                    end if
               end if
          else
               return (-3)
          end if
     end if
     error on
else
     return (-1)
end if
return (case lerror (0,0) else -2)
end function  'vlibif()


function vunlibif(f)
local err
'-------------------------------------
'f         = lib name  (as "lib.ext")
'e         = error var
'requires  flchkstr()
'          fldelstr()
'-------------------------------------
'returns   0 = success
'         <0 = error
'         -1 = unable to unload lib
'-------------------------------------
err = 0
f = lower(f)
currlib = lower(currlib)
if flchkstr(f,currlib) = TRUE
     error off
     clearerror
     unload f
     error on
     if lerror = 0
          currlib = fldelstr(f,currlib)
     else
          err = -1
     end if
elseif f == "all"
     error off
     while group(currlib,1) <> null
          clearerror
          unload group(currlib,1)
          if lerror = 0
               currlib = fldelstr(group(currlib,1),currlib)
          else
               err = -2
               exit while
          end if
     end while
     if err = 0
          currlib = null
     end if
     error on
end if
return (err)
end function  'vunlibif()



function increment(f,fn)
local e r l
ptval = BLANK
e = 0
for r = 1 to 6
     fopen f as fn
     e = cerror
     if e = 0
          exit for
     end if
     milli-wait 1
end for
if e = 0
     fread fn into l
     fseek fn 0
     fwrite fn from str(value(l)+1)
     ptval = value(l) + 1
else
     e = -1
end if
fclose fn
return (e)
end function  'increment()


function filemove(opath,npath,fname,mnu)
local r i ps ops nps f e rp ml mscn
r = 0
ptstr = NULL
ptval = BLANK
opath = trim(opath)
npath = trim(npath)
if len(opath) = 0
     opath = path(defpath)
end if
if len(npath) = 0
     npath = path(defpath)
end if
if right(npath,1) <> "/" and right(npath,1)<> "\"
     npath = npath|"\"
end if
if right(opath,1) <> "/" and right(opath,1)<> "\"
     opath = opath|"\"
end if
if left(opath,1) = "\" or left(opath,1) = "/"
     opath = getdrive()|opath
end if
if left(npath,1) = "\" or left(npath,1) = "/"
     npath = getdrive()|npath
end if
if opath == npath
     return (-2)
end if
ops = getfnames(opath|fname,1)
if exact(ops,NULL)=TRUE
     return (-1)
end if
smartpeek $_l1 ml
smartpeek $_paint rp
if rp = 1
     repaint off
end if
error off
clearerror
i = 1
if mnu = 1
     screen save ml 1 ml scrwidth mscn
     screen clear box ml 1 ml scrwidth 0 0 no-border
end if
while TRUE
     f = group(ops,i)
     if exact(f,NULL)=TRUE
          exit while
     end if
     if mnu = 1
          screen clear box ml 1 ml scrwidth 0 0 no-border
          screen print ml 1 bginvpleasing bgstandard "Moving:"&opath|f&"to"&npath
     end if
     tools file copy opath|f to npath
     e = cerror
     if e = 0
          tools file erase opath|f
     else
          r = -3
          ptval = ptval + 1
          ptstr = ptstr & f
'          ce = ce+1
'          nps = nps & f & str(e)
     end if
     i=i+1
end while
error on
'if exact(trim(nps),NULL)=FALSE
'     ptstr = trim(nps)
'end if
if rp = 1
     repaint on
end if
if mnu = 1
     screen shortrestore mscn
end if
return (r)
end function  'filemove()


function remove(f)
local r
r = 0
ptstr = NULL
if getfnames(f,1)>null
     error off
     clearerror
     tools file erase f
     error on
     if lerror <> 0
          r = -2
     end if
else
     r = -1
end if
ptstr = getfnames(f,1)
return (r)
end function   'remove()


function unique(pth,ext,fnum)
local f r
r = 0
f = "@T"|right("00000000"|str(int(uniform(10000000))),6)
while file(pth|f|ext) = TRUE
     f = "@T"|right("00000000"|str(int(uniform(10000000))),6)
end while
error off
clearerror
fopen pth|f|ext as fnum
fclose fnum
error on
if lerror <> 0
     r = -1
else
     ptstr = f|ext
end if
return (r)
end function  'unique()


function chkfname(pf)
local pos lp lf c e  p f xpf lx xf xx pp
ptval = blank
xx = null
e = 0
pf = trim(pf)
if trim(pf) ! chr(32)
     ptval = find(chr(32),pf,0) + 1
     return (-5)
end if

xpf = fileparse(pf)
if xpf = 0
     f = group(ptstr,1)
     p = group(ptstr,2)
     lf = len(f)
     lp = len(p)
else
     e = -1      'no file reference"
end if

if lp > 0
     error off
     clearerror
     pp = path(datapath)
     tools directory new-directory p
     if lerror > 0
          e = -6
     end if
     tools directory new-directory pp
     error on
     return (e)
end if

if left(f,1)="."
     e = -2         ' invalid root length min
end if

if e = 0

if f!!"."
     if lf > 8
          e=-3      ' invalid root length max
     end if
elseif f!"."
     lf= len(mid(f,0,(find(".",f,0))))
     lx= len(mid(f,(find(".",f,0)+2)))
     if lf > 8
          e = -3     ' filename exceeds 8 characters
     elseif lx > 3
          e = -4     ' file extension exceeds 3 characters
     end if
end if
if e = 0
  if f!"."
       xf = mid(f,0,(find(".",f,0)))
       xx= mid(f,(find(".",f,0)+2))
  else
       xf = f
  end if
  for pos=1 to lf
     c=upper(mid(xf,pos,1))
     if "0123456789ABCDEFGHIJKLMNOPQRSTUVXYZ!@#$%&()-_{}`'"!! c
          e = -5
          ptval  = lp + pos      ' Invalid filename at character position pos
          exit for
     end if
 end for
 if xx > null and e=0
  for pos=1 to lx
     c=upper(mid(xx,pos,1))
     if "0123456789ABCDEFGHIJKLMNOPQRSTUVXYZ!@#$%&()-_{}`'"!! c
          e = -5
          ptval =  lp + (1+lf+pos)   ' Invalid filename at character position pos
          exit for
     end if
  end for
 end if
end if

end if                   '(if e = 0 evaluation)
return (e)
end function   'chkfname()


function flchkstr(s,sl)
local t i
'-------------------------------------
's    = string to check
'sl   = string group
't    = targeted item to check
'i    = counter for group() function
'-------------------------------------
'returns  TRUE  = item is in string group
'         FALSE = item is not in list
'-------------------------------------
i=0
while exact(t,NULL)=FALSE
     i=i+1
     t = group(sl,i)
     if t = s
          return (TRUE)
     end if
end while
return (FALSE)
end function  'chkstr()


function fldelstr(s,sl)
local t i n f
'-------------------------------------
's    = string to check
'sl   = string group
't    = targeted string to check
'i    = counter for group() function
'n    = new string group
'f    = list changed flag
'-------------------------------------
'returns:  success =  list less item
'          failure =  original list
'-------------------------------------
f=0
i=0
n=NULL
while TRUE
     i=i+1
     t = group(sl,i)
     if exact(t,NULL)=TRUE
          exit while
     elseif t = s
          f=1
     else
          n=n&t
     end if
end while
return (case f (0,sl)(1,trim(n)))
end function  'fldelstr()


FUNCTION fileparse(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()

function getdrive()
local axr dd r
setreg(ax,0x1900)
interrupt 0x21
axr = getreg(ax)
dd = mod(axr,256)+1
return (mid("abcdefghijklmnopqrstuvwxyz",dd,1)|":")
end function  'getdrive()