# ------------------------------------------------------------ # Copyright (c) 2016-2017 # Q.W.Page Associates Inc. # www.qwpage.com # All rights reserved. # ------------------------------------------------------------ ::qw::packages::package_require_tablelist; /* { ::if {[::llength [::itcl::find classes ::qw::connection_monitor]]!=0} { ::itcl::delete class ::qw::connection_monitor; } */ } ::namespace eval ::qw::connection_monitor {} ::itcl::class ::qw::connection_monitor { /* { Usage per server/service_hub Just collect for server/service_hub On a workstation, there is one connection_monitor per remote server window. Their names are "::qw::connection_monitor::object_xxx" Displays a table with one row per connection. The table is displayed on a workstation when you open a remote server. The table gets its information from the server_side_message statistics. Question: Do we need a separate monitor object for each potential remote server? This object is created on the workstation side. It makes calls to the server side, using the remote_server connection to get the stats. # ------------------------------------------------------------ # Todo - general # ------------------------------------------------------------ - bug - server crashed with a bug and froze workstation on right machine - looks like crash occured when right machine was saving database - and there was a saving red progress bar up - database::handle merges with tcl::plug to become -> database::socket - tcp::plug becomes database::plug which database uses to access remote database through database::socket - instead of system object containing handles we should have database::server object containing database::sockets - make database utilities remote # ------------------------------------------------------------ # todo - connection_monitor project # ------------------------------------------------------------ - store options in workstation? - need a free chm2pdf program - destination folder/file for graphs, if any - graphs - map to temp directory and create new .pdfs each time - server_connection_manager - currently does not destroy connections - eliminate connection monitor updates from traffic collection - if you shut down a connection monitor, only open it again if the remote server is re-opened - test -server - .server and .workstation should be separate - in tcp.cpp - database_find should be found within specified group - also should change name to database_item_find or load - if load used can add help to error message in tcl code - popup menu for connection delete - tooltips - help page - file select dialog - double-click on folder should expand the folder - add menu including column add/delete - add interleaved rows (blue/white) - add history line graph - example in javascript cookbook (or was it jquery?) - shut connection window when empty - or when all remote servers closed - i guess that means empty # ------------------------------------------------------------ # Done # ------------------------------------------------------------ - add latency/throughput test - don't know how yet - any connection to server will do but we do need a server - app or server database actually do - remote server would give us a place for the command - suppose we have a server - we can use the connection monitor, picking one of the servers - perhaps we should have a connection monitor per server anyway - would no longer be a singleton but could be mapped from the a server is of some sort, perhaps the server database_id - bug - ws A has remote_server open - ws B opens ws database X - X does not disappear from A remote_server or connection_monitor - bug - on ws A delete app connection on remote_server A, -> ws B fails - 25 - then after killing B, connection_monitor app row in A remains - bug - 20161124 - server up_count missing - bug - 20161120 - have remote server open and kill ws process - all service_nodes become "stopped" - Alt-X of ws doe not cause same problem - stopped service_nodes - remote server only - service_nodes stopped - accounting database only - service_nodes kept running - remote_server and accounting database - service_nodes stopped - does this happen in a plain server? - no - bug - never resolved - got self destruction of connections working but remote_server connection in connection_monitor does not disappear - remaining problem is that we display error message on lost connection - actually server terminated connection which is not accurate - 20161122 - bug - have remote server open and kill ws process - all service_nodes become "stopped" - Alt-X of ws doe not cause same problem - stopped service_nodes - remote server only - service_nodes stopped - accounting database only - service_nodes kept running - remote_server and accounting database - service_nodes stopped - does this happen in a plain server? - no - 20161121 - bug - delete remote server connection in remote server window - should have error "you can't delete your own connection" but doesn't - leads to a gp on server when attempting to open an accounting database - does not update the connection montitor - delete accounting database connection in remote server window - get error "you can't delete your own connection" as expected - above was on server, below try again on service - deleting accounting database connection prevented by "you can't delete your own connection" - deleting remote_server connection did not get error and resulted in gp on server - actually the service hubs all stopped and eventually restarted - 20161111 - end process on workstation - still has the connection monitor row for the server - have to find out why it is not being removed - store size/options - should not wait until shutdown - perhaps on any action - not have to save the order of each column - add number of seconds to update - then divide action by number of seconds - this will help with big update delays - add remote server to the connection monitor - replace asterisks with real graph - displaying the wrong port (service_hub text port displayed). - add line number column - separate fields from columns - each column refers to a field - allow sorting - fix empty host column - one asterisk if any action at all ######################################################################## _field_definition_array - indexed by field path. Each entry is a sargs. _row_data_array - indexed by row_id. Contains fields value per "record". _column_id_list - this is a list of column names. The columns are in this order. We really only need to adjust this list when options are saved or else we could update in real time when columns are moved. In any case it must be adjusted when columns are added/deleted. _column_definition_array - each entry contains the display information for one column Although multiple columns can refer to the same field, they could have different formatting information, etc. But this information could be implicit in the display. What could really be different? Format masks perhaps. Color perhaps. Title perhaps. When a column is added, it is given a field, and we could inherit these properties from the field. Or we could default to the field values when not specified. Default versus copy-down. I choose copy-down for now. Adding a column - task manager has a nice solution based on one column per field - uses a list of check boxes - nv2 can have multiple columns per field - each column has it's own information, starting presumably with field defaults. - user does not need more than one column and the check box list is so simple - all logic can be incorporated into the view/select columns... command - won't need columnadd/delete commands */ } protected variable _script_id 314120161127110445; # used for options file record protected variable _script_version 2.0; protected variable _toplevel ""; protected variable _tablelist ""; protected variable _vsb ""; protected variable _hsb ""; protected variable _server ""; protected variable _port_number ""; protected variable _sort_order ""; # need to add to options protected variable _sort_column ""; # need to add to options protected variable _workstation_database ""; protected variable _row_data_array; protected variable _label_border_width 0.5m; protected variable _font {-family Arial -size 10 -weight normal}; protected variable _default_background ""; protected variable _column_definition_array; protected variable _field_definitions [::sargs]; protected variable _horizontal_scrollbar_is_enabled 1; protected variable _next_column_id 0; protected variable _column_id_list ""; protected variable _toplevel_geometry ""; protected variable _resize_is_enabled 1; protected variable _minsize_is_enabled 0; protected variable _bar_height 12; protected variable _remote_server_plug_cpp_object ""; constructor {} { ::array set _row_data_array {}; ::array set _column_definition_array {}; ::set Button [::button .button_3141201212031654421_temp]; ::set _default_background [$Button cget -background]; ::destroy $Button; } destructor { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor,destructor,1000.0,this==$this";} ::if {$rwb1_debug} {debug_dump_column_info;} ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor,destructor,1000.1";} # ::incr ::qw::control(window_kickout_is_enabled) -1; options_store; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor,destructor,1000.2";} /* { ::foreach OperationId [::array names _row_data_array] { ::if {[::sargs::get $_row_data_array($OperationId) .tick_handle] ne ""} { ::after cancel [::sargs::get $_row_data_array($OperationId) .tick_handle]; } } */ } ::if {$_toplevel ne ""} { ::qw::toplevel_remove .toplevel $_toplevel; } # ------------------------------------------------------------ # clean up the tooltips # ------------------------------------------------------------ ::if {[::winfo exists $_toplevel]} { ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.2.0";} ::qw::tooltip::disable .widget $_toplevel; ::destroy $_toplevel; ::set _toplevel ""; ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.3";} } ::if {[::winfo exists .help_shell]} { /* { 2.27.0 We could leave a dangling balloon window. For example, you position on a field to bring up balloon help and then hit or Alt-X to dismiss the dialog. The balloon help was disabled but that did not destroy an existing balloon help window. I checked the implementation of BWidgets DynamicHelp and found that they use the window ".help_shell". We are on dangerous ground relying on this but in any case we destroy that balloon help window if it exists. */ } ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.4";} ::destroy .help_shell; ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.5";} } catch dummy { ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.6.dummy=$dummy";} } } ::set _tablelist ""; ::set _toplevel ""; ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.99";} } method debug_dump_column_info {} { ::if {![::winfo exists $_tablelist]} { ::return; } ::puts "_column_id_list==$_column_id_list"; ::foreach ColumnId $_column_id_list { ::puts "-------------------------------- column $ColumnId"; ::set ColumnInfo [$_tablelist columnconfigure $ColumnId]; ::foreach Item $ColumnInfo { ::puts "$Item"; } } /* { -------------------------------- column .database_name -align align Align left left -background background Background {} {} -bg -background -changesnipside changeSnipSide ChangeSnipSide 0 0 -editable editable Editable 0 0 -editwindow editWindow EditWindow entry entry -fg -foreground -font font Font {} {} -foreground foreground Foreground {} {} -formatcommand formatCommand FormatCommand {} {} -hide hide Hide 0 0 -labelalign labelAlign Align {} {} -labelbd -labelborderwidth -labelborderwidth labelBorderWidth BorderWidth {} {} -labelcommand labelCommand LabelCommand {} {} -labelcommand2 labelCommand2 LabelCommand2 {} {} -labelfg -labelforeground -labelfont labelFont Font {} {} -labelforeground labelForeground Foreground {} {} -labelimage labelImage Image {} {} -labelpady labelPadY Pad {} {} -labelrelief labelRelief Relief {} {} -maxwidth maxWidth MaxWidth 0 0 -name name Name {} .database_name -resizable resizable Resizable 1 1 -selectbackground selectBackground Foreground {} {} -selectforeground selectForeground Background {} {} -showarrow showArrow ShowArrow 1 1 -showlinenumbers showLineNumbers ShowLineNumbers 0 0 -sortcommand sortCommand SortCommand {} {} -sortmode sortMode SortMode ascii ascii -stretchable stretchable Stretchable 0 0 -stripebackground stripeBackground Background {} {} -stripeforeground stripeForeground Foreground {} {} -text text Text {} d:/nv/demobooks_test/demobooks_229 -title title Title {} Name -valign valign Valign center center -width width Width 0 14 -wrap wrap Wrap 0 0 */ } } method connection_monitor_main {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_main,1000.0";} ::if {$_workstation_database eq ""} { ::set _workstation_database [[::qw::system] cpp_find_workstation_database]; } field_definitions_initialize; ::set _server [::sargs::get $sargs .server]; ::set _port_number [::sargs::get $sargs .port_number]; options_load; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_main,1000.1";} ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_main,1000.2";} toplevel_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_main,1000.3";} client_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_main,1000.4";} menu_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_main,1000.5";} popup_menu_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_main,1000.6";} tooltip_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_main,1000.7";} # resize_and_minsize_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_main,1000.8";} } method field_definitions_initialize {} { ::set _field_definitions { .line_number { .field_path .line_number .title_text "Line" .align right .width 5 .field_type integer .sortmode integer .is_line_number 1 .tooltip "Line Number" } .database_name { .field_path .database_name .title_text "Name" .align left .width 13 .field_type string .sortmode dictionary .tooltip "Accounting database file name\n(or \"server\" if remote server.)" } .database_folder { .field_path .database_folder .title_text "Folder" .align left .width 25 .field_type string .sortmode dictionary .tooltip "Accounting database folder." } .workstation_hostname { .field_path .workstation_hostname .title_text "Workstation" .align left .width 10 .field_type string .sortmode dictionary .tooltip "Hostname of connected workstation." } .server_hostname { .field_path .server_hostname .title_text "Server" .align left .width 9 .field_type string .sortmode dictionary .tooltip "Hostname of the server." } .port_number { .field_path .port_number .title_text "Port" .align right .width 5 .field_type integer .sortmode integer .tooltip "Internet port number." } .username { .field_path .username .title_text "User" .align left .width 14 .field_type string .sortmode dictionary .tooltip "Accounting database user, or empty if remote server." } .total { .upload { .packet_count { .field_path .total.upload.packet_count .title_text "Up Count" .align right .width 10 .field_type integer .sortmode integer .tooltip "Number of messages sent from workstation to server." } .compressed_byte_count { .field_path .total.upload.compressed_byte_count .title_text "Up Bytes" .align right .width 10 .field_type integer .sortmode integer .tooltip "Number of bytes sent from workstation to server" } } .download { .packet_count { .field_path .total.download.packet_count .title_text "Down Count" .align right .width 10 .field_type integer .sortmode integer .tooltip "Number of messages sent from server to workstation." } .compressed_byte_count { .field_path .total.download.compressed_byte_count .title_text "Down Bytes" .align right .width 10 .field_type integer .sortmode integer .tooltip "Number of bytes sent from server to workstation." } } } .total_delta { .field_path .total_delta .title_text "Activity" .align left .width 30 .field_type string .sortmode dictionary .tooltip "Indicates recent activity, (updated per second)." } } } method formatcommand {args} { /* { This is a callback for tablelist to take the column value and format it to the form that is displayed in the column. For example, you might take a raw number and format it with commas, etc. */ } ::set rwb1_debug 0; ::set ColumnId [::lindex $args 0]; ::set Value [::lindex $args 1]; ::set FieldPath [::sargs::get $_column_definition_array($ColumnId) .field_path]; ::if {$rwb1_debug} {::puts "rwb1_debug,formatcommand,1000.0,ColumnId==\"$ColumnId\".";} ::if {$rwb1_debug} {::puts "rwb1_debug,formatcommand,1000.1,FieldPath==\"$FieldPath\".";} ::switch -- $FieldPath { .line_number { ::return [::qw::number::format_whole_number .value $Value]; } .database_name { ::return $Value; } .database_folder { ::return $Value; } .workstation_hostname { ::return $Value; } .server_hostname { ::return $Value; } .port_number { ::return $Value; } .username { ::return $Value; } .total.upload.packet_count { ::return [::qw::number::format_whole_number .value $Value]; } .total.download.packet_count { ::return [::qw::number::format_whole_number .value $Value]; } .total.upload.compressed_byte_count { # 2.31.3 - display megabytes ::return [::qw::number::format_whole_number .value $Value]; } .total.download.compressed_byte_count { # 2.31.3 - display megabytes ::return [::qw::number::format_whole_number .value $Value]; } .total_delta { ::return $Value; } .line_number { ::set Value [::sargs::get $Value .value]; } default { ::qw::bug 314120161006182858 "[::namespace current]::[::qw::methodname] - invalid field \"$FieldPath\"."; } } } method client_setup {} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.0,_column_id_list==$_column_id_list";} #::qw::dialog3::modal ::ttk::frame $_toplevel.client; ::pack $_toplevel.client -side top -expand 1 -fill both; ::foreach ColumnId $_column_id_list { ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.1";} ::lappend ColumnOptionList \ [::sargs::integer_get $_column_definition_array($ColumnId) .width] \ [::sargs::get $_column_definition_array($ColumnId) .title_text] \ [::sargs::get $_column_definition_array($ColumnId) .align] \ ; } # ::frame $_toplevel.client -borderwidth 0 -relief flat -background white; ::frame $_toplevel.client.table_frame -borderwidth 0 -relief flat; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.2";} ::set _tablelist $_toplevel.client.table_frame.tablelist; ::set _vsb $_toplevel.client.table_frame.vsb; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.3";} ::tablelist::tablelist $_tablelist \ -columns $ColumnOptionList \ -height 5 \ -width 0 \ -background white \ -yscrollcommand [::list $_vsb set] \ -tooltipaddcommand [::itcl::code $this tablelist_tooltip_add_callback] \ -tooltipdelcommand ::DynamicHelp::delete \ -stripeheight 1 \ -stripebackground white \ -stripeforeground blue \ -labelcommand [::itcl::code $this label_command] \ -movablecolumns 1 \ -incrarrowtype down \ -activestyle frame \ -selecttype row \ ; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.4";} ::if {$_horizontal_scrollbar_is_enabled} { ::set _hsb $_toplevel.client.table_frame.hsb; $_tablelist configure \ -xscrollcommand [::list $_hsb set] \ ; ::ttk::scrollbar $_hsb -orient horizontal -command [::list $_tablelist xview]; } ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.7";} ::ttk::scrollbar $_vsb -orient vertical -command [::list $_tablelist yview]; # ::ttk::scrollbar $_hsb -orient horizontal -command [::list $_tablelist xview]; # ------------------------------------------------------------ # Configure the column ids. # ------------------------------------------------------------ ::set ColumnNumber 0; ::foreach ColumnId $_column_id_list { $_tablelist columnconfigure $ColumnNumber -name $ColumnId; ::incr ColumnNumber 1; } # ------------------------------------------------------------ # Layout a grid. # ------------------------------------------------------------ ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.8";} # $_tablelist configure -stretch [::list .percent_done_graph]; ::grid $_toplevel.client.table_frame.tablelist -row 0 -column 0 -sticky news; ::grid $_vsb -row 0 -column 1 -sticky ns; ::if {$_horizontal_scrollbar_is_enabled} { ::grid $_hsb -row 1 -column 0 -sticky ew; } ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.9";} ::grid rowconfigure $_toplevel.client.table_frame 0 -weight 1 ::grid columnconfigure $_toplevel.client.table_frame 0 -weight 1 ::grid $_toplevel.client.table_frame -row 0 -column 1 -sticky nsew; ::grid rowconfigure $_toplevel.client 0 -weight 1; ::grid columnconfigure $_toplevel.client 1 -weight 1; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.10";} # ------------------------------------------------------------ # Configure the columns. # ------------------------------------------------------------ ::foreach ColumnId $_column_id_list { $_tablelist columnconfigure $ColumnId \ -name $ColumnId \ -sortmode [::sargs::get $_column_definition_array($ColumnId) .sortmode] \ -showlinenumbers 0 \ -hide [::sargs::boolean_get $_column_definition_array($ColumnId) .hide] \ -formatcommand [::itcl::code $this formatcommand $ColumnId] \ ; } # ------------------------------------------------------------ # Set some bindings. # ------------------------------------------------------------ # Note the -data %d only works in tcl 8.5 or higher # We don't use them anyway ::bind $_tablelist [::itcl::code $this tablelist_event .event configure .widget %W .data {%d}]; ::bind $_tablelist <> [::itcl::code $this tablelist_event .event column_moved .widget %W .data {%d}]; ::bind $_tablelist <> [::itcl::code $this tablelist_event .event column_resized .widget %W .data {%d}]; ::bind $_tablelist <> [::itcl::code $this tablelist_event .event column_sorted .widget %W .data {%d}]; ::bind $_tablelist <> [::itcl::code $this tablelist_event .event columns_sorted .widget %W .data {%d}]; # ::pack $_toplevel.client -side top -expand 1 -fill both -padx 0 -pady 0; /* { ::label $_toplevel.status \ -relief sunken \ -borderwidth $_label_border_width \ -anchor w \ -background $_default_background \ ; */ } # ::pack $Client -side top -fill both -expand 1; # ::grid $_tablelist -row 0 -column 0 -sticky news # ::grid $Client .vsb vsb -row 0 -column 1 -sticky ns; # ::pack $_toplevel.status -side bottom -fill x -padx 4 -pady 4; } method tooltip_setup {} { /* { The dialog_initialize_after_idle method is called after idle so that all of the widgets have been created and exist. For example, the tooltip methods traverse the tk widget hierarchy and to do so, all widgets in the hierarchy must exist. */ } # ------------------------------------------------------------ # tooltips # ------------------------------------------------------------ ::qw::tooltip::enable .widget $_toplevel .command [::itcl::code $this tooltip_get .widget %widget%]; /* { # ------------------------------------------------------------ # default focus widget # ------------------------------------------------------------ ::set DefaultFocusWidget [::sargs::get $_sargs .default_focus_widget]; ::if {$DefaultFocusWidget ne ""} { ::set DefaultFocusWidget $_toplevel$DefaultFocusWidget; ::if {[::winfo exists $DefaultFocusWidget]} { ::focus $DefaultFocusWidget; } } */ } /* { # ------------------------------------------------------------ # process resizable and minsize # ------------------------------------------------------------ ::if {[::winfo exists $_toplevel]} { ::switch -- [::sargs::boolean_get $_sargs .resize_is_enabled] { 0 { ::wm resizable $_toplevel 0 0; } 1 { ::if {[::sargs::boolean_get $_sargs .minsize_is_enabled]} { ::wm minsize $_toplevel [::winfo reqwidth $_toplevel] [::winfo reqheight $_toplevel]; } } } ::qw::winutil::edit_assist_position_toplevel $_sargs .toplevel $_toplevel; ::wm deiconify $_toplevel; ::raise $_toplevel; } */ } } method command_file_defaults {} { /* { The user is reverting to factory settings. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,command_file_defaults,1000.0"} ::set Text "Revert to default settings?"; ::append Text "\n\nThis will re-display columns in their"; ::append Text "\nfactory default order and widths."; ::append Text "\nIt will also set the monitor window"; ::append Text "\nsize and position to default values."; ::if {$rwb1_debug} {::puts "rwb1_debug,command_file_defaults,1000.1"} ::set Result [::qw::dialog85::confirm [::subst -nocommands { .text {$Text} .help_page { .id 314120090203125238 .tags {error} .body { [p { You can move and resize the connection monitor window and you can move and resize it's columns. [/* {You can even delete columns or add new ones. */}] }] [p { You can always issue the [qw_menu_command File Defaults] command to revert back to the original factory default settings in order to [qw_quoted "start over"]. }] } } \ }]]; ::if {!$Result} { ::return; } ::if {[::qw::command_exists $_workstation_database]} { ::if {[$_workstation_database cpp_file_exists .path /odb/script_options]} { # ------------------------------------------------------------ # Delete the options record (if it exists). # ------------------------------------------------------------ ::set Before [$_workstation_database cpp_file_record_read \ .path /odb/script_options \ .key [::list string $_script_id] \ ]; ::if {[::sargs::size $Before]!=0} { $_workstation_database cpp_file_record_delete \ .path /odb/script_options \ .before $Before \ ; } } } ::if {$rwb1_debug} {::puts "rwb1_debug,command_file_defaults,1000.2"} ::if {$_toplevel ne ""} { ::if {$rwb1_debug} {::puts "rwb1_debug,command_file_defaults,1000.3"} ::qw::tooltip::disable .widget $_toplevel; ::destroy $_toplevel; ::set _toplevel ""; ::set _tablelist ""; ::set _vsb ""; ::set _hsb ""; ::set _resize_is_enabled 1; ::set _minsize_is_enabled 0; ::set _sort_order ""; ::set _sort_column ""; ::array unset _column_definitions *; ::set _column_id_list ""; ::if {$rwb1_debug} {::puts "rwb1_debug,command_file_defaults,1000.4"} } ::if {$rwb1_debug} {::puts "rwb1_debug,command_file_defaults,1000.5"} connection_monitor_main; ::if {$rwb1_debug} {::puts "rwb1_debug,command_file_defaults,1000.9"} } method options_load {} { /* { The options are kept in the workstation database. They are kept in a record in the file /odb/script_options with record key $_script_id:$_server:_$_port_number. Script id happens to be 314120161127110445. We have one monitor window and hence one options record per remote server, identified by the server url and port number. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.0";} ::set Options [::sargs]; ::if {[::qw::command_exists $_workstation_database]} { ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.2";} ::if {![$_workstation_database cpp_file_exists .path /odb/script_options]} { # ------------------------------------------------------------ # Create the /odb/script_options file on demand # ------------------------------------------------------------ ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.3";} $_workstation_database cpp_file_create \ .path /odb/script_options \ .schema.key [::list string] \ .schema.amounts [::list .count] \ ; ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.4";} } ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.5";} /* { We used to have a single options record because we had only one monitor. If that record exists, get rid of it. */ } ::set Before [$_workstation_database cpp_file_record_read \ .path /odb/script_options \ .key [::list string $_script_id] \ ]; ::if {[::sargs::size $Before]!=0} { $_workstation_database cpp_file_record_delete \ .path /odb/script_options \ .before $Before \ ; } /* { Now get the options for this server, if any. */ } ::set Before [$_workstation_database cpp_file_record_read \ .path /odb/script_options \ .key [::list string "$_script_id:$_server:$_port_number"] \ ]; ::set Options [::sargs::get $Before .data]; ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.7,Options==\n[::sargs::format $Options]";} } ::if {[::sargs::size $Options]!=0} { # ------------------------------------------------------------ # Options were found in the workstation. # ------------------------------------------------------------ ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.7.0";} ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.8";} ::set _toplevel_geometry [::sargs::get $Options .toplevel.geometry]; ::set _column_id_list [::sargs::get $Options .column_name_list]; ::set _resize_is_enabled [::sargs::boolean_get $Options .resize_is_enabled]; ::set _minsize_is_enabled [::sargs::boolean_get $Options .minsize_is_enabled]; ::set _sort_order [::sargs::get $Options .sort_order]; ::if {$_sort_order eq ""} { ::set _sort_order "increasing"; } ::set _sort_column [::sargs::get $Options .sort_column]; ::if {$_sort_column eq ""} { ::set _sort_column ".database_folder"; } ::array set _column_definition_array [::sargs::get $Options .column_definition_array]; ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.9";} ::return; } # ------------------------------------------------------------ # Options record not found - create and store the default options. # ------------------------------------------------------------ ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.10";} ::set _toplevel_geometry 1080x144+100+100; ::set _sort_order "increasing"; ::set _sort_column ".database_folder"; ::foreach FieldPath [::sargs::select_field .structure $_field_definitions .field .field_path] { /* { Copydown semantics. We start each column definition with it's field definition. */ } ::set ColumnId .column_id_$_next_column_id; ::incr _next_column_id 1; ::lappend _column_id_list $ColumnId; ::set _column_definition_array($ColumnId) [::sargs::get $_field_definitions $FieldPath]; } ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.11";} ::if {$rwb1_debug} {debug_dump_column_info;} ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.12";} options_store; ::if {$rwb1_debug} {::puts "rwb1_debug,options_load,1000.13";} } method options_store {} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,options_store,1000.00";} ::if {$rwb1_debug} {debug_dump_column_info;} ::if {$rwb1_debug} {::puts "rwb1_debug,options_store,1000.01";} ::if {![::winfo exists $_toplevel]} { /* { If the toplevel doesn't exist, and I don't know why it wouldn't, but in any case don't try to save any options. It can only be a bad thing. */ } ::return; } ::if {![::qw::command_exists $_workstation_database]} { ::if {$rwb1_debug} {::puts "rwb1_debug,options_store,1000.2";} ::qw::warning 314120151215130845 "[::qw::methodname] - no workstation command."; ::return ""; } ::if {$rwb1_debug} {::puts "rwb1_debug,options_store,1000.3";} ::set _column_id_list [::list]; ::for {::set i 0;} {$i<[$_tablelist columncount]} {::incr i 1} { /* { Since options_store is called by any configure event, the columns might moved, so we have to refresh the column_name_list. */ } ::lappend _column_id_list [$_tablelist columncget $i -name]; } ::sargs::var::set Options .script_id $_script_id; ::sargs::var::set Options .script_version $_script_version; ::sargs::var::set Options .qw_release $::qw_release; ::sargs::var::set Options .toplevel.geometry [::wm geometry $_toplevel]; ::sargs::var::set Options .column_name_list $_column_id_list; ::sargs::var::boolean_set Options .resize_is_enabled $_resize_is_enabled; ::sargs::var::boolean_set Options .minsize_is_enabled $_minsize_is_enabled; ::sargs::var::set Options .sort_order $_sort_order; ::sargs::var::set Options .sort_column $_sort_column; ::if {$rwb1_debug} {::puts "rwb1_debug,options_store,1000.4";} ::if {$rwb1_debug} {::puts "rwb1_debug,options_store,1000.4.0,_column_id_list==$_column_id_list";} ::foreach ColumnId $_column_id_list { ::sargs::var::set _column_definition_array($ColumnId) .width [$_tablelist columncget $ColumnId -width]; } ::if {$rwb1_debug} { ::foreach ColumnId [::array names _column_definition_array] { puts "rwb1_debug,options_store,1000.4.1,name==$ColumnId,column_definition==\n$_column_definition_array($ColumnId)"; } } ::sargs::var::set Options .column_definition_array [::array get _column_definition_array]; ::if {$rwb1_debug} {::puts "rwb1_debug,options_store,1000.5";} ::set Key [::list string "$_script_id:$_server:$_port_number"]; ::set After [::sargs \ .key $Key \ .data $Options \ .amounts [::list .count 1.0] \ ]; ::if {$rwb1_debug} {::puts "rwb1_debug,options_store,1000.6";} ::set Before [$_workstation_database cpp_file_record_read .path /odb/script_options .key $Key]; ::if {$Before eq ""} { ::if {$rwb1_debug} {::puts "rwb1_debug,options_store,1000.7";} $_workstation_database cpp_file_record_insert .path /odb/script_options .after $After; } else { ::if {$rwb1_debug} {::puts "rwb1_debug,options_store,1000.8";} $_workstation_database cpp_file_record_write .path /odb/script_options .before $Before .after $After; } ::if {$rwb1_debug} {::puts "rwb1_debug,options_store,1000.9";} } method dump_options {sargs} { ::if {[::winfo exists $_tablelist]} { ::foreach {Name Structure} $_column_definitions { ::puts "Field:$Name"; ::foreach Option { -align -background -changesnipside -editable -editwindow -font -foreground -formatcommand -hide -labelalign -labelbackground -labelborderwidth -labelcommand -labelcommand2 -labelfont -labelforeground -labelheight -labelimage -labelpady -labelrelief -maxwidth -name -resizable -selectbackground -selectforeground -showarrow -showlinenumbers -sortcommand -sortmode -stretchable -text -title -width -wrap } { ::puts "\t$Option: [$_tablelist columnconfigure $Name $Option]"; } } } } method dialog_initialize_after_idle {} { /* { The dialog_initialize_after_idle method is called after idle so that all of the widgets have been created and exist. For example, the tooltip methods traverse the tk widget hierarchy and to do so, all widgets in the hierarchy must exist. */ } ::set rwb1_debug 0; if {$rwb1_debug} { debug_dump_column_info; } # ------------------------------------------------------------ # tooltips # ------------------------------------------------------------ # ::set Callback [::sargs::get $_sargs .tooltip_get_callback]; ::set Callback ""; ::switch -- $Callback { "" { ::qw::tooltip::enable .widget $_toplevel .command [::itcl::code $this tooltip_get .widget %widget%]; } default { ::qw::tooltip::enable .widget $_toplevel .command [::concat $Callback .widget %widget%]; } } # ::qw::tooltip::enable .widget $_toplevel .command [::itcl::code $this tooltip_get .widget %widget%]; # ------------------------------------------------------------ # default focus widget # ------------------------------------------------------------ /* { ::set DefaultFocusWidget [::sargs::get $_sargs .default_focus_widget]; ::if {$DefaultFocusWidget ne ""} { ::set DefaultFocusWidget $_toplevel$DefaultFocusWidget; ::if {[::winfo exists $DefaultFocusWidget]} { ::focus $DefaultFocusWidget; } } */ } # ------------------------------------------------------------ # process resizable and minsize # ------------------------------------------------------------ ::if {[::winfo exists $_toplevel]} { ::switch -- $_resize_is_enabled { 0 { ::wm resizable $_toplevel 0 0; } 1 { ::if {$_minsize_is_enabled} { ::wm minsize $_toplevel [::winfo reqwidth $_toplevel] [::winfo reqheight $_toplevel]; } } } # ::qw::winutil::edit_assist_position_toplevel $_sargs .toplevel $_toplevel; ::wm deiconify $_toplevel; ::raise $_toplevel; } } method toplevel_setup {} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog3::modal,toplevel_setup,1000.0";} ::set Count 0; ::while {[::winfo exists .connection_monitor_toplevel_$Count]} { ::incr Count 1; } ::set _toplevel [::toplevel .connection_monitor_toplevel_$Count]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog3::modal,toplevel_setup,1000.1,_toplevel==$_toplevel";} ::wm title $_toplevel "Connection monitor for $_server:$_port_number"; ::if {$rwb1_debug} {::puts "rwb1_debug,setting initial geometry to $_toplevel_geometry";} ::wm geometry $_toplevel $_toplevel_geometry; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog3::modal,toplevel_setup,1000.2";} ::wm protocol $_toplevel WM_DELETE_WINDOW [::itcl::code $this command_connection_monitor_dismiss]; ::wm group $_toplevel . ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog3::modal,toplevel_setup,1000.3";} ::bind $_toplevel {tk::TabToWindow [tk_focusNext %W]} ::bind $_toplevel <> {tk::TabToWindow [tk_focusPrev %W]} ::bind $_toplevel [::itcl::code $this dialog_dismiss]; ::bind $_toplevel [::itcl::code $this command_connection_monitor_dismiss]; ::bind $_toplevel [::itcl::code $this dialog_help] ::bind $_toplevel [::itcl::code $this command_connection_monitor_dismiss]; ::bind $_toplevel [::itcl::code $this command_connection_monitor_dismiss]; # ::bind $_toplevel [::itcl::code $this dialog_control_button_process .control_button .ok]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog3::modal,toplevel_setup,1000.4";} # ::set ResizeIsEnabled [::sargs::boolean_get $_sargs .resize_is_enabled]; # ::set MinsizeIsEnabled [::sargs::boolean_get $_sargs .minsize_is_enabled]; ::after idle [::subst -nocommands { ::if {[::qw::command_exists $this]} { $this dialog_initialize_after_idle; } }]; ::wm withdraw $_toplevel; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog3::modal,toplevel_setup,1000.6";} # this would be extremely annoying # ::qw::toplevel_add .toplevel $_toplevel; /* { We withdraw the toplevel to reduce noise such as when the client area is set up. We scheduled dialog_initialize_after_idle that will optionally position the toplevel and deiconify it. See above. */ } ::wm withdraw $_toplevel; # ::bind $_toplevel [::itcl::code $this configure_event]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog3::modal,toplevel_setup,1000.7";} } method command_connection_monitor_dismiss {} { ::itcl::delete object $this; } method tablelist_event {sargs} { /* { I put this stuff in when chading a bug but it could be useful in general so leaving it in even though it does nothing here. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist_event,1000.0,seconds==[::clock seconds],sargs==$sargs";} ::set Event [::sargs::get $sargs .event]; ::switch -- $Event { configure { options_store; } column_moved { } columns_sorted - column_sorted { } "" { } default { } } } method tablelist_tooltip_add_callback {Table Row Col} { /* { -tooltipaddcommand [::itcl::code $this tablelist_tooltip_add_callback] \ -tooltipdelcommand ::DynamicHelp::delete \ The classic tablelist tooltip help displays a tooltip for a cell that doesn't fit in it's column. And what the tooltip displays is the cell contents. We will do it this way: - title line displays tooltip for column and title text if snipped - cells display cell text if snipped */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist_tooltip_add_callback,1000.0,Row==$Row,Col==$Col";} ::set Field [$Table columncget $Col -name]; ::set CellText ""; ::set TooltipText ""; ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist_tooltip_add_callback,1000.1";} ::if {$Row<0} { /* { Title cell - display column tooltip, and optionally title text if snipped. Let's handle title row separately. */ } ::set ColumnId [$_tablelist columncget $Col -name]; ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist_tooltip_add_callback,1000.1.0,ColumnId==$ColumnId,entry==\n[::sargs::format $_column_definition_array($ColumnId)]";} ::set Text [::sargs::get $_column_definition_array($ColumnId) .tooltip]; ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist_tooltip_add_callback,1000.1.1,Text==$Text";} ::if {$Text ne ""} { ::DynamicHelp::add $Table -text $Text } ::return; ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist_tooltip_add_callback,1000.2";} ::if {[$Table istitlesnipped $Col Temp]} { ::set CellText $Temp; } ::set TooltipText [::sargs::get [tooltip_get .path $Field] .text]; ::if {$CellText ne ""&&$TooltipText ne ""} { ::set Text "$CellText\n\n$TooltipText"; } else { ::set Text "$CellText$TooltipText"; } ::if {$Text ne ""} { ::DynamicHelp::add $Table -text $Text } ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist_tooltip_add_callback,1000.3";} ::return; } /* { Body cell - contents only and only when snipped. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist_tooltip_add_callback,1000.4";} ::if {[$Table iselemsnipped $Row,$Col Temp]} { ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist_tooltip_add_callback,1000.5";} ::set CellText $Temp; ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist_tooltip_add_callback,1000.6";} ::DynamicHelp::add $Table -text $CellText ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist_tooltip_add_callback,1000.7";} ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist_tooltip_add_callback,1000.8";} } method tooltip_get {sargs} { ::set Path [::sargs::get $sargs .widget]; ::if {$Path eq ""} { ::set Path [::sargs::get $sargs .path]; } ::set Text ""; ::switch -glob -- $Path { *.file.exit { ::append Text "Dismiss the connection manager window."; ::return [::sargs .text $Text]; } *.file.defaults { ::append Text "Revert to connection monitor factory default settings."; ::return [::sargs .text $Text]; } *.statistics.display { ::append Text "Produces graphs of message statistics,"; ::append Text "\ndisplaying message activity by message size."; ::append Text "\nStatistics are accumulated since last reset."; ::return [::sargs .text $Text]; } *.statistics.reset { ::append Text "Resets the statistics in the graph displayed by the"; ::append Text "\n/Statistics/Display command. The next time you"; ::append Text "\ninvoke that command it will display statistics"; ::append Text "\nfrom the last reset. Note that the /Display/Reset"; ::append Text "\ncommand does not clear the statistics displayed in"; ::append Text "\nthis connection monitor window."; ::return [::sargs .text $Text]; } *.row.delete { ::append Text "Deletes (disconnects) a workstation connection." ::return [::sargs .text $Text]; } *.help.connections { ::append Text "General help on the connection monitor window."; ::return [::sargs .text $Text]; } *.help.about { ::append Text "Version information."; ::return [::sargs .text $Text]; } default { /* { 2.31.0 There are lots of helper widgets within the tablelist for which there are no tooltips so there were many unuseful warnings coming out. */ } #::qw::warning 314120161021165342 "tooltip - no entry for path \"$Path\""; } } /* { ::menu $_toplevel.menubar.edit -tearoff 0 $_toplevel.menubar add cascade -label "Edit" -menu $_toplevel.menubar.edit -underline 0 $_toplevel.menubar.file add command -label "Delete" -command [::itcl::code $this command_row_delete]; $_toplevel.menubar.file add command -label "Exit" -command [::itcl::code $this command_connection_monitor_dismiss]; */ } ::return [chain $args]; } method command_row_delete {} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.0";} ::set SelectedRowList [$_tablelist curselection]; ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.1,SelectedRowList==$SelectedRowList";} ::foreach RowNumber $SelectedRowList { ::set RowId [$_tablelist rowcget $RowNumber -name]; ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.2,row_number==$RowNumber,RowId==$RowId";} ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.3,data==\n[::sargs::format $_row_data_array($RowId)]";} /* { The row_id is actually the connection_odb_object but let's take it from the data anyway. The row_id could be subject to change in the future and using it would create unintended side-effects. */ } ::set ConnectionOdbObject [::sargs::get $_row_data_array($RowId) .connection_odb_object]; ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.4,ConnectionOdbObject==$ConnectionOdbObject";} ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.4.0,ConnectionOdbObject exists==[::qw::command_exists $ConnectionOdbObject]";} ::set PlugCppObject [::sargs::get $_row_data_array($RowId) .plug_cpp_object]; ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.5,PlugCppObject==$PlugCppObject";} ::if {[::qw::command_exists $PlugCppObject]} { /* { Explanation of what's happening here. To get rid of the row in the simplest way we just destroy the connection_odb_object. The odb address of the connection object is in the connection array record. The problem is that it may not actually exist on the client side. We have the plug that belongs to the remote server application database so we use it to get the client-seide database, and then we use that to find the connection odb object. Finally we destroy it. Why is this necessary? Because the odb_connection object may not have been loaded into the remote server database on the client side. The application database corresponding to the connection may be opened before the remote server is opened and the remote server might not be positioned in such a way that connection object need be loaded on the client side. So the cpp_object_find call is necessary to load it so we can call its odb_destroy method. When the object is destroyed all signals will eminate from the server-side back to the client side to remove the item from the table and the connection array. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.6";} ::set PlugApplicationDatabase [$PlugCppObject cpp_plug_application_database]; ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.7,PlugApplicationDatabase==$PlugApplicationDatabase";} ::if {[::qw::command_exists $PlugApplicationDatabase]} { ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.8";} ::set ConnectionOdbObject [$PlugApplicationDatabase cpp_object_find .address $ConnectionOdbObject]; ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.9,ConnectionOdbObject==$ConnectionOdbObject";} } } ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.10";} /* { The ConnectionOdbObject may not have been loaded in the ws database. This happens when the connection is opened before the remote server is opened, and the remote server also does not happen to display the connection object. So we need the connection object loaded before we can call it's odb_destroy method. */ } ::if {[::qw::command_exists $ConnectionOdbObject]} { ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.11,ConnectionOdbObject==$ConnectionOdbObject";} $ConnectionOdbObject odb_destroy; ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.12";} } ::if {$rwb1_debug} {::puts "rwb1_debug,command_edit_delete,1000.13";} } } method command_file_exit {} { ::itcl::delete object $this; } method command_help_connections {} { ::set HelpPage [connections_help_page]; ::qw::script::source \ .script.path [::file join $::qw_program_path doc qw_chtml_compile.qw_script] \ .structure $HelpPage \ ; } method command_help_about {} { ::qw::dialog3::notify { .html { .body { [p { Connection monitor }] [p { Version 2.0 }] [qw_code { Copyright (c) 2016-2017 Q.W.Page Associates Inc. www.qwpage.com All rights reserved. }] } } } } method command_statistics_display {} { ::set rwb1_debug 0; ::qw::throw \ .text "This command is currently disabled." \ .help_page { .id 314120210407113837 .tags {error} .body { [p { This command is disabled. It can be used only by PAGE customer support. It was generally unused by [qw_quoted "normal"] users and supporting it at the system level was an unnecessary performance hit. }] } } \ ; ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_display,1000.0";} ::if {![::qw::command_exists $_remote_server_plug_cpp_object]} { ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_display,1000.1";} ::qw::throw "Can't retrieve connection statistics because have no remote server connection."; } ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_display,1000.2";} ::package require qw::barchart_simple; ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_display,1000.3";} ::set Data [$_remote_server_plug_cpp_object cpp_tcp_call \ .tcp { .command call .source plug .destination socket .priority foreground } \ .command message_statistics_get \ ]; # sargs::var::set s_args .destination_folder [::file join d:/ rwb_text 2011_hockey_ross]; # sargs::var::set s_args .title "Major Bantam AA 2011-12"; ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_display,1000.4,data==\n$Data";} ::set RecordList [::sargs::get $Data .message_statistics_record_list]; ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_display,1000.5";} ::set ConnectionStatsGraphObject ::qw::message_statistics_graph_object; ::qw::message_statistics_graph $ConnectionStatsGraphObject \ .record_list $RecordList \ .title "Connection Statistics" \ ; ::qw::finally [::list ::itcl::delete object $ConnectionStatsGraphObject]; ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_display,1000.6";} } method command_statistics_reset {} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_reset,1000.0";} ::if {![::qw::command_exists $_remote_server_plug_cpp_object]} { ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_reset,1000.1";} ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_reset,1000.2";} ::if {![::qw::command_exists $_remote_server_plug_cpp_object]} { ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_reset,1000.3";} ::qw::throw "Can't reset connection statistics because have no remote server connection."; } ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_reset,1000.4";} $_remote_server_plug_cpp_object cpp_tcp_call \ .tcp { .command call .source plug .destination socket .priority foreground } \ .command message_statistics_reset \ ; ::if {$rwb1_debug} {::puts "rwb1_debug,command_statistics_reset,1000.5";} } /* { method minsize_set {} { ::set Width [::winfo reqwidth $_toplevel] ::set Height [::winfo reqheight $_toplevel] ::wm minsize $_toplevel $Width $Height } */ } method row_exists {sargs} { ::set RowId [::sargs::get $sargs .row_id]; ::qw::try { $_tablelist rowcget $RowId -name; } catch dummy { ::return 0; } ::return 1; /* { What follows is a linear search, but I will assume that the code above is faster so used it instead. ::set Size [$_tablelist size]; ::for {::set Row 0} {$Row<$Size} {::incr Row} { ::if {$OperationId eq [$_tablelist rowcget $Row -name]} { ::return 1; } } ::return 0; Also, could simply see if _row_data_array($RowId) exists but at time of writing wasn't sure we would have _row_data_array array. What follows is a linear search, but I will assume that the code above is faster so used it instead. */ } } method field_exists {sargs} { ::set Field [::sargs::get $sargs .field]; ::qw::try { $_tablelist columncget $Field -name; } catch Exception { ::return 0; } ::return 1; /* { What follows is a linear search, but I will assume that the code above is faster so used it instead. */ } /* { ::set Size [$_tablelist columncount]; ::for {::set Col 0} {$Col<$Size} {::incr Col} { ::if {$Field eq [$_tablelist columncget $Col -name]} { ::return 1; } } ::return 0; */ } } method debug_dump_update_record_list {sargs} { ::set UpdateRecordList [::sargs::get $sargs .update_record_list]; ::set Count 0; ::foreach UpdateRecord $UpdateRecordList { ::puts "------------------------------------------------"; ::puts "UpdateRecordList\[$Count\]==\n[::sargs::format $UpdateRecord]" ::puts "------------------------------------------------"; ::incr Count 1; } } method connection_monitor_update {sargs} { /* { We receive signals from our remote server and update each row representing each connection. There is an update record for each connection. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,----------------------------------------------------------------";} ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_update,1000.0,sargs==\n[::sargs::format $sargs]";} ::if {$rwb1_debug} {::puts "rwb1_debug,----------------------------------------------------------------";} ::set _remote_server_plug_cpp_object [::sargs::get $sargs .remote_server_plug_cpp_object]; ::set UpdateConnectionOdbObjectList [::list]; ::set RemoteServerPlugCppObject [::sargs::get $sargs .remote_server_plug_cpp_object]; ::if {$rwb1_debug} { debug_dump_update_record_list $sargs; } # ::set RenumberNeeded 0; ::foreach UpdateRecord [::sargs::get $sargs .update_record_list] { /* { We use the connection_odb_object as the row id because it should be universally unique. So we can mix connections from multiple servers, databases, etc., while maintaining uniqueness. Probable their are other combinations of values that would also be unique but this is simplest. .connection_odb_object ::qw::odb::20160715082136::/1496354578_974 .database_name server .database_folder {} .workstation { .hostname benn7 } .server { .hostname benn7 } .port_number 7890 .username {} .delta { .upload { .packet_count 70 .compressed_byte_count 13222 .uncompressed_byte_count 18202 } .download { .packet_count 71 .compressed_byte_count 18830 .uncompressed_byte_count 66698 } } .total { .upload { .packet_count 70 .compressed_byte_count 13222 .uncompressed_byte_count 18202 } .download { .packet_count 71 .compressed_byte_count 18830 .uncompressed_byte_count 66698 } } .total_delta 141 .max_delta 141 .clock_clicks_at_last_signal 1496354588003 */ } ::if {$rwb1_debug} {::puts "rwb1_debug,----------------------------------------------------------------";} ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_update,1000.00,UpdateRecord==\n[::sargs::format $UpdateRecord]";} ::if {$rwb1_debug} {::puts "rwb1_debug,----------------------------------------------------------------";} ::set RowId [::sargs::get $UpdateRecord .connection_odb_object]; ::if {$RowId eq ""} { /* { A connection other than the remote_server connection itself can be terminated and in the process of being take down. In that case the .connection_odb_object may not be in the service_node connection table entry. Ignoring it is therefore the right thing to do. Oringinally this was reported as a bug and it actually happened during testing. */ } ::continue; } ::lappend UpdateConnectionOdbObjectList $RowId; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_update,1000.2,RowId==$RowId";} ::sargs::var::set UpdateRecord .row_id $RowId; ::if {![row_exists .row_id $RowId]} { /* { We attach the calling plug_cpp_object to each row's data so that the row can be identified and deleted when the plug's connection is terminated. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_update,1000.3";} row_create $UpdateRecord .remote_server_plug_cpp_object $RemoteServerPlugCppObject; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_update,1000.4";} # ::set RenumberNeeded 1; renumber; } ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_update,1000.5";} ::if {$rwb1_debug} { ::puts "rwb1_debug,connection_monitor_update,1000.5.0,before,update_record_list=="; debug_dump_update_record_list $sargs; } /* { We += rather than set because we are holding the line number and possibly other calculated values in the data that we do not want to clobber. */ } ::sargs::var::+= _row_data_array($RowId) $UpdateRecord; ::if {$rwb1_debug} { ::puts "rwb1_debug,connection_monitor_update,1000.5.1, after,update_record_list=="; debug_dump_update_record_list $sargs; } row_update_from_data .row_id $RowId; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_update,1000.6";} } /* { We have processed every connection_odb_object in the update _record_list and added rows that didn't exist. On the other hand, there may be rows for which there is no update record. These must be deleted. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_update,1000.7, array names==[::array names _row_data_array]";} ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_update,1000.8,OdbObjectList==$UpdateConnectionOdbObjectList";} ::set CarcassList [::lindex [::qw::intersect3 $UpdateConnectionOdbObjectList [::array names _row_data_array]] 2]; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_update,1000.9,CarcassList==$CarcassList";} ::foreach RowId $CarcassList { ::if {![row_exists .row_id $RowId]} { ::qw::bug 314120161005160229 "[::namespace current]::[::qw::methodname] - no row \"$RowId\"."; } ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_update,1000.10,tablelist_size==[$_tablelist size]";} row_delete .row_id $RowId; # ::set RenumberNeeded 1; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_update,1000.11,tablelist_size==[$_tablelist size]";} } # ::if {$RenumberNeeded} { # renumber; # } } method connection_monitor_plug_destroyed {sargs} { /* { For now we only need to search for the remote_server_cpp_plug_object. All other connections are destroyed when update signals do not include them. But we never get update signals when a remote_server connection is destroyed because the signals come over that connection. Perhaps we should rethink this and always destroy connections when plugs are destroyed. But as we are displaying connections for all workstations connected to all remote servers that would not do it. .remote_server_plug_cpp_object ::qw::cpp::F46D0461A5CE_7900_67 */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_plug_destroyed,this==$this,1000.0,sargs==$sargs";} ::if {$rwb1_debug} {debug_dump_row_data_array}; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_plug_destroyed,1000.0.1";} ::set RemoteServerPlugCppObject [::sargs::get $sargs .remote_server_plug_cpp_object]; ::if {$RemoteServerPlugCppObject eq ""} { ::qw::bug 314120161005082942 "[::namespace current]::[::qw::methodname] - no .remote_server_plug_cpp_object argument."; } ::set RowIdList [::array names _row_data_array]; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_plug_destroyed,1000.1,RemoteServerPlugCppObject==$RemoteServerPlugCppObject,rowidlist==$RowIdList";} ::foreach RowId $RowIdList { ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_plug_destroyed,1000.2,RowId-data==\n[::sargs::format $_row_data_array($RowId)]";} ::if {[::sargs::get $_row_data_array($RowId) .remote_server_plug_cpp_object] eq $RemoteServerPlugCppObject} { ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_plug_destroyed,1000.3,RowId==$RowId";} row_delete .row_id $RowId; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_plug_destroyed,1000.4,RowId==$RowId";} } } ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor_plug_destroyed,1000.99,connection_monitor_exists==[::qw::command_exists $this]";} } method debug_dump_row_data_array {} { ::foreach RowId [::array names _row_data_array] { ::puts "rwb1_debug,--------------------------------------------------"; ::puts "rwb1_debug,_row_data_array\[$RowId\]==\n[::sargs::format $_row_data_array($RowId)]"; ::puts "rwb1_debug,--------------------------------------------------"; } } method row_create {sargs} { /* { .connection_id conn_1 .service_hub_socket_cpp_object ::qw::cpp::F46D0461A5CE_6296_8 .connection_odb_object ::qw::odb::20160715082136::/1479915436_1808 .database_path server .database_folder {} .database_name server .workstation { .hostname benn7 .serial INTERNAL-BENN-5 .nic F4-6D-04-61-A5-CE .ip 192.168.0.158 .release 2.30.0alpha.20161114 .unique_process_id 1479915513_7900 .username {} } .server { .hostname benn7 } .port_number 7890 .upload.packet_count 37 .up_message_count_delta 37 .upload.compressed_byte_count 9492 .up_byte_count_delta 9492 .download.packet_count 37 .down_message_count_delta 37 .download.compressed_byte_count 9060 .down_byte_count_delta 9060 .update_signal_description {service_hub - remote_server_connection} .clock_clicks_at_last_signal -1848190006 .max_delta 18626 .total_delta 18626 .clock_clicks_since_last_signal 565 .row_id ::qw::odb::20160715082136::/1479915436_1808 .remote_server_plug_cpp_object ::qw::cpp::F46D0461A5CE_7900_67 */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor::row_create,1000.0,sargs==\n[::sargs::format $sargs]";} ::set RowId [::sargs::get $sargs .row_id]; ::if {[row_exists .row_id $RowId]} { ::qw::bug 314120160304144420 "[::namespace current]::[::qw::methodname] - row id \"$RowId\" already exists."; } ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor::row_create,1000.1";} ::set _row_data_array($RowId) $sargs; # $_toplevel.status configure -text [::sargs::get $sargs .status]; ::set RowNumber [$_tablelist size]; $_tablelist insert end [::list]; $_tablelist rowconfigure $RowNumber -name $RowId; row_update_from_data .row_id $RowId; $_tablelist see $RowId; } method graph_window_create {Table Row Col Widget} { ::set rwb1_debug 0; ::if {[::winfo exists $Widget]} { ::qw::bug 314120160304190816 "[::namespace current]::[::qw::methodname] - window exists."; } ::canvas $Widget -height $_bar_height -width 200 -background white; # 2.23.0 - didn't have any effect but left it in ::bindtags $Widget [::lreplace [::bindtags $Widget] 1 1 TablelistBody]; ::set RowId [$_tablelist rowcget $Row -name]; ::if {$rwb1_debug} {::puts "rwb1_debug,graph_window_create,3330.0,Row==$Row,Col==$Col,Widget==[::file tail $Widget],RowId==$RowId";} ::if {[::info exists _row_data_array($RowId)]} { ::sargs::var::set _row_data_array($RowId) .widget $Widget; } $Widget create rectangle 0 0 0 0 -outline white -fill gray -tags bar; } method graph_window_destroyed {Table Row Col Widget} { ::set rwb1_debug 0; ::set RowId [$_tablelist rowcget $Row -name]; ::if {$rwb1_debug} {::puts "rwb1_debug,graph_window_destroyed,3330.1,Row==$Row,Col==$Col,Widget==[::file tail $Widget],RowId==$RowId";} #::qw::bug 314120170609085046 "[::namespace current]::[::qw::methodname] - artificial bug."; ::if {[::info exists _row_data_array($RowId)]} { ::sargs::var::set _row_data_array($RowId) .widget ""; } } method row_update_from_data {sargs} { /* { Usage: row_update_from_data .row_id $RowId; We put the raw data in the cell and allow formatcommand to format things like dates and numbers. This allows tablelist to sort the column using the raw data. The delta column is special because we graph it. To format it using formatcommand, we need access to the row id so we can get the maximum or other data related to the specific row. For now we will just format it here and forget the format command. */ } ::set rwb1_debug 0; ::set RowId [::sargs::get $sargs .row_id]; ::set Size [$_tablelist columncount]; ::if {$Size!=[::llength $_column_id_list]} { ::qw::bug 314120160304190816 "[::namespace current]::[::qw::methodname] - invalid size \"$Size\"."; } ::foreach ColumnId $_column_id_list { ::set FieldPath [::sargs::get $_column_definition_array($ColumnId) .field_path]; ::switch -- $FieldPath { .total_delta { ::set Widget ""; ::if {![::info exists _row_data_array($RowId)]} { ::qw::bug 314120161020152010 "[::qw::methodname] - no data for RowId \"$RowId\"."; } ::set Widget [::sargs::get $_row_data_array($RowId) .widget]; ::if {$Widget eq ""} { $_tablelist cellconfigure $RowId,$ColumnId \ -window [::itcl::code $this graph_window_create] \ -windowdestroy [::itcl::code $this graph_window_destroyed] \ -stretchwindow 1 \ ; ::set Widget [::sargs::get $_row_data_array($RowId) .widget]; ::if {$Widget eq ""} { ::qw::bug 314120161020152011 "[::qw::methodname] - empty widget name."; } } ::set TotalDelta [::sargs::real_get $_row_data_array($RowId) .total_delta]; ::set MaxDelta [::sargs::real_get $_row_data_array($RowId) .max_delta]; ::set Fraction 0.0; ::if {$MaxDelta>0&&$TotalDelta>0} { /* { No point if TotalDelta is zero and avoid divide by zero for MaxDelta. */ } ::set Fraction [::expr {$TotalDelta/$MaxDelta}]; /* { We track clock clicks (millisesonds) as scale relative to one second. 2.23.1 In tcl 8.4 it looks like "::clock clicks -milliseconds" is overflowing and returning negative values. Taking the absolute value of the difference of two clock clicks should resolve the issue. */ } } ::if {$Fraction>0.0&&$Fraction<0.05} { /* { Very small messages hardly show up so we scale them up a bit. */ } ::set Fraction 0.05; } ::if {$Fraction>100.0} { /* { Very small messages hardly show up so we scale them up a bit. */ } ::set Fraction 100; } ::set WindowWidth [$Widget cget -width]; ::set BarWidth [::expr {int($Fraction*$WindowWidth)}]; /* { We simply change the size of the rectangle in the canvas. */ } $Widget coords bar 0 0 [::expr $BarWidth] $_bar_height; } .line_number { /* { Do nothing because we renumber updates the _row_data_array element directly. */ } ::set Value [::sargs::get $_row_data_array($RowId) $ColumnId]; } .workstation_hostname { ::set Value [::sargs::get $_row_data_array($RowId) .workstation.hostname]; } .server_hostname { ::set Value [::sargs::get $_row_data_array($RowId) .server.hostname]; } default { ::set Value [::sargs::get $_row_data_array($RowId) $FieldPath]; } } $_tablelist cellconfigure $RowId,$ColumnId -text $Value; } } method row_delete {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor::row_delete,1000.0,sargs==\n[::sargs::format $sargs]";} ::set RowId [::sargs::get $sargs .row_id]; ::if {![row_exists .row_id $RowId]} { ::qw::bug 314120161005084103 "[::namespace current]::[::qw::methodname] - can't find row id \"$RowId\"."; } ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor::row_delete,1000.1,RowId==$RowId";} ::unset _row_data_array($RowId); ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor::row_delete,1000.2,_tablelist==$_tablelist,exists==[::winfo exists $_tablelist]";} $_tablelist delete $RowId; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor::row_delete,1000.3";} ::if {[$_tablelist size]==0} { ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor::row_delete,1000.4";} command_connection_monitor_dismiss; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor::row_delete,1000.5";} ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor::row_delete,1000.6";} renumber; ::if {$rwb1_debug} {::puts "rwb1_debug,connection_monitor::row_delete,1000.7";} } method row_destroy {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.0,sargs==$sargs";} ::set RowId [::sargs::get $sargs .row_id]; ::if {![::info exists _row_data_array($RowId)]} { ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.1";} ::return; } ::if {![row_exists $sargs]} { ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.2";} ::return; } /* { ::if {[::sargs::get $_row_data_array($RowId) .tick_handle] ne ""} { ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.3";} ::after cancel [::sargs::get $_row_data_array($RowId) .tick_handle]; } */ } ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.4";} ::unset _row_data_array($RowId); ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.5";} $_tablelist delete $RowId; ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.6";} $_tablelist see end; ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.7";} ::raise $_toplevel; ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.8";} /* { ::if {[$_tablelist size]>0} { ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.9";} ::set EndRowId [$_tablelist rowcget -name]; $_toplevel.status configure -text [::sargs::get $_row_data_array($EndRowId) .status]; ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.10";} } */ } ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.11";} } method renumber {} { ::set rwb1_debug 0; ::set SortOrder [$_tablelist sortorder]; ::if {$rwb1_debug} {::puts "rwb1_debug,renumber,1000.0,SortOrder==$SortOrder";} ::set LineNumberColumnIdList ""; ::set RbColumnIdList ""; ::if {$rwb1_debug} {::puts "rwb1_debug,renumber,1000.1";} ::foreach ColumnId $_column_id_list { ::if {[::sargs::boolean_get $_column_definition_array($ColumnId) .is_line_number]} { ::lappend LineNumberColumnIdList $ColumnId; } ::if {[::sargs::boolean_get $_column_definition_array($ColumnId) .is_running_balance]} { ::lappend RbColumnIdList $ColumnId; } } ::if {$rwb1_debug} {::puts "rwb1_debug,renumber,1000.2";} ::if {[::llength $LineNumberColumnIdList]==0&&[::llength $RbColumnIdList]==0} { ::if {$rwb1_debug} {::puts "rwb1_debug,renumber,1000.3";} ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,renumber,1000.4";} ::foreach ColumnId $RbColumnIdList { ::set Balances($ColumnId) 0.0; } ::switch $SortOrder { decreasing { ::set Size [$_tablelist size]; ::set RowNumber 0; ::set LineNumber $Size; ::while {$RowNumber<$Size} { ::set RowId [$_tablelist rowcget $RowNumber -name]; ::if {$rwb1_debug} {::puts "rwb1_debug,renumber,1000.4,RowId==$RowId";} ::foreach ColumnId $LineNumberColumnIdList { ::sargs::var::set _row_data_array($RowId) $ColumnId $LineNumber; ::if {$rwb1_debug} {::puts "rwb1_debug,renumber,1000.4.0,ColumnId==$ColumnId,LineNumber==$LineNumber";} $_tablelist cellconfigure $RowNumber,$ColumnId -text $LineNumber; } ::foreach ColumnId $RbColumnIdList { ::set Address [$_tablelist cellcget $RowNumber,.odb_reference -text]; ::set Amount [column_get .column_name .amount .address $Address]; ::qw::number::var::add Balances($ColumnId) $Amount; $_tablelist cellconfigure $RowNumber,$ColumnId -text $Balances($ColumnId); } ::incr RowNumber 1; ::incr LineNumber -1; } } increasing - default { ::set Size [$_tablelist size]; ::set RowNumber 0; ::set LineNumber 1; ::while {$RowNumber<$Size} { ::set RowId [$_tablelist rowcget $RowNumber -name]; ::if {$rwb1_debug} {::puts "rwb1_debug,renumber,1000.5,RowId==$RowId";} ::foreach ColumnId $LineNumberColumnIdList { ::sargs::var::set _row_data_array($RowId) $ColumnId $LineNumber; ::if {$rwb1_debug} {::puts "rwb1_debug,renumber,1000.5.0,ColumnId==$ColumnId,LineNumber==$LineNumber";} $_tablelist cellconfigure $RowNumber,$ColumnId -text $LineNumber; } ::foreach ColumnId $RbColumnIdList { ::set Address [$_tablelist cellcget $RowNumber,.odb_reference -text]; ::set Amount [column_get .column_name .amount .address $Address]; ::qw::number::var::add Balances($ColumnId) $Amount; $_tablelist cellconfigure $RowNumber,$ColumnId -text $Balances($ColumnId); } ::incr RowNumber 1; ::incr LineNumber 1; } } } } method column_sort_before {sargs} { ::qw::bug 314120170608115436 "not used." ::set ColumnId [::sargs::get $sargs .column_name]; ::switch -exact -- $ColumnId { .balance { ::qw::throw \ .text "You cannot sort by the \"[::sargs::get $_column_definitions $ColumnId.title]\" column." \ .help_page { .id 314120090203125238 .tags {error} .body { [p { This column is a running balance and its values depend on the amounts as sorted in the current order. Therefore that order must be based on another column and you cannot sort by the running balance column itself. }] } } \ ; } } } method column_sort_now {sargs} { ::qw::bug 314120170608115437 "not used." ::set rwb1_debug 0; ::set ColumnId [::sargs::get $sargs .column_name]; ::if {$rwb1_debug} {::puts "rwb1_debug,column_sort_now,1000.0";} # ::itcl::local ::QW::MOUSE_CURSOR_SANDWICH #auto .widget $_tablelist .cursor $::qw::platform_dependent_cursor(wait); /* { We are going to sort as closely as possible to the way existing odb indexes sort. Generally this means we sort by column and then by object id. */ } ::switch -exact -- $ColumnId { .line_number { ::if {$rwb1_debug} {::puts "rwb1_debug,column_sort_now,1000.1";} $_tablelist sortbycolumn $_sort_column -$_sort_order; ::if {$rwb1_debug} {::puts "rwb1_debug,column_sort_now,1000.2";} renumber; ::if {$rwb1_debug} {::puts "rwb1_debug,column_sort_now,1000.3";} } default { /* { For now we will sort by one column. Later will add the connection_id or something equivalent. */ } # $_tablelist sortbycolumnlist [::list $ColumnId .odb_reference] [::list $_sort_order $_sort_order]; ::if {$rwb1_debug} {::puts "rwb1_debug,column_sort_now,1000.4";} $_tablelist sortbycolumnlist [::list $ColumnId] [::list $_sort_order]; ::if {$rwb1_debug} {::puts "rwb1_debug,column_sort_now,1000.5";} renumber; ::if {$rwb1_debug} {::puts "rwb1_debug,column_sort_now,1000.6";} } } } method label_command {Table ColumnIndex} { /* { The user clicked on a column and we are expected to sort by the column. This gives us an opportunity to throw an exception if we don't want the column to be sorted, i.e. sort_before, and also sort_after if you want. */ } ::set ColumnId [$_tablelist columncget $ColumnIndex -name]; # column_sort_before .column_name $ColumnId; ::switch $_sort_order { increasing { ::set _sort_order "decreasing"; } decreasing { ::set _sort_order "increasing"; } } ::set _sort_column $ColumnId; ::eval ::tablelist::sortByColumn $Table $ColumnIndex; # column_sort_now .column_name $ColumnId; renumber; } method menu_setup {sargs} { ::set rwb1_debug 0; ::menu $_toplevel.menubar -tearoff 0; $_toplevel configure -menu $_toplevel.menubar; ::menu $_toplevel.menubar.file -tearoff 0; $_toplevel.menubar add cascade -label "File" -menu $_toplevel.menubar.file -underline 0; $_toplevel.menubar.file add command -label "Defaults" -command [::itcl::code $this command_file_defaults]; $_toplevel.menubar.file add command -label "Exit" -command [::itcl::code $this command_connection_monitor_dismiss]; ::menu $_toplevel.menubar.statistics -tearoff 0; $_toplevel.menubar add cascade -label "Statistics" -menu $_toplevel.menubar.statistics -underline 0; $_toplevel.menubar.statistics add command -label "Display" -command [::itcl::code $this command_statistics_display]; $_toplevel.menubar.statistics add command -label "Reset" -command [::itcl::code $this command_statistics_reset]; ::menu $_toplevel.menubar.row -tearoff 0; $_toplevel.menubar add cascade -label "Row" -menu $_toplevel.menubar.row -underline 0; $_toplevel.menubar.row add command -label "Delete" -command [::itcl::code $this command_row_delete]; ::menu $_toplevel.menubar.help -tearoff 0; $_toplevel.menubar add cascade -label "Help" -menu $_toplevel.menubar.help -underline 0; $_toplevel.menubar.help add command -label "Connections" -command [::itcl::code $this command_help_connections]; $_toplevel.menubar.help add command -label "About" -command [::itcl::code $this command_help_about]; ::tooltip::tooltip $_toplevel.menubar.file -index 0 [::sargs::get [tooltip_get .widget $_toplevel.menubar.file.defaults] .text]; ::tooltip::tooltip $_toplevel.menubar.file -index 1 [::sargs::get [tooltip_get .widget $_toplevel.menubar.file.exit] .text]; ::tooltip::tooltip $_toplevel.menubar.statistics -index 0 [::sargs::get [tooltip_get .widget $_toplevel.menubar.statistics.display] .text]; ::tooltip::tooltip $_toplevel.menubar.statistics -index 1 [::sargs::get [tooltip_get .widget $_toplevel.menubar.statistics.reset] .text]; ::tooltip::tooltip $_toplevel.menubar.row -index 0 [::sargs::get [tooltip_get .widget $_toplevel.menubar.row.delete] .text]; ::tooltip::tooltip $_toplevel.menubar.help -index 0 [::sargs::get [tooltip_get .widget $_toplevel.menubar.help.connections] .text]; ::tooltip::tooltip $_toplevel.menubar.help -index 1 [::sargs::get [tooltip_get .widget $_toplevel.menubar.help.about] .text]; } method popup_menu_setup {sargs} { ::set PopupMenu $_toplevel.popup_menu; ::menu $PopupMenu -tearoff no; ::menu $PopupMenu.file -tearoff 0 $PopupMenu add cascade -label "File" -menu $PopupMenu.file -underline 0 $PopupMenu.file add command -label "Defaults" -command [::itcl::code $this command_file_defaults]; $PopupMenu.file add command -label "Exit" -command [::itcl::code $this command_connection_monitor_dismiss]; ::menu $PopupMenu.statistics -tearoff 0 $PopupMenu add cascade -label "Statistics" -menu $PopupMenu.statistics -underline 0 $PopupMenu.statistics add command -label "Display" -command [::itcl::code $this command_statistics_display]; $PopupMenu.statistics add command -label "Reset" -command [::itcl::code $this command_statistics_reset]; ::menu $PopupMenu.row -tearoff 0 $PopupMenu add cascade -label "Row" -menu $PopupMenu.row -underline 0 $PopupMenu.row add command -label "Delete" -command [::itcl::code $this command_row_delete]; ::menu $PopupMenu.help -tearoff 0 $PopupMenu add cascade -label "Help" -menu $PopupMenu.help -underline 0 $PopupMenu.help add command -label "Connections" -command [::itcl::code $this command_help_connections]; $PopupMenu.help add command -label "About" -command [::itcl::code $this command_help_about]; ::set BodyTag [$_tablelist bodytag]; ::bind $BodyTag <> [::bind TablelistBody ] ::bind $BodyTag <> +[::bind TablelistBody ] ::bind $BodyTag <> +[::itcl::code $this popup_menu_post .x %X .y %Y]; } method popup_menu_setup_save {sargs} { # # Create a pop-up menu with two command entries; bind the script # associated with its first entry to the event, too # ::set PopupMenu $_toplevel.popup_menu; ::menu $PopupMenu -tearoff no; $PopupMenu add command -label "Delete" -command [::itcl::code $this command_row_delete]; # $PopupMenu add command -label "Contract" -command [mymethod command_process .command document_contract]; # $PopupMenu add command -label "Select" -command [mymethod command_process .command select]; # $PopupMenu add command -label "Display config" -command [mymethod dispConfigOfSelWidget]; ::set BodyTag [$_tablelist bodytag]; ::bind $BodyTag <> [::bind TablelistBody ] ::bind $BodyTag <> +[::bind TablelistBody ] ::bind $BodyTag <> +[::itcl::code $this popup_menu_post .x %X .y %Y]; } method popup_menu_post {sargs} { #------------------------------------------------------------------------------ # popup_menu_post # # Posts the pop-up menu $top.menu at the given screen position. Before posting # the menu, the procedure enables/disables its first entry, depending upon # whether the selected widget has children or not. #------------------------------------------------------------------------------ ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "popup_menu_post,1000.0";} ::set RootX [::sargs::get $sargs .x]; ::set RootY [::sargs::get $sargs .y]; ::if {$rwb1_debug} {::puts "popup_menu_post,1000.1";} ::set SelectionRowList [$_tablelist curselection]; ::if {$rwb1_debug} {::puts "popup_menu_post,1000.2";} ::if {[::llength $SelectionRowList]==0} { ::qw::throw \ .text "Expected a row to be selected." \ ; } ::if {$rwb1_debug} {::puts "popup_menu_post,1000.3";} ::set Menu $_toplevel.popup_menu; ::if {$rwb1_debug} {::puts "popup_menu_post,1000.4";} # $Menu entryconfigure "Delete" -state normal; ::if {$rwb1_debug} {::puts "popup_menu_post,1000.5";} ::tk_popup $Menu $RootX $RootY; ::if {$rwb1_debug} {::puts "popup_menu_post,1000.6";} ::return; ::set ObjectStructure [$self object_load .object_id $ObjectId]; ::set KidCount [::sargs::get $ObjectStructure .application.total.kids.record_count]; ::set ParentObjectStructure [$self object_load .address $_parent_address]; ::if {$KidCount==0} { $Menu entryconfigure "Expand" -state disabled; $Menu entryconfigure "Contract" -state normal; $Menu entryconfigure "Select" -state normal; } else { $Menu entryconfigure "Expand" -state normal; $Menu entryconfigure "Contract" -state normal; $Menu entryconfigure "Select" -state disabled; } ::set ParentObjectStructure [$self object_load .address $_parent_address]; ::if {[::sargs::get $ParentObjectStructure .system.path] eq "/OBJECT/NEWVIEWS/ACCOUNT"} { $Menu entryconfigure "Contract" -state disabled; } ::tk_popup $Menu $RootX $RootY; } method connections_help_page {sargs} { ::return { .title "Connection Monitor" .id 314220161117082901 .tags {tag_manual tag_user} .body { [h1 "Connection Monitor"] [p { The connection monitor displays a table of workstation/server connections. For help on the connection monitor see [link .chm [::file join $::qw_data manual.chm] .id 314120161205165852 {Connection Monitor}]. }] } } } } ::itcl::class ::qw::message_statistics_graph { /* { Produces graphs of message activity statistics and wraps them in a chm and optionally, pdf files. The chm file is displayed. */ } protected variable _sargs ""; protected variable _record_list ""; protected variable _temporary_directory ""; protected variable _destination_directory $::qw_program_folder; protected variable _title ""; protected variable _date [::clock format [::clock seconds] -format %Y%m%d]; method constructor {sargs} { /* { */ } ::wm deiconify . ::wm geometry . +0+0; ::raise .; ::set _sargs [::sargs \ .title "Connection Statistics" \ ]; ::sargs::var::+= _sargs $sargs; ::set _temporary_directory [::qw::fileutil::temporary_directory] ::set _record_list [::sargs::get $sargs .record_list]; ::while {1} { /* { We trim off leading zeros as this adds nothing to the graph. */ } ::if {[::sargs::get [::lindex $_record_list 0] .upload.packet_count]!=0} { ::break; } ::if {[::sargs::get [::lindex $_record_list 0] .download.packet_count]!=0} { ::break; } ::set _record_list [::lrange $_record_list 1 end]; } ::while {1} { /* { We trim off trailing zeros as this adds nothing to the graph. */ } ::if {[::sargs::get [::lindex $_record_list end] .upload.packet_count]!=0} { ::break; } ::if {[::sargs::get [::lindex $_record_list end] .download.packet_count]!=0} { ::break; } ::set _record_list [::lrange $_record_list 0 end-1]; } ::if {[::llength $_record_list]==0} { ::qw::throw "There is no message activity to report (all counts are zero)."; } the_whole_report $sargs; } method barchart {sargs} { /* { Draws chart and exports it to a temp .gif file. Returns the file path. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,barchart,1000.0,sargs==\n[::sargs::format $sargs]";} ::set ChartId [::sargs::get $sargs .chart_id]; ::if {$ChartId eq ""} { ::qw::throw "Chart id was not specified."; } /* { ::set AverageValue [::sargs::get $sargs .average.value]; ::if {$AverageValue ne ""} { ::set AverageText [::sargs::get $sargs .average.text]; ::if {$AverageText eq ""} { sargs::var::set sargs .average.text "Average"; } } */ } ::set File [::file join $_temporary_directory $ChartId.gif]; ::qw::barchart_simple::image_file_create $sargs .image.type gif .image.file $File; ::return $File; } method report_upload_stats {sargs} { ::set Id [::sargs::get $sargs .page_id]; ::set Title "Upload Message Statistics"; ::sargs::var::set Structure .id $Id; ::sargs::var::set Structure .title $Title; ::append Body [::subst -nocommands {[h1 {$Title}]\n}]; ::set Series ""; ::foreach Record $_record_list { ::set Size [::sargs::get $Record .size]; ::if {$Size>=1024} { ::set Size "[::expr {$Size/1024}]k"; } ::lappend Series [::sargs \ .text $Size \ .value [::sargs::integer_get $Record .upload.packet_count] \ .color pink \ ]; } barchart \ .title $Title \ .series $Series \ .chart_id $Id \ ; ::set FilePath [::file join $_temporary_directory $Id.gif]; ::append Body [img_chart $Id]; ::append Body {}; ::append Body [table_row_generate .description "Msg Size" .statistics $_record_list .field .size]; ::append Body [table_row_generate .description "Msg Count" .statistics $_record_list .field .upload.packet_count]; ::append Body "
"; ::append Body { [p { Upload record size statistics. }] } sargs::var::set Structure .body $Body; ::return $Structure; } method report_download_stats {sargs} { ::set Id [::sargs::get $sargs .page_id]; ::set Title "Download Message Statistics"; ::sargs::var::set Structure .id $Id; ::sargs::var::set Structure .title $Title; ::append Body [::subst -nocommands {[h1 {$Title}]\n}]; ::set Series ""; ::foreach Record $_record_list { ::set Size [::sargs::get $Record .size]; ::if {$Size>=1024} { ::set Size "[::expr {$Size/1024}]k"; } ::lappend Series [::sargs \ .text $Size \ .value [::sargs::integer_get $Record .download.packet_count] \ .color lightblue \ ]; } barchart \ .title $Title \ .series $Series \ .chart_id $Id \ ; ::set FilePath [::file join $_temporary_directory $Id.gif]; ::append Body [img_chart $Id]; ::append Body {}; # ::append Body [table_row_players $Players]; ::append Body [table_row_generate .description "Msg Size" .statistics $_record_list .field .size]; ::append Body [table_row_generate .description "Msg Count" .statistics $_record_list .field .download.packet_count]; ::append Body "
"; ::append Body { [p { Download record size statistics. }] } sargs::var::set Structure .body $Body; ::return $Structure; } method report_upload_and_download_stats {sargs} { ::set Id [::sargs::get $sargs .page_id]; ::set Title "Up/DownLoad Message Statistics"; ::sargs::var::set Structure .id $Id; ::sargs::var::set Structure .title $Title; ::append Body [::subst -nocommands {[h1 {$Title}]\n}]; ::set Series ""; ::foreach Record $_record_list { ::set Size [::sargs::get $Record .size]; ::if {$Size>=1024} { ::set Size "[::expr {$Size/1024}]k"; } ::lappend Series [::sargs \ .text $Size \ .value [::sargs::integer_get $Record .upload.packet_count] \ .color pink \ ]; ::lappend Series [::sargs \ .text $Size \ .value [::sargs::integer_get $Record .download.packet_count] \ .color lightblue \ ]; /* { ::lappend Series [::sargs \ .text "" \ .value 0 \ .color white \ ]; */ } } barchart \ .title $Title \ .series $Series \ .chart_id $Id \ ; ::set FilePath [::file join $_temporary_directory $Id.gif]; ::append Body [img_chart $Id]; ::append Body {}; # ::append Body [table_row_players $Players]; ::append Body [table_row_generate .description "Msg Size" .statistics $_record_list .field .size]; ::append Body [table_row_generate .description "Up Msg Count (pink)" .statistics $_record_list .field .upload.packet_count]; ::append Body [table_row_generate .description "Down Msg Count (blue)" .statistics $_record_list .field .download.packet_count]; ::append Body "
"; ::append Body { [p { Download record size statistics. }] } sargs::var::set Structure .body $Body; ::return $Structure; } method img_chart {ChartId} { ::set FilePath [::file join $_temporary_directory $ChartId.gif]; ::return [::subst -nocommands {[img .src {$FilePath}]\n}]; } method table_cell {Value} { ::return "$Value" } method page_root {sargs} { ::set Structure ""; ::set Body ""; ::if {$_title eq ""} { ::set _title "Connection Statistics Report"; } ::sargs::var::set Structure .title $_title; ::sargs::var::set Structure .id 314120071015074731; ::sargs::var::set Structure .tags {tag_manual tag_user tag_workshop_conversion tag_executive_summary tag_workshop_basic tag_workshop_intermediate tag_workshop_payroll} ::append Body [::subst -nocommands {[h1 "$_title"]\n}]; # ::set File [::file join d:/ rwb_text 2007_hockey_ross photos "OMHA_Champs.jpg"]; # ::append Body [::subst -nocommands {[img .src {$File}]\n}]; ::sargs::var::set Structure .body $Body; ::return $Structure; } method table_row_generate {sargs} { ::set Description [::sargs::get $sargs .description]; ::set Statistics [::sargs::get $sargs .statistics]; ::set Statistic [::sargs::get $sargs .field]; ::append Body ""; ::append Body [table_cell $Description]; ::foreach Record $Statistics { ::append Body [table_cell [::sargs::get $Record $Statistic]]; } ::append Body ""; ::return $Body; } method table_row {args} { ::if {[::eval ::qw::s_args_marshal_is_legacy $args]} { ::set List [::lindex $args 0]; ::append Body [::subst -nocommands {[tr \{\n}]; ::foreach Item $List { ::append Body [table_cell $Item]; } ::append Body [::subst -nocommands {\}\]}]; ::return $Body; } ::qw::sargs_marshal; ::append Body ""; ::set List [::sargs::get $sargs .list]; ::if {$List ne ""} { ::foreach Value $List { ::append Body [table_cell $Value]; } ::append Body ""; ::return $Body; } ::set Series [::sargs::get $sargs .series]; ::if {$Series ne ""} { ::foreach Item $Series { ::set Value [::sargs::get $Item .value]; ::append Body [table_cell $Value]; } ::return $Body; } ::qw::throw \ .error_id 314120101104085553 \ .text "Could not generate table row." \ ; } method the_whole_report {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,the_whole_report,1000.0";} sargs::var::set sargs .color darkslategray1; ::set Structure [page_root $sargs]; ::sargs::var::set Structure /314120101104092725 [report_upload_stats $sargs .page_id 314120101104092725]; ::sargs::var::set Structure /314120101104092726 [report_download_stats $sargs .page_id 314120101104092726]; ::sargs::var::set Structure /314120101104092727 [report_upload_and_download_stats $sargs .page_id 314120101104092727]; ::if {$rwb1_debug} {::puts "rwb1_debug,the_whole_report,1000.1";} ::if {$::qw::control(browser_help)} { ::if {$rwb1_debug} {::puts "rwb1_debug,the_whole_report,1000.2";} ::qw::script::source \ .script.path [::file join $::qw_library doc qw_chtml_compile.qw_script] \ .structure $Structure \ .window_title $_title \ .source_folder $_temporary_directory \ ; ::if {$rwb1_debug} {::puts "rwb1_debug,the_whole_report,1000.3";} ::return; } /* { Find first unused file names for destination chm and pdf files. These are created in the program folder unless a better place can be found, perhaps in the workstation folder (but it's usually the program folder anyway). */ } ::set Count 0; ::while {[::file exists [::file join $_destination_directory message_statistics_$Count.chm]]} { ::incr Count 1; } ::if {$rwb1_debug} {::puts "rwb1_debug,the_whole_report,1000.4";} ::set DestinationFileChm [::file join $_destination_directory message_statistics_$Count.chm]; ::set Count 0; ::while {[::file exists [::file join $_destination_directory message_statistics_$Count.chm]]} { ::incr Count 1; } ::if {$rwb1_debug} {::puts "rwb1_debug,the_whole_report,1000.5";} ::set DestinationFilePdf [::file join $_destination_directory message_statistics_$Count.pdf]; ::if {$rwb1_debug} {::puts "rwb1_debug,the_whole_report,1000.6";} ::qw::script::source \ .script.path [::file join $::qw_library doc qw_chtml_compile.qw_script] \ .structure $Structure \ .window_title $_title \ .destination $DestinationFileChm \ ; ::if {$rwb1_debug} {::puts "rwb1_debug,the_whole_report,1000.7";} ::if {$::qw::control(browser_help)} { ::if {$rwb1_debug} {::puts "rwb1_debug,the_whole_report,1000.8";} ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,the_whole_report,1000.9";} ::set DestinationNativeChm [::file nativename $DestinationFileChm]; ::set DestinationNativePdf [::file nativename $DestinationFilePdf]; ::set Exe ""; ::set Hostname [::string tolower [::info hostname]]; ::switch $Hostname { benn { ::set Exe [::file nativename [::file join c:/ "chm2pdf pilot 2.0" CHM2PDF_Pilot.exe]]; } benn7 { ::set Exe [::file nativename [::file join c:/ chm2pdf_212 CHM2PDF_Pilot.exe]]; } default { } } ::if {$Exe ne ""} { ::qw::try { ::exec $Exe $DestinationNativeChm $DestinationNativePdf /pmode outlines /compress flate } catch Exception { ::qw::throw $Exception; } } ::set Text ""; ::append Text "Created $DestinationFileChm"; ::if {$Exe ne ""} { ::append Text "\n\nCreated $DestinationFilePdf"; } ::qw::dialog::notify [::subst { .title "Statistics created." .text {$Text} .help { .help_id ??? } /button { /cancel { .text "OK" } } }]; } }