Thomas,

How can we define
#define cL_USE_AGAIN .t.

it is actually _triggerlevel > 1, but this fails. How can I set it properly?


>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**