Hi Nadya,

I am getting more doubtful on the validity of my previous assumption:
Is the "Currentrecord" in RIDefinitions guaranteed to stay even when triggers maybe call RI recursively inside each function ?
Since RIDefinitions is always used as alias and the recordponter insn't saved/reset,
any recursion could be dangerous to the correct coverage of the scan-loops.

Check the out the following (mostly done as finger flexing while waiting for another nachine to finish processing -
neither checked nor guaranteed - use to get ideas or at you own risk <g>), especially check the parts with cL_USE_AGAIN...

Hopefully worth more than you paid for it ;-)

regards

thomas

**__RI_HEADER!@ Do NOT REMOVE or MODIFY this line!!!! @!__RI_HEADER**
* Steve Sawyer - Updated 11/22/1999
* Carl Karsten - Updated 12/15/1999
* Doug Hennig  - Updated 02/18/2000

*  Program...........: NEWRI.PRG
*  Author............: Jzanus Dev Team
*  Project...........: Visual Collections
*  Created...........: 04/04/2005  14:28:19
*  Copyright.........: (c) Jzanus LTD, 2005
*) Description.......:
*  Calling Samples...:
*  Parameter List....:
*  Major change list.: Switched from scanning array of relations to table based

* Known limitations:
*	- Cascading updates and deletes for self-joins cause an "illegal recursion"
*		error because the RI code tries to update or delete records in the same
*		table the trigger is fired for, which VFP doesn't allow (all other
*		rules for self-joins are handled correctly)
*	- Compound keys aren't supported

function __RI_Handler
lparameters tcTriggerType

**-- CHANGE - NN - April 04, 2005 - 14:30:12 - added a new global variable
if vartype(m.glDontUseTriggers)="L" and m.glDontUseTriggers
	return && Don't do any validations
endif

local lcTable, ;
	lcAlias, ;
	lcRecordState, ;
	lnTriggerType, ;
	lcDBC, ;
	lcParent, ;
	lcChild, ;
	lcParentKeyExp, ;
	lcChildKeyExp, ;
	lnRIInfo, ;
	luOldKey, ;
	luNewKey, ;
	luOldFK, ;
	luNewFK, luKey, llReturn

* Get the name of the table the trigger was fired for and determine what type
* of trigger was fired.

lcTable       = upper(cursorgetprop('SourceName'))
lcAlias       = alias()
lcRecordState = getfldstate(-1)
llReturn = .t.

** This command is not supported by Ole DB
#define cnERR_TRIGGER_FAILED 1539
#define cnDeleteCode 10
#define cnInsertCode 20
#define cnUpdateCode 30
#define cL_USE_AGAIN .t.
* Trigger failed error number

* If the trigger was passed, use it.
if vartype(m.tcTriggerType) = 'C' and not empty(m.tcTriggerType)
	lnTriggerType = ICASE( ;
			upper(m.tcTriggerType)="DELETE", cnDeleteCode, ;
			upper(m.tcTriggerType)="INSERT", cnInsertCode, ;
			upper(m.tcTriggerType)="UPDATE", cnUpdateCode )
else
* If the deletion status was changed and the record is deleted, this is a
* "DELETE" trigger.
* Define some constants that'll make the code easier to read.
	local ccFLDSTATE_UNCHANGED, ccFLDSTATE_EDITDEL, ccFLDSTATE_NEWUNCHANGED, ccFLDSTATE_NEWCHANGED
	ccFLDSTATE_UNCHANGED	=   '1'
* GETFLDSTATE() 1 = the field is unchanged
	ccFLDSTATE_EDITDEL		=   '2'
* GETFLDSTATE() 2 = the record was edited or deletion status changed
	ccFLDSTATE_NEWUNCHANGED	 =  '3'
* GETFLDSTATE() 3 = a new unchanged field or new undeleted record
	ccFLDSTATE_NEWCHANGED	=   '4'
* GETFLDSTATE() 3 = a new changed field or new deleted record
	do case
	case left(m.lcRecordState, 1) = ccFLDSTATE_EDITDEL and deleted()
		lnTriggerType = cnDeleteCode

