/* { # ------------------------------------------------------------ # Event surfaces # ------------------------------------------------------------ /* { Tests Enter the following code in any description field and odb_change_before (in the root object class) will throw an exception of the following kind. testing 314120180417135121_test_bug QW::bug ws login table - nothing open - ok ws login table with app database open on server - app database open from two ws's - ok app database on -server - two databases and remote server open on the ws's - 6 lost connection messages - i\ok - linux - app database on service_node - 2 app databases and remote server open on 2 ws's - bug happened in one of the service nodes - server node should go down and database get message - ok - other database and remote server stay active - ok - another service node is created - ok - can re-open app database and keep going - ok - slight error in message - {Server "benn7" terminated a connection to workstation "".} - the workstation is missing app database on service_node - same as above but error on workstation login - ws1 shutdown, ws2 and services kept going properly - montior updates properly. remote server - same as above but error on workstation's remote server - all app databases and remote servers went down with error messages - ws's stayed up - service_hub/service_nodes restarted testing 314120180417135121_test_error_bg ::qw::throw background - bg error on ws - error displayed - all ok - bg error on service_hub (using remote server) - service_hub restarted - all ws's got error messages _ service_hub restarted - bg error on service_node (using app database) - no service_hubs went down - alt-x worked testing 314120180417135121_test_bug_bg qw::bug background - bg bug on ws - ok - error displayed - proper shutdown - bg bug on service_node (using app database) - service node shutdown and new node created - terminated a connection to workstation "" on ws1 and ws2 - bg bug on service_hub (using remote server) - full shutdown and restart - no error dialogs - ws's remained intact 314120170417135121_test_gpf - ws login table - displays error dialog - shutdown - server - gpf on app database - server shutdown a restarted - ws's all lost connections - server - gpf on remote server database - server shutdown a restarted - ws's all lost connections - server - gpf on local server database - server shutdown a restarted - ws's all lost connections - service_hub - 2 ws's, 2 app databases, 2 remote servers - gpf on ws - worked, error dialog and ws shutdown - gpf on app database - node shutdown and restarted - ws's each lost a connection - ws's kept other app db's and remote server open - gpf on remote server, i.e. service_hub - service_hub shutdown and restarted - ws's all got lost connections 314120170417135121_test_gpf_bg - ws login table - displays error dialog - shutdown - worked but used GENERAL_PROTECTION_FAULT - unknown c++ exception. - ws login table with app database open - displays error dialog - shutdown - worked but used GENERAL_PROTECTION_FAULT - unknown c++ exception. - server - gpf on app database - server shutdown and restarted - ws's all lost connections - server - gpf on remote server database - server shutdown a restarted - ws's all lost connections - server - gpf on local server database - server shutdown a restarted - ws's all lost connections - service_hub - 2 ws's, 2 app databases, 2 remote servers - gpf on ws - worked, error dialog and ws shutdown - gpf on app database - node shutdown and restarted - ws's each lost a connection - ws's kept other app db's and remote server open - gpf on remote server, i.e. service_hub - service_hub shutdown and restarted - ws's all got lost connections - note that mother not notified until service_hub restarted How: Enter code in database group description in remote server. This is a regular bug. server - server displays error message properly remote server - ws displays error message properly test_error_314120180417135121 - bug thrown in server How: Enter code in database group description in remote server. This is a regular bug. server - server displays error message properly remote server - ws displays error message properly artificial_314120180418142624 - regular exception thrown in service_node How: Enter How: Enter code in database group description in remote server. This is a regular bug. server - server displays error message properly remote server - ws displays error message properly Expected: this is a regular bug that should be returned through tcp to the ws and siplayed in an error dialog Test: service_hub benn7, ws benn7, ws benn_2013 two ws's open on service_hub, one has remote server open Result: error appeared perfectly, no problem test_error_314120180417135121 tcl_error service_hub tcp How: Enter code in database group description in remote server. Expected: service_hub and it's service nodes should restart. no error dialogs mothership signaled Test: service_hub benn7, ws benn7, ws benn_2013 two ws's open on service_hub, one has remote server open Result: error appeared perfectly, no problem test_error_314120180417135121 tcl_error server This test is identical to above but on server. test_error_314120180417135121 tcl_error service_hub bgerror thrown using after 60000 after booting all service nodes in service_hub main should be caught in bgerror. Tested with two ws's open on service. Each loses connection. Service_hub and all service nodes stop and the service_hub and it's node retart. Next step is to send a message to the mothership with a bug__id indicating that an eception reached bgerror in a service_hub. artificial_20180418090233 bug service_node tcp A bug is thrown while processing a tcp request from the ws. We need to shut down the node. This sgould cause the service hub to loose a connection, and detroy the associated connection object(s), which in turn will cause any workstation(s) to lose their connection. The bug is not reported on the ws but will be sent to the mothership. # ------------------------------------------------------------ There are three dominating factors in the management of exceptions. (1) Where the exception occurred. (2) Where the exception surfaced. (3) Whether exception was "regular" or "bug". service_hub service_node server workstation installation default (script for example) bug tcl qw_throw unknown c++ gp - can't catch this after release - simplify lost connection messages - create database socket class, replace database::handle When are bugs important enough to bring down the system? bug_policy_233 -------------- New bug policy implemented in 233. Need better name if can think of one. service_node ------------ If anything reaches bgerror we notify the mothership and shutdown the node. If any bug occurs and reaches the tcp surface, we should notify the mothership and shutdown. All bugs can bring down a service_node but the node should be shutdown and we should not attempt to re-use it. The bug should be returned to the workstation and displayed on the workstation. A toplevel should be closed but the workstation should not shutdown. The service_hub should pass the exception to the workstation but then destroy the connection. workstation ----------- The workstation receives a bug from a connection (server or service_hub). Display the bug, destroy the toplevel, but do not shutdown the workstation. If the bug occurs on the workstation, destroy connections and shutdown the workstation. server ------ Bug occurs on server. Destroy connections and shutdown the server. Just shutting down the server should be good enough. The question is whether we can or should display the error on verioud workstations connected to the server. service_hub ----------- Bug occurs in workstaion or service_node - destroy the connection. Do not shutdown. If the bug occurs in thr service_hub (perhaps in the server database) then shutdown the service_hub. This should destroy the connections. When a node loses a connection to the service hub, the node should shutdown. When the service_hub loses a connection to a service_node, the service_node record and all connections to it should be destroyed. Perhaps then a bug occurs we should shutdown whoever did it and the connections will be terminted. For example, a node has a bug and terminates. The bug is sent to the mothership. But the workstation simply reports that it lost the connection. The service_hub access_denied problem ------------------------------------- Here is the current guess: A ws dies with a bug. Although it's connections are disconnected, the service_node might not be closing it's file. The service_hub might be managing properly and if so then the service_node is put back on the idle list. However, when we attempt to open database A again, regardless of service_node we will use, the file is still open so we get "permission denied". - bug occurs in ws database - bug_process runs - makes system broken - before returning from insert/write/delete - database_make_broken is called - database_make_broken schedules cpp_database_toast on ws closes volume sends "broken" message - database_toast deletes the database - deletes system and plug observers - does nothing else because the database (and the system) are broken - bug ripples to bgerror in ws - bgerror calls workstation_connection_manager_exception_bug_occurred - workstation_connection_manager_exception_bug_occurred disconnects plug - don't know what happens to database_handle but as ws will shut down, irrlevant - service_hub tcp_signal_receive receives terminate message - socket disables read_data_ready, closes the channel, and deletes itself - ~SOCKET calls service_hub_connection_destroy - service_hub_connection_destroy - after delete socket, also calls service_hub_connection_destroy, but no harm - service_hub_connection_destroy 2.29.2 Test - regular, i.e. app_name_server - multiple workstations on different machines - workstations have same app database open - one database open - bug thrown by database write operation - success - service_hub, i.e. app_name==app_name_service_hub - multiple workstations on different machines - workstations have same app database open - one database open - bug thrown by database write operation - success - bug in ws.nv2 (1) Catch bugs in server regular calls to objects. (2) Catch bugs in server regular calls to socket. - catch bugs in app_name_server and app_name_workstation bgerror. - test bugs in remote server database - test bugs in workstations - attention to last workstation on a remote app database - test bug in service_node server.nv2 - test bug is call to socket - test ok when have remote server open - on server - on service_hub - when on server cause bug in local server window database, - i.e. through bgerror - Catch bugs in calls to service hub. Three types of exceptions: -------------------------- qw_throw These are non-bug regular exceptions thrown by ::qw::throw in tcl or by QW_THROW in cpp. bug These are thrown by qw::bug in tcl or BUG() in cpp. unexpected_tcl_error These are not thrown by the above techniques. Most often we would catch tcl errors and re-throw. When this error type hits an event surface without being caught and re-thrown it is an unexpected tcl error and it should be treated like a bug. If a bug occurs in a database why do we have to shut down? If we abort the database and disconnect a socket isn't that good enough? Todo: Try to find a filter for databases. Should be able to mark a database broken without killing the application. Process unexpected tcl errors. Get rid of cookies (handles) observiing a database. I would rather explicitly process them. The problem in general is that the observee has to know who is observing unless we use the observer mechanism. note - need to address possible hanging red progress bars on client Regular Server -------------- Bug occurs in socket_read_data_ready. Bug occurred when processing a call on behalf of a client. What must happen? - all client connections are signalled that server is down - each client must mark connection as terminated - server must be shut down - clients can keep working on other servers Client receives terminated message - can be in call loop - can be in signal receive - ws should not care whether connect to server or service How do we kill the connection and also report an error to the client - if it's a signal in the middle of a call then we through an ignore exception, destroy the database/plug, and put up an error. Problem scenario: Server encounters bug while working for client A. Server sends terminate message to all clients. However, client B makes a call before getting the message. If we are in a call then we throw an exception ignore and service_node ------------ Bug occurs in socket_read_data_ready. Bug occurred when processing a call on behalf of a client. What must happen? - all service_hub connections are signalled that service_node is down - service shub removes databas and its connections - all clients must be signalled plug_read_data_ready experiment ------------------------------- When a plug_read_data_ready event occurs, and plug_read_data_ready throws an exception, ::bgerror receives the exception. Event Sources ------------- AppType User Plug Socket Idle After workstation 1 1 ? ? server 1 1 ? ? service_hub 1 1 ? ? service_node 1 1 ? ? Workstation ----------- Signal from plug_read_data_ready. - something happened on server that cause server or connection to fail. - singleton::connection_destroy - throw exception so user sees connection destroyed - no bug makes it to ::bgerror Bug makes it to bgerror - this bug was generated within the workstation - the workstation must shutdown - later if we can deteremine bug occurred in app database then maybe only app database needs to be closed Server ------ Bug caught in socket_read_data_ready during call - if can determine app database, close database - signal workstation connection lost - if bug occurs within app database - signal all workstations connected to the app database - shut the app database - if bug makes it to bgerror then in effect all databases broken and server must shut down - all worksattrion are signaled service_hub - socket_tcl_call_receive can receive shutdown message/call - singleton::connection_destroy - plug_read_data_ready service_node - bug is caught by socket_read_data_ready - does not pass bug on - if database known, then can kill database and signal service_hub - all connections sognaled (there may be many) - if database not known, kill the service_node - presumable we never throw a bug Signal from plug_read_data_ready. - something happened on server that cause server or connection to fail. - singleton::connection_destroy - throw exception so user sees connection destroyed - no bug makes it to ::bgerror Bug makes it to bgerror - this bug was generated within the workstation - the workstation must shutdown - later if we can deteremine bug occurred in app database then maybe only app database needs to be closed Almost by definition, the event surfaces are the ones that will invoke ::bgerror on an uncaught exception. For a workstation or server, the user is an event surface. The server also has socket_read_data_ready as an event surface, and the workstation has plug_read_data_ready. The service_hub and service_node have no event surfaces by the above definition because they cannot let any exceptions reach bgerror. service_node ------------ Bug occurs in service_node. All bugs in a All application types The ultimate So there arwhat are the event surfaces User Bug classes - suppose we have a sargs-related bug, how dow we know this happened while accessing a database, or using an object manager? do we have a pipe for database/odb access? surfaces bgerror plug_read_data_ready workstation - received from server - singleton connection_destroy call - throw exception to bgerror - note that surface is really bgerror signal - if caught in call then can use bgerror - if throw, will bgerror get it? service_node ------------ Only event surface is the socket. service_hub ------------ Only event surface is the socket. Server ------ Event surface - user interface, bgerror. Mark database broken and ultimately socket broken. Mark system broken and schedule a cpp_database_toast. Actually ended up throwing priority ignore. Event surface - socket Workstation ----------- Event surface - user interface, bgerror. Event surface - plug - receives signals that database/connection broken, or server broken Types of errors --------------- Bug in a database or object system. qw::throw exception unexpected tcl error (1) Socket catches exception on call. If a bug I suppose we should shut down the service_node but the service_hub should simply lose the connection. Same for unexpect tcl error. (1) We never let the bug excape the event surface. Error Classes GeneralBug DatabaseBug Error Bug in service_node ------------------- (1) database_bug thrown in service_node (2) caught by event_surface - socket_read_data_ready (3) exception re-labelled and exception signal sent (4) service_hub plug_ready_data_ready receives signal (5) service hub recognizes database_bug - destroys the connection but keeps service_node alive - service_node must close database but keep service_node open (6) service_hub plug_read_database_ready signals workstation (7) workstation plug_ready_data_ready - - closes database - kills connection Bug in server. -------------- (1) Bug caught at socket_read_data_ready. (1) If database_bug destroy database (2) send exception to break connection. Workstation plug_call_send (3) Call qw::server::singleton connection_destroy .socket_cpp_object xxx; (2) Bug caught at ::bgerror Bug in Workstation ------------------ bgerror surface --------------- (1) call ::qw::workstation::singleton destroy_all_connections (2) qw::shutdown; - should we destroy all databases or just let shutdown do it - currently we makr database as broken and shutdown There is technically no other real surface. But a plug will receive either a signal or an exception a server. Potential scenario We call the server and a bug occurs on the server. We want the database closed but we do not have to shut the workstation. We do want the workstation to display something. Suppose we do the following (1) plug::tcp_call_send catches bug exception this indicates server connection down - call might receive a signal because an event initiated pn the server by a different workstation cause the server to shutdown - so call must not just process exceptions, but also signals. (2) plug calls ::qw::workstation::singleton connection_destroy plug destroys itself directly or indirectly What we used to do was throw a priority ignore but mark the database/connection as broken and store the exception in the plug. Then the next call would throw the exception. Not bad. Works for signals too. Howeber, if a plug receives and exception from the server on a call it can eventually throw an exception. Suppose a server goes down. It signals the workstations. They don't actually have a call outstanding. Question: If connection destroyed becasue signal received, how do we report the exception to bgerror on thew workstation, i.e. how is error reported on the workstation. Suppose we have ::qw::server::singleton ::qw::workstation::singleton These manage the connections. socket_read_data_ready catches the bug socket_read_data_ready returns an exception that tells the plug that the (a) The connection was lost due to a bug in the server. (b) If database_bug then the database must be shutdown. (c) The service hub The database database (1) The service_node must ultimately be shut down. (2) The workstation must ultimately lose the connection. (3) The connection must be destroyed in the service_node. Bug in service_hub ------------------ (1) service hub must shut down. (2) All workstations lose connections. (3) All service_nodes are destroyed. Bug in foreground server ------------------------ Because a foreground server is also an operating window system, bugs can make it to "the surface", i.e. bgerror. If any bug makes it to the surface the server must be shut down after the bug is reported. Non-bug errors can make it to the surface. (1) We want the ser When a bug is detected in a service What can we be? application_type service_type server regular workstation regular service_hub service service_node service script service script regular database_type - workstation - server - application - running a script - but script can open databases and package require nv2 - service - service_hub - also server??? - service_node - service_stub - workstation - server - also application? - can we run a script as a service? */ } */ } ::proc ::qw::process_restart {sargs} { /* { 2.37.0 Restart the current process, and shut down the current process. We run the process using the same command line that this process was run with. That should take care of running as a server or workstation using the same server or workstation database path, and also any other options that were used. In addition, we add a -process_restart_delay option if not already in the command line. The restarted process, if a server, must not attempt to open tcp ports or other non-sharable resourses such as a database file, before the current process is completely shut down or there will be a resource conflict. The restarted process will delay by the specified delay before attempting to start up any open ports or open any database files. Npte that we always shutdown and restart. It is the caller's responsibility to call this proc or not. For example, a workstation will not call this proc unless the qw_sargv .workstation_bug_restart flag is set. */ } ::set rwb1_debug 0; ::if {$::qw::verbose(startup_shutdown)} { ::set rwb1_debug 2; } ::if {!$::qw::control(process_restart_is_enabled)} { ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::process_restart,1000.0.0,sargs==\n[::sargs::format $sargs]"}; ::set Args $::argv; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::process_restart,1000.0.1,::argv==\n$::argv"}; ::switch -- $::qw::control(app_name) { "app_name_server" { /* { Fall through to terminate the current process and restart the server. */ } } "app_name_workstation" { #2.37.2 ::if {[::lsearch "-banner_skip" $Args]<0} {} ::if {[::lsearch -exact $Args "-banner_skip"]<0} { ::lappend Args "-banner_skip" "1"; } } "app_name_service_stub" { } "app_name_service_hub" { /* { Actually, processing a bug here would be problematic. (recursive). */ } /* { A service_hub should shut down but it should be restarted by the service_stub. */ } # work to do ::qw::bug 314120230408114942 "[::qw::procname] called with invalid .process_bug_restart."; } "app_name_service_node" { } "app_name_message_database" { } } ::if {$::qw::control(process_file_is_enabled)} { /* { 2.38.5 - added this to avoid potential deadlocks We were relying on ::qw::exit to release the mutex, if any. but let's do it before restarting. */ } # ------------------------------------------------------------ # Release potential mutex before launching an executable that may lock it. # ------------------------------------------------------------ ::if {$rwb1_debug} {::puts "rwb1_debug,qw_message_database,main,1000.10";} ::if {[::qw::mutex_manager mutex_is_locked .mutex_name $::qw::control(process_list_file) .lock_caller [::qw::procname]]} { ::if {$rwb1_debug} {::puts "rwb1_debug,qw_message_database,main,1000.11";} ::qw::mutex_manager mutex_unlock .mutex_name $::qw::control(process_list_file) .unlock_caller [::qw::procname]; } } # ------------------------------------------------------------ # Restart current process using same command line. # ------------------------------------------------------------ ::set Nv2Exe [::file nativename [::info nameofexecutable]]; #2.37.2 ::if {[::lsearch "-process_restart_delay" $Args]<0} {} ::if {[::lsearch -exact $Args "-process_restart_delay"]<0} { ::lappend Args "-process_restart_delay" $::qw::control(process_restart_delay); } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::process_restart,1000.07,seconds==[::clock seconds]";} ::set Commandline [::concat $Nv2Exe $Args]; ::set Commandline [::string map [::list "\\" "\\\\"] $Commandline]; ::append Commandline " &"; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::process_restart,1000.08,seconds==[::clock seconds]";} ::if {$rwb1_debug} {::puts "rwb1_debug,qw::process_restart,1000.09,Commandline==$Commandline";} ::eval ::exec $Commandline; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::process_restart,1000.10,seconds==[::clock seconds]";} ::qw::exit .exit_result 1; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::process_restart,1000.10,seconds==[::clock seconds]";} ::return; } ::proc ::qw::error {args} { ::set rwb1_debug 0; ::if {$::qw::verbose(exception)} { ::set rwb1_debug 2; } ::if {!$::qw::control(is_release)&&[::string match "benn*" [::info hostname]]} { ::puts "rwb1_debug,::qw::error,1000.0,args==$args"; } ::if {[::sargs::is_primitive $args]} { ::sargs::var::set sargs .error_id [::lindex $args 0]; ::sargs::var::set sargs .text [::lindex $args 1]; } else { ::sargs::marshal $args; } ::qw::throw $sargs; } ::proc ::qw::bug_process {args} { /* { 2.38.5 - cancel all after tasks 2.38.3 - callers will now assume that bug_process does not return. 2.37.0 - change to process bug immediately 2.37.1 - this is fine for most app_names - but app_name_server and app_name_node should throw bug - tcp message processing should pass bug to client and then shut down - client should detect bug, display that bug occurred on server - app_name_hub should pass bug from node back to client 2.32.0 A bug has occurred. We wrap it in extra information and send that information to the mothership. Depending on the app_name we will take different actions as described below. --------------------------------------------------------------------------- I could be in any type of app_name, i.e. server, service_hub/node, installation, or plain script. THe job here is to wrap the bug in additional useful information and send this information to the mothership. It is specifically not the job of this method to shutdown. The caller will control that. The wrapped bug structure is returned. Starting with 2.28.0 all bugs, even cpp bugs, come through here before they are actually thrown. The code in this method should really be in qw::bug but it was cut out so that the cpp code can also have access to it. We can't use sargs for the arguments because historically bugs took two arguments: bug id and text. */ } ::set rwb1_debug 0; ::set ::qw::control(dump_method_calls) 0; # 2.38.5 reduce firehose output after a bug has occurred ::if {$::qw::verbose(exception)} { ::set rwb1_debug 2; } ::if {!$::qw::control(is_release)} { /* { Always puts out bugs if not a release. */ } ::set rwb1_debug 2; } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.00,args==$args";} ::while {1} { # ------------------------------------------------------------ # Cancel all after tasks. # ------------------------------------------------------------ /* { 2.38.5 We were wondering if after tasks were causing additional problems when a bug has occurred. Cancelling all potential scheduled tasks is precautionary but probably a good idea. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.01";} ::qw::after_after cancel; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.02";} ::set IdList [::after info]; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.03,IdList==$IdList";} ::if {[::lempty $IdList]} { ::break; } ::set Id [::lindex $IdList 0]; ::if {$rwb1_debug} { ::puts "rwb1_debug,bug_process,1000.04,Id==$Id,Script==\n[::after info $Id]"; } ::after cancel $Id; } ::if {[::sargs::is_primitive $args]} { ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.05";} ::sargs::var::set sargs .bug_id [::lindex $args 0]; ::sargs::var::set sargs .text [::lindex $args 1]; } else { ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.06";} ::sargs::marshal; } ::if {$::qw::control(bug_process_errorInfo_is_enabled)} { # 2.34.9 - added ability to disable errorInfo ::sargs::var::set sargs .error_info $::errorInfo; } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.04";} ::set BugId [::sargs::get $sargs .bug_id]; ::set BugText [::sargs::get $sargs .text]; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.05,BugId==$BugId,BugText==$BugText";} ::set Exception $sargs; ::sargs::var::set Exception .bug_id $BugId; ::sargs::var::set Exception .bug_text $BugText; #2.32.3 ::sargs::var::set Exception .text "Encountered bug \"$BugId\" running [::string tolower [::file normalize [::info nameofexecutable]]] ($::qw_release) on computer \"[::string tolower [::info hostname]]\"."; ::sargs::var::set Exception .text "Encountered bug id:$BugId - \"$BugText\""; ::sargs::var::set Exception .priority "bug"; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.06";} #::set Exception [::qw::exception::log .exception $Exception]; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.07";} /* { For now we'll call it here but in the future will be called at originating point. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.08";} ::set LogRecord [::sargs]; ::sargs::var::set LogRecord .bug_exception $Exception; ::if {![::sargs::boolean_get $sargs .stack_skip]} { /* { 2.32.3 When called from bgerror on service_hub/node, the stack is pointless. errorInfo would make more sense but I am afraid it could be very large or ill-formed. */ } ::sargs::var::set LogRecord .stack_dump [::qw::stack_get]; } else { # no point in letting .stack_skip argument make it to logs or messages ::sargs::var::unset sargs .stack_skip; } ::sargs::var::set LogRecord .message_type qw_bug; ::if {$::qw::control(mothership_is_enabled)} { # ------------------------------------------------------------ # Send message to mothership. # ------------------------------------------------------------ ::if {$::qw::control(rwb_gpf_bug)} { ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.09";} ::qw::babyship::singleton asynch_post_to_mothership .message $LogRecord; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.10";} } catch rwb_gpf_bug_exception { ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.11,exception==$rwb_gpf_bug_exception";} ::qw::throw $rwb_gpf_bug_exception; } } else { ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.12";} ::qw::try { ::qw::babyship::singleton asynch_post_to_mothership .message $LogRecord; } catch dummy { # 2.38.5 try/catch dummy added # this avoids problems when mothership is not running } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.13";} } } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.14";} /* { ::set Seconds [::clock seconds]; ::set YMDHMS "[::clock format $Seconds -format %Y%m%d%H%M%S]"; ::sargs::var::set LogRecord .type error; ::sargs::var::set LogRecord .clock_seconds $Seconds; ::sargs::var::set LogRecord .ymdhms $YMDHMS; ::sargs::var::set LogRecord .event_surface [::sargs::get $sargs .event_surface]; ::set RecordId ".record_[::clock format [::clock seconds] -format %Y%m%d%H%M%S][::expr {abs([::clock clicks -milliseconds])}]"; ::sargs::var::set Record $RecordId $LogRecord; ::set Record [::sargs::format .structure $Record]; */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.15";} ::switch -glob -- [::string tolower [::info hostname]] { student4-pc - i7-3770* - peters* - schapple* - benn* - quacken* { /* { We only write to the stdout when debugging. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.16,LogRecord==\n[::sargs::format $LogRecord]";} } } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.17";} ::if {[::qw::command_exists ::qw::system]} { ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.18";} [::qw::system] cpp_system_make_broken $Exception; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.19";} } ::switch -- $::qw::control(app_name) { "app_name_service_stub" { /* { We already sent the error to the mothership. All we want to do now is mark the service_stub broken and shutdown. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.20";} ::if {!$::qw::control(bug_process_does_not_return)} { ::return [::sargs .priority ignore .text "service_hub bug already processed."]; } ::qw::exit; } "app_name_service_stub_checker" { /* { We already sent the error to the mothership. All we want to do now is mark the service_stub broken and shutdown. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.21";} ::if {!$::qw::control(bug_process_does_not_return)} { ::return [::sargs .priority ignore .text "service_hub bug already processed."]; } ::qw::exit; } "app_name_service_hub*" { /* { We already sent the error to the mothership. All we want to do now is mark the service_hub broken and shutdown. Inclused nv2_service_stub_checker */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.22";} ::if {[::qw::command_exists ::qw::service_hub::singleton]} { ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.23";} ::itcl::delete object ::qw::service_hub::singleton; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.24";} } ::qw::service_utils::run_as_service_shutdown; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.25";} ::if {!$::qw::control(bug_process_does_not_return)} { ::return [::sargs .priority ignore .text "service_hub bug already processed."]; } ::qw::exit; } "app_name_service_node" { /* { We already sent the error to the mothership. All we want to do now is mark the service_node broken and shutdown. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.26";} #2.32.3 ::if {[::qw::command_exists ::qw::service_node::singleton]} { ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.27";} ::itcl::delete object ::qw::service_node::singleton; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.28";} } /* { #2.34.8 ::if {!$::qw::control(file_process_is_enabled)} { ::qw::service_utils::run_as_service_shutdown; } */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.29";} ::qw::service_utils::run_as_service_shutdown; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.30";} # ::return [::sargs .priority ignore .text "service_node bug already processed."]; ::if {$::qw::control(bug_process_does_not_return)} { ::qw::exit; } } "app_name_server" { ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.31";} ::if {[::qw::command_exists ::qw::server_connection_manager::singleton]} { ::qw::server_connection_manager::singleton server_connection_manager_exception_bug_occurred .exception $Exception; } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.32";} ::qw::process_restart; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.33";} } "app_name_workstation" { /* { */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.34";} ::if {[::qw::command_exists ::qw::workstation_connection_manager::singleton]} { ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.35";} ::qw::workstation_connection_manager::singleton workstation_connection_manager_exception_bug_occurred .exception $Exception; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.36";} } ::if {[::sargs::boolean_get $::qw_sargv .workstation_bug_restart]} { # 2.37.0 = added for wgb ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.37";} ::qw::process_restart; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.38";} } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.39";} } "app_name_message_database" { # we don't restart because qw_message_database_checker will restart us. ::qw::exit; # ::qw::process_restart; } "app_name_default" { /* { This is probably a script of some sort. Could even be database_utilities. Like a workstation, we assume there is a human interface so let the bug be displayed in an error dialog. After that, the process will shutdown. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.40";} } default { /* { Same as app_name_default; */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.41";} } } # ------------------------------------------------------------ # Display error and then exit. # ------------------------------------------------------------ /* { Instead of unwinding to bgerror we display the bug error here and exit immediately afterward. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.42";} ::if {$::qw::control(tk_is_enabled)} { ::qw::dialog85::error .structure $Exception; } ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.43";} ::qw::exit .exit_result 1; ::if {$rwb1_debug} {::puts "rwb1_debug,bug_process,1000.44,Exception==\n[::sargs::format $Exception]";} } ::proc ::qw::stack_line_process {args} { /* { Converts a stack into a well-formed sargs. Why do that? The sargs can be easily passed across the net and can also be formatted for readability. Otherwise each stack level could be a very long command which displays poorly on a single line. We also detect any "too large" stack level argument or sargs leaf field and replace it with " ... arg too big - 999 bytes ... ". 2.31.3 In 2.31.2 we replaced big fields to reduce the stack size but we only did it for leaves. We have large window definitions that were extremely big even when leaf fields were replaced. So instead of recursively eliminating big leaf fields we instead emlinie "top-level" arguments that are too big. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,stack_line_parse,1000.00,args==\n$args";} #::set args [::string map [::list "\n" " "] $args]; #::set args [::string map [::list "\r" ""] $args]; ::set Result [::sargs]; ::set ArgNumber -1; ::foreach Word $args { ::set WordSize [::string length $Word]; ::if {$WordSize>1023} { ::if {0} { ::set Count 0; ::set Path [::file join $::qw_program_folder word_file_$Count]; ::while [::file exists $Path] { ::incr Count 1; ::set Path [::file join $::qw_program_folder word_file_$Count]; } ::set File [::open $Path w+]; ::puts $File $Word; ::close $File; } ::set Word " ... field too big - $WordSize bytes ... "; } ::sargs::var::set Result .stack_arg[::incr ArgNumber 1] $Word; } ::if {$rwb1_debug} {::puts "rwb1_debug,stack_line_parse,1000.99,result==\n[::sargs::format $Result]";} ::return $Result; } ::proc ::qw::bug {args} { /* { For now we'll call it here but in the furture will be called at originating point. */ } ::if {$::qw::control(bug_process_does_not_return)} { ::eval ::qw::bug_process $args; } else { ::set Exception [::eval ::qw::bug_process $args]; /* { ::if {$::tcl_version<8.6} { ::set Exception [::eval ::qw::bug_process $args]; } else { ::set Exception [::qw::bug_process {*}$args]; } */ } ::qw::throw $Exception; } } ::proc ::qw::exception::is_bug {sargs} { ::return [::sargs::find_field_value .structure $sargs .field .priority .value "bug"] } ::proc ::qw::exception::is_unexpected_tcl_error {sargs} { ::if {!$::qw::control(unexpected_tcl_error)} { ::return 0; } ::return [::expr {![::sargs::find_field_value .structure $sargs .field .exception_type .value "qw_throw"]}]; } ::proc ::qw::exception::is_ignore {sargs} { ::return [::expr {![::sargs::find_field_value .structure $sargs .field .priority .value "ignore"]}]; } ::set ::qw::exception::_unique_id 0; ::proc ::qw::exception::nest {sargs} { /* { Connects a sub-exception to a super-exception and returns the resulting exception structure. Example: ::set Super "Could not open file XXX."; ::set Sub "File not found."; ::qw::throw [::qw::exception::nest .sub $Sub .super $Super]; If primitives are supplie they are converted to structures using test. In the example above the following exception is actually thrown. --------------------------------- .text "Could not open file XXX." /12345 { .text "File not found." } --------------------------------- */ } ::set Sub [::sargs::get $sargs .sub]; ::if {$Sub eq ""} { ::qw::stack_dump; ::qw::throw "[::qw::procname] - empty .sub argument."; } ::set Super [::sargs::get $sargs .super]; ::if {$Super eq ""} { ::qw::throw "[::qw::procname] - empty .super argument."; } ::if {[::sargs::is_primitive $Sub]} { ::set Sub [::sargs .text $Sub]; } ::if {[::sargs::is_primitive $Super]} { ::set Super [::sargs .text $Super]; } ::sargs::var::set Super /[::clock seconds][::incr ::qw::exception::_unique_id] $Sub; ::return $Super; } ::proc ::qw::warning {args} { /* { Usage with primitive args: ::qw::warning 314120200828145357 "Had a problem with method foo, args==$args"; Usage with sargs: ::qw::warning .warning_id 314120200828145357 .text "Had a problem with method foo, args==$args"; 2.31.2 Changed proc args from {Id Message} to args. */ } ::set rwb1_debug 0; ::if {$::qw::verbose(exception)} { ::set rwb1_debug 2; } ::if {[::sargs::is_primitive $args]} { ::sargs::var::set sargs .warning_id [::lindex $args 0]; ::sargs::var::set sargs .text [::lindex $args 1]; } else { ::sargs::marshal; } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::warning,1000.0,args==\n[::sargs::format $sargs]";} ::set WarningId [::sargs::get $sargs .warning_id]; ::set WarningText [::sargs::get $sargs .text]; ::if {$::qw::control(mothership_is_enabled)} { ::if {[::sargs::boolean_get $sargs .send_warning_to_mothership]} { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::warning,1000.5";} /* { It looks funny if send_warning_to_mothership shows up in message so we unset it. */ } ::sargs::var::unset sargs .send_warning_to_mothership; ::set Record [::sargs]; ::sargs::var::set Record .warning $sargs; ::sargs::var::set Record .stack_dump [::qw::stack_get]; ::sargs::var::set Record .message_type qw_warning; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::warning,1000.6,Record==\n[::sargs::format $Record]";} ::qw::babyship::singleton asynch_post_to_mothership .message $Record; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::warning,1000.7";} } } } /* { before 2.31.2 ::proc ::qw::warning {Id {Message ""}} { ::switch -glob -- [::string tolower [::info hostname]] { win10* - teacher* - "i7-3770" - "student4-pc" - peters* - quackenb* { } benn* { ::if {$Message eq ""} { ::puts "warning_id==$Id"; } else { ::puts "warning_id==$Id,warning_message==$Message"; } } } } */ } ::proc ::qw::computer_information {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::computer_information,1000.0,sargs==$sargs";} ::set FieldList [::sargs::get $sargs .field_list]; ::if {[::llength $FieldList]==0} { /* { Supply .field_list only if less is wanted. */ } ::set FieldList { qw registration customer_support_registration processor tcl_platform tcl tk memory screen } } ::set Record [::sargs]; ::foreach Field $FieldList { ::switch -- $Field { qw { ::sargs::var::set Record .qw.app_name $::qw::control(app_name); # app_name_service or app_name_server # ::sargs::var::set Record .qw.version $::qw_version; # ::sargs::var::set Record .qw.patch_level $::qw_patch_level; # ::sargs::var::set Record .qw.build $::qw_build; ::sargs::var::set Record .qw.release $::qw_release; ::sargs::var::set Record .qw.nameofexecutable [::info nameofexecutable]; ::sargs::var::set Record .qw.hostname [::info hostname]; ::sargs::var::set Record .qw.sub_product $::qw_sub_product; ::sargs::var::set Record .qw.ip [[::qw::system] cpp_ip_address_get]; ::sargs::var::set Record .qw.nic [[::qw::system] cpp_nic_get]; } registration { /* { 2.34.2 - removed warnings and checksum - unnecessary fluff */ } ::sargs::var::set Record .registration [[::qw::system] cpp_registration_get]; ::sargs::var::unset Record .registration.warning1; ::sargs::var::unset Record .registration.warning2; ::sargs::var::unset Record .registration.warning3; ::sargs::var::unset Record .registration.checksum; } customer_support_registration { #2.34.5 ::sargs::var::set Record .customer_support_registration [[::qw::system] cpp_customer_support_registration_record_get]; ::sargs::var::set Record .customer_support_registration [::qw::registrations::record_get]; } processor { /* { #2.32.2 linux - these vars don't seem to exist in linux */ } ::if {[::info exists ::env(PROCESSOR_ARCHITECTURE)]} { ::sargs::var::set Record .processor.architecture $::env(PROCESSOR_ARCHITECTURE); } ::if {[::info exists ::env(PROCESSOR_IDENTIFIER)]} { ::sargs::var::set Record .processor.architecture $::env(PROCESSOR_IDENTIFIER); } ::if {[::info exists ::env(PROCESSOR_LEVEL)]} { ::sargs::var::set Record .processor.architecture $::env(PROCESSOR_LEVEL); } ::if {[::info exists ::env(PROCESSOR_REVISION)]} { ::sargs::var::set Record .processor.architecture $::env(PROCESSOR_REVISION); } ::if {[::info exists ::env(NUMBER_OF_PROCESSORS)]} { ::sargs::var::set Record .processor.architecture $::env(NUMBER_OF_PROCESSORS); } } tcl_platform { ::foreach Name [::array names ::tcl_platform] { ::if {[::sargs::is_field_path .$Name]} { ::sargs::var::set Record .tcl_platform.$Name $::tcl_platform($Name); } else { ::if {$rwb1_debug} {::puts "rwb1_debug.tclplatform,1000.7.0,Name==$Name";} } } } tcl { ::sargs::var::set Record .tcl.version $::tcl_version; ::sargs::var::set Record .tcl.patchLevel $::tcl_patchLevel; ::sargs::var::set Record .tcl.library $::tcl_library; } tk { ::sargs::var::set Record .tk.version $::tk_version; ::sargs::var::set Record .tk.patchLevel $::tk_patchLevel; ::sargs::var::set Record .tk.library $::tk_library; } memory { #rwb1_debug ::sargs::var::set Record .memory.physical [::qw::memoryutil::memory_physical]; #rwb1_debug ::sargs::var::set Record .memory.allocated [::qw::memoryutil::memory_allocated]; #rwb1_debug ::sargs::var::set Record .memory.available [::qw::memoryutil::memory_available]; } env { /* { Getting ::env could be considered intrusive (hacking) and we don't really need the info. We'll just extract processor info (see below). # ::env ::foreach Name [::array names ::env] { ::if {[::sargs::is_field_path .$Name]} { ::sargs::var::set Record .env.$Name $::env($Name); } else { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::computer_information,1000.4.2,name==$Name";} } } */ } } screen { ::sargs::var::set Record .screen.size [::winfo screenwidth .]x[::winfo screenheight .] ::sargs::var::set Record .screen.maximum_size [::lindex [::wm maxsize .] 0]x[::lindex [::wm maxsize .] 1]; } default { ::qw::bug 314120170315150737 "[::qw::procname] - invalif field \"$Field\"."; } } } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::computer_information,1000.98,ip_list==\n[[::qw::system] cpp_nic_info_list_get]";} # ::sargs::var::set Record .network.ip [[::qw::system] cpp_nic_info_list_get]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::computer_information,1000.99,computer_information==\n[::sargs::format $Record]";} ::return $Record; } ::proc ::qw::deprecated {Id {Message ""}} { /* { uplevel 1 gives us the offending statement, but uplevel 2 gives us the proc that contains the offending statement */ } ::switch -glob -- [::info hostname] { benn* { ::puts "Deprecated,Id==$Id,Message==$Message,stack_top==[::uplevel 2 ::qw::stack_top]" } } } ::proc ::qw::throw {args} { /* { The ::qw::throw command throws an exception using the tcl ::error command, except that it takes a variable number of arguments. If there is only one argument then ::qw::throw is identical to the tcl error command. If there are no arguments then an empty string is thrown. When there are two or more arguments, they are combined in a sargs representing the error. This is described in the ::qw::exeption command. */ } ::set rwb1_debug 0; ::if {$::qw::verbose(exception)} { ::set rwb1_debug 2; } ::if {[::eval ::sargs::marshal_is_legacy $args]} { /* { The args argument is not a well-formed sargs. We allow a throw, like ::error, to simply throw a text string. Here we will assume this is the case and wrap it up as the .text field of a sargs. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,legacy,1000.0,args==$args";} ::if {[::llength $args]==0} { ::qw::stack_dump; } ::if {[::lindex $args 0] eq ""} { ::qw::stack_dump; } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,legacy,1000.1";} ::switch -- [::llength $args] { 1 { ::set SArgs [::lindex $args 0]; ::if {[::sargs::is_primitive $SArgs]} { ::sargs::var::set SArgs .text $SArgs; } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,legacy,1000.2";} ::sargs::var::set SArgs .exception_type qw_throw; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,legacy,1000.3";} ::if {$::qw::control(window_event_in_progress_count)!=0} { /* { In a server when an event is initiated by a user, it is generally a window event. This is to be distinguished from file events that generally come in from a client (i.e. workstation). If the event is user-initialted then we want an error message. Otherwise, it is a non-user-initated error that reached bgerror and we must re-start the server. Otherwise there would be an error displayed on the server and the server would appear to "hang" from the client perspective. We can't allow errors to be displayed on a server unless it is user-initiated. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,legacy,1000.4";} ::sargs::var::set SArgs .window_event_in_progress_count $::qw::control(window_event_in_progress_count); } ::error $SArgs; } } ::set Exception [::eval ::qw::exception $args]; ::sargs::var::set Exception .exception_type qw_throw; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,legacy,1000.5";} ::if {$::qw::control(window_event_in_progress_count)!=0} { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,legacy,1000.6";} ::sargs::var::set Exception .window_event_in_progress_count $::qw::control(window_event_in_progress_count); } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,1000.7,xxxxxxxxxx: $args";} ::error $Exception; } ::sargs::marshal; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,1000.8,xxxxxxxxxx: $args";} ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,1000.9,nameofexecutable==[::info nameofexecutable],hostname==[::info hostname]";} ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,1000.10,sargs==\n[::sargs::format $sargs]";} ::if {![::sargs::find_field .structure $args .field .exception_type]} { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,1000.11";} ::sargs::var::set sargs .exception_type qw_throw; } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,legacy,1000.12";} ::if {$::qw::control(window_event_in_progress_count)!=0} { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,legacy,1000.13";} ::sargs::var::set sargs .window_event_in_progress_count $::qw::control(window_event_in_progress_count); } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,1000.14,::bgerror exists==[::qw::command_exists ::bgerror]";} ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,1000,15,sargs==\n[::sargs::format $sargs]";} ::error $sargs; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::throw,1000.16,this should never come out";} } ::proc ::qw::exception {args} { /* { This command takes a variable number of arguments and returns them in a sargs representing an error. If there are no arguments then an empty string is returned. If there is only one argument then it is returned. When there are two or more arguments, they are combined in a qw::structure. The left-most argument is the root of the structure and as the arguments are processed left to right, they are recursively added as subs. Each sub name is uniquely generated and the each argument is placed in the .text field of the sub. ::qw::exception "Database error occurred." "Could not write to file." "Encountered bad sector." returns .text {Database error occurred.} /123 { .text {Could not write to file.} /124 { .text {Encountered bad sector.} } } */ } ::if {$::qw::verbose(exception)} { ::set rwb1_debug 2; } ::for {::set i 0} {$i<[::llength $args]} {::incr i 1} { /* { Normalize each argument into a sargs. If the argument is a primitive we assume it is text and put that text in the .text field, and replace the argument. */ } ::set Exception [::lindex $args $i]; ::if {![::sargs::is_primitive $Exception]} { ::continue; } ::set Message $Exception; ::set Exception ""; ::sargs::var::set Exception .text $Message; ::set args [::lreplace $args $i $i $Exception]; } ::set Result [::lindex $args end]; ::for {::set i [::expr {[::llength $args]-2}]} {$i>=0} {::incr i -1} { /* { Working backward we now nest the arguments into a tree of exceptions. */ } ::set Parent [::lindex $args $i]; ::set Kid $Result; # ::if {[::sargs::is_primitive $Parent]} {::set Parent [::list .text $Parent];} # ::if {[::sargs::is_primitive $Kid]} {::set Kid [::list .text $Kid];} ::set Result [::sargs::set $Parent /[::qw::id_factory] $Kid]; } ::return $Result; } # ------------------------------------------------------------ # ::qw::exceptions # ------------------------------------------------------------ /* { An exception is a qw::structure that contains the following fields. .code .name .description .tree The exception has a special field named .tree which contains a hierarchy of errors. Each error has a number of inner fields. It can also have a number of sub fields representing errors below in the hierarchy. An exception's error tree is typically built bottom up. A typical screnrio occurs when a try block catches an exception, addes an error to the exception, and re-throws. In this way information is added to the exception as the stack "unwinds". The information is usually added as the new root of the error tree so that when the exception is diaplyed in a tree, the least specific information is displayed at the root and more specific information is displayed as we move down the tree. Note, at first it might seem that you want the most specific at the root. But consider a batch where multiple errors are retained. The root can diplay a general message such as "The batch had errors". Then the errors are desendants of the root and siblings of each other. Putting less specific errors nearer to the root is the only way an error tree can work in the general case. More is needed than just an error tree because the code that catched the exception must be able to identify the cause of the error, or at least its severity. For example, the file system must distinguish between errors that occur during the "normal course of business" and those which are fatal. An attempt to open a file may fail an cause an exception to be thrown such as "File does not exist." But this is very different from a failure that occurs due to a bad sector on the file. AT other times, the failure to opena file can be fatal, such as when creating temporary files needed by the file system to perform its work. Bugs are another class of errors. To handle this situation we must put error codes in the exception. Suppose we put the codes in each error. */ }