*******************************************************************************
*									      *
*	Author - Nick Makris - STARTECH SYSTEMS - San Francisco, CA	      *
*	Date  -	 NOVEMBER 1988						      *
*									      *
*		********* SAMPLE LOCKING ERROR PROGRAMS *********	      *
*									      *
*		*********      NO RIGHTS RESERVED       *********	      *
*									      *
*******************************************************************************

*****************************  SAMPLE APPLICATION  ****************************

WTIME=10
MEXIT=.F.
IF NETWORK()				&& NEED TO CHECK IF ABLE TO LOCK RECORD
	 ON ERROR DO RTRAP WITH PROGRAM(),LINENO()
	 IF RLOCK()			&& FLOCK() WILL ALSO WORK HERE
	    ON ERROR
	    IF ISCOLOR()
	       SET COLOR TO W+/N
	    ENDIF
	    DO APPLCALL			&& EVERYTHING IS OK
	 ELSE 
	    DO LERRTRAP WITH .T.,LKSYS(2)
	    IF MEXIT
	       TDISP = .F.
	    ELSE
	       ON ERROR DO RTRAP WITH PROGRAM(),LINENO()
	       IF RLOCK()
		  ON ERROR
		  IF ISCOLOR()
		     SET COLOR TO &RCOLOR
		  ENDIF
		  DO APPLCALL		&& EVERYTHING IS OK
	       ELSE
		  DO LERRTRAP WITH .F.,LKSYS(2)
		  TDISP = .F.
	       ENDIF
	    ENDIF
	 ENDIF
	 ON ERROR
ELSE					&& STANDALONE SYSTEM
	 DO APPLCALL			&& EVERYTHING IS OK
ENDIF



PROCEDURE LERRTRAP
PARAMETERS ERR,EUID

****** ERR  = .F. = CALLED MORE THAN ONCE - ABORT
****** ERR  = .T. = PROGRAM WAITS
****** EUID = LKSYS(2) (NETWORK USERID) WHO HAS RECORD LOCKED

WTIME=10
IF ISCOLOR()
   SET COLOR TO W+/N
ENDIF
@YROW-1,2 CLEAR TO YROW+5,78
@YROW-1,2 TO YROW+5,77 DOUBLE
IF ISCOLOR()
   SET COLOR TO W+/R
ENDIF
@YROW,26 SAY "JOB FILE RECORD LOCKED MENU"
IF ISCOLOR()
   SET COLOR TO GR+/N
ENDIF
IF ERR
   @YROW+2,20 SAY "PLEASE WAIT JOB "
   SET COLOR TO W+/N
   @ROW(),COL() SAY PROBLVAR 
   IF ISCOLOR()
      SET COLOR TO GR+/N
   ENDIF
   @ROW(),COL()+1 SAY " IS LOCKED BY"
   SET COLOR TO W+/N
   @ROW(),COL()+2 SAY EUID && THE USER CAUSING THE ERROR
   IF ISCOLOR()
      SET COLOR TO GR+/N
   ENDIF
   @YROW+3,10 SAY "WAITING "
   IF ISCOLOR()
      SET COLOR TO W+/R
   ENDIF
   @ROW(),COL() SAY  STR(WTIME,2,0)
   IF ISCOLOR()
      SET COLOR TO GR+/N
   ENDIF
   @ROW(),COL() SAY " SECONDS FOR LOCK TO CLEAR PRESS Esc  TO ABORT."
   DO RLOCKTST WITH WTIME
ELSE
   @YROW+3,14 SAY "JOB "
   IF ISCOLOR()
      SET COLOR TO W+/R
   ENDIF
   @ROW(),COL() SAY PROBLVAR
   IF ISCOLOR()
      SET COLOR TO GR+/N
   ENDIF
   @ROW(),COL() SAY " IS STILL LOCKED BY"
   IF ISCOLOR()
      SET COLOR TO W+/R
   ENDIF
   @ROW(),COL()+1 SAY EUID && THE USER CAUSING THE ERROR
   IF ISCOLOR()
      SET COLOR TO GR+/N
   ENDIF
   @ROW(),COL()+1 SAY "JOB SELECTION ABORTED."
   X=INKEY(WTIME)
