/* { progress_red_per_second - to replace progress_red - updates once per second but uses clock, not event queue - all-or-nothing - can't be aborted - signals across net as progress_red does - should only signal at beginning, once per second, and at end - based on once per second update like progress_blue - try to keep it almost compatible with progress_red - so current workstations updating from new server will work - changes mainly on server side */ } /* { The Progress Resolution Problem ------------------------------- Current ------- The progress_red window grabs focus so no new events can be processed. Whenever a red progress is up, only the process that put it up has control. On a workstation this is the incoming tag_change event which effectively stops the workstation and thus prevents it from calling the server again. Note that when the last tag is deleted, the window is destroyed, also releasing the grab. Future ------ WSA has DBA open on SERVERA. WSA also has DBB open on SERVERB WSB has DBB open on SERVERB A red progress is initiated on serverB. Both WSA and WSB should be suspended from calling SERVERB but why would WSA be suspensed from server A? Also, it is impolite to put the red progress in WSA's face while working on DBA. One red progress window per database. Perhaps we can filter out any events associated with the database if they are directed to any window within a toplevel associated with that database. The goal is to freeze event associated with the red_progress's database but not others. How and where can we identify event destined for a particular database. (1) This only applies to a workstation in multiuser environment. (2) We identify the window (or equivalent itcl object or proc) by the database id. Whenever a semaphore object identified by the database id exists, we no longer call the server holding the database. Really? It's like we want to ignore all events that result in calls. Say the user page's down and suddenly we put up a red progress on that database. Can we somehow pause? Can we wait on a variable and still allow But what do we do? How about we throw a signal ignore whenever we attempt to call the database? That might work. (3) If there is no database id then just put the red progress up on the server. Maybe we should never actually put the red progress up on the server. How about we have an object that contains the operations and may or may not display a progress bar. Null Database ------------- There is a window for the "null" database, i.e. when the database is not specified. This would give us backward compatibility. */ } #::namespace eval ::QW::PROGRESS {} # ------------------------------------------------------------ # ::QW::PROGRESS class # ------------------------------------------------------------ /* { You display an ongoing operation as follows: ::set Progress [::itcl::local ::QW::PROGRESS #auto .text "Display this text as the operation."] You set the limit as follows: $Progress limit 100; You set the value follows: $Progress value 20; This will append a label and a completion percentage bar to the progress window. They are removed automatically when the local goes out of scope. A progress window is created and destroyed on demand. To do: - When > 1 bar is displayed, the widths of the label and progress bars are not the same for each. Need some fancier geometry management to make it all look 'pretty' - Need an optional Cancel button - Need option to control screen position */ } ::itcl::class ::QW::PROGRESS_TOPLEVEL { /* { This class represents the toplevel containing the progress messages. */ } public common _window {} protected variable _toplevel {}; protected variable _options ""; protected variable _count 0; method option_get {Path} {::return [::sargs::get_poly $_options $Path];} method option_set {args} { ::qw::s_args_marshal; ::sargs::var::+= _options $s_args; } method constructor {args} { ::set _options $::qw::widget::options; ::sargs::var::+= _options [::subst { .title "[::string tolower [::info nameofexecutable]]" }]; ::sargs::var::+= _options $args; ::set _toplevel [::toplevel .qw_operation_window_[::qw::id_factory] -background [option_get .background]]; ::wm overrideredirect $_toplevel 1 # Next lines removed when overrideredirect was added. #::wm title $_toplevel [option_get .title]; #::wm protocol $_toplevel WM_DELETE_WINDOW [::list ::qw::itcl_delete_object $this]; #::wm deiconify $_toplevel; # ::set Frame [::frame $_toplevel.frame]; $Frame configure -borderwidth 5 -background [option_get .background] -relief raised; ::pack $Frame -expand true -fill both; ::wm geometry $_toplevel +50+50; ::wm geometry $_toplevel +200+200; ::set ::QW::PROGRESS_TOPLEVEL::_window $this; } destructor { #::if {::winfo exists $_toplevel} {::destroy $_toplevel} ::destroy $_toplevel; ::set ::QW::PROGRESS_TOPLEVEL::_window ""; } method toplevel {} {::return $_toplevel;} } ::set ::QW::PROGRESS_TOPLEVEL::_window ""; # Just to be sure it exists. ::itcl::class ::QW::PROGRESS { /* { This class represents a progress message and % complete bar. Its current implemenation is to create the label and bar and pack them into the progress toplevel level window. They are destroyed when the operation is complete and this object is destroyed, usually using ::itcl::local. The toplevel itself is created if it doesn't exists and is destroyed if its last label is destroyed. */ } protected variable _frame {}; protected variable _toplevel {}; protected variable _label {}; protected variable _progress_bar {}; protected variable _options ""; protected variable _limit 0; protected variable _value 0; protected variable _text ""; # method option_get {Path} {::return [::sargs::get_poly $_options $Path];} method option_set {args} { ::qw::s_args_marshal; ::sargs::var::+= _options $s_args; } method constructor {args} { ::set _options $::qw::widget::options; ::sargs::var::+= _options [::subst { .title "[::string tolower [::info nameofexecutable]] is performing an operation ..." .font {-family Arial -size 12 -weight bold} .text "[::string tolower [::info nameofexecutable]] is performing an operation." .foreground black .background white .justify left }]; # was azure3 ::sargs::var::+= _options $args; ::if {$::QW::PROGRESS_TOPLEVEL::_window eq ""} { ::set _toplevel [[::eval ::QW::PROGRESS_TOPLEVEL #auto $_options] toplevel]; } else { ::set _toplevel [$::QW::PROGRESS_TOPLEVEL::_window toplevel]; } ::set _frame [::frame $_toplevel.frame.frame[::qw::id_factory]]; ::set _label [::label $_frame.label[::qw::id_factory] \ -font [option_get .font] \ -foreground [option_get .foreground] \ -background [option_get .background] \ -justify [option_get .justify] \ -textvariable [::itcl::scope _text] \ ]; ::set _progress_bar $_frame.progress[::qw::id_factory]; ::QW::WIDGET::COMPLETION_PERCENTAGE $_progress_bar -limitvariable [::itcl::scope _limit] -valuevariable [::itcl::scope _value]; # Geometry #::pack $_frame -side top -expand 1 -fill both; #::pack $_label -side left -anchor w -expand 0 -fill none -padx 10; #::pack $_progress_bar -side left -anchor w -expand 1 -fill both -padx 0; ::pack $_frame -side top -expand 1 -fill both; ::grid $_label -row 0 -column 0 -sticky ewns; ::grid $_progress_bar -row 0 -column 1 -sticky ewns; ::grid columnconfigure $_frame 0 -weight 0; ::grid columnconfigure $_frame 1 -weight 1 -minsize 300; # text [option_get .text]; } method value {{Src {get}}} { ::if {$Src eq "get"} {::return $_value;} ::set _value $Src; } method limit {{Src {get}}} { ::if {$Src eq "get"} {::return $_limit;} ::set _limit $Src; } method text {{Src {get}}} { ::if {$Src eq "get"} {::return $_text;} ::set _text $Src; ::update } destructor { ::destroy $_label; ::destroy $_progress_bar; ::destroy $_frame; ::if {![::llength [::pack slaves $_toplevel.frame]]} { ::itcl::delete object $::QW::PROGRESS_TOPLEVEL::_window; #209 ::rename $::QW::PROGRESS_TOPLEVEL::_window {}; } ::update; } } # ------------------------------------------------------------ # QW::PROGRESS::WINDOW class # ------------------------------------------------------------ ::itcl::class ::QW::PROGRESS::WINDOW { /* { We use arrays and the usual tcl prefix mechanism insead of structures only so that we can map textvariables to the widgets in the displayed table. */ } inherit itk::Toplevel; protected variable _tag_list ""; protected variable _label_border_width 0.5m; protected variable _control_padding 1m; # protected variable _font {-family Tahoma -size 8 -weight normal}; protected variable _font {-family Arial -size 10 -weight normal}; protected variable _status_stack ""; protected variable _structures ""; protected variable _row_count 0; protected variable _clock_seconds [::clock seconds]; protected variable _blue_columns 1; # protected variable _previous_focus_window ""; method constructor {args} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.0";} ::if {$::qw::control(red_progress_semaphore_is_enabled)} { ::if {[[::qw::system] cpp_application_type_get] eq "workstation"} { /* { 2.34.0 tbf_master The goal is the create a file to be used as a semaphore that the red progress bar is running and hence the process is busy. This is needed for tbf cloud architecture. Otherwise the workstation freezes when any app database is working. At least this way we can report something to the user. The destructor deletes the semaphore file. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.1";} ::set WorkstationDatabase [[::qw::system] cpp_find_workstation_database]; ::if {[::qw::command_exists $WorkstationDatabase]} { /* { There might not be a workstation database. Although this is the workstation application, the red progress might be up due to a backup, such as the backup that occurs during a convert, and there is no database open. This in fact happened. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.2";} ::set WorkstationPath [$WorkstationDatabase cpp_database_path]; ::set SemaphorePath [::file join [::file dirname $WorkstationPath] nv_semaphore.txt]; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.3";} ::if {[::file exists $SemaphorePath]} { /* { The file can exist if nv2 crashed. So we just clean it up. If the delete fails then we really are in trouble. */ } ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.4";} ::file delete $SemaforePath; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.5";} } catch Exception { ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.6,Exception==$Exception";} } } ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.7";} ::set FileHandle [::open $SemaphorePath w]; # ::puts $FileHandle "NewViews Semaphore"; #nv2.35.0 (diagnostics) - ::QW::PROGRESS::WINDOW constructor - red progess semaphore file with details for start time and progess operations appended as we go #//::puts "pgq,debug...::QW::PROGRESS::WINDOW constructor args==$args"; #::puts $FileHandle "NewViews Semaphore"; #::puts $FileHandle "$args"; ::puts $FileHandle "NewViews Semaphore - Start: [::clock format [::clock seconds] -format %Y%m%d-%H%M%S]"; ::close $FileHandle; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.8";} } catch Exception { ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.9,Exception==$Exception";} } } ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.10";} } } ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.11";} ::set Title "Operation in progress, please wait..."; ::set Index [::lsearch -exact $args "-title"]; ::if {$Index>=0} { ::set Title [::lindex $args [::incr Index]]; } ::frame $itk_interior.table -relief sunken -borderwidth 5; ::frame $itk_interior.title_frame -relief sunken -borderwidth 5 ::label $itk_interior.title_frame.title -padx 4 -pady 4 -relief sunken -background red4 -foreground white -borderwidth $_label_border_width -anchor w -font $_font -text $Title; ::label $itk_interior.status -relief sunken -borderwidth $_label_border_width -anchor w -font $_font; ::pack $itk_interior.title_frame -fill x -padx 1 -pady 1; ::pack $itk_interior.title_frame.title -fill x -padx 1 -pady 1; ::pack $itk_interior.table -expand yes -fill both -padx 4 -pady 4; ::pack $itk_interior.status -fill x -padx 4 -pady 4; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.12";} ::wm group $itk_component(hull) .; ::label $itk_interior.table._title_operation -text "Operation" -font $_font -relief sunken -borderwidth $_label_border_width -width 30 -anchor w ::label $itk_interior.table._title_file -text "File" -font $_font -relief sunken -borderwidth $_label_border_width -width 20 -anchor w ::label $itk_interior.table._title_user -text "User" -font $_font -relief sunken -borderwidth $_label_border_width -width 15 -anchor w ::if {$_blue_columns} { ::label $itk_interior.table._title_state -text "State" -font $_font -relief sunken -borderwidth $_label_border_width -width 8 -anchor e ::label $itk_interior.table._title_runtime -text "Run Time" -font $_font -relief sunken -borderwidth $_label_border_width -width 9 -anchor e ::label $itk_interior.table._title_exception_count -text "Errors" -font $_font -relief sunken -borderwidth $_label_border_width -width 6 -anchor e ::label $itk_interior.table._title_fixed_count -text "Fixed" -font $_font -relief sunken -borderwidth $_label_border_width -width 6 -anchor e } ::label $itk_interior.table._title_limit -text "Count" -font $_font -relief sunken -borderwidth $_label_border_width -width 11 -anchor e ::label $itk_interior.table._title_done -text "Done" -font $_font -relief sunken -borderwidth $_label_border_width -width 11 -anchor e ::label $itk_interior.table._title_progress -text "Percent Done" -font $_font -relief sunken -borderwidth $_label_border_width -width 30 -anchor c ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.13";} ::set Row 0; ::set Column 0; ::grid $itk_interior.table._title_operation -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table._title_file -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table._title_user -row $Row -column $Column -sticky ewns;::incr Column; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.14";} ::if {$_blue_columns} { ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.15";} ::grid $itk_interior.table._title_state -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table._title_runtime -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table._title_exception_count -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table._title_fixed_count -row $Row -column $Column -sticky ewns;::incr Column; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.16";} } ::grid $itk_interior.table._title_limit -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table._title_done -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table._title_progress -row $Row -column $Column -sticky ewns;::incr Column; ::grid columnconfigure $itk_interior.table 0 -weight 100; ::grid columnconfigure $itk_interior.table 1 -weight 1; ::grid columnconfigure $itk_interior.table 2 -weight 1; ::if {$_blue_columns} { ::grid columnconfigure $itk_interior.table 3 -weight 1; ::grid columnconfigure $itk_interior.table 4 -weight 1; ::grid columnconfigure $itk_interior.table 5 -weight 1; ::grid columnconfigure $itk_interior.table 6 -weight 1; ::grid columnconfigure $itk_interior.table 7 -weight 1; ::grid columnconfigure $itk_interior.table 8 -weight 1; ::grid columnconfigure $itk_interior.table 9 -weight 100; } else { ::grid columnconfigure $itk_interior.table 3 -weight 1; ::grid columnconfigure $itk_interior.table 4 -weight 1; ::grid columnconfigure $itk_interior.table 5 -weight 100; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.18";} ::eval itk_initialize $args; ::wm overrideredirect $itk_interior 1; # ::set _previous_focus_window [::focus]; /* { The next statement was added in 2.09.2. In all versions right back to 2.00, absence of this statement allowed cursor movement and basic focus to continue on the qw window, usually a table, and this of course led to all kinds of trouble. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.19'"} ::focus $itk_interior; ::grab set $itk_interior; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_progress_red,constructor,1000.99";} } method progress_window_raise {} { ::raise $itk_interior; } destructor { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,QW::PROGRESS::WINDOW::destructor,1000.0";} ::grab release $itk_interior; ::if {$rwb1_debug} {::puts "rwb1_debug,QW::PROGRESS::WINDOW::destructor,1000.1";} ::if {[[::qw::system] cpp_application_type_get] ne "server"} { /* { 2.13.4 We stopped trying to bring the server to the top. When we were running a server and workstation on the same computer, the server kept raising above the workstation. We are willing to live with the fact that on a computer with just the server running, we do not raise the server after every long operation. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,QW::PROGRESS::WINDOW::destructor,1000.2";} ::if {[::info exists ::qw_gui_global_focus_window]&&$::qw_gui_global_focus_window ne ""&&[::winfo exists $::qw_gui_global_focus_window]} { ::if {!$::qw::control(less_aggressive_toplevel_raise)} { /* { When nv2 is running not at the top of the z-order. He hasn't looked at nv for a while. Somebody in the company performs an all or nothing we are raised to the top, i.e. on top of the user's other application - very annoying. */ } /* { 2.23.0 Don't know why I added ::qw::control(less_aggressive_toplevel_raise) but it caused a problem - nv2 was not getting focus back after a progress operation. So I ended up setting the flag back to 0 anyway. I really should have documented the reason I put it in in the first place. */ } ::wm deiconify [::winfo toplevel $::qw_gui_global_focus_window]; } ::focus $::qw_gui_global_focus_window; } ::if {$rwb1_debug} {::puts "rwb1_debug,QW::PROGRESS::WINDOW::destructor,1000.3";} } ::if {$::qw::control(red_progress_semaphore_is_enabled)} { ::if {[[::qw::system] cpp_application_type_get] eq "workstation"} { ::if {$rwb1_debug} {::puts "rwb1_debug,QW::PROGRESS::WINDOW::destructor,1000.4";} ::set WorkstationDatabase [[::qw::system] cpp_find_workstation_database]; ::if {$rwb1_debug} {::puts "rwb1_debug,QW::PROGRESS::WINDOW::destructor,1000.5";} ::if {[::qw::command_exists $WorkstationDatabase]} { ::if {$rwb1_debug} {::puts "rwb1_debug,QW::PROGRESS::WINDOW::destructor,1000.6";} ::set WorkstationPath [$WorkstationDatabase cpp_database_path]; ::set SemaphorePath [::file join [::file dirname $WorkstationPath] nv_semaphore.txt]; ::if {[::file exists $SemaphorePath]} { ::if {$rwb1_debug} {::puts "rwb1_debug,QW::PROGRESS::WINDOW::destructor,1000.7";} ::file delete $SemaphorePath; ::if {$rwb1_debug} {::puts "rwb1_debug,QW::PROGRESS::WINDOW::destructor,1000.8";} } else { ::if {$rwb1_debug} {::puts "rwb1_debug,QW::PROGRESS::WINDOW::destructor,1000.9";} } ::if {$rwb1_debug} {::puts "rwb1_debug,QW::PROGRESS::WINDOW::destructor,1000.10";} } } } ::if {$rwb1_debug} {::puts "rwb1_debug,QW::PROGRESS::WINDOW::destructor,1000.99";} } method percent_calculate {Done Limit} { ::if {$Limit<=0.0} { ::return 0; } ::if {$Done>=$Limit} { ::return 100; } ::return [::expr int((1.0*$Done)/$Limit*100.0)]; } method signal_receive {sargs} { /* { This method is called on a workstation when a progress signal is received from a server. */ } ::switch -- [::sargs::get $sargs .command] { "tag_create" { tag_create $sargs; } "tag_destroy" { tag_destroy $sargs; } "tag_change" { tag_change $sargs; } "tag_configure" { tag_configure $sargs; } } } method send_signal_to_all_clients {sargs} { /* { 2.34.5 Cut this out from all methods when fixing the .database_path problem. If we have clients, i.e. workstations with databases open we signal them where they will keep duplicate red progress windows running. */ } ::if {$::qw::control(process_file_is_enabled)} { ::if {![::qw::mutex_manager mutex_is_locked .mutex_name $::qw::control(process_list_file)]} { ::qw::mutex_manager mutex_lock .mutex_name $::qw::control(process_list_file) .lock_caller [::qw::methodname]; ::qw::finally [::list ::qw::mutex_manager mutex_unlock .mutex_name $::qw::control(process_list_file) .lock_caller [::qw::methodname]]; } ::sargs::file::set $::qw::control(process_list_file) .[::pid].ping_clock [::clock seconds]; } ::if {$::qw::control(progress_window_remote_disable_count)!=0} { ::return; } ::switch -- $::qw::control(app_name) { "app_name_server" - "app_name_service_node" { ::set Tag [::sargs::get $sargs .tag]; ::set sargs [::sargs::+= [::sargs::get $_structures $Tag] $sargs]; ::if {[::sargs::get $_structures ${Tag}.socket] ne ""} { /* { tag_create is originally called with a .socket argument when there is no open database that has its own socket, but nevertheless there still is a big operation. An example seems to be backup_convert. */ } ::set Socket [::sargs::get $_structures ${Tag}.socket]; ::if {[::qw::command_exists $Socket]} { ::set Signal ""; ::sargs::var::set Signal .tcp.command "signal"; ::sargs::var::set Signal .tcp.source "socket"; ::sargs::var::set Signal .tcp.destination "plug"; ::sargs::var::set Signal .tcp.priority "foreground"; ::sargs::var::set Signal .command "progress"; ::sargs::var::set Signal .progress $sargs; $Socket cpp_tcp_signal_send $Signal; } } else { # 2.38.3 - was sending two signals needlessly ::set Signal ""; ::sargs::var::set Signal .tcp.priority "foreground"; ::sargs::var::set Signal .command "progress"; ::sargs::var::set Signal .progress $sargs; [::qw::system] cpp_databases_tcp_signal_send $Signal; } } } } method tag_create {sargs} { ::set rwb1_debug 0; ::if {[::sargs::get $sargs .limit] eq ""} { ::sargs::var::set sargs .limit 0; } ::if {[::sargs::get $sargs .done] eq ""} { ::sargs::var::set sargs .done 0; } ::set Tag [::sargs::get $sargs .tag]; ::set DatabaseId [::sargs::get $sargs .database_id]; ::if {[::lsearch $_tag_list $Tag]>=0} { ::return; } ::lappend _tag_list $Tag; ::set Row [::llength $_tag_list]; ::sargs::var::set sargs .row $Row; ::if {![::sargs::exists $sargs .database_path]} { /* { 2.09 This simply avoids the need to grep and replace .directory with .file in all pgq/rth code. */ } ::sargs::var::set sargs .database_path [::sargs::get $sargs .file]; } ::if {![::sargs::exists $sargs .file]} { /* { 2.34.5 We make sure both .file and .database_path are set because somewhere in the past we changed .file to .database_path and not everyone got the memo. Specifically, tcp signals were using .file and therefore did not receive signals when the server side used .database_path. */ } ::sargs::var::set sargs .file [::sargs::get $sargs .database_path]; } ::sargs::var::set _structures $Tag $sargs; ::if {$Row==[::expr {$_row_count+1}]} { ::incr _row_count; ::label $itk_interior.table.${Row}operation -font $_font -relief sunken -borderwidth $_label_border_width -width 22 -anchor w; ::label $itk_interior.table.${Row}file -font $_font -relief sunken -borderwidth $_label_border_width -width 22 -anchor w; ::label $itk_interior.table.${Row}user -font $_font -relief sunken -borderwidth $_label_border_width -width 15 -anchor w; ::if {$_blue_columns} { ::label $itk_interior.table.${Row}state -font $_font -relief sunken -borderwidth $_label_border_width -width 8 -anchor w; ::label $itk_interior.table.${Row}runtime -font $_font -relief sunken -borderwidth $_label_border_width -width 9 -anchor e; ::label $itk_interior.table.${Row}exception_count -font $_font -relief sunken -borderwidth $_label_border_width -width 6 -anchor e; ::label $itk_interior.table.${Row}fixed_count -font $_font -relief sunken -borderwidth $_label_border_width -width 6 -anchor e; } ::label $itk_interior.table.${Row}limit -font $_font -relief sunken -borderwidth $_label_border_width -width 11 -anchor e; ::label $itk_interior.table.${Row}done -font $_font -relief sunken -borderwidth $_label_border_width -width 11 -anchor e; ::QW::WIDGET::COMPLETION_PERCENTAGE1 $itk_interior.table.${Row}completion; ::set Column 0; ::grid $itk_interior.table.${Row}operation -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table.${Row}file -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table.${Row}user -row $Row -column $Column -sticky ewns;::incr Column; ::if {$_blue_columns} { ::grid $itk_interior.table.${Row}state -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table.${Row}runtime -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table.${Row}exception_count -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table.${Row}fixed_count -row $Row -column $Column -sticky ewns;::incr Column; } ::grid $itk_interior.table.${Row}limit -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table.${Row}done -row $Row -column $Column -sticky ewns;::incr Column; ::grid $itk_interior.table.${Row}completion -row $Row -column $Column -sticky ewns;::incr Column; ::grid rowconfigure $itk_interior.table $Row -weight 1; } $itk_interior.table.${Row}operation configure -text [::sargs::get $sargs .operation]; $itk_interior.table.${Row}file configure -text [::sargs::get $sargs .database_path]; $itk_interior.table.${Row}user configure -text [::sargs::get $sargs .user]; ::if {$_blue_columns} { $itk_interior.table.${Row}state configure -text "working"; $itk_interior.table.${Row}runtime configure -text "0"; $itk_interior.table.${Row}exception_count configure -text 0; $itk_interior.table.${Row}fixed_count configure -text 0; } $itk_interior.table.${Row}limit configure -text [::qw::number::format_whole_number .value [::sargs::get $sargs .limit]]; $itk_interior.table.${Row}done configure -text [::qw::number::format_whole_number .value [::sargs::get $sargs .done]]; $itk_interior.table.${Row}completion percent 0; ::lappend _status_stack [::sargs::get $sargs .status]; status_refresh; # ::wm deiconify $itk_interior; send_signal_to_all_clients $sargs .command tag_create; ::update; } method tag_change {sargs} { ::set Tag [::sargs::get $sargs .tag]; ::if {[::lsearch -exact $_tag_list $Tag]<0} { ::qw::warning "314120050302102741" "Could not find tag."; ::return; } ::set Done [::sargs::integer_get $sargs .done]; ::if {$Done!=0} { ::set Row [::sargs::get $_structures ${Tag}.row]; ::sargs::var::set _structures ${Tag}.done $Done; $itk_interior.table.${Row}done configure -text [::qw::number::format_whole_number .value [::sargs::get $sargs .done]]; ::set AfterPercent [percent_calculate [::sargs::get $_structures ${Tag}.done] [::sargs::get $_structures ${Tag}.limit]]; $itk_interior.table.${Row}completion percent $AfterPercent; ::update; } ::if {[::winfo exists $itk_interior.table.${Row}runtime]} { $itk_interior.table.${Row}runtime configure -text [::sargs::get $sargs .runtime]; } send_signal_to_all_clients $sargs .command tag_change; } method tag_configure {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,tag_configure,1000.0,sargs==$sargs";} ::set Tag [::sargs::get $sargs .tag]; ::if {[::lsearch -exact $_tag_list $Tag]<0} { ::qw::warning "314120180709150131" "Could not find tag \$Tag\"."; ::return; } ::if {![::sargs::exists $_structures ${Tag}.row]} { ::qw::warning "314120180712124551" "Could not find row \"$Row\"."; ::return; } ::set Row [::sargs::get $_structures ${Tag}.row]; ::foreach {Field After} $sargs { ::switch -- $Field { .state { $itk_interior.table.${Row}state configure -text $After; } .exception_count { $itk_interior.table.${Row}exception_count configure -text $After; } .fixed_count { $itk_interior.table.${Row}fixed_count configure -text $After; } default { ::continue; } } } /* { 2.33.0 The update here forces most changes to the screen immediately. Unlike increment, these changes, such as updated fixes or errors, are relatively rare. */ } send_signal_to_all_clients $sargs .command tag_configure; ::update; } method tag_destroy {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,tag_destroy,1000.0,this==$this,sargs==$sargs";} ::set Tag [::sargs::get $sargs .tag]; ::set Index [::lsearch -exact $_tag_list $Tag]; ::if {$Index<0} { ::if {$rwb1_debug} {::puts "rwb1_debug,tag_destroy,1000.1";} ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,tag_destroy,1000.2";} send_signal_to_all_clients $sargs .command tag_destroy; ::if {$rwb1_debug} {::puts "rwb1_debug,tag_destroy,1000.3";} ::set _status_stack [::lreplace $_status_stack $Index $Index]; status_refresh; ::if {$rwb1_debug} {::puts "rwb1_debug,tag_destroy,1000.4";} ::set Row [::sargs::get $_structures ${Tag}.row]; ::if {$Row eq ""} { /* { Added 2.09.7. Bug occurs when a workstation has two databases open on the same server and we get a red progress box initiated by yet another workstation. */ } # ::return; } $itk_interior.table.${Row}operation configure -text ""; $itk_interior.table.${Row}file configure -text ""; $itk_interior.table.${Row}user configure -text ""; ::if {$_blue_columns} { $itk_interior.table.${Row}state configure -text ""; $itk_interior.table.${Row}runtime configure -text ""; $itk_interior.table.${Row}exception_count configure -text ""; $itk_interior.table.${Row}fixed_count configure -text ""; } $itk_interior.table.${Row}limit configure -text ""; $itk_interior.table.${Row}done configure -text ""; $itk_interior.table.${Row}completion percent 0; ::if {$rwb1_debug} {::puts "rwb1_debug,tag_destroy,1000.5";} /* { Used to do this when we removed the row but now we let the progress grow and eliminate unnecessary noise when it increases/decreases size. ::foreach Name {directory user operation limit done completion} { ::if {[::winfo exists $itk_interior.table${Tag}$Name]} { ::destroy $itk_interior.table${Tag}$Name; } } */ } ::sargs::var::unset _structures $Tag; ::set _tag_list [::lreplace $_tag_list $Index $Index]; ::if {$rwb1_debug} {::puts "rwb1_debug,tag_destroy,1000.6,length==[::llength $_tag_list]";} ::if {[::llength $_tag_list]==0} { ::if {$rwb1_debug} {::puts "rwb1_debug,tag_destroy,1000.7";} ::itcl::delete object $this; ::if {$rwb1_debug} {::puts "rwb1_debug,tag_destroy,1000.8";} } /* { ::if {[::sargs::boolean_get $sargs .update_skip]} { #2.29.0 ::update idletasks; } else { ::update; } ::update idletasks; */ } # ::update; ::if {$rwb1_debug} {::puts "rwb1_debug,tag_destroy,1000.99";} } method tag_increment {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,tag_increment,1000.0,sargs==$sargs"} ::set Tag [::sargs::get $sargs .tag]; ::set Increment [::sargs::integer_get $sargs .increment]; ::if {$Increment==0} { # 2.33.3 ::if {$rwb1_debug} {::puts "rwb1_debug,tag_increment,1000.0.0"} ::return; } ::if {[::lsearch -exact $_tag_list $Tag]<0} { ::if {$rwb1_debug} {::puts "rwb1_debug,tag_increment,1000.0.1"} ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,tag_increment,1000.1"} ::set Done [::sargs::integer_get $_structures ${Tag}.done]; ::incr Done $Increment; ::sargs::var::integer_set _structures ${Tag}.done $Done; ::set ClockSeconds [::clock seconds]; ::if {$rwb1_debug} {::puts "rwb1_debug,tag_increment,1000.1,ClockSeconds==$ClockSeconds,_clock_seconds==$_clock_seconds"} ::if {$ClockSeconds>$_clock_seconds} { ::if {$rwb1_debug} {::puts "rwb1_debug,tag_increment,1000.2,ClockSeconds==$ClockSeconds";} ::set _clock_seconds $ClockSeconds; tag_change $sargs .done $Done; } ::if {$Done==[::sargs::integer_get $_structures ${Tag}.limit]} { ::if {$rwb1_debug} {::puts "rwb1_debug,tag_increment,1000.3,ClockSeconds==$ClockSeconds";} ::set _clock_seconds $ClockSeconds; tag_change $sargs .done $Done; tag_configure $sargs .state "completed"; # 2.34.9 added the state } #2.34.9 tag_change $sargs .done $Done; } method status_refresh {} { ::set Status [::lindex $_status_stack end]; $itk_interior.status configure -text "[::string range $Status 0 128]"; } method destroy_all_tags_for_database_id {sargs} { /* { The database is broken, disconnected etc. We want all rows associated with the database destroyed. We are given the database id. We hunt down and destroy each row associated with the database id. If the last row of the window is destroyed, the window self-destructs. This method is called from the database cpp method make_broken. */ } ::set DatabaseId [::sargs::get $sargs .database_id]; ::if {$DatabaseId eq ""} { #2.27.0 ::qw::bug 314120050225063725 "Encountered empty database id."; # now all operations cleared if database id is empty } ::foreach Name [::sargs::names .structure $_structures] { ::if {$DatabaseId eq ""||[::sargs::get $_structures ${Name}.database_id] eq $DatabaseId} { tag_destroy .tag [::sargs::get $_structures ${Name}.tag]; } } } method progress_destroy {sargs} { /* { The database is broken, disconnected etc. We want all rows associated with the database destroyed. We are given the database id. We hunt down and destroy each row associated with the database id. If the last row of the window is destroyed, the window self-destructs. This method is called from the database cpp method make_broken. */ } ::set DatabaseId [::sargs::get $sargs .database_id]; ::if {$DatabaseId eq ""} { ::qw::bug 314120080829090412 "Encountered empty database id."; } ::foreach Name [::sargs::names .structure $_structures] { ::if {[::sargs::get $_structures ${Name}.database_id] eq $DatabaseId} { tag_destroy [::sargs .tag [::sargs::get $_structures ${Name}.tag]]; } } } method debug_dump_structures {sargs} { # 2.33.1 ::foreach Name [::sargs::names .structure $_structures] { ::puts "red_progress::debug_dump_structures,_structures\[$Name\]==\n[::sargs::format $_structures($Name)]"; } } } ::namespace eval ::qw::progress_red {} ::proc ::qw::progress_red::progress_window {sargs} { /* { 2.28.4 - Moved here from qw_system0.cpp */ } ::if {![::winfo exists .progress_window]} { ::if {$::qw::control(progress_window_disable_count)>0} { ::return ""; } #rwb_master 2.29.0 ::QW::PROGRESS::WINDOW .progress_window -title "Operation in progress, please wait..."; # ::uplevel #0 ::QW::PROGRESS::WINDOW .progress_window -title "Operation in progress, please wait..."; ::QW::PROGRESS::WINDOW .progress_window -title "Operation in progress, please wait..."; ::wm geometry .progress_window +50+100; ::qw::toplevel_add .toplevel .progress_window .is_red_progress 1; } ::return .progress_window; } ::proc ::qw::progress_red::destroy_operations {sargs} { # 2.27.0 ::if {[::winfo exists .progress_window]} { .progress_window destroy_all_tags_for_database_id $sargs; } } ::itcl::class ::QW::PROGRESS::OPERATION { # ------------------------------------------------------------ # QW::PROGRESS::OPERATION class # ------------------------------------------------------------ protected variable _progress_window ""; protected variable _sargs [::sargs]; protected variable _clock_start ""; protected variable _operation_tag ""; common _unique_id 1; proc unique_id {} {::return [::incr _unique_id];} method constructor {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} { ::puts "rwb1_debug,::QW::PROGRESS::OPERATION,constructor,1000.0,this==$this"; ::puts "rwb1_debug,::QW::PROGRESS::OPERATION,constructor,1000.1,namespace==[::namespace current]"; ::puts "rwb1_debug,::QW::PROGRESS::OPERATION,constructor,1000.2,sargs==\n[::sargs::format $sargs]"; } ::if {$::qw::control(progress_window_disable_count)} { ::return; } # ::set _progress_window [[::qw::system] cpp_progress_window]; #nv2.35.0 (diagnostics) - ::QW::PROGRESS::WINDOW constructor - red progess semaphore file with details for start time and progess operations appended as we go #::set _progress_window [[::qw::system] cpp_progress_window]; ::set _progress_window [[::qw::system] cpp_progress_window $sargs]; ::set DatabaseId [::sargs::get $sargs .database_id]; ::if {$DatabaseId eq ""} { # 2.28.0 - using red progress for auto_update # don't have a database to specify #2.28.0 ::qw::bug 314120041129103234 "::qw::progress::operation - no .database_id arg."; } /* { We create each tag so that it is unique. We use a unique id as generated on the server/workstation but these can still conflict on a workstation when progress rows are a mixture of rows generated by both the workstation and server as in the fill column script. So we also use the computer's nic, after stripping the hyphens. But even this is not good enough when the server and workstation are on the same computer. So we also use the process id. That should do it. */ } ::set Nic [::qw::remove_hyphens [[::qw::system] cpp_nic_get]]; ::sargs::var::set sargs .tag ".${DatabaseId}_${Nic}_[::pid]_[unique_id]"; ::set _sargs $sargs; ::set _clock_start [::clock seconds]; $_progress_window tag_create $sargs; ::if {$rwb1_debug} {::puts "rwb1_debug,::QW::PROGRESS::OPERATION,constructor,1000.5";} #nv2.35.0 (diagnostics) - ::QW::PROGRESS::WINDOW constructor - red progess semaphore file with details for start time and progess operations appended as we go #//::puts "pgq,debug...::QW::PROGRESS::OPERATION constructor sargs==$sargs"; ::set WorkstationDatabase [[::qw::system] cpp_find_workstation_database]; ::if {[::qw::command_exists $WorkstationDatabase]} { ::if {$rwb1_debug} {::puts "rwb1_debug,::QW::PROGRESS::OPERATION,constructor,1000.6";} ::set WorkstationPath [$WorkstationDatabase cpp_database_path]; ::set SemaphorePath [::file join [::file dir $WorkstationPath] nv_semaphore.txt]; ::if {$rwb1_debug} {::puts "rwb1_debug,::QW::PROGRESS::OPERATION,constructor,1000.7";} ::if {[::file exists $SemaphorePath]} { ::set FileHandle [::open $SemaphorePath a]; ::puts $FileHandle "[::sargs::format .structure $sargs]"; ::close $FileHandle; } ::if {$rwb1_debug} {::puts "rwb1_debug,::QW::PROGRESS::OPERATION,constructor,1000.8";} } ::return $this; } destructor { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,::QW::PROGRESS::OPERATION,destructor,1000.0,this==$this";} ::if {![::sargs::boolean_get $_sargs .destroy_skip]} { destroy; } } method destroy {sargs} { ::if {[::qw::command_exists $_progress_window]} { $_progress_window tag_destroy $_sargs; ::set _progress_window ""; } } method increment {{Increment 1}} { ::if {!$::qw::control(progress_is_enabled)} { ::return; } ::if {[::qw::command_exists $_progress_window]} { $_progress_window tag_increment $_sargs \ .increment $Increment \ .runtime [::qw::clockutil::runtime_format_hms .seconds [::expr {[::clock seconds]-$_clock_start}]] \ ; } } method configure {sargs} { ::set rwb1_debug 0; ::if {[::qw::command_exists $_progress_window]} { if {$rwb1_debug} {::puts "rwb1_debug,qw::red_progress::configure,1000.0,sargs==$sargs";} ::set Tag [::sargs::get $_sargs .tag]; if {$rwb1_debug} {::puts "rwb1_debug,qw::red_progress::configure,1000.1,_sargs==\n[::sargs::format $_sargs]";} ::set sargs [::sargs::+= $_sargs $sargs]; if {$rwb1_debug} {::puts "rwb1_debug,qw::red_progress::configure,1000.2,sargs==\n[::sargs::format $sargs]";} $_progress_window tag_configure $sargs \ .tag $Tag \ .runtime [::qw::clockutil::runtime_format_hms .seconds [::expr {[::clock seconds]-$_clock_start}]] \ ; if {$rwb1_debug} {::puts "rwb1_debug,qw::red_progress::configure,1000.3";} } } method operation_tag_get {} { ::return [::sargs::get $_sargs .tag]; } } ########################################################################################## ::namespace eval ::qw::progress_red {} ::namespace eval ::qw::progress {} ::proc ::qw::progress::auto {} { ::set Count 0; ::while {1} { /* { 2.34.7 was released with the next line which was missing a leading ::. This seemed to only cause problems in tcl 8.6. 2.34.8 fixed it. */ } #::set Id qw::progress::operation_$Count; ::set Id ::qw::progress::operation_$Count; ::if {![::qw::command_exists $Id]} { ::break; } ::incr Count 1; } ::return $Id; } ::proc ::qw::progress::operation_increment {sargs} { ::if {[::sargs::exists $sargs .operation_id]} { ::return [::incr [::sargs::get $sargs .count_variable] [::sargs::integer_get $sargs .increment]]; } ::set RedProgressOperation [::sargs::get $sargs .red_progress_operation]; ::if {[::qw::command_exists $RedProgressOperation]} { ::return [$RedProgressOperation increment [::sargs::integer_get $sargs .increment]]; } } ::proc ::qw::progress::operation_configure {sargs} { ::if {[::sargs::exists $sargs .operation_id]} { ::return [::qw::progress_blue::operation_configure $sargs]; } ::set RedProgressOperation [::sargs::get $sargs .red_progress_operation]; ::if {[::qw::command_exists $RedProgressOperation]} { ::return [$RedProgressOperation configure $sargs]; } } ::proc ::qw::progress::operation_is_aborted {sargs} { ::if {[::sargs::exists $sargs .operation_id]} { ::return [::qw::progress_blue::operation_is_aborted $sargs]; } ::return 0; } ::proc ::qw::progress::operation_destroy {sargs} { ::if {[::sargs::exists $sargs .operation_id]} { ::return [::qw::progress_blue::operation_destroy $sargs]; } ::set RedProgressOperation [::sargs::get $sargs .red_progress_operation]; ::if {[::qw::command_exists $RedProgressOperation]} { ::return [$RedProgressOperation destroy $sargs]; } } ::proc ::qw::progress::count_variable_generate {sargs} { /* { Creates a unique count variable (in the ::qw::progress namespace) and initializes it to 0. */ } ::set Count 0; ::while {[::info exists ::qw::progress::count_variable_$Count]} { ::incr Count 1; } ::set ::qw::progress::count_variable_$Count 0; ::return ::qw::progress::count_variable_$Count; }