Marius Mutu
63f3828d5e
Co-Authored-By: Claude Fable 5 <noreply@anthropic.com> Claude-Session: https://claude.ai/code/session_012P75yL9Fc9EcT33tMbuxcF
1929 lines
59 KiB
Plaintext
1929 lines
59 KiB
Plaintext
*--------------------------------------------------------------------------------------------------------------------------------------------------------
|
|
* (EN) AUTOGENERATED - ATTENTION!! - NOT INTENDED FOR EXECUTION!! USE ONLY FOR MERGING CHANGES AND STORING WITH SCM TOOLS!!
|
|
*--------------------------------------------------------------------------------------------------------------------------------------------------------
|
|
*< FOXBIN2PRG: Version="1.21" SourceFile="_app.vcx" CPID="1252" /> (Solo para binarios VFP 9 / Only for VFP 9 binaries)
|
|
*
|
|
*
|
|
*< LIBCOMMENT: Application Wizard framework class library. />
|
|
*
|
|
DEFINE CLASS _datasession AS _custom OF "_base.vcx"
|
|
*< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" />
|
|
|
|
#INCLUDE "_app.h"
|
|
*<DefinedPropArrayMethod>
|
|
*m: datachanged && Checks if data has changed, according to the current system as specified in iDataChangedMode.
|
|
*m: dataflush && Ensures that the activecontrol will have its current contents "recognized" even if you choose to update from a toolbar button while a grid has focus.
|
|
*m: datavalid
|
|
*m: getactivecontrolref && Returns the real active control such as cases where the current active control is a Grid.
|
|
*m: getmessageboxtitle
|
|
*m: queryunload && Occurs before a Form is unloaded.
|
|
*m: restoresessionid && Restores the data session.
|
|
*m: revert && Reverts data.
|
|
*m: setsessionid && Sets the data session.
|
|
*m: update && Updates data.
|
|
*p: idatachangedmode && Detemines what constitutes data change. 0 - anything changed. 1 - ignore view fields not in Updatefields list. 2- ignore views not set to send updates. Subclasses can add more categories and augment DataChanged() method.
|
|
*p: isavedsessionid && Data session ID.
|
|
*p: lsuccess && Whether data operation (update) was successful.
|
|
*p: lusetransactions && Whether to wrap updating routine in transaction. Note: tables not in a DBC are unaffected in transaction.
|
|
*</DefinedPropArrayMethod>
|
|
|
|
*<PropValue>
|
|
idatachangedmode = 0
|
|
isavedsessionid = 1
|
|
lsuccess = .T.
|
|
lusetransactions = .T.
|
|
Name = "_datasession"
|
|
Width = 24
|
|
*</PropValue>
|
|
|
|
PROCEDURE datachanged && Checks if data has changed, according to the current system as specified in iDataChangedMode.
|
|
LPARAMETERS toSession, tiChangeMode
|
|
|
|
ASSERT TYPE("toSession.DataSessionID") = "N" OR ;
|
|
EMPTY(toSession)
|
|
|
|
LOCAL liAction, liIndex, laTables[1], liBufferMode, liChangeMode, ;
|
|
liField, liCurrentRecord, ;
|
|
lcFieldStates, lcFieldList, lcAlias
|
|
|
|
IF TYPE("toSession.DataSessionID") = "N"
|
|
THIS.SetSessionID(toSession.DataSessionID)
|
|
ENDIF
|
|
|
|
STORE 0 TO liAction, liBufferMode, liField, ;
|
|
liCurrentRecord
|
|
|
|
IF VARTYPE(tiChangeMode) # "N"
|
|
|
|
liChangeMode = THIS.iDataChangedMode
|
|
|
|
ELSE
|
|
|
|
liChangeMode = tiChangeMode
|
|
|
|
ENDIF
|
|
|
|
ASSERT VARTYPE(liChangeMode) = "N"
|
|
|
|
* take care of current control if necessary:
|
|
IF NOT THIS.DataFlush() && will only happen in a pessimistic
|
|
&& buffering mode where we shouldn't
|
|
&& actually be editing this table!
|
|
|
|
RETURN .F.
|
|
|
|
ENDIF
|
|
|
|
|
|
|
|
FOR liIndex = 1 TO AUSED(laTables)
|
|
|
|
lcAlias = laTables[liIndex,1]
|
|
liAction = 0
|
|
liBuffermode = CURSORGETPROP("Buffering", lcAlias)
|
|
|
|
ASSERT INLIST(liBufferMode,DB_BUFOFF,DB_BUFLOCKRECORD,DB_BUFLOCKTABLE,DB_BUFOPTRECORD,DB_BUFOPTTABLE)
|
|
|
|
|
|
DO CASE
|
|
|
|
CASE ISREADONLY(lcAlias)
|
|
* don't bother...
|
|
|
|
CASE INLIST(liBufferMode, DB_BUFLOCKRECORD, DB_BUFOPTRECORD)
|
|
* row buffering
|
|
|
|
IF NOT EOF(lcAlias)
|
|
* problem with GETFLDSTATE returning .NULL. at EOF()!!
|
|
|
|
DO CASE
|
|
|
|
CASE liChangeMode = 1
|
|
* This is one of two "nondefault cases" currently known;
|
|
* It indicates "ignore columns in views that
|
|
* are not in the UpdateFields list for that view
|
|
* when assessing data changes"
|
|
|
|
lcFieldStates = GETFLDSTATE(-1,lcAlias)
|
|
|
|
IF lcFieldStates = REPL("1",FCOUNT(lcAlias)+1)
|
|
liAction = 0
|
|
ELSE
|
|
liAction = 1
|
|
* now exempt the alias in specific circumstances
|
|
IF LEFT(lcFieldStates,1) = "1" AND ;
|
|
CURSORGETPROP("SourceType", lcAlias) # 3
|
|
* we're in a local or remote view, not a table,
|
|
* and no deletion was carried out
|
|
liAction = 0
|
|
lcFieldList =","+UPPER(CURSORGETPROP("UpdatableFieldList",lcAlias))+","
|
|
lcFieldList = STRTRAN(lcFieldList,", ", ",")
|
|
FOR liField = 1 TO FCOUNT(lcAlias)
|
|
IF SUBSTR(lcFieldStates,liField+1,1) # "1" AND ;
|
|
(","+UPPER(FIELD(liField,lcAlias))+"," $ ;
|
|
lcFieldList)
|
|
|
|
liAction = 1
|
|
EXIT
|
|
|
|
ENDIF
|
|
ENDFOR
|
|
ENDIF
|
|
ENDIF
|
|
|
|
CASE liChangeMode = 2
|
|
* the second currently-possible "nondefault" case;
|
|
* it indicates "ignore views that are not set
|
|
* to send updates back to their tables for the
|
|
* purposes of assessing data as changed"
|
|
|
|
IF CURSORGETPROP("SourceType", lcAlias) = 3 OR ;
|
|
CURSORGETPROP("SendUpdates", lcAlias)
|
|
liAction = IIF(GETFLDSTATE(-1,lcAlias) = ;
|
|
REPL("1",FCOUNT(lcAlias)+1), ;
|
|
0,1)
|
|
ENDIF
|
|
|
|
OTHERWISE
|
|
|
|
* original code applies
|
|
liAction = IIF(GETFLDSTATE(-1,lcAlias) = ;
|
|
REPL("1",FCOUNT(lcAlias)+1), ;
|
|
0,1)
|
|
|
|
ENDCASE
|
|
|
|
ENDIF
|
|
|
|
CASE INLIST(liBufferMode, DB_BUFLOCKTABLE, DB_BUFOPTTABLE)
|
|
* table buffering
|
|
|
|
DO CASE
|
|
|
|
CASE liChangeMode = 1
|
|
* see notes above
|
|
|
|
IF CURSORGETPROP("SourceType", lcAlias) = 3
|
|
|
|
liAction = GETNEXTMODIFIED(0,lcAlias)
|
|
|
|
ELSE
|
|
|
|
liCurrentRecord = IIF(EOF(lcAlias),0, ;
|
|
RECNO(lcAlias))
|
|
liRecord = GETNEXTMODIFIED(0,lcAlias)
|
|
liAction = 0
|
|
lcFieldList =","+UPPER(CURSORGETPROP("UpdatableFieldList",lcAlias))+","
|
|
lcFieldList = STRTRAN(lcFieldList,", ", ",")
|
|
|
|
DO WHILE liRecord # 0 AND liAction = 0
|
|
GO liRecord IN (lcAlias)
|
|
lcFieldStates = GETFLDSTATE(-1,lcAlias)
|
|
IF lcFieldStates = REPL("1",FCOUNT(lcAlias)+1)
|
|
liAction = 0
|
|
ELSE
|
|
liAction = 1
|
|
IF LEFT(lcFieldStates,1) = "1" AND ;
|
|
CURSORGETPROP("SourceType", lcAlias) # 3
|
|
liAction = 0
|
|
FOR liField = 1 TO FCOUNT(lcAlias)
|
|
IF SUBSTR(lcFieldStates,liField+1,1) # "1" AND ;
|
|
(","+UPPER(FIELD(liField,lcAlias))+"," $ ;
|
|
lcFieldList)
|
|
|
|
liAction = 1
|
|
EXIT
|
|
ENDIF
|
|
ENDFOR
|
|
ENDIF
|
|
ENDIF
|
|
liRecord = GETNEXTMODIFIED(liRecord,lcAlias)
|
|
ENDDO
|
|
IF liCurrentRecord # RECNO(lcAlias)
|
|
IF liCurrentRecord = 0
|
|
GO BOTTOM IN (lcAlias)
|
|
IF RECCOUNT(lcAlias) > 0
|
|
SKIP IN (lcAlias)
|
|
ENDIF
|
|
ELSE
|
|
GO liCurrentRecord IN (lcAlias)
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
|
|
CASE liChangeMode = 2
|
|
* see notes above
|
|
IF CURSORGETPROP("SourceType", lcAlias) = 3 OR ;
|
|
CURSORGETPROP("SendUpdates", lcAlias)
|
|
liAction = GETNEXTMODIFIED(0,lcAlias)
|
|
ENDIF
|
|
|
|
OTHERWISE
|
|
|
|
* original code applies:
|
|
liAction = GETNEXTMODIFIED(0,lcAlias)
|
|
|
|
ENDCASE
|
|
|
|
|
|
OTHERWISE
|
|
|
|
* no buffering -- or (god forbid)
|
|
* an unknown return that hasn't been
|
|
* caught by assertion during testing
|
|
* do nothing
|
|
|
|
ENDCASE
|
|
|
|
IF liAction # 0
|
|
* changes have occurred in at least one table in the system
|
|
EXIT
|
|
ENDIF
|
|
|
|
ENDFOR
|
|
|
|
IF TYPE("toSession.DataSessionID") = "N"
|
|
THIS.RestoreSessionID()
|
|
ENDIF
|
|
|
|
|
|
RETURN liAction # 0
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE dataflush && Ensures that the activecontrol will have its current contents "recognized" even if you choose to update from a toolbar button while a grid has focus.
|
|
LOCAL loActiveControl, lcAlias
|
|
|
|
IF TYPE("_SCREEN.ActiveForm.ActiveControl") # "O"
|
|
RETURN
|
|
ENDIF
|
|
|
|
loActiveControl = THIS.GetActiveControlRef(_SCREEN.ActiveForm.ActiveControl)
|
|
|
|
|
|
IF TYPE("loActiveControl.Value") # "U" AND ;
|
|
TYPE("loActiveControl.ControlSource") # "U" AND ;
|
|
TYPE(loActiveControl.ControlSource) # "U" AND ;
|
|
(TYPE("loActiveControl.ReadOnly") = "U" OR ;
|
|
NOT loActiveControl.ReadOnly) AND ;
|
|
(NOT EVAL(loActiveControl.Controlsource) == loActiveControl.Value)
|
|
|
|
IF "." $ loActiveControl.ControlSource
|
|
lcAlias = LEFT(loActiveControl.ControlSource,AT(".",loActiveControl.ControlSource) - 1)
|
|
ELSE
|
|
lcAlias = ALIAS()
|
|
ENDIF
|
|
IF INLIST(CURSORGETPROP("BUFFERING",lcAlias),DB_BUFLOCKRECORD,DB_BUFLOCKTABLE) ;
|
|
AND NOT ISRLOCKED(RECNO(lcAlias),lcAlias)
|
|
IF NOT RLOCK(RECNO(lcAlias),lcAlias)
|
|
* help ! pessimistic locking in effect
|
|
* and somebody else actually has this record
|
|
* locked! we shouldn't be editing this record...
|
|
* actually this should never happen!
|
|
= MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ;
|
|
MB_OK+MB_ICONSTOP,;
|
|
THIS.GetMessageBoxTitle()+": "+PROPER(lcAlias))
|
|
|
|
RETURN .F.
|
|
ELSE
|
|
* this was a speculative lock only
|
|
* if it was a view it really isn't
|
|
* a problem to have taken this lock
|
|
* briefly, although it didn't help either
|
|
UNLOCK RECORD RECNO(lcAlias) IN (lcAlias)
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
loActiveControl.Value = loActiveControl.Value
|
|
|
|
|
|
ELSE
|
|
|
|
* no flush required
|
|
|
|
ENDIF
|
|
|
|
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE datavalid
|
|
ENDPROC
|
|
|
|
PROCEDURE Error
|
|
LPARAMETERS nError, cMethod, nLine
|
|
|
|
LOCAL laErrors[1]
|
|
=AERROR(laErrors)
|
|
|
|
THIS.lSuccess = .F.
|
|
|
|
IF UPPER(cMethod)=="UPDATE"
|
|
|
|
IF (INLIST(nError,1580,1581,1582,1583,1531,1539,1590,;
|
|
1546, 1547,111,1157,1579,1598, 1647, 1504, 1887) ;
|
|
OR ;
|
|
INLIST(nError, 2007, 2008, 2010,2011,2015,1491, 1996, 1589, ;
|
|
1864,1865,1879,1884,1886, 1712,2014,1594, 1588 ) ;
|
|
OR ;
|
|
INLIST(nError,1548,1777,1495)) ; && leaving room for more...
|
|
AND NOT ISNULL(laErrors[1,4])
|
|
|
|
* rule failure,trigger, transaction failure,
|
|
* and some additional problems
|
|
* that the programmer
|
|
* should see and handle in the rule code or other
|
|
* work in the form itself, it is not something that
|
|
* should be resolved by the user at runtime!
|
|
|
|
DODEFAULT(nError,cMethod,nLine)
|
|
ELSE
|
|
* otherwise we want to treat this as an error
|
|
* that Update handles internally.
|
|
* this may not be important
|
|
|
|
ENDIF
|
|
|
|
|
|
ELSE
|
|
|
|
DODEFAULT(nError, cMethod, nLine)
|
|
|
|
ENDIF
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE getactivecontrolref && Returns the real active control such as cases where the current active control is a Grid.
|
|
LPARAMETERS toActiveControl
|
|
|
|
LOCAL loRealActiveControl, liThisColumn, loColumn
|
|
|
|
IF TYPE("toActiveControl.BaseClass")# "C"
|
|
* redundant in DataFlush() call, but could be called from elsewhere
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
IF UPPER(toActiveControl.BaseClass) == "GRID"
|
|
|
|
liThisColumn = toActivecontrol.ActiveColumn
|
|
FOR EACH loColumn IN toActiveControl.Columns
|
|
IF loColumn.ColumnOrder # liThisColumn
|
|
LOOP
|
|
ENDIF
|
|
IF NOT (loColumn.ReadOnly and loColumn.Bound)
|
|
loRealActiveControl = EVAL("loColumn."+loColumn.CurrentControl)
|
|
ENDIF
|
|
EXIT
|
|
ENDFOR
|
|
|
|
ELSE
|
|
|
|
loRealActiveControl = toActiveControl
|
|
|
|
ENDIF
|
|
|
|
RETURN loRealActiveControl
|
|
ENDPROC
|
|
|
|
PROCEDURE getmessageboxtitle
|
|
RETURN DATA_MESSAGEBOX_TITLE_LOC
|
|
ENDPROC
|
|
|
|
PROCEDURE Init
|
|
IF NOT DODEFAULT()
|
|
RETURN .F.
|
|
ENDIF
|
|
THIS.iSavedSessionID = SET("DATASESSION")
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE queryunload && Occurs before a Form is unloaded.
|
|
LPARAMETERS tlDataChangeAlreadyConfirmed, toSession, tlNoShow
|
|
|
|
ASSERT VARTYPE(tlDataChangeAlreadyConfirmed) = "L"
|
|
ASSERT TYPE("toSession.DataSessionID") = "N" OR ;
|
|
TYPE("_SCREEN.ActiveForm") = "O"
|
|
ASSERT VARTYPE(tlNoShow) = "L"
|
|
|
|
LOCAL liResult, llChange, loSession
|
|
|
|
IF TYPE("toSession.DataSessionID") = "N"
|
|
loSession = toSession
|
|
ELSE
|
|
loSession = _SCREEN.ActiveForm
|
|
ENDIF
|
|
|
|
THIS.SetSessionID(loSession.DataSessionID)
|
|
|
|
llChange = tlDataChangeAlreadyConfirmed OR THIS.DataChanged(loSession)
|
|
|
|
IF llChange
|
|
|
|
* changes have been detected somewhere...
|
|
|
|
IF PEMSTATUS(loSession,"Show",5) AND NOT tlNoShow
|
|
loSession.Show()
|
|
ENDIF
|
|
|
|
liResult = ;
|
|
MESSAGEBOX( DATA_SAVE_BEFORE_CLOSE_LOC ,;
|
|
MB_ICONEXCLAMATION + MB_YESNOCANCEL, ;
|
|
THIS.GetMessageBoxTitle())
|
|
|
|
ELSE
|
|
|
|
liResult = IDNO
|
|
|
|
ENDIF
|
|
|
|
DO CASE
|
|
CASE liResult = IDYES
|
|
THIS.Update(.T.,.T.,loSession)
|
|
CASE liResult = IDNO AND llChange
|
|
THIS.Revert(.T.,.T.,loSession)
|
|
OTHERWISE
|
|
* there were data changes and they chose to cancel
|
|
ENDCASE
|
|
|
|
THIS.RestoreSessionID()
|
|
|
|
RETURN (liResult # IDCANCEL)
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE restoresessionid && Restores the data session.
|
|
IF SET("DATASESSION") # THIS.iSavedSessionID
|
|
|
|
SET DATASESSION TO THIS.iSavedSessionID
|
|
|
|
ENDIF
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE revert && Reverts data.
|
|
LPARAMETERS tlUserChoiceAlreadyConfirmed, tlDataChangeAlreadyConfirmed, toSession, tlNoShow
|
|
|
|
ASSERT VARTYPE(tlUserChoiceAlreadyConfirmed) = "L"
|
|
ASSERT VARTYPE(tlDataChangeAlreadyConfirmed) = "L"
|
|
ASSERT TYPE("toSession.DataSessionID") = "N" OR ;
|
|
TYPE("_SCREEN.ActiveForm") = "O"
|
|
ASSERT VARTYPE(tlNoShow) = "L"
|
|
ASSERT SET("MULTILOCKS") = "ON"
|
|
|
|
LOCAL liConfirmed, liIndex, laTables[1], llChange, loSession
|
|
|
|
IF TYPE("toSession.DataSessionID") = "N"
|
|
loSession = toSession
|
|
ELSE
|
|
loSession = _SCREEN.ActiveForm
|
|
ENDIF
|
|
|
|
THIS.SetSessionID(loSession.DataSessionID)
|
|
|
|
IF tlUserChoiceAlreadyConfirmed
|
|
|
|
liConfirmed = IDOK
|
|
|
|
ELSE
|
|
|
|
llChange = tlDataChangeAlreadyConfirmed OR THIS.DataChanged()
|
|
|
|
IF llChange
|
|
|
|
IF PEMSTATUS(loSession,"Show",5) AND NOT tlNoShow
|
|
loSession.Show()
|
|
ENDIF
|
|
|
|
liConfirmed =MESSAGEBOX(DATA_OK_TO_REVERT_LOC,;
|
|
MB_ICONQUESTION+MB_OKCANCEL,THIS.GetMessageBoxTitle())
|
|
ELSE
|
|
|
|
liConfirmed = IDCANCEL
|
|
|
|
ENDIF
|
|
ENDIF
|
|
|
|
IF liConfirmed = IDOK
|
|
|
|
FOR liIndex = 1 TO AUSED(laTables)
|
|
|
|
IF CURSORGETPROP("Buffering",laTables[liIndex,1]) # DB_BUFOFF
|
|
=TABLEREVERT(.T.,laTables[liIndex,1])
|
|
ENDIF
|
|
|
|
ENDFOR
|
|
|
|
ENDIF
|
|
|
|
IF PEMSTATUS(loSession,"Refresh",5) AND NOT tlNoShow
|
|
loSession.Refresh()
|
|
ENDIF
|
|
|
|
THIS.RestoreSessionID()
|
|
|
|
RETURN (liConfirmed = IDOK)
|
|
ENDPROC
|
|
|
|
PROCEDURE setsessionid && Sets the data session.
|
|
LPARAMETERS tiSession
|
|
|
|
IF VARTYPE(tiSession) = "N" AND SET("DATASESSION") # tiSession
|
|
|
|
THIS.iSavedSessionID = SET("DATASESSION")
|
|
SET DATASESSION TO tiSession
|
|
|
|
ENDIF
|
|
ENDPROC
|
|
|
|
PROCEDURE update && Updates data.
|
|
LPARAMETERS tlUserChoiceAlreadyConfirmed, tlDataChangeAlreadyConfirmed, toSession, tlNoShow
|
|
|
|
ASSERT VARTYPE(tlUserChoiceAlreadyConfirmed) = "L"
|
|
ASSERT VARTYPE(tlDataChangeAlreadyConfirmed) = "L"
|
|
ASSERT TYPE("toSession.DataSessionID") = "N" OR ;
|
|
TYPE("_SCREEN.ActiveForm") = "O"
|
|
ASSERT VARTYPE(tlNoShow) = "L"
|
|
ASSERT SET("MULTILOCKS") = "ON"
|
|
|
|
LOCAL llChange, liConfirmed, liIndexTables, loSession, lcRecs, ;
|
|
laTables[1], liBuffermode, liSelect, laErrors[1], liRecModified, ;
|
|
llUseTransactions, llView
|
|
|
|
IF TYPE("toSession.DataSessionID") = "N"
|
|
loSession = toSession
|
|
ELSE
|
|
loSession = _SCREEN.ActiveForm
|
|
ENDIF
|
|
|
|
THIS.SetSessionID(loSession.DataSessionID)
|
|
|
|
THIS.lSuccess = .T.
|
|
|
|
IF tlUserChoiceAlreadyConfirmed
|
|
|
|
liConfirmed = IDOK
|
|
llChange = .T.
|
|
|
|
ELSE
|
|
|
|
llChange = tlDataChangeAlreadyConfirmed OR THIS.DataChanged()
|
|
|
|
IF llChange
|
|
|
|
IF PEMSTATUS(loSession,"Show",5) AND NOT tlNoShow
|
|
loSession.Show()
|
|
* otherwise it could be a session object
|
|
ENDIF
|
|
|
|
liConfirmed =MESSAGEBOX(DATA_OK_TO_SAVE_LOC, ;
|
|
MB_ICONQUESTION+MB_OKCANCEL, ;
|
|
THIS.GetMessageBoxTitle())
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
IF llChange AND liConfirmed = IDOK
|
|
|
|
*&* transaction aspect of this system,
|
|
*&* suggested here, are really only
|
|
*&* going to work for tables in a DBC
|
|
*&* which is why we take the record locks as well..
|
|
IF THIS.lUseTransactions AND TXNLEVEL() < 5
|
|
llUseTransactions = .T.
|
|
BEGIN TRANSACTION
|
|
ENDIF
|
|
|
|
liSelect = SELECT()
|
|
|
|
FOR liIndexTables = 1 TO AUSED(laTables)
|
|
|
|
SELECT (laTables[liIndexTables,1])
|
|
liBuffermode = CURSORGETPROP("Buffering")
|
|
llView = (CURSORGETPROP("SourceType")# DB_SRCTABLE)
|
|
|
|
ASSERT INLIST(liBuffermode,DB_BUFOFF,DB_BUFLOCKRECORD,DB_BUFLOCKTABLE,DB_BUFOPTRECORD,DB_BUFOPTTABLE)
|
|
|
|
DO CASE
|
|
|
|
|
|
CASE liBufferMode = DB_BUFOFF
|
|
* do nothing for this table
|
|
LOOP
|
|
|
|
CASE INLIST(liBufferMode,DB_BUFLOCKRECORD,DB_BUFLOCKTABLE)
|
|
|
|
* no need to check whether any editing was actually done;
|
|
* if it wasn't, nothing will happen with the TABLEUPDATE()...
|
|
|
|
IF TABLEUPDATE(.T.)
|
|
|
|
* success
|
|
|
|
ELSE
|
|
|
|
|
|
THIS.lSuccess = .F.
|
|
|
|
* we already have the lock and control of the record(s),
|
|
* this is a real error
|
|
|
|
=AERROR(laErrors)
|
|
* let the standard error handler deal with it, for now
|
|
* -- whether it's the ON ERROR routine or the Error
|
|
* method for this object is immaterial
|
|
|
|
ERROR laErrors[1,1]
|
|
|
|
ENDIF
|
|
|
|
CASE liBuffermode = DB_BUFOPTTABLE
|
|
|
|
liRecModified = GETNEXTMODIFIED(0)
|
|
lcRecs = ""
|
|
IF liRecModified = 0
|
|
* no changes to this file
|
|
LOOP
|
|
ENDIF
|
|
|
|
DO WHILE liRecModified # 0
|
|
IF liRecModified > 0
|
|
lcRecs = lcRecs+","+ALLTR(STR(liRecModified))
|
|
ENDIF
|
|
liRecModified = GETNEXTMODIFIED(liRecModified)
|
|
ENDDO
|
|
|
|
*&* We are only worrying about one table at a time;
|
|
*&* presumably there is additional data-specific code in the
|
|
*&* form itself that
|
|
*&* preserves referential integrity
|
|
*&* if the tables are *not* in a DBC and protected by the transaction.
|
|
|
|
IF NOT EMPTY(lcRecs)
|
|
lcRecs = SUBSTR(lcRecs,2)
|
|
ELSE
|
|
*&* all changed records are newly added
|
|
ENDIF
|
|
|
|
IF EMPTY(lcRecs) OR llView OR RLOCK(lcRecs,ALIAS())
|
|
|
|
DO CASE
|
|
CASE NOT THIS.lSuccess
|
|
* this may only be a problem with VFP3.
|
|
* it's possible for the RLOCK() to cause
|
|
* an error rather than a failed update
|
|
= MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ;
|
|
MB_OK+MB_ICONSTOP,;
|
|
THIS.GetMessageBoxTitle()+": "+ALIAS())
|
|
|
|
CASE TABLEUPDATE(.T.,.F.)
|
|
* success
|
|
IF llView
|
|
SELECT (laTables[liIndexTables,1])
|
|
ENDIF
|
|
OTHERWISE
|
|
|
|
IF llView
|
|
SELECT (laTables[liIndexTables,1])
|
|
ENDIF
|
|
|
|
|
|
* could go through the delimited string here
|
|
* and ask record by record...
|
|
|
|
IF MESSAGEBOX(DATA_HAS_BEEN_EDITED_LOC, ;
|
|
MB_OKCANCEL+MB_ICONEXCLAMATION,;
|
|
THIS.GetMessageBoxTitle()+": "+ALIAS()) = IDOK
|
|
|
|
IF TABLEUPDATE(.T.,.T.)
|
|
* success
|
|
IF llView
|
|
SELECT (laTables[liIndexTables,1])
|
|
ENDIF
|
|
|
|
ELSE
|
|
|
|
* real error -- *UNLESS* it's a view, in which
|
|
* case taking the lock wouldn't help, could
|
|
* actually prevent SET REPROCESS from working
|
|
* normally!
|
|
|
|
THIS.lSuccess = .F.
|
|
|
|
IF llView
|
|
|
|
SELECT (laTables[liIndexTables,1])
|
|
|
|
= MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ;
|
|
MB_OK+MB_ICONSTOP,;
|
|
THIS.GetMessageBoxTitle()+": "+ALIAS())
|
|
ELSE
|
|
=AERROR(laErrors)
|
|
ERROR laErrors[1,1]
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
ELSE
|
|
THIS.lSuccess = .F.
|
|
ENDIF
|
|
ENDCASE
|
|
ELSE
|
|
THIS.lSuccess = .F.
|
|
|
|
= MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ;
|
|
MB_OK+MB_ICONSTOP,;
|
|
THIS.GetMessageBoxTitle()+": "+ALIAS())
|
|
|
|
ENDIF
|
|
|
|
CASE (EOF()) AND liBuffermode = DB_BUFOPTRECORD
|
|
* do nothing if we're at EOF() and optimistic record locking ...
|
|
* this is permissible if a relation is 1 to 0..n
|
|
* and may happen if you have chosen to use
|
|
* optimistic record buffering on child tables.
|
|
LOOP
|
|
|
|
CASE liBuffermode = DB_BUFOPTRECORD
|
|
|
|
IF llView OR RLOCK()
|
|
|
|
DO CASE
|
|
CASE NOT THIS.lSuccess
|
|
* see comment above; this really shouldn't happen
|
|
= MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ;
|
|
MB_OK+MB_ICONSTOP,;
|
|
THIS.GetMessageBoxTitle()+": "+ALIAS())
|
|
CASE TABLEUPDATE(.F.,.F.)
|
|
* success
|
|
IF llView
|
|
SELECT (laTables[liIndexTables,1])
|
|
ENDIF
|
|
|
|
OTHERWISE
|
|
|
|
* were other people working on the record?
|
|
* you could do a more elaborate dialog here,
|
|
* using OLDVAL() and CURVAL() to show what has occurred
|
|
IF llView
|
|
SELECT (laTables[liIndexTables,1])
|
|
ENDIF
|
|
|
|
|
|
IF MESSAGEBOX(DATA_HAS_BEEN_EDITED_LOC, ;
|
|
MB_OKCANCEL+MB_ICONEXCLAMATION,;
|
|
THIS.GetMessageBoxTitle()+": "+ALIAS()) = IDOK
|
|
|
|
IF TABLEUPDATE(.F.,.T.)
|
|
* success
|
|
IF llView
|
|
SELECT (laTables[liIndexTables,1])
|
|
ENDIF
|
|
ELSE
|
|
|
|
* real error -- *UNLESS* it's a view, in which
|
|
* case taking the lock wouldn't help, could
|
|
* actually prevent SET REPROCESS from working
|
|
* normally!
|
|
THIS.lSuccess = .F.
|
|
IF llView
|
|
SELECT (laTables[liIndexTables,1])
|
|
= MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ;
|
|
MB_OK+MB_ICONSTOP,;
|
|
THIS.GetMessageBoxTitle()+": "+ALIAS())
|
|
ELSE
|
|
|
|
= AERROR(laErrors)
|
|
ERROR laErrors[1,1]
|
|
ENDIF
|
|
ENDIF
|
|
ELSE
|
|
THIS.lSuccess = .F.
|
|
ENDIF
|
|
ENDCASE
|
|
|
|
ELSE
|
|
|
|
THIS.lSuccess = .F.
|
|
= MESSAGEBOX(DATA_UPDATE_CONFLICT_LOC, ;
|
|
MB_OK+MB_ICONSTOP,;
|
|
THIS.GetMessageBoxTitle()+": "+ALIAS())
|
|
|
|
ENDIF
|
|
|
|
OTHERWISE
|
|
* we're either at EOF() and
|
|
* opt record locking or
|
|
* in trouble <g> -- the assertion uptop
|
|
* should be taking care of this!
|
|
THIS.lSuccess = .F.
|
|
|
|
ENDCASE
|
|
|
|
IF llView
|
|
*&* JIC!
|
|
SELECT (laTables[liIndexTables,1])
|
|
ELSE
|
|
UNLOCK && this file
|
|
ENDIF
|
|
|
|
IF NOT THIS.lSuccess
|
|
EXIT
|
|
ENDIF
|
|
|
|
ENDFOR
|
|
|
|
*&* outer transaction covering all tables
|
|
*&* Tablereverts of what is left un-Updated
|
|
*&* may still help if there are free tables.
|
|
*&* Again, this will not cover the
|
|
*&* problem of a partial update already
|
|
*&* having been committed if there are
|
|
*&* free tables, but RI code should have
|
|
*&* been in place to prevent something
|
|
*&* "really bad" happening in this case.
|
|
|
|
IF llUseTransactions AND TXNLEVEL() > 0
|
|
|
|
IF THIS.lSuccess
|
|
END TRANSACTION
|
|
ELSE
|
|
ROLLBACK
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
IF NOT THIS.lSuccess
|
|
FOR liIndexTables = 1 TO ALEN(laTables,1)
|
|
=TABLEREVERT(.T.,laTables[liIndexTables,1])
|
|
ENDFOR
|
|
ENDIF
|
|
*&*
|
|
|
|
|
|
SELECT (liSelect)
|
|
|
|
IF llChange AND PEMSTATUS(loSession,"Refresh",5)
|
|
loSession.Refresh()
|
|
ENDIF
|
|
|
|
|
|
ENDIF
|
|
|
|
THIS.RestoreSessionID()
|
|
|
|
RETURN (NOT llChange) OR (liConfirmed = IDOK AND THIS.lSuccess)
|
|
|
|
ENDPROC
|
|
|
|
ENDDEFINE
|
|
|
|
DEFINE CLASS _error AS _custom OF "_base.vcx" && Error handler
|
|
*< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" />
|
|
|
|
#INCLUDE "_app.h"
|
|
*<DefinedPropArrayMethod>
|
|
*m: displayerrorlog && Displays error log.
|
|
*m: doerrorlogui && Called by DisplayErrorLog for actual UI display after setup. The simple default behavior here (BROWSE NOWAIT) is meant to be overridden by application-specific behavior.
|
|
*m: fillarrays && Fills error classification array (aErrorClass) first time, and current error array (aErrors) for each error that occurs. Bails if conditions are so severe (memory errors) that further processing is undesirable.
|
|
*m: filllogrecord && Writes error information to the log.
|
|
*m: geterrorattribute && Returns appropriate information from aErrorClass array for a given error number.
|
|
*m: getmessageboxtitle && This is really meant for your subclass or instance to fill out with app-specific information, so that all user feedback (WAIT WINDOW NOWAITs and MESSAGEBOX()) by the error object matches your app properly.
|
|
*m: handle && Main routine to handle error.
|
|
*m: isdisallowedserveraction && Tells whether the error is caused by an attempt to execute UI or other disallowed action from a server
|
|
*m: isfatal && Whether error is a fatal type error.
|
|
*m: isgooderrorlog && Validates error log
|
|
*m: istrivial && Whether error is a trivial type error.
|
|
*m: logerrorreport && If lServer is .T. or user indicates logging is desired, opens error log and logs the error.
|
|
*m: oktocontinue && Abstract method to evaluate error whether to continue program execution.
|
|
*m: oktoreport && Abstract method to evaluate error whether to report error.
|
|
*m: recordservererror && Establishes a consistent method for logging feedback which would ordinarily go to UI, for use in servers
|
|
*m: setlog && Evaluates log table name and alias, attempts to open and validate the table, creates new alias and log table name on the fly if anything goes wrong.
|
|
*m: usercancelled && Returns whether user opted to cancel after the current error.
|
|
*m: userhandleserror && Gives user choices about whether to go on with the app after an error.
|
|
*p: ccurrentclass && The error classification that the error object gives this particular error number.
|
|
*p: ccurrenterrorparam && SYS(2018) of current error
|
|
*p: ccurrentmessage && MESSAGE() of current error
|
|
*p: ccurrentmethod && Method or procedure where error occurred, as passed to Handle().
|
|
*p: clogalias && Alias under which the error log is opened. See SetLog().
|
|
*p: clogdbf && Fully qualified name of current error table on disk. See SetLog().
|
|
*p: icurrenterror && Error number for current error.
|
|
*p: icurrentline && Line where current error occurred.
|
|
*p: lserver && Checks _VFP.StartMode to see whether any sort of modal feedback should be avoided.
|
|
*p: lusercancelled && Allows the outside program to cleanup and do whatever is necessary before release.
|
|
*a: aerrorclass[1,3] && Error numbers by classification for evaluation of type and severity.
|
|
*a: aerrors[1,6]
|
|
*</DefinedPropArrayMethod>
|
|
|
|
*<PropValue>
|
|
ccurrentclass = ("")
|
|
ccurrenterrorparam = ("")
|
|
ccurrentmessage = ("")
|
|
ccurrentmethod = ("")
|
|
clogalias = ("")
|
|
clogdbf = ("")
|
|
icurrenterror = 0
|
|
icurrentline = 0
|
|
lserver = (INLIST(_VFP.StartMode,1,2,3,5))
|
|
Name = "_error"
|
|
*</PropValue>
|
|
|
|
PROCEDURE Destroy
|
|
LOCAL liSession
|
|
liSession = SET("DATASESSION")
|
|
SET DATASESSION TO 1
|
|
IF USED(THIS.cLogAlias)
|
|
USE IN (THIS.cLogAlias)
|
|
* this is actually only going to happen
|
|
* in the "default" datasession
|
|
* because any other USEs should have
|
|
* been closed when their forms and formsets
|
|
* died by this point.
|
|
* note that the errorlog may be opened
|
|
* many times in different sessions, and
|
|
* this session information will be reflected in the log
|
|
ENDIF
|
|
SET DATASESSION TO liSession
|
|
DODEFAULT()
|
|
ENDPROC
|
|
|
|
PROCEDURE displayerrorlog && Displays error log.
|
|
LOCAL liSelect
|
|
liSelect = SELECT()
|
|
THIS.SetLog()
|
|
|
|
DO CASE
|
|
|
|
CASE (EMPTY(THIS.cLogAlias) OR NOT USED(THIS.cLogAlias))
|
|
|
|
IF NOT THIS.lServer
|
|
|
|
MESSAGEBOX(ERROR_LOG_UNAVAILABLE_LOC,;
|
|
MB_ICONEXCLAMATION,;
|
|
THIS.GetMessageBoxTitle())
|
|
ENDIF
|
|
|
|
CASE RECCOUNT(THIS.cLogAlias) = 0
|
|
|
|
IF NOT THIS.lServer
|
|
|
|
MESSAGEBOX(ERROR_LOG_EMPTY_LOC,;
|
|
MB_ICONEXCLAMATION,;
|
|
THIS.GetMessageBoxTitle())
|
|
ENDIF
|
|
|
|
OTHERWISE
|
|
|
|
SELECT (THIS.cLogAlias)
|
|
THIS.DoErrorLogUI(THIS.cLogAlias)
|
|
SELECT (liSelect)
|
|
|
|
ENDCASE
|
|
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE doerrorlogui && Called by DisplayErrorLog for actual UI display after setup. The simple default behavior here (BROWSE NOWAIT) is meant to be overridden by application-specific behavior.
|
|
LPARAMETERS tcAlias
|
|
|
|
* this code is really expecting to be overridden
|
|
IF NOT THIS.lServer
|
|
BROWSE NORMAL NOWAIT
|
|
ENDIF
|
|
ENDPROC
|
|
|
|
PROCEDURE Error
|
|
LPARAMETERS nError, cMethod, nLine
|
|
* special case, must override
|
|
* any use of ON ERROR which
|
|
* might call this object recursively
|
|
IF "setlog" $ LOWER(cMethod)
|
|
THIS.cLogDBF = ""
|
|
ELSE
|
|
ERROR ERROR_IN_ERROR_METHOD_LOC+":"+CHR(13)+ ;
|
|
"#"+TRANSFORM(nError)+CHR(13)+ ;
|
|
THIS.Name+" "+cMethod+", "+TRANSFORM(nLine)+CHR(13)+ ;
|
|
THIS.cCurrentMessage
|
|
ENDIF
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE fillarrays && Fills error classification array (aErrorClass) first time, and current error array (aErrors) for each error that occurs. Bails if conditions are so severe (memory errors) that further processing is undesirable.
|
|
IF VARTYPE(THIS.aErrorClass[1]) ="L"
|
|
* first time through
|
|
THIS.aErrorClass[1,2] = "memory"
|
|
THIS.aErrorClass[1,1] = "/21/22/43/1012/1149/1150/1151/1201/1202/1507/1600/1809/1986/2000/"
|
|
ENDIF
|
|
|
|
LOCAL lcErrString, llBail
|
|
|
|
lcErrString = "/"+TRANSFORM(THIS.iCurrentError)+"/"
|
|
|
|
IF lcErrString $ THIS.aErrorClass[1,1]
|
|
llBail = .T.
|
|
ELSE
|
|
=AERROR(THIS.aErrors)
|
|
ENDIF
|
|
|
|
IF (NOT llBail) AND (TYPE("THIS.aErrorClass[2,1]") # "C")
|
|
|
|
DIME THIS.aErrorClass[16,2]
|
|
* note: you can add more columns for more error attributes,
|
|
* for example a severity gauge for different classes
|
|
* or other error class groupings
|
|
|
|
THIS.aErrorClass[2,2] = "index"
|
|
THIS.aErrorClass[2,1] = "/5/19/20/114/1103/1141/1707/"
|
|
THIS.aErrorClass[3,2] = "disk"
|
|
THIS.aErrorClass[3,1] = "/56/1410/1157/"
|
|
THIS.aErrorClass[4,2] = "file"
|
|
THIS.aErrorClass[4,1] = "/1/6/7/15/41/50/54/55/102/110/111/115/116/117/119/120"+;
|
|
"/121/127/202/255/266/297/356/392/1102/1104/1105/1108"+;
|
|
"/1111/1112/1113/1115/1126/1166/1131/1167/1168/1169"+;
|
|
"/1243/1245/1246/1294/1298/1509/1510/1637/1643"+;
|
|
"/1644/1705/1708/"
|
|
THIS.aErrorClass[5,2] = "command"
|
|
THIS.aErrorClass[5,1] = "/1405/1411/1412/"
|
|
THIS.aErrorClass[6,2] = "lock"
|
|
THIS.aErrorClass[6,1] = "/3/108/109/130/1502/1503/1106/1585/"
|
|
THIS.aErrorClass[7,2] = "output"
|
|
THIS.aErrorClass[7,1] = "/216/221/222/223/227/228/332/1002/1153/"
|
|
THIS.aErrorClass[8,2] = "program or resource file"
|
|
THIS.aErrorClass[8,1] = "/67/91/1161/1178/1193/1194/1195/1196/1296/1309/1338/"
|
|
THIS.aErrorClass[9,2] = "print"
|
|
THIS.aErrorClass[9,1] = "/124/125/1910/1524/1643/1644/1717/"
|
|
THIS.aErrorClass[10,2] = "activex"
|
|
THIS.aErrorClass[10,1] = "/1420/1421/1422/1423/1424/1426/1427/1428/1429/1431/1434/1436/1508"+;
|
|
"/1440/2003/1782/2021/"
|
|
THIS.aErrorClass[11,2] = "sql"
|
|
THIS.aErrorClass[11,1] = "/1465/1466/1471/1472/1474/1475/1476/1477/1864/1865/1802/1890/1845/"
|
|
THIS.aErrorClass[12,2] = "cursor"
|
|
THIS.aErrorClass[12,1] = "/1467/1468/1473/1478/1479/1489/1491/1492/1493/1494/1495/1498/1499/1542/1546/1547/1548/1568/"
|
|
THIS.aErrorClass[13,2] = "odbc"
|
|
THIS.aErrorClass[13,1] = "/1480/1481/1482/1483/1484/1485/1486/1487/1496/1497/1522/1523/1525/1526/1527/1528/1530/"
|
|
THIS.aErrorClass[14,2] = "relational integrity"
|
|
THIS.aErrorClass[14,1] = "/1539/1555/1567/1879/1881/1882/1883/1884/1886/1887/"
|
|
THIS.aErrorClass[15,2] = "datasession"
|
|
THIS.aErrorClass[15,1] = "/1540/1545/1549/"
|
|
THIS.aErrorClass[16,2] = "offline views"
|
|
THIS.aErrorClass[16,1] = "/2007/2008/2010/2011/2015/2018/"
|
|
* THIS.aErrorClass[17,2] = "database"
|
|
* THIS.aErrorClass[17,1] = "/1529/1531/1534/1535/1536/1537/1538/1541/1542/1550/1551/1552/1553/1557/1558/1561/1562/1563/1564/1565/1566/1569/1570/"
|
|
|
|
ENDIF
|
|
|
|
RETURN (NOT llBail)
|
|
ENDPROC
|
|
|
|
PROCEDURE filllogrecord && Writes error information to the log.
|
|
INSERT INTO (THIS.cLogAlias) ("Errstamp") VALUES (DATETIME())
|
|
|
|
LOCAL lcErrData, liErrLevel, liSelect, liSession, liFormSession
|
|
|
|
liSelect = SELECT()
|
|
liSession = SET("DATASESSION")
|
|
|
|
SELECT (THIS.cLogAlias)
|
|
|
|
* create listing memo field from chunks of data --
|
|
* do a couple of REPLACEs so that less memory is
|
|
* used for each step of this process
|
|
|
|
lcErrData = "Error # "+TRANSFORM(THIS.iCurrentError)
|
|
IF NOT EMPTY(THIS.cCurrentClass)
|
|
lcErrData = lcErrData+ " class: "+THIS.cCurrentClass
|
|
ENDIF
|
|
lcErrData = lcErrData+CHR(13)+"Program "+ THIS.cCurrentMethod
|
|
lcErrData = lcErrData+CHR(13)+"Message "+ THIS.cCurrentMessage
|
|
IF NOT EMPTY(THIS.cCurrentErrorParam)
|
|
lcErrData = lcErrData+ " (" +THIS.cCurrentErrorParam+")"
|
|
ENDIF
|
|
lcErrData = lcErrData+CHR(13)+"Line # "+TRANSFORM(THIS.iCurrentLine)
|
|
|
|
liFormSession = liSession
|
|
|
|
IF TYPE("_SCREEN.ActiveForm") = "O"
|
|
lcErrData = lcErrData+CHR(13)+"Active: "+_SCREEN.ActiveForm.Name
|
|
IF TYPE("_SCREEN.ActiveForm.ActiveControl") = "O"
|
|
lcErrData = lcErrData+ " ("+_SCREEN.ActiveForm.ActiveControl.Name+")"
|
|
ENDIF
|
|
DO CASE
|
|
CASE TYPE("_SCREEN.ActiveForm.DataSessionID") = "N"
|
|
liFormSession = _SCREEN.ActiveForm.DataSessionID
|
|
CASE TYPE("_SCREEN.ActiveForm.Parent.DataSessionID") = "N"
|
|
* formset
|
|
liFormSession = _SCREEN.ActiveForm.Parent.DataSessionID
|
|
OTHERWISE
|
|
* can be a defined window or modi memo or whatever
|
|
ENDCASE
|
|
ENDIF
|
|
|
|
lcErrData = lcErrData+CHR(13)+"Session "+TRANSFORM(liFormSession)
|
|
REPLACE listing WITH lcErrData ADDITIVE
|
|
|
|
lcErrData = CHR(13)+"DiskSpc "+TRANSFORM(DISKSPACE())
|
|
lcErrData = lcErrData+CHR(13)+"Screen "+TRANSFORM(SYSMETRIC(2))+" by "+TRANSFORM(SYSMETRIC(1))
|
|
lcErrData = lcErrData+CHR(13)+"OS "+OS()
|
|
lcErrData = lcErrData+CHR(13)+"Vers(1) "+VERSION(1)
|
|
lcErrData = lcErrData+CHR(13)+"Vers(2) "+TRANSFORM(VERSION(2))
|
|
lcErrData = lcErrData+CHR(13)+"Vers(3) "+VERSION(3)
|
|
lcErrData = lcErrData+CHR(13)+"SMode "+TRANSFORM(_VFP.StartMode)
|
|
lcErrData = lcErrData+CHR(13)+"(1016) "+TRANSFORM(VAL(SYS(1016))/1024)+" user object memory used"
|
|
lcErrData = lcErrData+CHR(13)+"(1001) "+TRANSFORM(VAL(SYS(1001))/1024)+" pool available memory"
|
|
lcErrData = lcErrData+CHR(13)+"CPU "+ SYS(17)
|
|
lcErrData = lcErrData+CHR(13)+"Video "+SYS(2006)
|
|
lcErrData = lcErrData+CHR(13)+CHR(13)+REPLICATE("=",50)
|
|
lcErrData = lcErrData+CHR(13)+" Calling Chain:"
|
|
|
|
REPLACE listing WITH lcErrData ADDITIVE
|
|
|
|
liErrLevel = 1
|
|
lcErrData = CHR(13)
|
|
DO WHILE NOT EMPTY(SYS(16,liErrLevel)) AND NOT SYS(16,liErrLevel) == PROGRAM()
|
|
lcErrData = lcErrData + CHR(13)+SYS(16,liErrLevel)
|
|
liErrLevel= liErrLevel+1
|
|
ENDDO
|
|
|
|
lcErrData = lcErrData+CHR(13)+REPLICATE("=",50)
|
|
lcErrData = lcErrData+CHR(13)+CHR(13)+REPLICATE("=",50)
|
|
lcErrData = lcErrData+CHR(13)+" CONFIG file: "+SYS(2019)
|
|
IF FILE(SYS(2019))
|
|
lcErrData = lcErrData + CHR(13)+REPLICATE("=",50)+CHR(13)
|
|
REPLACE listing WITH lcErrData ADDITIVE
|
|
APPEND MEMO listing FROM (SYS(2019)) && ADDITIVE by default
|
|
ELSE
|
|
lcErrData = lcErrData + " NOT AVAILABLE"+CHR(13)+REPLICATE("=",50)+CHR(13)
|
|
REPLACE listing WITH lcErrData ADDITIVE
|
|
ENDIF
|
|
|
|
lcErrData = CHR(13)+CHR(13)+REPLICATE("=",50)
|
|
lcErrData = lcErrData+CHR(13)+" Status listing of Current Data Session "
|
|
lcErrData = lcErrData+CHR(13)+REPLICATE("=",50)+CHR(13)
|
|
REPLACE listing WITH lcErrData ADDITIVE
|
|
|
|
lcErrData = SYS(2023)+"\"+SYS(3)+".tmp"
|
|
|
|
DO WHILE FILE(lcErrData)
|
|
lcErrData = SYS(2023)+"\"+SYS(3)+".tmp"
|
|
ENDDO
|
|
|
|
IF liSession = liFormSession
|
|
SELECT (liSelect)
|
|
ELSE
|
|
SET DATASESSION TO (liFormSession)
|
|
ENDIF
|
|
LIST STATUS TO (lcErrData) NOCONSOLE
|
|
|
|
IF liSession = liFormSession
|
|
SELECT (THIS.cLogAlias)
|
|
ELSE
|
|
SET DATASESSION TO (liSession)
|
|
ENDIF
|
|
|
|
APPEND MEMO listing FROM (lcErrData)
|
|
|
|
ERASE (lcErrData)
|
|
REPLACE listing WITH CHR(13)+REPLICATE("=",50)+CHR(13)+;
|
|
" Memory listing"+CHR(13)+;
|
|
REPLICATE("=",50)+CHR(13) ;
|
|
ADDITIVE
|
|
|
|
LIST MEMORY TO (lcErrData) NOCONSOLE
|
|
APPEND MEMO listing FROM (lcErrData)
|
|
|
|
ERASE (lcErrData)
|
|
SELECT (liSelect)
|
|
|
|
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE geterrorattribute && Returns appropriate information from aErrorClass array for a given error number.
|
|
LPARAMETER tiColumn, tvErrNo
|
|
|
|
ASSERT EMPTY(tiColumn) OR ;
|
|
(VARTYPE(tiColumn) = "N" AND ;
|
|
BETWEEN(tiColumn,1,ALEN(THIS.aErrorClass,2)))
|
|
|
|
ASSERT EMPTY(tvErrNo) OR INLIST(VARTYPE(tvErrNo),"N","C")
|
|
|
|
LOCAL lcErrString, liColumn, liIndex, lvReturn, lcType
|
|
|
|
DO CASE
|
|
CASE EMPTY(tvErrNo)
|
|
lcErrString = "/"+TRANSFORM(THIS.iCurrentError)+"/"
|
|
CASE VARTYPE(tvErrNo) = "N"
|
|
lcErrString = "/"+TRANSFORM(tvErrNo)+"/"
|
|
OTHERWISE
|
|
lcErrString = "/"+ALLTR(tvErrNo)+"/"
|
|
ENDCASE
|
|
|
|
IF EMPTY(tiColumn)
|
|
* return the first column, error number string
|
|
liColumn = 1
|
|
ELSE
|
|
liColumn = tiColumn
|
|
ENDIF
|
|
|
|
lcType = VARTYPE(THIS.aErrorClass[1,liColumn])
|
|
DO CASE
|
|
CASE lcType = "C"
|
|
lvReturn = ""
|
|
CASE INLIST(lcType,"N","I","Y")
|
|
lvReturn = NTOM(0)
|
|
CASE INLIST(lcType,"D","T")
|
|
lvReturn = {}
|
|
CASE lcType = "O"
|
|
lvReturn = .NULL.
|
|
OTHERWISE
|
|
* lvReturn = .F.
|
|
ENDCASE
|
|
|
|
FOR liIndex = 1 TO ALEN(THIS.aErrorClass,1)
|
|
IF lcErrString $ THIS.aErrorClass[liIndex,1]
|
|
lvReturn = THIS.aErrorClass[liIndex,liColumn]
|
|
EXIT
|
|
ENDIF
|
|
ENDFOR
|
|
|
|
RETURN lvReturn
|
|
|
|
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE getmessageboxtitle && This is really meant for your subclass or instance to fill out with app-specific information, so that all user feedback (WAIT WINDOW NOWAITs and MESSAGEBOX()) by the error object matches your app properly.
|
|
RETURN ERROR_MESSAGEBOX_TITLE_LOC
|
|
ENDPROC
|
|
|
|
PROCEDURE handle && Main routine to handle error.
|
|
LPARAMETERS tiError, tcMethod, tiLine
|
|
|
|
THIS.cCurrentMessage = MESSAGE()
|
|
THIS.cCurrentErrorParam = SYS(2018)
|
|
THIS.iCurrentError = IIF(VARTYPE(tiError) # "N",0,tiError)
|
|
THIS.cCurrentMethod = TRANSFORM(tcMethod)
|
|
THIS.iCurrentLine = IIF(VARTYPE(tiLine) # "N",0,tiLine)
|
|
THIS.cCurrentClass = ""
|
|
THIS.lUserCancelled = .F. && it's possible
|
|
&& for an outside program to ignore a previous CANCEL instruction
|
|
|
|
THIS.FillArrays()
|
|
|
|
* note: FillArrays() does an early bail for memory
|
|
* errors,which will be messaged by THIS.IsFatal() below
|
|
|
|
* see FillArrays() for structure
|
|
* of aErrorClass array --
|
|
* GetErrorAttribute
|
|
* gets a particular element by looking
|
|
* up error numbers in the first array column and specifying
|
|
* what column of the array is needed. This column
|
|
* is passed as GetErrorAttribute's first parameter
|
|
* (you can also pass a second parameter containing
|
|
* a particular error number to look up -- this defaults
|
|
* to the iCurrentError contents)
|
|
THIS.cCurrentClass = THIS.GetErrorAttribute(2)
|
|
* for example,
|
|
* THIS.cCurrentLevel = THIS.GetErrorAttribute(3)
|
|
* for a property that used a third column of
|
|
* the array to store some error severity classification system
|
|
|
|
IF NOT (THIS.IsDisallowedServerAction(.T.) OR ;
|
|
THIS.IsFatal(.T.) OR ;
|
|
THIS.IsTrivial(.T.))
|
|
|
|
IF THIS.OKToReport()
|
|
|
|
THIS.LogErrorReport()
|
|
|
|
ENDIF
|
|
|
|
IF THIS.OKToContinue()
|
|
|
|
THIS.UserHandlesError()
|
|
|
|
ENDIF
|
|
|
|
|
|
ENDIF
|
|
|
|
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE isdisallowedserveraction && Tells whether the error is caused by an attempt to execute UI or other disallowed action from a server
|
|
LPARAMETERS tlWantRecord
|
|
LOCAL llDisallowedServerAction
|
|
IF THIS.lServer AND ;
|
|
(THIS.iCurrentError = 2031 OR ;
|
|
(THIS.iCurrentError = 1001 AND ;
|
|
_VFP.Startmode = 5) )
|
|
llDisallowedServerAction = .T.
|
|
IF tlWantRecord
|
|
THIS.RecordServerError(;
|
|
THIS.cCurrentMessage+CHR(13)+;
|
|
THIS.cCurrentErrorParam+CHR(13)+;
|
|
TRANS(THIS.iCurrentError)+CHR(13)+;
|
|
THIS.cCurrentMethod+CHR(13)+;
|
|
TRANS(THIS.iCurrentLine))
|
|
ENDIF
|
|
ENDIF
|
|
RETURN llDisallowedServerAction
|
|
ENDPROC
|
|
|
|
PROCEDURE isfatal && Whether error is a fatal type error.
|
|
LPARAMETERS tlWantDialog
|
|
|
|
LOCAL llIsFatal, lcMessage
|
|
lcMessage = ""
|
|
|
|
llIsFatal = INLIST("/"+THIS.cCurrentClass+"/", ;
|
|
"/memory/", ;
|
|
"/disk/", ;
|
|
"/program or resource file/" )
|
|
|
|
|
|
IF llIsFatal AND tlWantDialog
|
|
lcMessage = ERROR_SERIOUS_CLASS_LOC + ": " + UPPER(THIS.cCurrentClass) + CHR(13) +;
|
|
ERROR_CANNOT_BE_LOGGED_LOC + CHR(13)+ ;
|
|
CHR(13)+CHR(13)+;
|
|
SYS(16,0)+ ;
|
|
CHR(13)+ CHR(13)+ ;
|
|
"#"+TRANSFORM(THIS.iCurrentError)+" "+ ;
|
|
THIS.cCurrentMethod+", "+TRANSFORM(THIS.iCurrentLine) + ;
|
|
CHR(13)+CHR(13)+ ;
|
|
["]+THIS.cCurrentMessage+["]
|
|
|
|
IF THIS.lServer
|
|
|
|
THIS.RecordServerError(lcMessage)
|
|
|
|
ELSE
|
|
=MESSAGEBOX(lcMessage+CHR(13)+CHR(13)+ ;
|
|
ERROR_USER_NOTE_LOC, ;
|
|
MB_ICONSTOP, ;
|
|
THIS.GetMessageBoxTitle())
|
|
ENDIF
|
|
|
|
|
|
ENDIF
|
|
|
|
RETURN llIsFatal
|
|
ENDPROC
|
|
|
|
PROCEDURE isgooderrorlog && Validates error log
|
|
LPARAMETERS tcAlias
|
|
ASSERT USED(tcAlias)
|
|
|
|
LOCAL ARRAY aTemp[1]
|
|
|
|
=AFIELDS(aTemp,tcAlias)
|
|
|
|
RETURN UPPER(aTemp(1,1))== "ERRSTAMP" AND ;
|
|
UPPER(aTemp(2,1))== "LISTING" AND ;
|
|
UPPER(aTemp(3,1))== "USERNOTES" AND ;
|
|
aTemp(1,2)+aTemp(2,2)+aTemp(3,2)=="TMM"
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE istrivial && Whether error is a trivial type error.
|
|
LPARAMETERS tlWantDialog
|
|
|
|
LOCAL llIsTrivial, lcMessage
|
|
lcMessage = ""
|
|
llIsTrivial = INLIST("/"+THIS.cCurrentClass+"/", ;
|
|
"/print/", ;
|
|
"/lock/")
|
|
|
|
IF llIsTrivial AND tlWantDialog
|
|
* messageboxes
|
|
|
|
DO CASE
|
|
CASE THIS.cCurrentClass == "print"
|
|
|
|
lcMessage = ERROR_PRINT_LOC + ":"+ ;
|
|
CHR(13)+CHR(13)+;
|
|
["]+THIS.cCurrentMessage+["]
|
|
|
|
|
|
CASE THIS.cCurrentClass == "lock"
|
|
* should not happen unless SET REPROCESS
|
|
* is not properly set
|
|
lcMessage = ERROR_LOCK_LOC + ":"+ ;
|
|
CHR(13)+CHR(13)+;
|
|
THIS.cCurrentMessage
|
|
|
|
ENDCASE
|
|
|
|
IF NOT THIS.lServer
|
|
|
|
=MESSAGEBOX(lcMessage+CHR(13)+CHR(13)+ ;
|
|
ERROR_USER_FIX_LOC,;
|
|
MB_ICONEXCLAMATION, ;
|
|
THIS.GetMessageBoxTitle())
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
RETURN llIsTrivial
|
|
ENDPROC
|
|
|
|
PROCEDURE logerrorreport && If lServer is .T. or user indicates logging is desired, opens error log and logs the error.
|
|
LOCAL lcMessage
|
|
|
|
lcMessage = ["]+THIS.cCurrentMessage +["] + CHR(13)+CHR(13)+ ;
|
|
"("+TRANSFORM(THIS.iCurrentError)+")"+ ;
|
|
IIF(EMPTY(THIS.cCurrentErrorParam),"",;
|
|
" ("+THIS.cCurrentErrorParam+")" )+CHR(13)+ ;
|
|
THIS.cCurrentMethod+", "+TRANSFORM(THIS.iCurrentLine)+ CHR(13)+;
|
|
SYS(16,0)
|
|
|
|
IF THIS.lServer OR ;
|
|
MESSAGEBOX(ERROR_OCCURRED_LOC+":"+CHR(13)+CHR(13)+;
|
|
lcMessage+ CHR(13)+CHR(13)+ ;
|
|
ERROR_LOG_LOC, ;
|
|
MB_ICONSTOP+MB_YESNO, ;
|
|
THIS.GetMessageBoxTitle()) ;
|
|
= IDYES
|
|
|
|
IF NOT THIS.lServer
|
|
WAIT WINDOW NOWAIT LEFTC(lcMessage,254)
|
|
ENDIF
|
|
THIS.SetLog()
|
|
THIS.FillLogRecord()
|
|
WAIT CLEAR
|
|
|
|
ENDIF
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE oktocontinue && Abstract method to evaluate error whether to continue program execution.
|
|
* abstract in the base
|
|
ENDPROC
|
|
|
|
PROCEDURE oktoreport && Abstract method to evaluate error whether to report error.
|
|
* abstract in the base
|
|
ENDPROC
|
|
|
|
PROCEDURE recordservererror && Establishes a consistent method for logging feedback which would ordinarily go to UI, for use in servers
|
|
LPARAMETERS tcMessage
|
|
LOCAL lcMessage
|
|
lcMessage = TRANSFORM(tcMessage)
|
|
THIS.SetLog()
|
|
INSERT INTO (THIS.cLogAlias) ("Errstamp") VALUES (DATETIME())
|
|
REPLACE Listing WITH lcMessage IN (THIS.cLogAlias)
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE setlog && Evaluates log table name and alias, attempts to open and validate the table, creates new alias and log table name on the fly if anything goes wrong.
|
|
LPARAMETERS tcTableName, tcAlias
|
|
|
|
IF (NOT EMPTY(THIS.cLogAlias)) AND ;
|
|
USED(THIS.cLogAlias) AND ;
|
|
THIS.IsGoodErrorLog(THIS.cLogAlias)
|
|
RETURN .T.
|
|
ENDIF
|
|
|
|
LOCAL lcAlias, lcTableName, liSelect
|
|
|
|
|
|
IF VARTYPE(tcAlias) = "C" AND NOT EMPTY(tcAlias)
|
|
lcAlias = ALLTR(tcAlias)
|
|
IF USED(lcAlias) AND THIS.IsGoodErrorLog(lcAlias)
|
|
THIS.cLogAlias = lcAlias
|
|
ENDIF
|
|
ENDIF
|
|
|
|
IF EMPTY(THIS.cLogAlias)
|
|
lcAlias = "E"+SYS(2015)
|
|
DO WHILE USED(lcAlias)
|
|
lcAlias = "E"+SYS(2015)
|
|
ENDDO
|
|
THIS.cLogAlias = lcAlias
|
|
ENDIF
|
|
|
|
* now for the table name:
|
|
IF USED(THIS.cLogAlias)
|
|
|
|
lcTableName = DBF(lcAlias)
|
|
|
|
ELSE
|
|
|
|
DO CASE
|
|
CASE VARTYPE(tcTableName) = "C" AND NOT EMPTY(tcTableName)
|
|
lcTableName = ALLTR(tcTableName)
|
|
CASE NOT EMPTY(THIS.cLogDBF)
|
|
lcTableName = ALLTR(THIS.cLogDBF)
|
|
OTHERWISE
|
|
lcTableName = "errorlog.dbf"
|
|
ENDCASE
|
|
IF AT(".",lcTableName) = 0
|
|
lcTableName = lcTableName+".dbf"
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
THIS.cLogDBF = LOWER(FULLPATH(lcTableName))
|
|
|
|
IF NOT USED(THIS.cLogAlias)
|
|
|
|
IF NOT EMPTY(SYS(2000,THIS.cLogDBF))
|
|
USE (THIS.cLogDBF) AGAIN SHARED ALIAS (THIS.cLogAlias) IN 0
|
|
IF EMPTY(THIS.cLogDBF) ;
|
|
OR NOT THIS.IsGoodErrorLog(THIS.cLogAlias)
|
|
IF USED(THIS.cLogAlias)
|
|
USE IN (THIS.cLogAlias)
|
|
ENDIF
|
|
* recursive call with new, temporary filename:
|
|
THIS.SetLog(FULLPATH(THIS.cLogAlias), THIS.cLogAlias)
|
|
ENDIF
|
|
ELSE
|
|
liSelect = SELECT()
|
|
SELE 0
|
|
* v-darylm
|
|
CREATE TABLE (THIS.cLogDBF) FREE ;
|
|
(errstamp t, ;
|
|
listing m,;
|
|
usernotes m)
|
|
*!* CREATE TABLE (THIS.cLogDBF) ;
|
|
*!* (errstamp t, ;
|
|
*!* listing m,;
|
|
*!* usernotes m)
|
|
USE (THIS.cLogDBF) AGAIN SHARED ALIAS (THIS.cLogAlias)
|
|
SELECT (liSelect)
|
|
ENDIF
|
|
ENDIF
|
|
|
|
RETURN
|
|
ENDPROC
|
|
|
|
PROCEDURE usercancelled && Returns whether user opted to cancel after the current error.
|
|
RETURN THIS.lUserCancelled
|
|
ENDPROC
|
|
|
|
PROCEDURE userhandleserror && Gives user choices about whether to go on with the app after an error.
|
|
LOCAL liContinue
|
|
|
|
DO CASE
|
|
|
|
CASE THIS.lServer
|
|
liContinue = IDYES
|
|
CASE VERSION(2) = 0
|
|
liContinue = MESSAGEBOX( ERROR_USEREND_LOC,;
|
|
MB_ICONEXCLAMATION+MB_OKCANCEL, ;
|
|
THIS.GetMessageBoxTitle())
|
|
|
|
OTHERWISE
|
|
liContinue = MESSAGEBOX(ERROR_DEVEND_LOC, ;
|
|
MB_ICONEXCLAMATION+MB_YESNOCANCEL, ;
|
|
THIS.GetMessageBoxTitle())
|
|
ENDCASE
|
|
|
|
|
|
DO CASE
|
|
|
|
CASE INLIST(liContinue,IDYES, IDOK)
|
|
RETURN
|
|
|
|
CASE liContinue = IDNO
|
|
DEBUG
|
|
SUSPEND
|
|
|
|
|
|
OTHERWISE
|
|
|
|
THIS.lUserCancelled = .T.
|
|
* at this point in an object method, a CANCEL may be
|
|
* the same as a RETURN. The owning object
|
|
* has to decide what to do. If you do a CANCEL
|
|
* here it will have the effect of making it
|
|
* difficult for the container to RELEASE properly.
|
|
* This is especially a problem if the error
|
|
* has been invoked by the ON ERROR handler, because
|
|
* the ON... interrupt can take you back to anywhere.
|
|
|
|
ENDCASE
|
|
|
|
|
|
|
|
ENDPROC
|
|
|
|
ENDDEFINE
|
|
|
|
DEFINE CLASS _objectstate AS _custom OF "_base.vcx" && Saves and restores state for any object either automatically (on Init and Destroy of this object) or on demand.
|
|
*< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" />
|
|
|
|
*<DefinedPropArrayMethod>
|
|
*m: restore && Restores value of a property for oObject.
|
|
*m: save && Saves current value of a property for oObject.
|
|
*m: set && Sets a property to a new value for oObject.
|
|
*p: lautomatic && Automatically saves/restores properties for oObject.
|
|
*p: oobject && Reference to target object whose state is being saved.
|
|
*a: aproperties[1,3] && Array for saving/restoring properties of oObject.
|
|
*</DefinedPropArrayMethod>
|
|
|
|
*<PropValue>
|
|
Name = "_objectstate"
|
|
oobject = .NULL.
|
|
*</PropValue>
|
|
|
|
PROCEDURE Destroy
|
|
DODEFAULT()
|
|
|
|
IF THIS.lAutomatic
|
|
THIS.Restore()
|
|
ENDIF
|
|
THIS.oObject = .NULL.
|
|
ENDPROC
|
|
|
|
PROCEDURE Init
|
|
LPARAMETERS toObject
|
|
IF NOT DODEFAULT()
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
IF TYPE("toObject.BaseClass") = "C"
|
|
|
|
THIS.lAutomatic = .T.
|
|
|
|
THIS.oObject = toObject
|
|
|
|
ENDIF
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE restore && Restores value of a property for oObject.
|
|
LPARAMETERS tcWhichProperty
|
|
|
|
IF ISNULL(THIS.oObject)
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
LOCAL lcProperty, liPos, liRow, lvCurrentValue, lcCurrentProperty
|
|
|
|
ASSERT EMPTY(tcWhichProperty) OR VARTYPE(tcWhichProperty) = "C"
|
|
|
|
IF EMPTY(tcWhichProperty)
|
|
|
|
* restore all
|
|
|
|
FOR liRow = 1 TO ALEN(THIS.aProperties,1)
|
|
|
|
IF EMPTY(THIS.aProperties[liRow,1])
|
|
LOOP
|
|
ENDIF
|
|
|
|
lcCurrentProperty = STRTRAN(THIS.aProperties[liRow,1],"#","")
|
|
|
|
lvCurrentValue = EVAL("THIS.oObject."+lcCurrentProperty)
|
|
|
|
* avoid re-setting properties to their current
|
|
* value because this may cause a "flash"
|
|
IF THIS.aProperties[liRow,2] = "C"
|
|
|
|
IF lvCurrentValue == THIS.aProperties[liRow,3]
|
|
LOOP
|
|
ENDIF
|
|
|
|
ELSE
|
|
|
|
IF lvCurrentValue = THIS.aProperties[liRow,3]
|
|
LOOP
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
STORE THIS.aProperties[liRow,3] TO ;
|
|
("THIS.oObject."+lcCurrentProperty)
|
|
|
|
ENDFOR
|
|
|
|
ELSE
|
|
|
|
lcProperty = LOWER(tcWhichProperty)
|
|
|
|
liPos = ASCAN(THIS.aProperties,"#"+lcProperty+"#")
|
|
|
|
IF liPos = 0
|
|
|
|
RETURN .F.
|
|
|
|
ELSE
|
|
|
|
liRow = ASUBSCRIPT(THIS.aProperties, liPos, 1)
|
|
STORE THIS.aProperties[liRow,3] TO ("THIS.oObject."+lcProperty)
|
|
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE save && Saves current value of a property for oObject.
|
|
LPARAMETERS tcProperty, tcTypeValue
|
|
|
|
ASSERT VARTYPE(tcProperty) = "C" AND NOT EMPTY(tcProperty)
|
|
ASSERT PCOUNT() < 2 OR VARTYPE(tcTypeValue) = "C"
|
|
|
|
IF ISNULL(THIS.oObject)
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
LOCAL lcProperty, liPos, liRow, lcTypeValue
|
|
|
|
lcProperty = LOWER(tcProperty)
|
|
|
|
liPos = ASCAN(THIS.aProperties,"#"+lcProperty+"#")
|
|
|
|
IF liPos = 0
|
|
|
|
IF PCOUNT() = 2
|
|
lcTypeValue = tcTypeValue
|
|
ELSE
|
|
lcTypeValue = TYPE("THIS.oObject."+tcProperty)
|
|
ENDIF
|
|
|
|
liRow = ALEN(THIS.aProperties,1)
|
|
IF TYPE("THIS.aProperties[liRow,1]") = "C"
|
|
liRow = liRow + 1
|
|
DIME THIS.aProperties[liRow,3]
|
|
ENDIF
|
|
|
|
THIS.aProperties[liRow,1] = "#"+lcProperty+"#"
|
|
THIS.aProperties[liRow,2] = lcTypeValue
|
|
|
|
ELSE
|
|
|
|
liRow = ASUBSCRIPT(THIS.aProperties, liPos, 1)
|
|
|
|
ENDIF
|
|
|
|
THIS.aProperties[liRow,3] = EVAL("THIS.oObject."+lcProperty)
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE set && Sets a property to a new value for oObject.
|
|
LPARAMETERS tcProperty, tvValue, tlSave
|
|
|
|
IF ISNULL(THIS.oObject)
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
ASSERT TYPE("THIS.oObject."+tcProperty) # "U"
|
|
|
|
LOCAL lcTypeValue
|
|
|
|
lcTypeValue = VARTYPE(tvValue)
|
|
|
|
IF lcTypeValue # TYPE("THIS.oObject."+tcProperty)
|
|
RETURN .F.
|
|
ENDIF
|
|
|
|
IF tlSave
|
|
THIS.Save(tcProperty, lcTypeValue)
|
|
ENDIF
|
|
|
|
STORE tvValue TO ;
|
|
("THIS.oObject."+tcProperty)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
ENDPROC
|
|
|
|
ENDDEFINE
|
|
|
|
DEFINE CLASS _systoolbars AS _custom OF "_base.vcx" && Hides and shows system toolbars, either automatically (at Init and Destroy of this object) or on demand.
|
|
*< CLASSDATA: Baseclass="custom" Timestamp="" Scale="Pixels" Uniqueid="" />
|
|
|
|
#INCLUDE "_app.h"
|
|
*<DefinedPropArrayMethod>
|
|
*m: hidesystemtoolbars && Manually hides system toolbars for your application.
|
|
*m: initializetoolbararray
|
|
*m: showsystemtoolbars && Manually shows system toolbars for your application.
|
|
*p: lautomatic && Automatically hides and restores system toolbars for application.
|
|
*a: asystemtoolbars[1,0] && Array of system toolbars.
|
|
*</DefinedPropArrayMethod>
|
|
|
|
*<PropValue>
|
|
Name = "_systoolbars"
|
|
*</PropValue>
|
|
|
|
PROCEDURE Destroy
|
|
DODEFAULT()
|
|
IF THIS.lAutomatic
|
|
THIS.ShowSystemToolbars()
|
|
ENDIF
|
|
ENDPROC
|
|
|
|
PROCEDURE hidesystemtoolbars && Manually hides system toolbars for your application.
|
|
LOCAL iIndex
|
|
|
|
FOR iIndex = 1 TO ALEN(THIS.aSystemToolbars,1)
|
|
* note: it is possible for them to have been RELEASEd
|
|
* and not exist at all
|
|
IF WEXIST(THIS.aSystemToolbars[iIndex,1]) AND ;
|
|
WVISIBLE(THIS.aSystemToolbars[iIndex,1])
|
|
THIS.aSystemToolbars[iIndex,2] = .T.
|
|
HIDE WINDOW (THIS.aSystemToolbars[iIndex,1])
|
|
ENDIF
|
|
ENDFOR
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE Init
|
|
LPARAMETERS tlAuto
|
|
|
|
IF NOT DODEFAULT()
|
|
RETURN .F.
|
|
ENDIF
|
|
THIS.InitializeToolbarArray()
|
|
|
|
IF THIS.lAutomatic OR tlAuto
|
|
THIS.lAutomatic = .T.
|
|
THIS.HideSystemToolbars()
|
|
ENDIF
|
|
ENDPROC
|
|
|
|
PROCEDURE initializetoolbararray
|
|
DIME THIS.aSystemToolbars[11,2]
|
|
|
|
THIS.aSystemToolbars[1,1]= TB_STANDARD_LOC
|
|
THIS.aSystemToolbars[2,1]= TB_LAYOUT_LOC
|
|
THIS.aSystemToolbars[3,1]= TB_QUERY_LOC
|
|
THIS.aSystemToolbars[4,1]= TB_VIEWDESIGNER_LOC
|
|
THIS.aSystemToolbars[5,1]= TB_COLORPALETTE_LOC
|
|
THIS.aSystemToolbars[6,1]= TB_FORMCONTROLS_LOC
|
|
THIS.aSystemToolbars[7,1]= TB_DATADESIGNER_LOC
|
|
THIS.aSystemToolbars[8,1]= TB_REPODESIGNER_LOC
|
|
THIS.aSystemToolbars[9,1]= TB_REPOCONTROLS_LOC
|
|
THIS.aSystemToolbars[10,1]= TB_PRINTPREVIEW_LOC
|
|
THIS.aSystemToolbars[11,1]= TB_FORMDESIGNER_LOC
|
|
|
|
ENDPROC
|
|
|
|
PROCEDURE showsystemtoolbars && Manually shows system toolbars for your application.
|
|
LOCAL iIndex
|
|
|
|
FOR iIndex = 1 TO ALEN(THIS.aSystemToolbars,1)
|
|
IF WEXIST(THIS.aSystemToolbars[iIndex,1]) AND ;
|
|
THIS.aSystemToolbars[iIndex,2]
|
|
SHOW WINDOW (THIS.aSystemToolbars[iIndex,1])
|
|
ENDIF
|
|
ENDFOR
|
|
|
|
|
|
|
|
ENDPROC
|
|
|
|
ENDDEFINE
|
|
|
|
DEFINE CLASS _traceawaretimer AS _timer OF "_base.vcx" && Timer with a special (slower) interval for debugging, so that timer events still occur but don't interrupt other tracing.
|
|
*< CLASSDATA: Baseclass="timer" Timestamp="" Scale="Pixels" Uniqueid="" />
|
|
|
|
*<DefinedPropArrayMethod>
|
|
*p: iregularinterval && Standard interval period.
|
|
*p: itraceinterval && Slower interval period you wish to use while debugging.
|
|
*</DefinedPropArrayMethod>
|
|
|
|
*<PropValue>
|
|
iregularinterval = 0
|
|
itraceinterval = 10000
|
|
Name = "_traceawaretimer"
|
|
*</PropValue>
|
|
|
|
PROCEDURE Init
|
|
IF NOT DODEFAULT()
|
|
RETURN .F.
|
|
ENDIF
|
|
THIS.iRegularInterval = THIS.Interval
|
|
ENDPROC
|
|
|
|
PROCEDURE Timer
|
|
IF WVISIBLE("trace") OR ;
|
|
WVISIBLE("debugger") OR ;
|
|
WVISIBLE("call") OR ;
|
|
WVISIBLE("watch") OR ;
|
|
WVISIBLE("locals")
|
|
|
|
IF THIS.Interval # THIS.iTraceInterval
|
|
THIS.iRegularInterval = THIS.Interval
|
|
THIS.Interval = THIS.iTraceInterval
|
|
ENDIF
|
|
|
|
ELSE
|
|
|
|
IF THIS.Interval = THIS.iTraceInterval
|
|
THIS.Interval = THIS.iRegularInterval
|
|
ENDIF
|
|
THIS.iRegularInterval = THIS.Interval
|
|
|
|
ENDIF
|
|
ENDPROC
|
|
|
|
ENDDEFINE
|