* If the deletion status was changed and the record is not deleted, it was
* just recalled, so this is an "INSERT" trigger.

	case left(m.lcRecordState, 1) = ccFLDSTATE_EDITDEL
		lnTriggerType = cnInsertCode

* If this is a new record, this is an "INSERT" trigger.

	case ccFLDSTATE_NEWUNCHANGED $ m.lcRecordState or ;
			ccFLDSTATE_NEWCHANGED $ m.lcRecordState
		lnTriggerType = cnInsertCode

* Some field in the table has been changed, so this is an "UPDATE" trigger.

	case ccFLDSTATE_EDITDEL $ m.lcRecordState
		lnTriggerType = cnUpdateCode

* Carl Karsten found a weird bug in VFP: if you have a table with a memo field
* and delete a record such that the subsequent records have to be physically
* moved when you PACK, the "UPDATE" trigger for the table fires when you move
* the record pointer or close the table. In that case, we'll ignore it.

	case m.lcRecordState = replicate(ccFLDSTATE_NEWUNCHANGED, len(m.lcRecordState))
		return
	endcase
endif

* If we're at the top trigger level, start a transaction, create an error flag
* and array variables, get a snapshot of open tables, and set up the
* environment the way we need it.

if _triggerlevel = 1
	private plError
	plError = .f.
	release gaErrors
	public gaErrors[1, 12]

	private paUsed[1], ;
		pcExact, ;
		pcANSI, ;
		pcDeleted, ;
		pcOnEscape, ;
		pcError, ;
		pcOldDBC, plError

	aused(paUsed)
	pcExact  = set('EXACT')
	pcANSI   = set('ANSI')
	pcDeleted = set('DELETED')
	pcError   = on('ERROR')
	pcOnEscape = on('escape')
	pcOldDBC = iif(empty(dbc()), '', '"' + dbc() + '"')

* this command is not supported in Ole Db
	on escape RICleanUp(.t.)

	set exact on
	set ansi on
	set deleted on
	on error LogRIError(error(),message()) &&plError = .t.
	#if cL_USE_AGAIN
		SELECT 0
		use RIDefinitions AGAIN
		LOCAL lnSelRIDefi
		lnSelRIDefi = SELECT()
	#else
		if not used('RIDefinitions')
			use RIDefinitions in 0 && Open table with RI Definitions
		ENDIF
	#endif
	begin transaction
endif

if not m.plError
	lcDBC = cursorgetprop('Database')
	set database to (m.lcDBC)
	local lcParentTag, lcSearch
	store "" to lcParentKeyExp, lcChildKeyExp, lcParentTag

	lcSearch = padr(m.lcTable,128)
	lcParent = m.lcTable
	#if cL_USE_AGAIN
		SELECT (m.lnSelRIDefi)
	#else
		select RIDefinitions
	#endif
	scan for upper(ParentTB) = m.lcSearch and alltrim(ParentTag)<> m.lcParentTag and not m.plError

		lcParentTag  = alltrim(ParentTag)

		do case

* If this is an update trigger and this relation has our table as the parent,
* let's process it. We'll ignore it if the RI rule is empty or "ignore".

		case m.lnTriggerType = cnUpdateCode
			if UpdTrigger > 0 && not ignore
				if not alltrim(ParentKey) == m.lcParentKeyExp && So it would calculate it only once
					lcParentKeyExp = alltrim(ParentKey)
					luOldKey       = oldval(m.lcParentKeyExp, m.lcAlias)
					luNewKey       = evaluate(IIF("."$m.lcParentKeyExp, "", m.lcAlias + ".") + m.lcParentKeyExp ) 
				endif

