Hi everybody,

I was trying to use Steve Saywer's/Doug Henning's RI builder. The idea of using just one simple procedure instead of lots of multiple convoluted procedures is very appealing. I made bunch of modifications in Doug's code trying to optimize this procedure. Perhaps, I made it worse than before. The code originally used Select-SQL for restrict triggers (insert/update/delete). I switched to IndexSeek. The code also looped through array of relationships, I changed it slightly to use ASCAN. In my opinion these changes should have speed the procedure up. Anyway, comparing with the old native RI it seems to be much slower. I'm thinking that I may use KEYMATCH instead of INDEXSEEK. Would it make it run faster? Bellow is the code as I have right now. I would appreciate if you can point me to the problematic pieces. I also tried to incorporate Glen's idea of save/restore environment logic. However, it adds a layer of complexity, which is probably undesired...

**__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.:

* 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(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, ;
	lcTriggerType, ;
	lcDBC, ;
	laRelations[1], ;
	lnRelations, ;
	lcRIInfo, ;
	lcParent, ;
	lcChild, ;
	lcParentKeyExp, ;
	lcChildKeyExp, ;
	luOldKey, ;
	luNewKey, ;
	luOldFK, ;
	luNewFK

* Define some constants that'll make the code easier to read.

#define cnCHILDCOL				   1
* The column in the relations array for the child table
#define cnPARENTCOL				   2
* The column in the relations array for the parent table
#define cnCHILDKEYCOL			   3
* The column in the relations array for the child tag
#define cnPARENTKEYCOL			   4
* The column in the relations array for the parent tag
#define cnRIINFOCOL				   5
* The column in the relations array for the RI information
#define cnRIINFO_UPDATE			   1
* The position in the RI information for the update rule
#define cnRIINFO_DELETE			   2
* The position in the RI information for the delete rule
#define cnRIINFO_INSERT			   3
* The position in the RI information for the insert rule
#define ccFLDSTATE_UNCHANGED	   '1'
* GETFLDSTATE() 1 = the field is unchanged
#define ccFLDSTATE_EDITDEL		   '2'
* GETFLDSTATE() 2 = the record was edited or deletion status changed
#define ccFLDSTATE_NEWUNCHANGED	   '3'
* GETFLDSTATE() 3 = a new unchanged field or new undeleted record
#define ccFLDSTATE_NEWCHANGED	   '4'
* GETFLDSTATE() 3 = a new changed field or new deleted record
#define cnERR_TRIGGER_FAILED	1539
* Trigger failed error number

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

do case

* If the trigger was passed, use it.

case vartype(m.tcTriggerType) = 'C' and not empty(m.tcTriggerType)
	lcTriggerType = upper(m.tcTriggerType)

* If the deletion status was changed and the record is deleted, this is a
* "DELETE" trigger.

case left(m.lcRecordState, 1) = ccFLDSTATE_EDITDEL and deleted()
	lcTriggerType = 'DELETE'

* 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
	lcTriggerType = 'INSERT'

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

case ccFLDSTATE_NEWUNCHANGED $ m.lcRecordState or ;
		ccFLDSTATE_NEWCHANGED $ m.lcRecordState
	lcTriggerType = 'INSERT'

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

case ccFLDSTATE_EDITDEL $ m.lcRecordState
	lcTriggerType = 'UPDATE'

* 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


* 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.
local llManualCleanUp, loSession
llManualCleanUp = .f.

if _triggerlevel = 1
	private plError
	plError = .f.
	release gaErrors
	public gaErrors[1, 12]
	try
		loSession = newobject('aSessionEnvironment','aEnviron.vcx')
	catch
		llManualCleanUp = .t.
		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')
		on escape RICleanUp(.t.)
	endtry

	set exact on
	set ansi on
	set deleted on
	on error LogRIError(error(),message()) &&plError = .t.
	begin transaction
endif

if vartype(m.plError) = "L" and m.plError
** Error occurred
else
* Select the database the table belongs to and get an array of relations.

	pcOldDBC = iif(empty(dbc()), '', '"' + dbc() + '"')
	lcDBC    = cursorgetprop('Database')
	set database to (m.lcDBC)
	lnRelations = adbobjects(laRelations, 'RELATION')

	local lnTParent, lnTChild, lnI, lcChildTag, lcParentTag
	store 0 to lnTParent, lnTChild
	store "" to lcParentKeyExp, lcChildKeyExp

** First search in the parent column
	lnTParent = ascan(laRelations, m.lcTable, m.lnTParent  + 1, ;
		m.lnRelations , cnPARENTCOL, 8)

	do while between(m.lnTParent,1,m.lnRelations)  and not m.plError
		lnI = m.lnTParent

		lcParent = laRelations[m.lnI, cnPARENTCOL]
		lcChild  = laRelations[m.lnI, cnCHILDCOL]
		lcRules  = upper(laRelations[m.lnI, cnRIINFOCOL])

		lcParentTag  = laRelations[m.lnI, cnPARENTKEYCOL]

		lcChildTag  = laRelations[m.lnI, cnCHILDKEYCOL]

		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.lcTriggerType = 'UPDATE' and m.lcParent = m.lcTable
			lcRIInfo = substr(m.lcRules, cnRIINFO_UPDATE, 1)
			if not empty(m.lcRIInfo) and m.lcRIInfo <> 'I'
				lcParentKeyExp = key(tagno(laRelations[m.lnI, cnPARENTKEYCOL], ;
					'', m.lcAlias), m.lcAlias)
				lcChildKeyExp  = GetKeyIndexExp(m.lcChild, ;
					laRelations[m.lnI, cnCHILDKEYCOL])
				luOldKey       = oldval(m.lcParentKeyExp)
				luNewKey       = evaluate(m.lcParentKeyExp)

* 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 == m.lcChild
					luOldFK = oldval(m.lcChildKeyExp)
					luNewFK = evaluate(m.lcChildKeyExp)
					if m.luOldFK <> m.luNewFK and ;
							substr(m.lcRules, cnRIINFO_INSERT, 1) = 'R'
						Restrict_Insert(m.lcParent, m.lcChild, m.lcParentKeyExp, ;
							m.lcChildKeyExp, m.luNewFK, m.lcTriggerType, m.lcParentTag )
					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.lcRIInfo = 'C'
					Cascade_Update(m.lcParent, m.lcChild, m.lcParentKeyExp, ;
						m.lcChildKeyExp, m.luOldKey, m.luNewKey)
				case m.lcRIInfo = 'R'
					Restrict_Update(m.lcParent, m.lcChild, m.lcParentKeyExp, ;
						m.lcChildKeyExp, m.luOldKey, m.luNewKey, m.lcChildTag)
				endcase
			endif not empty(lcRIInfo) ...

* 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.lcTriggerType = 'DELETE' and m.lcParent == m.lcTable
			lcRIInfo = substr(m.lcRules, cnRIINFO_DELETE, 1)
			if not empty(m.lcRIInfo) and m.lcRIInfo <> 'I'
				lcParentKeyExp = key(tagno(laRelations[m.lnI, cnPARENTKEYCOL], ;
					'', m.lcAlias), m.lcAlias)
				lcChildKeyExp  = GetKeyIndexExp(m.lcChild, ;
					laRelations[m.lnI, cnCHILDKEYCOL])
				luKey          = evaluate(m.lcParentKeyExp)

* Call the appropriate function, depending on whether this is a cascade or
* restrict rule.

				do case
				case m.lcRIInfo = 'C'
					Cascade_Delete(m.lcParent, m.lcChild, m.lcParentKeyExp, ;
						m.lcChildKeyExp, m.luKey)
				case m.lcRIInfo = 'R'
					Restrict_Delete(m.lcParent, m.lcChild, m.lcParentKeyExp, ;
						m.lcChildKeyExp, m.luKey, m.lcChildTag)
				endcase
			endif not empty(lcRIInfo) ...
		endcase

		lnTParent = ascan(laRelations, m.lcTable, m.lnI + 1, ;
			m.lnRelations - m.lnI, cnPARENTCOL, 8)
	enddo

** Now do the same for the child column
	lnTChild = ascan(laRelations, m.lcTable, m.lnTChild  + 1, m.lnRelations , cnCHILDCOL, 8)

	do while m.lnTChild > 0  and not m.plError
		lnI = m.lnTChild
		lcParent = laRelations[m.lnI, cnPARENTCOL]
		lcChild  = laRelations[m.lnI, cnCHILDCOL]
		lcRules  = upper(laRelations[m.lnI, cnRIINFOCOL])

		lcParentTag  = laRelations[m.lnI, cnPARENTKEYCOL]

		lcChildTag  = laRelations[m.lnI, cnCHILDKEYCOL]

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

*case lcChild = lcTable
		lcRIInfo = substr(m.lcRules, cnRIINFO_INSERT, 1)
		if m.lcRIInfo = 'R'
			lcParentKeyExp = GetKeyIndexExp(m.lcParent, ;
				laRelations[m.lnI, cnPARENTKEYCOL])
			lcChildKeyExp  = key(tagno(laRelations[m.lnI, cnCHILDKEYCOL], ;
				'', m.lcAlias), m.lcAlias)
			luKey          = evaluate(m.lcChildKeyExp)

* 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 m.lcTriggerType <> 'UPDATE' or oldval(m.lcChildKeyExp) <> m.luKey
				Restrict_Insert(m.lcParent, m.lcChild, m.lcParentKeyExp, ;
					m.lcChildKeyExp, m.luKey, m.lcTriggerType, m.lcParentTag)
			endif lcTriggerType <> 'UPDATE' ...
		endif lcRIInfo = 'R'
		lnTChild = ascan(laRelations, m.lcTable, m.lnI + 1, ;
			m.lnRelations - m.lnI, cnCHILDCOL, 8)
	enddo
* 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 m.llManualCleanUp
		=RICleanUp(.f.)
	else
		if m.plError
			rollback
		else
			end transaction
		endif plError
	endif

* If we're not at the top trigger level, return .T. so we don't trigger an
* error yet.
endif _triggerlevel = 1
return not m.plError

* CleanUp procedure
function RICleanUp(tlEscaped)
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
	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
	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
	on escape &pcOnEscape
endif
return

* Determine the key expression for the specified tag.
function GetKeyIndexExp(tcTable, ;
	tcTag)
local lcTable, ;
	lcIndexExp
lcTable = strtran(m.tcTable, ' ', '_')
if not used(m.lcTable)
	use (m.tcTable) again in 0 shared alias (m.lcTable)
endif not used(lcTable)
lcIndexExp = key(tagno(m.tcTag, '', m.lcTable), m.lcTable)
return m.lcIndexExp

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

function Cascade_Update(tcParentTable, ;
	tcChildTable, ;
	tcParentKey, ;
	tcChildKey, ;
	tuOldKey, ;
	tuNewKey)
local laError[1]

* Do the cascading update. Log any error that occurred.
if isnull(m.tuOldKey )
	update (m.tcChildTable) ;
		set &tcChildKey = m.tuNewKey ;
		where &tcChildKey is null
else
	update (m.tcChildTable) ;
		set &tcChildKey = m.tuNewKey ;
		where &tcChildKey = m.tuOldKey
endif

if m.plError
	aerror(laError)
	LogRIError(laError[1], laError[2], 'Cascade Update', ;
		m.tcParentTable, iif(used(m.tcParentTable),recno(m.tcParentTable),0), ;
		m.tcParentKey, m.tuNewKey, ;
		m.tcChildTable, 0, m.tcChildKey, m.tuOldKey)
endif plError
return

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

function Cascade_Delete(tcParentTable, ;
	tcChildTable, ;
	tcParentKey, ;
	tcChildKey, ;
	tuOldKey, ;
	tuNewKey)
local laError[1]

if isnull(m.tuOldKey)
	delete ;
		from (m.tcChildTable) ;
		where &tcChildKey is null
else
	delete ;
		from (m.tcChildTable) ;
		where &tcChildKey = m.tuOldKey
endif
if m.plError
	aerror(laError)
	LogRIError(laError[1], laError[2], 'Cascade Delete', ;
		m.tcParentTable, iif(used(m.tcParentTable),recno(m.tcParentTable),0), ;
		m.tcParentKey, m.tuNewKey, ;
		m.tcChildTable, 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(tcParentTable, ;
	tcChildTable, ;
	tcParentKey, ;
	tcChildKey, ;
	tuKey, tcTag)
*local laCount[1]
local lcTable

if not isnull(m.tuKey)
	lcTable = strtran(m.tcChildTable, ' ', '_')

	if not used(m.lcTable)
		use (m.tcChildTable) again in 0 shared alias (m.lcTable)
	endif not used(lcTable)
	if indexseek(m.tuKey, .f., m.lcTable, m.tcTag) && Record exists
*!*	select count(*), ;
*!*		recno() ;
*!*		from (tcChildTable) ;
*!*		where &tcChildKey = tuKey ;
*!*		into array laCount
*!*	if _tally > 0
		plError = .t.
		LogRIError(cnERR_TRIGGER_FAILED, 'Trigger Failed', 'Restrict Delete', ;
			m.tcParentTable, iif(used(m.tcParentTable),recno(m.tcParentTable),0), ;
			m.tcParentKey, m.tuKey, ;
			m.tcChildTable, 0, m.tcChildKey, m.tuKey)
	endif _tally > 0
endif
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(tcParentTable, ;
	tcChildTable, ;
	tcParentKey, ;
	tcChildKey, ;
	tuOldKey, ;
	tuNewKey, tcTag)
*local laCount[1]
local lcTable

if not isnull(m.tuOldKey)
	lcTable = strtran(m.tcChildTable, ' ', '_')

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

	if indexseek(m.tuOldKey, .f., m.lcTable, m.tcTag) && Record exists

*!*	select count(*), ;
*!*		recno() ;
*!*		from (tcChildTable) ;
*!*		where &tcChildKey = tuOldKey ;
*!*		into array laCount
*!*	if _tally > 0

		plError = .t.
		LogRIError(cnERR_TRIGGER_FAILED, 'Trigger Failed', 'Restrict Update', ;
			m.tcParentTable, iif(used(m.tcParentTable),recno(m.tcParentTable),0), ;
			m.tcParentKey, m.tuNewKey, ;
			m.tcChildTable, 0, m.tcChildKey, m.tuOldKey)
	endif _tally > 0
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 forign 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(tcParentTable, ;
	tcChildTable, ;
	tcParentKey, ;
	tcChildKey, ;
	tuKey, ;
	tcTriggerType, tcTag)
*local laCount[1]
local lcTable

* CFK - 5/28
* If the key is Null, don't check for a parent, let it pass.
if !isnull( m.tuKey )

* If no rows in the parent table match the foreign key, SELECT COUNT(*) will
* always return one row, so _TALLY = 1; SELECT COUNT(*), (more fields) will not
* return a row. Therefore, we need to check laCount[1] rather than _TALLY.

*!*		select count(*) ;
*!*			from (tcParentTable) ;
*!*			where &tcParentKey = tuKey ;
*!*			into array laCount
*!*		if laCount[1] = 0
	lcTable = strtran(m.tcParentTable, ' ', '_')

	if not used(m.lcTable)
		use (m.tcParentTable) again in 0 shared alias (m.lcTable)
	endif not used(lcTable)
	if not indexseek(m.tuKey,.f.,m.lcTable,m.tcTag)
		plError = .t.
		LogRIError(cnERR_TRIGGER_FAILED, 'Trigger Failed', 'Restrict ' + ;
			proper(m.tcTriggerType), m.tcParentTable, 0, m.tcParentKey, 'Not Found', ;
			m.tcChildTable, iif(used(m.tcChildTable),recno(m.tcChildTable),0), ;
			m.tcChildKey, m.tuKey)
	endif laCount[1] = 0
endif  !isnull( tuKey )

return

* Log errors to the public gaError array.

procedure LogRIError(tnErrNo, ;
	tcMessage, ;
	tcCode, ;
	tcParentTable, ;
	tnParentRec, ;
	tcParentExp, ;
	tuParentKey, ;
	tcChildTable, ;
	tnChildRec, ;
	tcChildExp, ;
	tuChildKey)
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**