Level Extreme platform
Subscription
Corporate profile
Products & Services
Support
Legal
Français
Graceful exit on ESC from triggers and rules
Message
General information
Forum:
Visual FoxPro
Category:
Coding, syntax & commands
Environment versions
Visual FoxPro:
VFP 8 SP1
OS:
Windows XP SP2
Miscellaneous
Thread ID:
01002344
Message ID:
01002348
Views:
17
>Would TRANSACTIONS be overkill ?
If I press ESC, I end up with unclosed transaction and other problems. E.g. all the commands which should restore environment are not happening automatically.

Here is the trigger's code, put it in some test table and run a long replacement (say, replace next 10000 field1 with ""). Then press ESC and answer Yes On interrupted dialog.
**__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, ;
	laUsed[1], ;
	lcExact, ;
	lcANSI, ;
	lcDeleted, ;
	lcError, ;
	lcOldDBC, ;
	lcDBC, ;
	laRelations[1], ;
	lnRelations, ;
	lcRIInfo, ;
	lcParent, ;
	lcChild, ;
	lcParentKeyExp, ;
	lcChildKeyExp, ;
	luOldKey, ;
	luNewKey, ;
	luOldFK, ;
	luNewFK, ;
	laTables[1], ;
	lnTables

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

if _triggerlevel = 1
	begin transaction
	private plError
	plError = .f.
	release gaErrors
	public gaErrors[1, 12]
	aused(laUsed)
	lcExact   = set('EXACT')
	lcANSI    = set('ANSI')
	lcDeleted = set('DELETED')
	lcError   = on('ERROR')
	set exact on
	set ansi on
	set deleted on
	on error LogRIError(error(),message()) &&plError = .t.
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.

	lcOldDBC = 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.
endif
if not empty(m.lcOldDBC)
	set database to (m.lcOldDBC)
endif
if _triggerlevel = 1
	if m.plError
		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(laUsed, m.lcTable) = 0
			use in (m.lcTable)
		endif not empty(lcTable) ...
	next lnI
	if m.lcExact = "OFF"
		set exact off
	endif
	if m.lcANSI = "OFF"
		set ansi off
	endif
	if m.lcDeleted = "OFF"
		set deleted off
	endif
	on error &lcError

* If we're not at the top trigger level, return .T. so we don't trigger an
* error yet.
else

endif _triggerlevel = 1
return not m.plError

* 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**
If it's not broken, fix it until it is.


My Blog
Previous
Next
Reply
Map
View

Click here to load this message in the networking platform