Module Dferror.pkg
1//************************************************************************
2 //
3 //* Copyright (c) 1997 Data Access Corporation, Miami Florida,
4 //* All rights reserved.
5 //* DataFlex is a registered trademark of Data Access Corporation.
6 //*
7 //* Module Name:
8 //* DFERROR.PKG
9//************************************************************************
10
11
12
13Use LanguageText.pkg
14
15#CHKSUB 1 1 // Verify the UI subsystem.
16
17Use Windows.pkg
18Use msgbox.pkg
19Use GlobalFunctionsProcedures.pkg
20
21//integer ghoErrorSource
22//Move 0 to ghoErrorSource
23//// ghoErrorSource object is expected to support this message
24//Register_Function Extended_Error_Message returns string
25
26// Include or define all useful symbols.
27Use ERRORNUM.INC
28#Replace MAX_ERROR_NUMBER 32766
29// these are kept for compatibility. Don't use them
30#Replace FIND_PAST_END 42
31#Replace FIND_PAST_BEGIN 41
32
33// used by error handler and UserError to pull a caption out of the error string
34Define C_ErrorCaption for "*CAPTION*="
35
36// This array stores the set of trapped errors as toggled ranges starting
37// with the errors that are trapped. The array should always contain 0 and
38// MAX_ERROR_NUMBER + 1, which are the limits. If an array contained the
39// following items...
40//
41// { 0, 5, 10, MAX_ERROR_NUMBER + 1 }.
42//
43// This would mean that errors 1 - 4 are trapped, 5 - 9 are ignored, and
44// 10 through the rest are trapped.
45//
46{ Visibility=Private }
47Class Trapped_Errors_Array is an array
48
49 // Find largest error LE targetError. Assumes array is sorted.
50 Function findErrorLE Integer targetError Returns Integer
51
52 Integer lowIndex hiIndex midIndex currError
53
54 // If error is outside of boudary conditions, use
55 // value of closest valid error# instead.
56 If targetError le 0;
57 Move 1 to targetError
58 Else If targetError ge MAX_ERROR_NUMBER ;
59 Move ( MAX_ERROR_NUMBER - 1 ) to targetError
60
61 Move 0 to lowIndex
62 Move ( item_count( Self ) - 1 ) to hiIndex
63
64 // midIndex will contain the closest error LE to target upon exit.
65 Repeat
66
67 Move ( ( lowIndex + hiIndex ) / 2 ) to midIndex
68 Move ( integer_value( Self, midIndex ) ) to currError
69
70 // midIndex is targetIndex if a match occurs
71 If currError eq targetError ;
72 Function_Return midIndex
73
74 // We are either on it or just below it.
75 If ( lowIndex eq midIndex ) Begin
76
77 If ( integer_value( Self, hiIndex ) le targetError ) ;
78 Move hiIndex to midIndex
79
80 Function_Return midIndex
81
82 End
83
84 // No match, so move the boundaries.
85 If currError gt targetError ;
86 Move ( midIndex - 1 ) to hiIndex
87 Else ;
88 Move midIndex to lowIndex
89
90 Until lowIndex gt hiIndex
91
92 Function_Return midIndex
93
94 End_Function
95
96 // Boundaries of the table are assumed to hold error limits.
97 Procedure initArray
98 Send delete_data
99 Set array_value item 0 to 0
100 Set array_value item 1 to ( MAX_ERROR_NUMBER + 1 )
101 End_Procedure
102
103 // Return 1 if Error is trapped, 0 otherwise.
104 Function isTrapped Integer Error# Returns Integer
105 Function_Return ( not ( mod( findErrorLE( Self, Error# ), 2 ) ) )
106 End_Function
107
108 // Add the error as long as it doesn't violate boundary conditions.
109 // This routine leaves the array unsorted.
110 Procedure addError Integer Error#
111 If ( ( Error# lt MAX_ERROR_NUMBER ) and ( Error# gt 0 ) ) ;
112 Set array_value item ( item_count( Self ) ) to ( Integer( Error# ) )
113 End_Procedure
114
115 // Set error to flagged state.
116 Procedure handleError Integer Error# Integer trapFlag
117
118 Integer prevErrIndex prevErrFlag prevErrValue nextErrValue
119
120 If ( ( Error# gt MAX_ERROR_NUMBER ) or ( Error# lt 0 ) ) Begin
121 Error DFERR_ERROR_NUMBER_OUT_OF_RANGE
122 Procedure_Return
123 End
124
125 Get findErrorLE Error# to prevErrIndex
126 Get isTrapped Error# to prevErrFlag
127
128 // if eq, Error already handled in some range.
129 If PrevErrFlag NE trapFlag Begin
130
131 // This is kind of complicated. If we are adding an error,
132 // we have to account for the error already being in the
133 // array as well as rejoining ranges that have been previously
134 // split and splitting ranges when adding a new flag.
135
136 Get integer_value item ( prevErrIndex + 1 ) to nextErrValue
137 Get integer_value item prevErrIndex to prevErrValue
138
139 // Do this first so prevErrIndex stays valid.
140 If nextErrValue eq ( Error# + 1 ) ;
141 Send delete_item ( prevErrIndex + 1 )
142 Else ;
143 Send addError ( Error# + 1 )
144
145 If ( prevErrValue lt Error# ) ;
146 Send addError Error#
147 Else ;
148 Send delete_item prevErrIndex
149 End
150 Send sort_items UPWARD_DIRECTION
151
152 End_Procedure
153
154 //*** Flag error as trappable
155 Procedure Trap_Error Integer Error#
156 Send handleError Error# 1
157 End_Procedure
158
159 //*** Flag error as non-trappable
160 Procedure Ignore_Error Integer Error#
161 Send handleError Error# 0
162 End_Procedure
163
164 //*** Flag all errors as trappable
165 Procedure Trap_All
166 Send initArray
167 End_Procedure
168
169 //*** Flag all errors as non-trappable
170 Procedure Ignore_All
171 Send delete_data
172 Set array_value item 0 to 0
173 Set array_value item 1 to 1
174 Set array_value item 2 to ( MAX_ERROR_NUMBER + 1 )
175 End_Procedure
176
177End_Class
178
179
180{ HelpTopic=ErrorSystem ClassLibrary=Windows }
181Class ErrorSystem is a cObject
182
183 Procedure construct_object
184 Forward Send construct_object
185
186 Set delegation_mode to no_delegate_or_error
187
188 { Category="Error Handling" }
189 Property Integer Verbose_State True
190 { DesignTime=False }
191 { Visibility=Private }
192 Property Integer Current_Error_Number 0
193 { DesignTime=False }
194 { Visibility=Private }
195 Property Integer Error_Line_Number 0
196
197 // If set false, this makes the error handler work the old way which
198 // does not use the new unhandled dialog. Only exists for compatibility reasons
199 { Category="Error Handling" }
200 Property Boolean pbUnhandledErrorSupport True
201
202 // shows error numbers with user errors. Only set this true if your
203 // application has meaningful numbers that helps the end user. Note that
204 // unhandled errors always show numbers.
205 // this is ignored if pbUnhandledErrorSupport is false
206 { Category="Error Handling" }
207 Property Boolean pbShowErrorNumber False
208
209
210 // This is the caption that appears for unhandled errors dialog box
211 { Category="Error Handling" }
212 Property String psUnhandledErrorCaption C_$UnhandledProgramError
213
214 // This is the caption that appears for standard user errors
215 { Category="Error Handling" }
216 Property String psUserErrorCaption C_$Error
217
218 // Flag which is sent when error is being processed. This
219 // stops error recursion.
220 { Visibility=Private }
221 Property Integer Error_Processing_State False
222
223 // array of errors that we consider User Errors
224 { Visibility=Private }
225 Property Integer[] pUserErrorsArray
226
227 // This allows us to skip find errors (GT & LT) and to only
228 // ring a bell when these occur.
229 //
230 { Visibility=Private }
231 Property Integer Bell_on_Find_Error_State True
232
233 Object trappedErrors is a Trapped_Errors_Array
234 Send initArray
235 End_Object
236
237 Send Trap_All
238
239 // define the standard user error numbers
240 Send AddUserError 0
241 Send AddUserError DFERR_NUMBER_TOO_LARGE
242 Send AddUserError DFERR_WINDOW_RANGE
243 Send AddUserError DFERR_ENTRY_REQUIRED
244 Send AddUserError DFERR_ENTER_A_NUMBER
245 Send AddUserError DFERR_BAD_ENTRY
246 Send AddUserError DFERR_ENTER_VALID_DATE
247 Send AddUserError DFERR_NUMERIC_RANGE
248 Send AddUserError DFERR_DUPLICATE_REC
249 Send AddUserError DFERR_TEXT_FIELD_TOO_LONG
250 Send AddUserError DFERR_FIND_PRIOR_BEG_OF_FILE
251 Send AddUserError DFERR_FIND_PAST_END_OF_FILE
252 Send AddUserError DFERR_NO_REC_TO_DELETE
253 Send AddUserError DFERR_FIELD_NOT_INDEXED // can be invoked w/ find keys
254 Send AddUserError DFERR_REC_NUMBER_RANGE
255 Send AddUserError DFERR_ENTER_VALID_REC_ID
256 Send AddUserError DFERR_OPERATOR_ERROR
257 Send AddUserError DFERR_CANT_CHANGE_KEY_FIELD
258 Send AddUserError DFERR_NO_DELETE_RELATED_RECORDS_EXIST
259 Send AddUserError DFERR_OPERATION_NOT_ALLOWED
260 Send AddUserError DFERR_OPERATOR
261 Send AddUserError DFERR_XML_HTTP
262 Send AddUserError DFERR_CLIENT_SOAP_TRANSFER
263 Send AddUserError DFERR_CLIENT_SOAP_FAULT
264 Send AddUserError DFERR_TEXT_TOO_LARGE_FOR_FIELD
265 Send AddUserError DFERR_WINPRINT
266 Send AddUserError DFERR_CRYSTAL_REPORT
267 Send AddUserError DFERR_MAPI
268 Send AddUserError DFERR_FILE_ACCESS_VIOLATION
269 Send AddUserError DFERR_VISUAL_REPORT_WRITER
270 Send AddUserError 999 // This is defined as DD_DEFAULT_ERROR_NUMBER in DataDict.pkg and is the default Field_error
271 // number of DDs.
272 Move Self to Error_Object_Id
273 End_Procedure
274
275 { Visibility=Private MethodType=Property }
276 Function Help_Context Integer Context_Type Returns String
277 Function_Return (Current_Error_Number(Self))
278 End_Function
279
280 //*** Catch and display error Error#.
281 Procedure Trap_Error Integer Error#
282 Send Trap_Error to ( trappedErrors( Self ) ) Error#
283 End_Procedure
284
285 //*** Pass error Error# on to the regular DataFlex error handler.
286 Procedure Ignore_Error Integer Error#
287 Send Ignore_Error to ( trappedErrors( Self ) ) Error#
288 End_Procedure
289
290 //*** Catch and display all errors.
291 Procedure Trap_All
292 Send Trap_All to ( trappedErrors( Self ) )
293 End_Procedure
294
295 //*** Forward all error to regular DataFlex error handler.
296 Procedure Ignore_All
297 Send Ignore_All to ( trappedErrors( Self ) )
298 End_Procedure
299
300 //*** Build complete error description from Flexerrs and user error message.
301 { Visibility=Private }
302 Function Error_Description Integer Error# String ErrMsg Returns String
303 String Full_Error_Text
304
305 trim ErrMsg to ErrMsg
306 Move (trim(error_text(DESKTOP,Error#))) to Full_Error_Text
307
308 If (ErrMsg<>"") Begin
309
310 If ( ( Full_Error_Text<>"" ) and ;
311 error_text_available( DESKTOP, Error# ) ) Begin
312 // Make sure last character of error text is a separating symbol.
313 // if not, add a "." So we have format of "error-text. error-detail"
314 If ( pos(right(Full_error_text,1),".,:;")=0 ) ;
315 Move (Full_Error_Text - ".") to Full_Error_Text
316 Move (Full_Error_Text * ErrMsg) to Full_Error_Text
317 End
318 Else ;
319 Move ErrMsg to Full_Error_Text
320
321 End
322
323 Function_Return Full_Error_Text
324 End_Function
325
326 //** return true if an error number is critical
327 { Visibility=Private }
328 Function Is_Critical Integer Error# Returns Integer
329 Function_Return (".3.10.18.19.20.21.22.43.70.72.74.75.78.80.97.";
330 contains ("."+String(Error#)+"."))
331 End_Function
332
333 // adds a user error to the array
334 Procedure AddUserError Integer iError
335 Integer[] UserErrors
336 Get pUserErrorsArray to UserErrors
337 // We assume that there are few enough user errors to worry about speed of finding
338 // the an array item. It always does a linear seach, which should be plenty fast.
339 If (SearchArray(iError,UserErrors)=-1) Begin
340 Move iError to UserErrors[SizeOfArray(UserErrors)]
341 Set pUserErrorsArray to UserErrors
342 End
343 End_Procedure
344
345 // removes an error from the user array
346 Procedure RemoveUserError Integer iError
347 Integer[] UserErrors
348 Integer iIndex iSize
349 Get pUserErrorsArray to UserErrors
350 Move (SearchArray(iError,UserErrors)) to iIndex
351 If (iIndex<>-1) Begin
352 // replace the removed error with the last error and resize the array
353 Move (SizeOfArray(UserErrors)) to iSize
354 Move UserErrors[iSize-1] to UserErrors[iIndex]
355 Set pUserErrorsArray to (ResizeArray(UserErrors,iSize-1))
356 End
357 End_Procedure
358
359 // removes all user errors
360 Procedure RemoveAllUserErrors
361 Integer[] UserErrors
362 Set pUserErrorsArray to UserErrors
363 End_Procedure
364
365 // returns true if this is an unhandled error (i.e., not a user error
366 Function IsUnhandledError Integer iError Returns Boolean
367 Integer[] UserErrors
368 Get pUserErrorsArray to UserErrors
369 Function_Return (SearchArray(iError,UserErrors)=-1)
370 End_Function
371
372 Procedure UnhandledErrorDisplay Integer iErrorLine String sMessage
373 String sCaption sCRLF
374 Move (Character(13)+Character(10)) to sCRLF
375 Get psUnhandledErrorCaption to sCaption
376 Move (Replaces("\n",sMessage,sCRLF)) to sMessage
377 Move (Replaces("\"+sCRLF, sMessage, "\n")) to sMessage
378 ErrorDisplay iErrorLine sMessage sCaption C_$OK C_$Copy
379 End_Procedure
380
381 //*** Handle error event, displaying error info to user.
382 { MethodType=Event }
383 Procedure Error_Report Integer ErrNum Integer Err_Line String ErrMsg
384 Integer iReply iIcon
385 String sErrorText sMess
386 String sSource sCaption
387 Integer iSrcPos iSrc iTxtLen
388 Boolean bIsUnhandled bUnhandledSupport bCritical bVerbose
389
390 If (Error_processing_State(Self)) Begin // don't allow error
391 Procedure_Return // recursion
392 End
393
394 Set Error_Processing_State to True // we are now in an error reporting state
395
396 Set Current_Error_Number to ErrNum
397 Set Error_Line_Number to Err_Line
398
399 // if this is false, this will work old-style -- all errors go through message box
400 Get pbUnhandledErrorSupport to bUnhandledSupport
401
402 Get Is_Critical errnum to bCritical
403 Get IsUnhandledError ErrNum to bIsUnhandled
404
405
406 //
407 // Changes made so find errors don't report - just beep
408 //
409
410 If ( Bell_On_find_Error_State(Self) and ;
411 ErrNum=DFERR_FIND_PRIOR_BEG_OF_FILE or ErrNum=DFERR_FIND_PAST_END_OF_FILE) Begin
412 Send Bell
413 End
414 Else If not ( isTrapped( TrappedErrors( Self ), ErrNum ) ) Begin
415 // if trapped do nothing
416
417 // We used to forward send. Since this is based on array, it does not understand this message, the forward was
418 // not understood. Since arrays don't delegate or error, nothing happened.
419 // An easier way to do nothing, is to do nothing, hence this line if removed
420 //forward send Error_Report ErrNum Err_Line ErrMsg
421 End
422 Else Begin
423
424 // See if source information is provided (Source = module.function). If so remove
425 // as detail. Must find last instance of this in string
426 Move (pos(C_ErrorContextSourceText,ErrMsg)) to iSrc
427 If iSrc Begin
428 Move (iSrc-1) to iSrcPos
429 Move (length(C_ErrorContextSourceText)) to iTxtLen
430 Move ErrMsg to sSource
431 Repeat // this makes sure we find last instance of this
432 Move (remove(sSource, 1, iSrc-1 + iTxtLen )) to sSource // right part of string
433 Move (pos(C_ErrorContextSourceText,sSource)) to iSrc // see if it was the last
434 If iSrc ; // if not, track length
435 Move (iSrcPos + iTxtLen + iSrc-1) to iSrcPos
436 Until (iSrc=0)
437 Move (trim(left(ErrMsg,iSrcPos))) to ErrMsg
438 If (right(ErrMsg,1)=',') ;
439 Move (left(ErrMsg,length(ErrMsg)-1)) to ErrMsg
440 End
441
442 // the caption normally used for handled user errors
443 Get psUserErrorCaption to sCaption
444 // if an operator error this may be a Procedure UserError situation where the
445 // caption is passed in the error text. If so, get the caption
446 If (ErrNum=DFERR_OPERATOR) Begin
447 Move (pos(C_ErrorCaption,ErrMsg)) to iSrc
448 If iSrc Begin
449 Move (length(C_ErrorCaption)) to iTxtLen
450 Move (remove(ErrMsg, 1, iSrc-1 + iTxtLen )) to sCaption
451 Move (Left(ErrMsg,iSrc-1)) to ErrMsg
452 End
453 End
454
455 Get Error_Description ErrNum ErrMsg to sErrorText
456
457 // if the error source is identified we can get extended error
458 // text for our error message
459 If ghoErrorSource Begin
460 Get extended_error_Message of ghoErrorSource to sMess
461 If sMess ne '' ;
462 Move (sErrorText + "\n\n" + sMess ) to sErrorText
463 End
464
465 If (bUnhandledSupport) Begin
466 // as of 14.1, this is the preferred way to do errors
467 If ( bCritical or bIsUnhandled) Begin
468 Move ( sErrorText + "\n\n" + C_$Error + ":" * String(ErrNum) ) to sErrorText
469 If (sSource<>"") Begin
470 Move (sErrorText + "\n" + C_$ErrorSource +" =" * sSource) to sErrorText
471 End
472 End
473 Else If (pbShowErrorNumber(Self)) Begin
474 // if a user error, we provide a way to see error numbers.
475 Move ( sErrorText + "\n\n" + C_$Error + ":" * String(ErrNum) ) to sErrorText
476 End
477 End
478 Else Begin
479 // we get here if we want it to work the old (less good) way. This is provided
480 // only for backwards compatibility. All errors go through the message box
481 Get Verbose_State to bVerbose
482 If (bVerbose) Begin
483 Move ( sErrorText + "\n\n" + SFormat(C_$TechnicalDetails, ErrNum, Err_Line) ) to sErrorText
484 If (sSource<>"") Begin
485 Move (sErrorText + "\n" + C_$ErrorSource +" =" * sSource) to sErrorText
486 End
487 End
488 End
489
490 If ( (bCritical or bIsUnhandled) and bUnhandledSupport) Begin
491 Send UnhandledErrorDisplay Err_Line sErrorText
492 End
493 Else Begin
494 Move (If(bCritical,MB_IconHand,MB_IconExclamation)) to iIcon
495 Get Message_Box sErrorText sCaption MB_Ok iIcon to iReply
496 End
497
498 // abort on critical errors
499 If bCritical Abort
500
501 End
502 Move 0 to ghoErrorSource
503 Set Error_Processing_State to False // no longer reporting an error
504 End_Procedure
505
506
507 // JJT- Note if you are using the WINDAF windows help system
508 // the following functions are not used.
509
510 // The functions below are used to construct a general help
511 // name for errors that are generated by the system. If processing
512 // comes here, then there was no module specific help found. These
513 // functions will provide a more general help name that appears in
514 // the form of SYSTEM..ERROR:#. All global errors should be
515 // places in the help file under this application and module name.
516
517 //*** Returns "ERROR:errornum" to supply error help.
518 { MethodType=Property Visibility=Private Obsolete=True }
519 Function Help_Name Returns String
520 Function_Return (Append("ERROR:",lastErr))
521 End_Function
522
523 { MethodType=Property Visibility=Private Obsolete=True }
524 Function Application_Name Returns String
525 Function_Return 'SYSTEM'
526 End_Function
527
528 { MethodType=Property Visibility=Private }
529 Function Module_Name Returns String
530 Function_Return ''
531 End_Function
532End_Class
533
534Object Error_Info_Object is a ErrorSystem
535End_Object
536
537
538Procedure UserError Global String sMessage String sCaption
539 String sCapt
540 If (Error_Object_Id=0) Begin
541 Error DFERR_PROGRAM "No Error Handler"
542 Procedure_Return
543 End
544
545 // Accept not passing a caption in which case the error handler's
546 // default caption. It had been the intention to require a caption ("" if none)
547 // but having no caption kind of worked where the caption would be "0". Since it
548 // kind of worked, I don't want to remove this which might generate runtime errors.
549 If (num_arguments>1) Begin
550 Move sCaption to sCapt
551 End
552
553 Error DFERR_OPERATOR (sMessage + If(sCapt<>"",C_ErrorCaption + sCapt,""))
554
555End_Procedure