ENDIF
IF ISCOLOR()
   SET COLOR TO &RCOLOR
ENDIF
ON ERROR
RETURN

PROCEDURE RLOCKTST
PARAMETERS MTIME

WTIME=10
II = 0
MEXIT = .F.
ON ERROR DO RTRAP WITH PROGRAM(),LINENO()
DO WHILE .NOT. RLOCK() .AND. II < MTIME
 II = II + 1
 TZP = INKEY(1)  && WAITS ONE SECOND BEFORE LOOP
 IF TZP = 27
    MEXIT = .T.
    EXIT
 ENDIF
ENDDO
ON ERROR
RETURN



PROCEDURE RTRAP

PARAMETERS PROGRAM,LINENO

***** PROCEDURE TO FOOL THE DBASE 'ON ERROR' code.....
***** THESE ARE THE ONLY VALID ERROR CODES ON A RECORD LOCK

IF ERROR() # 372 .AND. ERROR() # 373 .AND. ERROR() # 108 .AND. ERROR() # 109
  do systerr WITH PROGRAM,LINENO
ENDIF 
return

PROCEDURE SYSTERR
PARAMETERS PROGRAM,LINENO

********  WHEN ALL ELSE FAILS - ONLY CALLED FROM RTRAP ABOVE

load prtscrn.bin		&& PROVIDED ON DISK
call prtscrn
release module prtscrn
EJECT
SET PRINTER ON
SET CONSOLE OFF
LIST HISTORY TO PRINT
LIST STATUS TO PRINT
LIST MEMORY TO PRINT
SET CONSOLE ON
SET PRINTER OFF
EJECT
cause = str(error(),4)
message = MESSAGE()
if network()
 load netlog.bin && PROVIDED ON DISK
 call netlog with 'User = '+userid+'!  Program '+program+', line = '+ltrim(str(lineno,6))+'!'
 call netlog with 'Dbase error code = '%2bcause%2b.html'!  Dbase message ='+message+'!'
 release module netlog
endif
if iscolor()
  set color to W+/R
else
  set color to W+/N,N/W
endif
@10,14 clear TO 19,65
if iscolor()
  set color to n/W
endif
@10,14 TO 19,65 DOUBLE
if iscolor()
  set color to W+/R
endif
@11,20 SAY "------ UNANTICIPATED PROGRAM ERROR ------"
@13,19 SAY "dBASE ERROR CODE --- "+cause
@14,19 SAY message
@15,19 SAY 'Source was '+program+', at line '+ltrim(str(lineno,6))+'!'
@16,19 SAY 'Copy to be sent to the printer!!!'
@17,19 say 'Mail listings to STARTECH Systems!'
ON ERROR
set color to w/
do setdevpt
@11,6 SAY  DTOC(DATE())
@11,18 SAY "------ UNANTICIPATED PROGRAM ERROR ------"
@11,63 SAY  TIME()
@13,19 SAY "dBASE ERROR CODE --- "+cause
@14,19 SAY UPPER(message)
@15,19 SAY 'Source was '+program+', at line '+ltrim(str(lineno,6))+'!'
@16,19 say 'Mail to STARTECH Systems!'
@17,19 say '12 Longview Court'
@18,19 say 'San Francisco, CA 94131'
@25,10 SAY "------- PLEASE PROVIDE THE FOLLOWING INFORMATION -------"
@30,6 SAY "Company name ____________________________________________"
@32,6 SAY "Your name _______________________________________________"
@34,6 SAY MHOMETELNO
@36,6 SAY "Best time to contact you ________________________________"
@38,6 SAY "Original program that was run ___________________________"
SET DEVICE TO SCREEN
@22,4 SAY 'NOTIFIY THE SYSTEM MANAGER OF THIS PROBLEM - PROGRAM WILL NOW TERMINATE!'
EJECT
CLOSE ALL
CLEAR ALL
CANCEL

PROCEDURE PABORT

