*
*
*  FP2_XLIB version 1.02        Release date 08-17-1991
*                               Author       Edward M. Rauh
*                                            Gamboge International
*                                            300 Long Beach Blvd.
*                                            Stratford, CT  06497
*                                            FAX 203/386-9333
*
* Changes in 1.02:
*
*  new UDF - CHG_DIR(newpath,set_2_dflt)
*
*               changes directories on non-default drives, optionally
*               sets new path to default.  Does not use RUN/!
*
*  new UDF - ISBN_CKD(booknumb)
*
*               cacluates the check digit needed to convert a 9-digit
*               book number to an ISBN
*
*  Reductions in use of & operator to improve speed
*
*  No, the job server is not being released yet for FoxPro2 - you can
*  still use the one I released for Foxbase+ in LAN_PROC;  it is likely
*  that the FoxPro 2 specific version will be a commercial product in
*  conjunction with a Novell/NetBIOS function library written with the
*  C API.
*


procedure std_init
*
*  Standard Handler Initialization
*
*
*       The Standard Handler estabilishes a known working environment for 
*       FoxPro in the machine.  A few common variables are set up, a private
*       workspace is established for the end-user, an enhanced error recovery
*       handler is initialized and the BAS5 (Basic Access System version 5)
*       work environment is activated.  The existance of a network is 
*       determined by examining the network machine name.  A few standard
*       communication windows are also established for common access use.
*
*
*  in_lan establishes the existance of a NETBIOS machine name by examining
*  SYS(0).  SET EXCLUSIVE should be controlled by this variable.  In Novell
*  networks, the System Login Script should assign a machine name using the
*  MACHINE="name" statement if NETBIOS is not loaded.
*
public in_lan, err_handl
err_handl = .f.
do std_sets     && added to make recreating the standard environment setting
                && accessible after modification of the operating environment
in_lan =  network() .and. sys(0) # space(15)+'# 0'  && test for NETBIOS machine name
if in_lan
   set exclusive off
else
   set exclusive on
endif
set status off
set brstatus off
set deleted on
*
*  trap_app is used to flag when errors from APPEND BLANK are intercepted
*  trap_use is used to flag when errors from USE statements are intercepted
*
public trap_app, trap_use

trap_app = .f.
trap_use = .f.
*
*  err_hand is a much-enhanced error processing routine for FoxPro2
*
on error do err_hand with error(),message(),program(),message(1),lineno()
err_handl = .t.
*
*  xlib is a standard error message window
*  xdlg is a standard system dialog window at the screen bottom
*
define window xlib from 0,0 to 2,79 nofloat nogrow nozoom noclose color scheme 9
define window xdlg from 22,0 to 24,79 nofloat nogrow nozoom noclose color scheme 11