* If this is a self-join, we may have an update trigger because the FK field
* in the "child" copy of the table was changed (which really is an insert
* trigger), so let's handle it if we have a restrict insert rule. The reason
* we don't handle it in a CASE below is that the user may have changed both
* the parent and foreign key fields.

				if m.lcParent ==  alltrim(ChildTB) && very rare case
					luOldFK = oldval(m.lcChildKeyExp, m.lcAlias)
					luNewFK = evaluate(IIF("."$m.lcChildKeyExp, "", m.lcAlias + ".") + m.lcChildKeyExp

** Restrict ?
					if InsTrigger = 1 ;
							and not isnull(m.luOldFK) ;
							and not isnull(m.luNewFK) ;
							and m.luOldFK <> m.luNewFK
						Restrict_Insert(m.luNewFK, "UPDATE")
					endif luOldFK <> luNewFK ...
				endif lcParent = lcChild

				do case

* The parent key wasn't changed or an error occurred, so we have nothing to do.

				case m.plError or m.luOldKey = m.luNewKey

* If the parent key has been changed, call the appropriate function, depending
* on whether this is a cascade or restrict rule.

				case m.lnRIInfo = 2 AND not isnull(m.luOldKey) && 'Cascade'
					Cascade_Update(m.luOldKey, m.luNewKey, alltrim(ChildKey))

				case m.lnRIInfo = 1 AND not isnull(m.luOldKey) && Restrict
					Restrict_Update(m.luOldKey, m.luNewKey)

				endcase
			endif

* If this is a delete trigger and this relation has our table as the parent,
* let's process it. We'll ignore it if the RI rule is empty or "ignore".

		case m.lnTriggerType = cnDeleteCode
			if DelTrigger > 0
				if not alltrim(ParentKey) == m.lcParentKeyExp && So it would calculate it only once
						lcParentKeyExp = alltrim(ParentKey)
						*-- iif can be eliminated/replaced by concat if no alias is ever present in parentkey...
						luKey = evaluate(IIF("."$m.lcParentKeyExp, "", m.lcAlias + ".") + m.lcParentKeyExp ) 
				endif
				
* Call the appropriate function, depending on whether this is a cascade or
* restrict rule.
				= ICASE(isnull(m.luKey), .f., ;
						DelTrigger = 2, Cascade_Delete(m.luKey, alltrim(ChildKey)), ;
						DelTrigger = 1, Restrict_Delete(m.luKey) )
			endif
		endcase

	endscan

** Now do the same for the child
	if inlist(m.lnTriggerType,cnInsertCode,cnUpdateCode) && there are no restrictions on delete, if it's a child table
		#if cL_USE_AGAIN
			SELECT (m.lnSelRIDefi)
		#else
			select RIDefinitions
		#endif
		lcChild = m.lcTable
		lcChildKeyExp = ""

		scan for upper(ChildTB) = m.lcSearch and InsTrigger = 1 and not m.plError

			if vartype(m.pcCascadeParent) = "C" and m.pcCascadeParent = alltrim(ParentTB)			
** In this case we do nothing - otherwise we're burried in recursion
			else

* If this relation has our table as the child, let's process it. We'll only
* process a "restrict" rule in either an insert or update trigger.
				if not m.lcChildKeyExp == alltrim(ChildKey) && we don't want to evaluate more times than needed
					lcChildKeyExp = alltrim(ChildKey)
					luNewKey  = evaluate(IIF("."$m.lcChildKeyExp, "", m.lcAlias + ".") + m.lcChildKeyExp
					luOldKey = oldval(m.lcChildKeyExp, m.lcAlias)
				endif

* If this is an insert trigger or if it's an update trigger and the foreign key
* has changed, call the Restrict_Insert function to ensure the foreign key
* exists in the parent table.

				if !isnull(m.luNewKey) AND (m.lnTriggerType = cnInsertCode or m.luOldKey <> m.luNewKey)
					Restrict_Insert(m.luNewKey, "INSERT")
				endif 
			endif
		endscan
	endif
endif

* If we're at the top trigger level, either end the transaction or roll it
* back, depending on whether the trigger succeeded or not, close any tables we
* opened, restore the things we changed, and return whether we succeeded or
* not.
if _triggerlevel = 1
	=RICleanUp(.f.)
* If we're not at the top trigger level, return .T. so we don't trigger an
* error yet.
	llReturn = not m.plError
endif _triggerlevel = 1
return m.llReturn

* CleanUp procedure
function RICleanUp(tlEscaped)
if m.tlEscaped and messagebox("Are you sure you want to stop the trigger's execution?",4+16,"Stop execution") = 7
**
	retry
else

	#if cL_USE_AGAIN
		USE IN (m.lnSelRIDefi)
	#endif
	local lnTables, laTables[1], lnI
	if not empty(m.pcOldDBC)
		set database to (m.pcOldDBC)
	endif
	if _triggerlevel = 1
		if m.plError or m.tlEscaped
			rollback
		else
			end transaction
		endif plError
		
** Gregory Adam suggested in the thread #<A HREF="/wconnect/wc.dll?LevelExtreme~2,15,1002645">1002645</A> to only close tables in Default DS
		if set("Datasession") > 1 or vartype(m.glLeaveTablesOpen)="L" and m.glLeaveTablesOpen && we're dealing with private DS, don't need to close
		else
			lnTables = aused(laTables)
			for lnI = 1 to m.lnTables
				lcTable = laTables[m.lnI, 1]
				if not empty(m.lcTable) and ascan(paUsed, m.lcTable) = 0
					use in (m.lcTable)
				endif not empty(lcTable) ...
			next lnI

		endif

		if m.pcExact = "OFF"
			set exact off
		endif

		if m.pcANSI = "OFF"
			set ansi off
		endif

		if m.pcDeleted = "OFF"
			set deleted off
		endif
		on error &pcError
** this command is not supported in Ole Db
		on escape &pcOnEscape
	endif
endif
return

* Cascade update function: change the foreign key field in all child records
* that belong to the parent record.

function Cascade_Update
lparameters tuOldKey, tuNewKey, tcChildKey
* call 3. parameter with alltrim(ChildKey)

*-- necessary ? if so, replace further down with this private...
private pcCascadeParent
pcCascadeParent = alltrim(ParentTB)
* Do the cascading update. Log any error that occurred.
update (m.pcCascadeParent) ;
	set &tcChildKey = m.tuNewKey ;
	where &tcChildKey = m.tuOldKey

if m.plError
	local laError[1], tcParentKey
	aerror(laError)

	LogRIError(laError[1], laError[2], 'Cascade Update', ;
		m.pcCascadeParent, .f., alltrim(ParentKey), m.tuNewKey, ;
		alltrim(ChildTB), 0, m.tcChildKey, m.tuOldKey)
endif && plError
return

* Cascade delete function: delete all child records that belong to the parent
* record.

function Cascade_Delete
lparameters tuOldKey, tcChildKey

delete ;
	from (ChildTB) ;
	where &tcChildKey = m.tuOldKey

if m.plError
	local laError[1]
	aerror(laError)

	LogRIError(laError[1], laError[2], 'Cascade Delete', ;
		alltrim(ParentTB), .f., alltrim(ParentKey), m.tuOldKey, ;
		alltrim(ChildTB), 0, m.tcChildKey, m.tuOldKey)
endif && plError
RETURN

* Restrict delete function: see if there are any records in the specified child
* table matching the specified key in the parent table.

function Restrict_Delete
lparameters tuKey

local lcTable
lcTable = strtran(m.tcChildTable, ' ', '_')

if not used(m.lcTable)
	use (m.tcChildTable) again in 0 shared alias (m.lcTable)
endif &¬ used(lcTable)

**** WHERE IS m.tcTag comin from now ??? was commented out but not in the new code ??
if indexseek(m.tuKey, .f., m.lcTable, m.tcTag) && Record exists
*	if keymatch(m.tuKey,tagno(m.tcTag, '', m.lcTable), m.lcTable) && Record exists
	plError = .t.
	LogRIError(cnERR_TRIGGER_FAILED, 'Trigger Failed', 'Restrict Delete', ;
		alltrim(ParentTB), .f., alltrim(ParentKey), m.tuKey, ;
		alltrim(ChildTB), 0, alltrim(ChildKey), m.tuKey)
endif &&_tally > 0
RETURN

* Restrict update function: see if there are any records in the specified child
* table matching the specified key in the parent table.

function Restrict_Update
lparameters tuOldKey, tuNewKey

local lcTable
lcTable = strtran(alltrim(ChildTB), ' ', '_')

if not used(m.lcTable)
	use (alltrim(ChildTB)) again in 0 shared alias (m.lcTable)
endif && not used(lcTable)

if indexseek(m.tuOldKey, .f., m.lcTable, alltrim(ChildTag)) && Record exists
	plError = .t.
	LogRIError(cnERR_TRIGGER_FAILED, 'Trigger Failed', 'Restrict Update', ;
		alltrim(ParentTB), .f., alltrim(ParentKey), m.tuNewKey, ;
		alltrim(ChildTB), 0, alltrim(ChildKey), m.tuOldKey)
endif
RETURN

* Restrict insert function: ensure a record in the parent table for the foreign
* key exists.
* CFK - 5/28
* Or if the foreign key is null, no parent record is needed.
* The logic is this:
*  if you specify in the dbc that a child cannot exist with out a parent,
*    you can laxly enforce that by allowing nulls in that feild
*    and this code will allow that setting to be overridden
*    by setting the foreign key to null
*  or,
*  you can strictly enforce it by not allowing nulls, and then it will
*    pass this test, but fail the "allow nulls" test that the
*    database engine enforces.

function Restrict_Insert
lparameters tuKey, tcTriggerType

* CFK - 5/28
* If the key is Null, don't check for a parent, let it pass.

local lcTable
lcTable = strtran(alltrim(ParentTB), ' ', '_')

if not used(m.lcTable)
	use (alltrim(ParentTB)) again in 0 shared alias (m.lcTable)
ENDIF && not used(lcTable)

if not indexseek(m.tuKey,.f.,m.lcTable,alltrim(ParentTag))
	plError = .t.
	LogRIError(cnERR_TRIGGER_FAILED, 'Trigger Failed', 'Restrict ' + proper(m.tcTriggerType), ;
		alltrim(ParentTB), 0, alltrim(ParentKey), 'Not Found', ;
		alltrim(ChildTB), .f., alltrim(ChildKey), m.tuKey)
endif
RETURN


* Log errors to the public gaError array.
procedure LogRIError(tnErrNo, ;
	tcMessage, ;
	tcCode, ;
	tcParentTable, ;
	tnParentRec, ;
	tcParentExp, ;
	tuParentKey, ;
	tcChildTable, ;
	tnChildRec, ;
	tcChildExp, ;
	tuChildKey)

IF VARTYPE(m.tnParentRec)!="N"
	tnParentRec = iif(used(m.tcParentTable),recno(m.tcParentTable), 0)
ENDIF

IF VARTYPE(m.tnChildRec)!="N"
	tnChildRec = iif(used(m.tcChildTable),recno(m.tcChildTable), 0)
ENDIF

local lnErrorRows, ;
	lnLevel

plError = .t.
* Add another row to the error array if necessary.

lnErrorRows = alen(gaErrors, 1)
if type('gaErrors[lnErrorRows, 1]') <> 'L'
	lnErrorRows = lnErrorRows + 1
	dimension gaErrors[lnErrorRows, alen(gaErrors, 2)]
endif type('gaErrors[lnErrorRows, 1]') <> 'L'

* Log the error information, including the parameters passed to us and the
* program stack.

gaErrors[lnErrorRows,  1] = tnErrNo
gaErrors[lnErrorRows,  2] = tcMessage
gaErrors[lnErrorRows,  3] = evl(tcCode,"")
gaErrors[lnErrorRows,  4] = ''
for lnLevel = 1 to program(-1)
	gaErrors[lnErrorRows,  4] = gaErrors[lnErrorRows, 4] + ',' + ;
		program(lnLevel)
next lnLevel
gaErrors[lnErrorRows,  5] = evl(tcParentTable,"")
gaErrors[lnErrorRows,  6] = evl(tnParentRec,0)
gaErrors[lnErrorRows,  7] = evl(tuParentKey,"")
gaErrors[lnErrorRows,  8] = evl(tcParentExp,"")
gaErrors[lnErrorRows,  9] = evl(tcChildTable,"")
gaErrors[lnErrorRows, 10] = evl(tnChildRec,0)
gaErrors[lnErrorRows, 11] = evl(tuChildKey,"")
gaErrors[lnErrorRows, 12] = evl(tcChildExp,"")
return tnErrNo

**__RI_FOOTER!@ Do NOT REMOVE or MODIFY this line!!!! @!__RI_FOOTER**