********** THIS IS ANOTHER EXAMPLE OF A LOCKING ERROR OPTION

WTIME=10
IF LEN(LKSYS(2)) = 0			&& NO USER ID AVAILABLE WHEN FILE
   @ROW(),COL()+2 SAY " EXCLUSIVE  "	&& IS LOCKED (USED) EXCLUSIVELY
ELSE
   @ROW(),COL()+2 SAY LKSYS(2)		&& USER ID
ENDIF
@ROW()+ 2,32  SAY "PROGRAM ABORTED."
X=INKEY(WTIME)
CLOSE DATABASES
RETURN TO MASTER


PROCEDURE EXCLLOCK
PARAMETER FILTOLCK,FILELOCKED

******* TO BLINDLY LOCK A FILE WITH EXCLUSIVE USE
******* CHANGE CODE FOR FILES IN OTHER DIRECTORIES

WTIME=10
FILTOLCK=UPPER(TRIM(FILTOLCK))
FILELOCKED=.T.
TCWEA = ALIAS()
SAVE SCREEN TO FILLCK
IF NETWORK()
 ON ERROR DO DUMMY1			&& ANY ERROR MEANS THE FILE WAS NOT SELECTED
 USE &FILTOLCK EXCL IN SELECT()
 ON ERROR
 IF SELECT() # 10
  SELECT SELECT()+1
 ELSE
  SELECT 10
 ENDIF
 IF UPPER(TRIM(ALIAS())) # FILTOLCK	&& SELECTED FILE PREVIOUSLY IN USE
   SET COLOR TO W+/W
   @ 11,18 CLEAR TO 13,62
   @ 11,18 TO 13,62 DOUBLE
   @ 12, 20 SAY "UNABLE TO USE FILE "+FILTOLCK+" EXCLUSIVELY!"
   X=INKEY(WTIME)
   RESTORE SCREEN FROM FILLCK
   IF LEN(TRIM(TCWEA)) # 0
    SELECT &TCWEA			&& SELECTED AREA PREVIOUSLY IN USE
   ENDIF
   FILELOCKED=.F.
   RETURN
  ENDIF
ELSE
  USE &FILTOLCK IN SELECT()
ENDIF
SELECT &FILTOLCK
RETURN


PROCEDURE CHKACCESS

* The following commented code should provide security on a Novell network
* where certain users are denied any rights to the given directory.  The 
* file can be a null file of any name.  Note the absence of a check to 
* determine if the system is on a network - this works either way and
* requires that the directory/file should be present on both.

* IF .NOT. FILE("\ACCESS\CHECK\CHECK.ACC") && THIS CODE SHOULD WORK ON BOTH
*   CLEAR				  && STANDALONE & NETWORKED SYSTEMS	
*   @15,8 say "Need to have access rights to checking/accounting system for this command!"
*   @17,8 say "See the system manager about obtaining those rights!"
*   TZP = INKEY(DTIME)
*   return
* ENDIF

ECOLOR1 = "W+/BG" && enhanced display color all information except.
ECOLOR2 = "W+/GR" && enhanced display color for selected employee.
ECOLOR3 = "  /  ," + ECOLOR1 && enhanced display color for selected employee.
IF NETWORK()			&& CAN'T LOCK FILES ON A STAND ALONE SYSTEM
     SELECT SELECT()
     USE PROCSTAT		&& PROCESS STATUSE FILE
     GO 5
     ON ERROR DO RTRAP WITH PROGRAM(),LINENO()
     IF RLOCK()
        on error
     ELSE
	RESTORE SCREEN FROM MAIN
	SET COLOR TO &SVCOLOR
	@ 12, 18 SAY "THE CHECKING PROCESS IS LOCKED BY"
	IF ISCOLOR()
	   SET COLOR TO &ECOLOR2
	ENDIF
	@ ROW(), COL() + 2 SAY LKSYS(2)
	IF ISCOLOR()
	   SET COLOR TO GR+/N
	ENDIF
	ON ERROR
	RETURN TO MASTER
     ENDIF
ENDIF