activate window xdlg top
@ 0,23 say 'Initializing FoxPro Environment'
activate screen
*
*       wk_dir is a private working directory, on the drive specified by the
*              DOS environment variable WKDRV
*       wk_files is a guarenteed unique 8-character filename;  I usually
*              reference it as (wk_dir+'\'+wk_files+'.<ext>')
*       in_dir is the initial working directory
*       _ret_act is a procedure to be executed on select by pickone();  it is
*              a global variable (I'm lazy, and you can't necessary pick up
*              other locals inside a UDF) so make sure to save the old value
*              whenever you change it
*       userid is a user identifier passed by the DOS environment variable
*              USERID
*       viewnum is used to store context switching activation, it is used by
*              several routines not included in this release of my library
*       help_topic specifies the active help topic for BAS5HELP
* 
public wk_dir, in_dir, wk_files, _ret_act, userid, viewnum, help_topic

viewnum = 0
_ret_act = ''
in_dir = sys(5) + curdir()
wk_dir = getenv('WKDRV')
set default to (wk_dir)
wk_dir = sys(5) + curdir() + sys(3)
set default to (in_dir)
! md &wk_dir >nul
help_topic = 'Error Messages'
if file('BAS5HELP.DBF') .and. file('BAS5HELP.FPT')
   set help to BAS5HELP
   set help on
else
   set help off
endif
on key label F1 do pophelp
if file('BAS5KEYS.FKY')                 && BAS5KEYS sets Alt-C to Activate
   restore macros from BAS5KEYS         && the calculator
   on key label F2 do popcalc
   on key label Shift-F2 do calc_kbd
endif
wk_files = sys(3)

on key label Shift-F1 do sel_pdev
userid = getenv('USERID')
set function 2 to ''
set function 3 to ''
set function 4 to ''
set function 5 to ''
set function 6 to ''
set function 7 to ''
set function 8 to chr(23)               && I use F8 rather than ^W to exit
set function 9 to ''                    && from screens
set function 10 to ''
deactivate window xdlg

return

procedure std_sets
*
*  Reestablish the standard environment settings
*
set step off
set echo off
set talk off
set debug off
set safety off
set confirm off
set exact off
set escape off
set help off
set reprocess to 10
set near on
*
*  The following was added to allow the standard error handler to be reenabled
*  by calling std_sets after having invoked it with std_init
*
if type('err_handl')='L'
   if err_handl
      on error do err_hand with error(),message(),program(),message(1),lineno()
   endif
endif
return

procedure pophelp
*
*  Pophelp will activate the FoxPro context sensitive help facility if the
*  Help file has been activated.
*
if set('HELP')='ON'
   help &help_topic
else 
   wait 'No Help File available' window timeout 60
endif
return

procedure popcalc
*
*  Popcalc pops up the calculator if the Alt-C macro from BAS5KEYS is defined
*
play macro Alt_C
retry

proc calc_kbd
*
* Calc_kbd takes the content of the calculator and places it in the current
* variable or field being edited on-screen.  The code is non-intuitive;  it
* checks the context of the current variable being edited to see if it is a
* field or memory variable, determines the size and type of data being edited,
* and then converts the calculator data to fit the field in question if it
* can, or converts it to a string and keyboards the result if no better
* solution can be found.
*
private varnm,calcstr,holdfld,fldnm
calcstr = ltrim(str(_calcvalue,18,7))
do while right(calcstr,1) = '0'
   calcstr = left(calcstr,len(calcstr)-1)
enddo
varnm = varread()
fldnm = alias()+'.'+varnm
varnm = 'm.'+varnm
clear typeahead
do case
case type(varnm) $ 'UDLS' .and. type(fldnm) $ 'UDL'
   keyboard calcstr
case type(varnm) $ 'UDLS'  && Has to be a field
   do case
   case type(fldnm) $ 'NF'
      replace &fldnm with _calcvalue
   case type(fldnm) = 'C'
      replace &fldnm with calcstr
   otherwise && Memo Field
      keyboard calcstr
   endcase
case type(fldnm)$'UDL'
   do case
   case type(varnm) $ 'NF'
      &varnm = _calcvalue
   case type(varnm) = 'C'
      calcstr = left(calcstr+space(len(eval(varnm))),len(eval(varnm)))
      &varnm = calcstr
   otherwise && Different File or illegal field type
      keyboard calcstr
   endcase
case type(varnm)$'NF' .and. .not. type(fldnm)$'NF'
   &varnm = _calcvalue
case type(varnm)$'NF'
   if reclock()
      holdfld = eval(fldnm)
      repl &fldnm with .11111111
      calcstr = ltrim(str(_calcvalue,fsize(&fldnm), -int(log10(.11111111-eval(fldnm)))))
      repl &fldnm with holdfld
   endif
   keyboard calcstr
case type(fldnm)$ 'NF'
   repl &fldnm with _calcvalue
case type(fldnm)='M'
   keyboard left(calcstr, min(len(calcstr), len(eval(varnm))))
otherwise
   keyboard left(calcstr, min(len(calcstr), min(len(eval(varnm)),len(eval(fldnm)))))
endcase
return


procedure prg_exit
*
*  Exit from program and clean up temp files on work drive
*
parameters errmsg
private erasefil
set escape off
on key
set device to screen
set console on
set print off
activate screen
close databases
flush
if type('errmsg')#'C'
   errmsg = ''
endif
do instruct with errmsg+' - returning to DOS'
?
flush
*
*  Check to see if the temporary work directory is empty - if not, we
*  must erase all files in the directory before removing it!
*
set default to (in_dir)
erasefil = sys(2000,wk_dir+'\*.*')
clear typeahead
if .not. empty(erasefil)
   set printer to yes.ans
   ??? 'Y'+chr(13)
   set printer to
   flush
   !erase &wk_dir <yes.ans
   erase yes.ans
endif
! rd &wk_dir >nul               && I _REALLY_ want to get rid of this!
quit
      
   
function fillock
*
*  Recoverable File lock acquisition
*
private setc, give_up
setc = save_env()
set console on
set device to screen
set print off
if .not. flock()
   give_up = .f.
   activate window xlib in screen top
   clear
   clear typeahead
   do while .not. (flock() .or. give_up)
      @ 0,0 say 'Waiting for file '+trim(alias())+' - abort?' get give_up picture 'Y'
      read timeout 2
   enddo
   clear
   deactivate window xlib
endif
do rest_env with &setc
return flock()


function reclock
*
* Recoverable Single record lock acquisition
*
private setc, give_up

setc = save_env()
set console on
set device to screen
set print off
if .not. rlock()
   give_up = .f.
   activate window xlib in screen top
   clear
   clear typeahead
   do while .not. (rlock() .or. give_up)
      @ 0,0 say 'Waiting for record '+ltrim(str(recno(),9))+' in '+trim(alias())+' - abort?' get give_up picture 'Y'
      read timeout 2
   enddo
   clear
   deactivate window xlib
endif
do rest_env with &setc
return rlock()


PROCEDURE err_hand
*
*  Standard Error Processing Routine
*
parameters errnum, mess, curr_prg, bad_line,bad_lineno
*
*  errnum       FoxPro Error Message Number
*  mess         FoxPro Error Description
*  curr_prg     Interrupted Procedure Name
*  bad_line     Interrupted Statement
private setconsole,setdevice,setprint,setcolor

setconsole = sys(100)
setdevice = sys(101)
setprint = sys(102)
setcolor = sys(2001,'COLOR')
set console on
set device to screen
set print off

private err_screen,errlogfile

errlogfile = in_dir+sys(3)
save screen to err_screen


do case errnum
case trap_app .and. errnum = 108
   activate window xlib top
   @ 0,0 say padc('Waiting for append in file '+trim(alias())+' - <Esc> to abort',78)
   trap_app = inkey() # 27
   if trap_app
      retry
   else
      return
   endif
   
case trap_app
   trap_app = .f.
   return
   
case trap_use .and. errnum = 108
   activate window xlib top
   @ 0,0 say padc('Waiting to open file '+use_alias+' - <Esc> to abort',78)
   trap_use = inkey() # 27
   if trap_use
      retry
   else
      return
   endif
   
case trap_use
   trap_use = .f.
   return
   
case errnum = 216
   set console &setconsole
   set device to &setdevice
   set print &setprint
   set color to &setcolor
   return

case errnum = 4 .and. approved(.f.,'EOF limit exceeded - use EOF?',600)
   go bottom
   set console &setconsole
   set device to &setdevice
   set print &setprint
   set color to &setcolor
   restore screen from err_screen
   if .not. bof()
      retry
   else
      return
   endif

case errnum = 1405 .and. approved(.f.,'Unable to run external program - proceed anyway?',600)
   set console &setconsole
   set device to &setdevice
   set print &setprint
   set color to &setcolor
   return

case errnum = 1405 .and. approved(.f.,'Retry '+ alltrim(bad_line) + '?',600)
   set console &setconsole
   set device to &setdevice
   set print &setprint
   set color to &setcolor
   retry

case errnum = 38 .and. approved(.f.,'BOF exceeded - position at BOF?',600)
   go top
   set console &setconsole
   set device to &setdevice
   set print &setprint
   set color to &setcolor
   restore screen from err_screen
   if .not. eof()
      retry
   else
      return
   endif

case errnum = 108 .and. upper(left(alltrim(bad_line),3)) # 'USE'
   if fillock()
      set console &setconsole
      set device to &setdevice
      set print &setprint
      set color to &setcolor
      restore screen from err_screen
      retry
   else
      do prg_exit with "Failed to lock file."
   endif

case errnum = 108
   activate window xlib
   clear
   @ 0,0 say 'Waiting on '+bad_line
   if inkey(4) # 27
      set console &setconsole
      set device to &setdevice
      set print &setprint
      set color to &setcolor
      deactivate window xlib
      retry
   else
      do prg_exit with 'Failed to open file'
   endif

case errnum = 109 .or. errnum = 130
   if reclock()
      set console &setconsole
      set device to &setdevice
      set print &setprint
      set color to &setcolor
      restore screen from err_screen
      retry
   else
      do prg_exit with "Failed to lock record."
   endif

case errnum = 124
   set printer to
   set color to &setcolor
   set console &setconsole
   set device to &setdevice
   set print &setprint
   restore screen from err_screen
   return

case errnum = 125
   activate window xlib
   clear
   @ 0,0 say 'Printer not ready.  Redirect printer output with Shift-F1'
   clear typeahead
   do while sys(13) = 'OFFLINE' .and. approved('Continue waiting for printer to be fixed?',2)
      ?? chr(7)
   enddo
   deactivate window xlib
   if sys(13) = 'OFFLINE'
      do prg_exit with 'User aborted program.'
   endif
   restore screen from err_screen
   set console &setconsole
   set device to &setdevice
   set print &setprint
   set color to &setcolor
   retry

otherwise
   hide windows all
   activate screen
   @ 15,0 clear to 20,79
   @ 0,0 say mess color +W/N
   @ 15,0 to 20,79 double color +W/N
   @ 16,8 say 'A fatal system error has occurred.  The program cannot continue.'
   @ 17,8 say 'The run-time environment will be dumped to the file ERROR.LOG'
   @ 18,8 say 'in the directory '+in_dir
   @ 19,8 say 'Please notify Ambassador Book about this error promptly.'
   set color to &setcolor
   private setprtdev,disknotful
   setprtdev = sys(6)
   set printer to
   disknotful = 'errnum # 56 .or. curdir() # in_dir'
   on error set printer to 
   set printer to (in_dir+'error.log') additive
   on error do prg_exit with ''
   set device to print
   @ 1,10 say 'System error number '+ltrim(str(errnum,4))
   @ 2,10 say mess
   @ 4,10 say 'Called from '+curr_prg
   @ 6,10 say time()
   @ 6,20 say date()
   @ 6,30 say 'User Name '+getenv('USERID')
   @ 7,0 say '...'
   @ 7,pcol()+3 say bad_lineno
   @ 8,0 say bad_line
   set device to screen
   set console off
   do instruct with 'Listing RunTime Status'
   list status to print
   do instruct with 'Listing Program Private Storage'
   list memory to print
   eject page
   set console on
   set printer to
   if file(in_dir+'ORD.PRG')
      if approved('Suspend program execution but stay in FoxBase+?')
         on error
         set talk on
         set help on
         set help to
         suspend
      endif
   endif
   do prg_exit with 'FoxBase+ runtime error occurred'

endcase

return


procedure instruct
*
*  Display message on line 24
*
parameter msgln
private setc
setc = save_env()
set device to screen
activate screen
@ 24,0 say padc(msgln,79)
do rest_env with &setc
return

function approved
*
*  Get yes or no response
*
parameter myanswer, question, op_dly
private setc, w_name,w_pos
if type('question') # 'C'
   if type('question') = 'N'
      op_dly = question
   endif
   question = myanswer
   myanswer = .t.
endif
question = trim(question)
w_name = 'A_'+alltrim(sys(2))
w_pos = int((75 - len(question))/2)
define window (w_name) from 21,w_pos to 23,w_pos+len(question)+4 in screen double shadow color scheme 6
setc = save_env()
set console on
set device to screen
set print off
activate window (w_name) top
@ 0,0 say question get myanswer picture 'Y' color scheme 8 
if type('op_dly') = 'N'
   read timeout op_dly
else
   read
endif
release window (w_name)
do rest_env with &setc
return myanswer


function askchar
*
*  Get a single character response from a limited set
*
parameter question, valid_list
private setc,myanswer
setc = save_env()
set console on
set device to screen
set print off
activate window xdlg top
clear
myanswer = ' '
@ 0,0 say trim(padc(question,78)) get myanswer picture '!' valid  myanswer $ valid_list error 'Select one of "'+valid_list+'"'
read
do rest_env with &setc
deactivate window xdlg
return myanswer

function appblank
*
*  Recoverable append blank
*
private setc
setc = save_env()
set console on
set device to screen
set print off
private append_ok
trap_app = .t.
append blank
unlock
append_ok = trap_app
trap_app = .f.
if append_ok
   append_ok = reclock()
endif
deactivate window xlib
do rest_env with &setc
return append_ok

function use_db
*
*  Recoverable file open
*
parameters dbfname, use_args
private setc,use_ok
setc = save_env()
set console on
set device to screen
set print off
trap_use = .t.
if parameters() < 2 .or. type('use_args') # 'C'
   use_args = ''
endif
use (dbfname) &use_args
use_ok = trap_use
trap_use = .f.
deactivate window xlib
do rest_env with &setc
return use_ok 


function save_env
*
*  Save standard runtime environment as a single string variable
*
private _rv
_rv = '['+set('DEVICE')+'],['+set('CONSOLE')+'],['+set('PRINTER')+'],['
_rv = _rv+set('COLOR',1)+'],['+set('ALTERNATE')+'],['+woutput()+']'
return _rv


procedure rest_env
*
*  Restore environment from single string expanded as parameters
*
parameters _dvc, _cns, _ptr, _clr, _alt, _outwin
set device to &_dvc
set console &_cns
set printer &_ptr
set color to &_clr
set alternate &_alt
if empty(_outwin)
   activate screen
else
   activate window (_outwin)
endif
return

procedure sel_pdev
*
*  Sel_pdev allows the user to select an appropriate print device, change
*  print modes, send control codes to the printer, make julienne fries, etc.
*  Std_init sets it up to run off of <Shift>F1.  It can also be invoke by
*  DO sel_pdev.  You must ensure that no pop-up array menu is active on-screen
*  at the time Sel_pdev is invoked, or an error will occur and the user will
*  be dropped harmlessly (well, more or less harmlessly) out to DOS.
*
private setc, pdev_in, pdev_wk, m_opt, p_on, spool, prnfile
clear typeahead
on key label Shift-F1
p_on = upper(set('DEVICE')) = 'PRINT' .or. set('PRINT') = 'ON'
pdev_in = set('PRINT',1)
pdev_wk = left(pdev_in+space(64),64)
spool = left(pdev_wk,2)='\\'
prnfile = .not. (spool .or. right(trim(pdev_wk),1) = ':')
m_opt = 1

dimension sel_p(4)
sel_p(1) = 'Exit Print Menu'
sel_p(2) = 'Print Device'
sel_p(3) = 'Form Alignment'
sel_p(4) = 'Network Control'

setc = save_env()
set console on
set device to screen
set print off

define window pdev from 1,1 to 8,78 nofloat nogrow nozoom noclose title 'Print Device Assignment'
activate window pdev in screen top
clear
activate screen
do while m_opt > 0
   do pdev_dsp
   @ 11,1 menu sel_p, iif(in_lan,4,3) title 'Print Control'
   read menu to m_opt
   do case
   case m_opt < 2
      exit
   case m_opt = 2
      do set_pdev
   case m_opt = 3
      do mng_form
   case m_opt = 4
      do net_ctrl
   endcase
   pdev_wk = left(set('PRINT',1)+space(64),64)
enddo
release window pdev
do rest_env with &setc
on key label Shift-F1 do sel_pdev
return


procedure set_pdev
private numdevs,choice, newdev
numdevs = iif(in_lan,11,10)
choice = iif(spool,11,iif(prnfile,10,1))
dimension p_devs(11)
p_devs( 1) = 'PRN:'
p_devs( 2) = 'LPT1:'
p_devs( 3) = 'LPT2:'
p_devs( 4) = 'LPT3:'
p_devs( 5) = 'COM1:'
p_devs( 6) = 'COM2:'
p_devs( 7) = 'COM3:'
p_devs( 8) = 'AUX:'
p_devs( 9) = 'NUL:'
p_devs(10) = 'DISK'
p_devs(11) = 'NETWORK'
@ 10,40 menu p_devs,numdevs Title 'Print Devices'
read menu to choice
newdev = ''
do case
case choice = 0
   return
case choice < 10
   newdev = p_devs(choice)
case choice = 10
   newdev = putfile('Print to File',iif(prnfile,trim(pdev_wk),'PRINTOUT.html'))
   if file(newdev) .and. len(newdev)>0
      if approved('File '+newdev+' exists.  Append?')
         newdev = newdev + ' Additive'
      else
         if .not. approved(.f.,'Overwrite file '+alltrim(newdev)+'?')
            newdev = ''
         endif
      endif
   endif
case choice = 11
   private netp,netf,netb,netc
   netp = 0
   netf = 0
   netb = left(getenv('USERID')+space(12),12)
   netc = 1
   activate window pdev in screen top
   @ 5,0 clear to 5,70
   @ 5,1 say 'Printer # ' get netp picture '#' range 0,4
   @ 5,15 say 'Form ' get netf picture '999' range 0,255
   @ 5,25 say 'Copies ' get netc picture '99' range 1,99
   @ 5,40 say 'Banner (Blank = None)' get netb picture '@!'
   read
   @ 5,0
   activate screen
   newdev='\\SPOOLER\P='+str(netp,1)+'\F='+alltrim(str(netf,3))+'\C='+trim(str(netc,2))+'\'
   newdev = newdev + iif(len(trim(netb))=0,'NB','B='+alltrim(netb))
endcase
if newdev == ''.or. upper(newdev)==upper(pdev_wk) 
   return
endif
set printer to nul:
set console off
eject page
set console on
set printer to (newdev)
if set('PRINT',1)='PRN:' .and. newdev # 'PRN:'
   if prnfile
      set printer to (pdev_wk) additive
   else
      set printer to (pdev_wk)
      if .not. spool
         set console off
         eject page
         set console on
      else
         _pageno = 1
      endif
      _plineno = 0
   endif
else
   _pageno = 1
   _plineno = 0
endif
return

procedure mng_form
private choice,pctl_str
dimension acts(4)
choice = 0
acts(1)='Eject to Top of Form'
acts(2)='Top of Form/No Eject'
acts(3)='Send Print Code'
acts(4)='Change Print Status'
do while .t.
   activate screen
   @ 10,40 menu acts,4 title 'Form Control'
   read menu to choice
   do case
   case choice = 0
      exit
   case choice = 1
      set console off
      eject page
      set console on
   case choice = 2
      set printer to nul:
      set console off
      eject page
      set console on
      if prnfile
         set printer to (pdev_wk) additive
      else
         set printer to (pdev_wk)
      endif
   case choice = 3
      activate window xdlg top
      clear
      pctl_str = space(150)
      @ 0,0 say 'Enter String Expression:' get pctl_str picture '@S40' valid type(trim(pctl_str))='C' .or. len(alltrim(pctl_str))=0
      read
      pctl_str = trim(pctl_str)
      if .not. (empty(pctl_str) .or. lastkey()=27)
         ??? evaluate(pctl_str)
      endif
      deactivate window xdlg
   case choice = 4
      activate window pdev in screen top
      @ 4,0 say 'Page: ' 
      @ 4,col() get _pageno picture '9999' range 1,9999
      @ 4,col()+4 say 'Line: ' 
      @ 4,col() get _plineno picture '9999' range 0,_plength-1
      @ 4,col()+4 say 'Column: '
      @ 4,col() get _pcolno picture '999' range 0,_rmargin-1
      @ 4,col()+4 say 'Lines/page: '
      @ 4,col() get _plength picture '999' valid between(_plength, _plineno+1, 255)
      @ 4,col()+4 say 'Cols/line: '
      @ 4,col() get _rmargin picture '999' valid between(_rmargin, _pcolno+1, 255)
      read
      activate screen
   endcase
enddo
return

procedure net_ctrl
private choice, scr_in
activate screen
save screen to scr_in
dimension nact(4)
nact(1) = 'PCONSOLE'
nact(2) = 'PRINTCON'
nact(3) = 'PRINTDEF'
nact(4) = 'Release Print Job'
choice = 0
@ 10,40 menu nact,4 title 'Network Control'
read menu to choice
do case
case choice = 1
   run /0 pconsole
case choice = 2
   run /0 printcon
case choice = 3
   run /0 printdef
case choice = 4
   if spool .or. .not. prnfile
      set console off
      set printer to nul:
      eject page
      set printer to (pdev_wk)
      set console on
   endif
endcase
restore screen from scr_in
return

procedure pdev_dsp
activate window pdev in screen top
spool = left(pdev_wk,2)='\\'
prnfile = .not. (spool .or. right(trim(pdev_wk),1) = ':')
@ 0,0 say 'Printer Assignment: ' get pdev_wk picture '@!S45'
@ 2,0 say 'Printer '+iif(p_on,'A','Ina')+'ctive   '
@ 2,22
do case
case spool
   @ 2,22 say 'SPOOLING TO NETWORK QUEUE - Spool'+ iif(_pageno+_plineno>1,' active',' empty')
case prnfile
   @ 2,22 say 'PRINTING TO DISK FILE'
otherwise
   @ 2,22 say 'PRINTER '+sys(13)
endcase
@ 4,0 say 'Page: ' 
@ 4,col() say _pageno picture '9999'
@ 4,col()+4 say 'Line: ' 
@ 4,col() say _plineno picture '9999'
@ 3, col()-5 say '('+str(prow(),4)+')'
@ 4,col()+3 say 'Column: '
@ 4,col() say _pcolno picture '999'
@ 3,col()-4 say '('+str(pcol(),3)+')'
@ 4,col()+3 say 'Lines/page: '
@ 4,col() say _plength picture '999'
@ 4,col()+4 say 'Cols/line: '
@ 4,col() say _rmargin picture '999' 
clear gets
activate screen
return

function pickone
parameters disp_line,win_head,match_test,key_prefix,ul_row,ul_col,num_rows,kill_after,win_name
*
*  PickOne() - display and scroll through a FoxBase+ database on screen
*              in a pop-up window.  Allow preconditioning of user-entered
*              keys and prevent selection of any records not meeting the
*              specified matching condition
*
*   Returns:   .T. if choice was made.  CWA positioned on selection.
*              .F. if Esc was pressed.  CWA positioned as at entry.
*
*              Fatal errors suspend program, return .F. if resumed
*
*   Arguments:
*              disp_line  - <ExpC>, macro of detail line content.  Must be
*                           expanded to a fixed-length string
*
*                           Example: [LastName+" "+str(salary,9,2)+" "+title]
*
*              list_head  - <ExpC>, Title of pop-up box
*
*                           Example: [Sales Department Salaries]
*
*              match_test - <ExpC>, macro of selection criteria test for
*                           valid, selectable records.  Must expand to a
*                           logical expression. Use [.t.] for no test
*
*                           Example: [Department="SALES"]
*
*              key_prefix - <ExpC>, used as prefix on key lookup
*
*                           Example: []
*
*              ul_row     - <ExpN> Range (0..21) First box row
*
*                           Example: 8
*
*              ul_col     - <ExpN> Range (0..71) First box column
*
*                           Example: 4
*
*              num_rows   - <ExpN> Range (1..22-ul_row) Max records on
*                           screen in box at one time.  If a negative
*                           value is passed, a box of abs(num_rows) will
*                           be displayed, but the screen will not be
*                           restored on exit from the routine.
*
*                            Example: 8
*
*              kill_after - <ExpN> - Maximum time to wait for a user to
*                           press a key before killing the program.  Use
*                           -1 to wait forever.
*
*                            Example: 600  (e.g. 10 minutes)
*
*              win_name   - <ExpC> - Name of window to use to display the
*                           scrolling window box (default WIN_PICK).  By
*                           specifying different window names, multiple
*                           scrolling boxes could be nested.
*
********************************
*  Sample usage:
*
*
*   && Set up a box containing 8 records at a time anchored at 7,14.
*   && Show the user str_fld_1, date_fld_2 and num_fld_3 for each record.
*   && Label the box "This year's entries"
*   && Only allow the user undeleted records, where the date in date_fld_2
*   && falls in the current year
*   && If the user does nothing for 10 minutes, kill the program
*
*   showme = 'str_fld_1+[ ]+dtoc(date_fld_2)+[ ]+str(num_fld_3,6,2)'
*   box_title = "This year's entries"
*   must_be = '.not. deleted() .and. (year(date_fld_2) = year(date()) )'
*   top_row = 7
*   left_col = 14
*   recs_inbox = 8
*   quit_in = 600
*   
*   a= PickOne(showme,box_title,must_be,'',top_row,left_col,recs_inbox,quit_in)
********************************
*  Validity tests and error handling:
*
*       ul_col not in range         - UDF displays error message, program
*       ul_row not in range           is SUSPENDed
*       num_rows < 1
*       type(disp_line) # 'C'
*       type(match_test) # 'L'
*       type('key_prefix') # 'C'
*       type('ul_row') # 'N'
*       type('ul_col') # 'N'
*       type('num_rows') # 'N'
*       type('kill_after') # 'N'
*
*       type('list_head') # 'C'     - Box heading is not displayed
*
*       ul_row+num_rows > 22        - num_rows reduced to (22-ul_row)
*
*       ul_col+len(&disp_line) > 78 - left(&disp_line,78-ul_col) used in
*                                     place of &disp_line
*
*       len(list_head) > boxsize    - left(list_head,boxsize) displayed
*
*       type('win_name') # 'C"      - window 'WIN_PICK' is used to display
*                                     the scrolling box.
********************************
*
*  Gadgetry:
*
*  I write for multiuser environments, where it can be quite damaging for
*  an end-user to just walk away from a console with their program running,
*  perhaps while holding an active Flock() or Rlock(), or worse, preventing
*  someone from making a backup of the open datafiles.  I use a simple
*  inkey(1) timing loop to knock down the program after some period of 
*  inactivity in the scroll box, specified in the kill_after parameter.
*  
*  The public variable _ret_act can be used to pass the name of a DO procedure
*  to be executed on making a valid selection by pressing <Return>.  If you
*  use the pickone() routine recursively, make sure to save value of _ret_act
*  before invoking pickone() recursively.
*

private _up, _down, _left, _right, _bell_chr
private _pgup, _pgdn, _home, _end, _return, _esc, _f1, _f2

* The code makes more sense referring to a variable for keystrokes instead
* of the inkey() values or chr() arguments.

_up = 5
_down = 24
_left = 19
_right = 4
_bell_chr = chr(7)
_pgup = 18
_pgdn = 3
_home = 1
_end = 6
_return = 13
_esc = 27
_f1 = 28
_f2 = -1

private _setc

* _setc preserves the status on entry to the UDF

_setc = save_env()

do case                         && Test for fatal error conditions

case type(disp_line) # 'C'
   do psb_err with 'Display line argument must evaluate to a string',disp_line
   return .f.
case type(match_test) # 'L'
   do psb_err with 'Record match test must evaluate to a logical expression',match_line
   return .f.
case type('key_prefix') # 'C'
   do psb_err with 'Key prefix must be a character expression',key_prefix
   return .f.
case type('ul_row') # 'N'
   do psb_err with 'Upper left row argument must be numeric',ul_row
   return .f.
case type('ul_col') # 'N'
   do psb_err with 'Upper left column argument must be numeric',ul_col
   return .f.
case type('num_rows') # 'N'
   do psb_err with 'Number of rows argument must be numeric',num_rows
   return .f.
case type('kill_after') # 'N'
   do psb_err with 'Wait time between keys must be numeric',kill_after
   return .f.
case ul_col < 0 .or. ul_col > 71
   do psb_err with 'Upper left column argument out of range (0..71)',ul_col
   return .f.
case ul_row < 0 .or. ul_row > 21
   do psb_err with 'Upper left row argument out of range (0..21)',ul_row
   return .f.
endcase


private on_row,rows,boxbot,boxtop,first_col,boxsize,disp_arg,init_recno

* on_row is current display row
* rows is the max records that can be displayed at once
* boxbot is last display row
* boxtop is first display row
* first_col is the first column of the scrolling area
* boxsize is the width of the scroll area
* disp_arg is the content of the display line
* init_recno is the file position at entry to the routine
 
if reccount() = 0 .or. bof() .or. eof()
   return .f.
endif

init_recno = recno()
rows = abs(num_rows)
rows = iif(rows = 0 .or. rows+ul_row < 23, rows, 22 - ul_row)
boxbot = rows - 1
boxtop = 0
first_col = 0
disp_arg = disp_line
boxsize = max(len(evaluate(disp_arg)),7)
if ul_row + boxsize > 78
   boxsize = 78 - ul_row
   disp_arg = 'left(' + disp_line + ',' + str(boxsize,2) + ')'
endif

if type('win_name') # 'C'
   win_name = 'Win_Pick'
endif
if wexist(win_name)
   release window (win_name)
endif
define window (win_name) from ul_row,ul_col to ul_row + rows + 1, ul_col + boxsize + 1 double nozoom nogrow float shadow title win_head
activate window (win_name) top
on_row = boxtop
do disprecs

skip boxtop - on_row
on_row = boxtop
do hidisp

private xkey

* xkey is the keystroke that exits the selection loop in pickit

xkey = 0
do pickit
do rest_env with &_setc
if num_rows < 0
   show window (win_name) save
endif
release window (win_name)

if xkey = _esc 
   goto init_recno
endif

return (xkey # _esc)


procedure pickit
private skey, rsave, savrow, helpcnt

* skey is the ASCII value of the last keystroke scanned
* rsave saves the record pointer before a seek or skip action
* savrow holds the highlighted row position before PgUp or PgDn
* helpcnt works as a countdown timer for some inkey() loops


set escape off
do while .t.
   set cursor off
   helpcnt = int(kill_after)              &&  if kill_after < 0, wait forever
   xkey = 0
   do while (xkey = 0) .and. (helpcnt # 0)
      xkey = inkey(1)
      helpcnt = helpcnt - 1
      if between(helpcnt,1,45)
         activate window xlib top
         @ 0,0
         @ 0,0 say str(helpcnt,3)+' seconds left until user declared inactive!'
         ?? chr(7)
      endif
   enddo
   set cursor on
   deactivate window xlib
   if xkey = 0 .and. helpcnt = 0
      unlock all
      do prg_exit with 'Program aborted - no key pressed for '+ltrim(str(kill_after,9))+' seconds'
   endif
     skey = iif(xkey > 0,upper(chr(xkey)),'')
   do case
   case xkey = _esc
      exit
   case ( xkey = _return .and. evaluate(match_test) )
      if len(alltrim(_ret_act)) = 0
          exit
      else
      if .not. ' ' $ alltrim(_ret_act)
          do (_ret_act)
      else
          do &_ret_act
      endif
   case skey >='A' .and. skey <='Z'
      rsave = recno()
      seek key_prefix+skey
      if found()
         do disprecs
         skip boxtop - on_row
         on_row = boxtop
         do hidisp
      else
         ?? _bell_chr
         goto rsave
      endif
   case skey >='0' .and. skey <='9'
      rsave = recno()
      seek key_prefix+skey
      if found()
         do disprecs
         skip boxtop - on_row
         on_row = boxtop
         do hidisp
      else
         ?? _bell_chr
         goto rsave
      endif

   case xkey =  _up .and. .not. bof()
      if on_row > boxtop
         do dis
         on_row = on_row - 1
         skip -1
         do hidisp
      else
         skip -1
         if bof()
            ?? _bell_chr
            goto top
         else
            skip
            do dis
            scroll boxtop, first_col , boxbot, first_col + boxsize - 1, -1
            skip -1
            on_row = boxtop
            do hidisp
         endif
      endif

   case xkey =  _down .and. .not. eof()
      skip
      if eof()
         skip -1
         ?? _bell_chr
         do hidisp
      else
         skip -1
         do dis
         skip
         if on_row < boxbot
            on_row = on_row + 1
         else
            scroll boxtop, first_col , boxbot, first_col + boxsize - 1, 1
            on_row = boxbot
         endif
         do hidisp
      endif

   case xkey =  _pgdn .and. .not. eof()
      savrow = on_row
      skip boxbot - on_row + 1
      if eof()
         ?? _bell_chr
         go bottom
      endif
      do disprecs
      if on_row > savrow
         skip savrow - on_row
         on_row = savrow
      endif
      do hidisp

   case xkey =  _pgup .and. .not. bof()
      savrow = on_row
      skip boxtop - on_row - rows
      if bof()
         ?? _bell_chr
         goto top
      endif
      do disprecs
      skip savrow - on_row
      on_row = savrow
      do hidisp

   case xkey =  _home
      goto top
      do disprecs
      goto top
      on_row = boxtop
      do hidisp

   case xkey =  _end
      goto bott
      skip 1-rows
      if bof()
         go top
      endif
      do disprecs
      do hidisp

   case xkey = _f1
      define window wphelp from 1,1 to 20,78 shadow color scheme 10 title 'Pop-up Selection Help'
      activate window wphelp top
      clear
      ? ' This pop-up box will allow you to choose a specific item from a list of'
      ? ' potential choices by browsing through the list of choices on-screen. Lines'
      ? ' made up entirely of asterisks (*) cannot be selected from the item list.'
      ? ' You may select an item by highlighting your choice and pressing the'
      ? ' <Return> key.  Pressing the <Esc> key exits without selecting an item.'
      ?
      ? " <PgUp> and <PgDn> scroll the selection window up or down a page at a time"
      ? " "+chr(24)+" and "+chr(25)+" scroll the selection window up or down one line at a time"
      ? " <Home> and <End> move to the first and last entries respectively"
      ? " A letter (A-Z) or number (0-9) will jump to the first item starting with"
      ? " that character.  <F2> allows you to specify a search key of more than one"
      ? ' character length.  <F3> moves to the next eligible selection, while <F4>'
      ? ' moves to the previous eligible selection in the list.'
      @ 17,21 SAY "This help box will clear in    seconds"
      clear typeahead
      helpcnt = 30
      do while inkey(1) = 0 .and. helpcnt > 0
         @ 17,49 SAY helpcnt picture '99' color *N/W
         helpcnt = helpcnt - 1
      enddo
      release window wphelp
   case xkey = _f2
      activate window xdlg top
      clear
      accept 'Enter desired key--> ' to skey
      deactivate window xdlg
      rsave = recno()
      skey = key_prefix+upper(skey)
      seek skey
      do while len(skey) > len(key_prefix)+1 .and. .not. found()
         skey = left(skey,len(skey)-1)
         seek skey
      enddo
      if found()
         do disprecs
         skip boxtop - on_row
         on_row = boxtop
         do hidisp
      else
         ?? _bell_chr
         goto rsave
      endif
   case xkey = _f2 - 1 .and. .not. eof()
      rsave = recno()
      skip
      do while .not. (eof() .or. evaluate(match_test) )
         skip
      enddo
      if .not. eof()
         do disprecs
         skip boxtop - on_row
         on_row = boxtop
         do hidisp
      else
         ?? _bell_chr
         goto rsave
      endif
   case xkey = _f2 - 2 .and. .not. bof()
      rsave = recno()
      skip - 1
      do while .not. (bof() .or. evaluate(match_test) )
         skip - 1
      enddo
      if .not. bof()
         do disprecs
         skip boxtop - on_row
         on_row = boxtop
         do hidisp
      else
         ?? _bell_chr
         goto rsave
      endif
   endcase
enddo
return

procedure hidisp
@ on_row,0 say iif(evaluate(match_test),evaluate(disp_arg),repl('*',boxsize)) color N/W
return

procedure dis
@ on_row,0 say iif(evaluate(match_test),evaluate(disp_arg),repl('*',boxsize))
return

procedure disprecs
on_row = boxtop
clear
do while .not. eof() .and. .not. on_row = boxbot + 1
   do dis
   skip
   on_row = on_row + 1
enddo
on_row = on_row - 1
skip -1
return

procedure psb_err
parameters error_msg, bad_var
define window pick_psb from 9,0 to 14,79 panel title 'Window Selection Error'
activate window pick_psb top
clear
@ 0, 38 - (len(error_msg)+1)/2 say error_msg
@ 2, 31  say 'Value passed was:' color +W/N
@ 3,0 say bad_var color +W/N
wait window timeout 60
release window pick_psb
return

function val_crcd
*
*  Validates that the character field contains a valid credit card number
*  using modulo-10 checksumming on alternate digit multipliers
*
parameter cardno
private cksum, is_valid, cardlen, multiplier, i, factor, j
cardno = alltrim(cardno)
cardlen = len(cardno)
is_valid = inlist(cardlen,13,16)
i = cardlen
cksum = 0
multiplier = 1
do while is_valid .and. i > 0
   is_valid = isdigit(subst(cardno,i,1))
   if is_valid
      factor = alltrim(str(val(subst(cardno,i,1))*multiplier))
      for j = 1 to len(factor)
         cksum = cksum + val(subst(factor,j,1))
      endfor
   endif
   i = i - 1
   multiplier = mod(multiplier,2)+1
enddo
is_valid = is_valid .and. (mod(cksum,10) = 0)
return is_valid

function val_isbn
*
*  Validates that a field contains a valid ISBN
*  (International Standard Book Number) - requires a 10-character field
*
parameter test_str

if len(test_str) # 10
   return .f.
endif

if test_str = space(10)
   return .t.
endif

private _wk, chksum

chksum = at(upper(right(test_str,1)), '0123456789X') - 1
if chksum < 0
   return .f.
endif

_wk = ltrim(str(val(left(test_str, 9)),9))
if right(repl('0',8)+_wk,9) # left(test_str,9)
   return .f.
endif

_wk = _wk + ' '
do while len(_wk) > 1
   chksum = chksum + ( (asc(_wk)-48) * len(_wk))
   _wk = subst(_wk,2)
enddo
return ( mod(chksum,11) = 0)

procedure chg_dir
*
*  CHG_DIR()            Change directory on non-default drive
*                       and optionally set new directory as default
*
parameter new_path, set_2_dflt
if parameters() = 0
   wait window '* CHG_DIR() - no path parameter passed' timeout 60
   return .f.
endif
if type('new_path') # 'C'
   wait window '* CHG_DIR() - path parameter was not a char string' timeout 60
   return .f.
endif
if type('set_2_dflt') # 'L'
   set_2_dflt = .f.
endif
private old_drive, failed_cd
old_drive = sys(5)
failed_cd = .f.
on error failed_cd = .t.
set default to (new_path)
do std_sets
if .not. (set_2_dflt .or. failed_cd)
   set default to (old_drive)
endif
return (.not. failed_cd)
  
function isbn_ckd
parameter booknum
private chkdigs,pointer
pointer = 1
chkdigs = '0123456789X*'
do while .not. val_isbn(booknum+subst(chkdigs,pointer,1)
   pointer = pointer + 1
   if pointer > 11
      exit
   endif
enddo
return subst(chkdigs,pointer,1)