::qw::packages::package_require_tablelist; ::namespace eval ::qw::widget3 {}; ::proc ::qw::widget3::create_helper {sargs} { /* { Basic idea from Flynt page 516-17. The purpose of this mechanism is to turn an itcl instance name into a tk widget path. This widget is not a toplevel widget. There is a separate hierarchy for dialogs and/or toplevels. We can be called with .tkpath which will be this widget's name, or else we can be called with .tkparent in which case a unique child name will be generated and appended to .tkparent to form .tkpath, Ordinary widgets need a tk path as their parent and then the inner widgets have present names. Dialogs do not need a parent but in the interest of keeping things general we will allow a .parent sargs field, in which case we will create a frame a place it within the parent. (1) Create a toplevel using $TkPath or generated name (2) Rename the command to $TkPath.toplevel We intend to reuse it's command name. Note that renaming it changed the command name but not the widget path. It's widget path is still $TkPath and we will reuse it's command. (3) Call the main method and return it's result. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,widget3::create_helper,1000.0"} ::set TkPath [::sargs::get $sargs .tkpath]; ::if {$TkPath eq ""} { ::set TkParent [::sargs::get $sargs .tkparent]; ::if {$TkParent eq ""} { ::qw::bug 314120160317085549 "No widget path. sargs==\n[::sargs::format $sargs]"; } ::set Id 0; ::while {[::winfo exists $TkParent.kid$Id]} { /* { Parent was specified but not the new child so generate a unique non-existing name for the new child widget. */ } ::incr Id; } ::set TkPath $TkParent.kid$Id; ::sargs::var::set sargs .tkpath $TkPath; } ::if {$rwb1_debug} {::puts "rwb1_debug,widget3::create_helper,1000.1"} ::set ItclWidgetClass [::sargs::get $sargs .itcl_widget_class]; ::if {$ItclWidgetClass eq ""} { ::qw::bug 314120160317085550 "No itcl widget class. sargs==\n[::sargs::format $sargs]"; } ::set TkWidgetClass [::sargs::get $sargs .tk_widget_class]; ::if {$TkWidgetClass eq ""} { ::qw::bug 314120160317085551 "No tk widget class. sargs==\n[::sargs::format $sargs]"; } ::if {$rwb1_debug} {::puts "rwb1_debug,widget3::create_helper,1000.2"} ::set TkWidget [::uplevel $TkWidgetClass $TkPath]; ::if {$rwb1_debug} {::puts "rwb1_debug,widget3::create_helper,1000.3"} ::uplevel #0 ::rename $TkPath $TkPath.xxx; ::if {$rwb1_debug} {::puts "rwb1_debug,widget3::create_helper,1000.4"} ::set ItclWidget [::namespace eval :: [::list $ItclWidgetClass $TkPath]]; ::if {$rwb1_debug} {::puts "rwb1_debug,widget3::create_helper,1000.5"} $ItclWidget main $sargs; # widget can use .tkpath. ::if {$rwb1_debug} {::puts "rwb1_debug,widget3::create_helper,1000.6"} ::return $TkPath; } /* { By default menu tearoffs are enabled. The following line overrides the default, setting it to false, and hence eliminates the need to specify it with each menu creation. */ } ::option add *tearOff 0; ::namespace eval ::qw::widget3 {}; ::itcl::class ::qw::widget3::toplevel { /* { */ } protected variable _sargs ""; # original args but nodified by script at will protected variable _sargs_before ""; # original arguments passed to script protected variable _toplevel ""; # this is the toplevel containing the dialog protected variable _image_array; # convenience if images needed - automatically released protected variable _window ""; protected variable _database ""; protected variable _database_id ""; protected variable _database_path ""; protected variable _database_type ""; protected variable _user ""; protected variable _username ""; # protected variable _toolbar_button_font {-family Arial -size 8 -weight normal}; # protected variable _main_font system; # protected variable _folder_font {-family Arial -size 9 -weight normal}; # protected variable _resize_is_enabled 1; # protected variable _reduce_size_is_enabled 1; protected variable _default_folder [::file join $::qw_library system images]; # protected variable _dynamic_scrollbars 1; protected variable _html ""; # used if you have .html instead of .text protected variable _hsb ""; # only used if you have scollbars protected variable _vsb ""; protected variable _hsb_is_on 1; protected variable _vsb_is_on 1; # protected variable _hsb_is_on 0; # protected variable _vsb_is_on 0; protected variable _html_fontscale 0.75; # protected variable _default_focus_widget ""; constructor {} { #::qw::dialog3::modal ::array set _image_array {}; } destructor { #::qw::dialog3::modal ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.0";} ::qw::try { # options_store; } catch Dummy { ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.1,Dummy==$Dummy";} } ::if {$_toplevel ne ""} { ::qw::toplevel_remove .toplevel $_toplevel; } ::if {[::winfo exists $_toplevel]} { ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.2";} ::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. */ } ::destroy .help_shell; } ::foreach ImageName [::array names _image_array] { ::qw::try { ::image delete $_image_array($ImageName); } catch Dummy { ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.4,Dummy==$Dummy";} } } ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.5";} } method main {sargs} { /* { Override the main method and do not chain to it. The main method controls the calling of all other slices and you should have maximum flexibility to do anything you want here. We provide the suggested order in which calls are typically made. The main method calls all of the other pre-defined methods that each set up some aspect of the dialog. They also tend to pack themselves. We tend to create the components from top to botton, i.e. menu, then toolbar, then client, then control buttons. Just don't implement a method if you don't need the component. For example, don't implement menu_setup and you won't have a menu. Slices ------ We refer to methods such as sargs_setup or client_setup, etc., as slices. The main method calls these slices in a controlled order. sargs_setup sets up default options. Then the sargs received by main are merged with these options, adding to them or overriding (clobbering) them. However, we also set the variable _sargs with the original arguments received by main, just in case a slice needs them. Don't override main ------------------- For modal dialogs main returns only when the dialog is done. You might think you overide it by doing "your stuff" before chaining. However, the main you chain to destroys the object and it never returns, instead producing a gp. So if you do override, replace it completely, and don't chain. Note that you can override chain if you override wait and simply not chain from wait, That would also change the dialog from modal into modeless. In this case you can override main and the comments above no longer apply. Why a main method? ------------------ The work done by main could have been done in a constructor. Instead, the constructor takes no argumnebts and does nothing, leaving main to do the real work. There are a number of reasons we don't do the work in a constructor; among them are: (1) If we use a constructor then the constructor has to take arguments. This in turn involves chaining and the use of the init itcl constructor construct, etc. Let's avoid this complication. (2) Regardless of what a constructor attempts to return, itcl forces it to return the hame of the newly created object. Our dialogs have to return other information if they are to be useful. (3) The main method actually destroys the dialog after wainting on the result variable. This is all done to make the dailog modal by controlling the grab. We can in fact destroy the object from the within the constructor and it has been done. But why make things more obtuse than they need to be? (4) There are polymorphism issues when calling methods from a constructor. This can all be done in itcl but it requires reviewing the manual to be sure you know exactly how itcl works in this regard and there is not guarantee the design can be ported to a different object system. Why not just use what we know works? That is, we know that the calls will be treat polymorpically then called from a "regular" method such as main. */ } /* { _sargs is set to the original sargs passed to the dialog. _options is originally set to the dialogs default values. $sargs is merged with _options to potentially override any values. button_setup is called before client_setup sot that if buttons are used and if the window is resized to a smaller window, the buttons will not disappear first. (They disappear in reverse packing order). */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.0"} ::set _sargs_before $sargs; sargs_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.1,sargs==\n[::sargs::format $sargs]"} options_load; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.1.0,sargs==\n[::sargs::format $sargs]"} ::sargs::var::+= _sargs $sargs; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.2,_sargs==\n[::sargs::format $_sargs]"} boot_check; user_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.3"} toplevel_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.4"} menu_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.5"} toolbar_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.6"} control_button_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.7"} icon_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.8"} client_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.9"} popup_menu_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.10"} #initialize; # initialize_after_idle has taken over ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.11"} ::if {[::sargs::boolean_get $sargs .is_modeless]} { ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.12"} ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.13"} wait; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.14"} ::set Result $_dialog_result; ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::widget3::toplevel,main,1000.15"} ::return $Result; } method boot_check {} { } method sargs_setup {} { #::qw::dialog3::modal /* { The sargs_setup method should assign default values to the _sargs variable. After calling sargs_setup, we merge _sargs with the sargs received by main, effectively overriding _sargs values with those supplied by the caller. Note that empty fields need not be explicitly set but we do it anyway to show what fields exist and can be set in derived dialog classes. */ } ::set _sargs { .title "" .bbox "" .text_font system .resize_is_enabled 0 .minsize_is_enabled 0 .control_button { .help { .text "Help" .tooltip { .text "(F1) - Help on this dialog." } } .dismiss { .text "Dismiss" .tooltip { .text "(Esc) - Dismiss this dialog." } .value "" } } .image_path "" .default_focus_widget .control_button.dismiss }; # ::sargs::var::set _sargs .image_path [::file join $::qw_library system images info.gif]; } method options_load {} { } method options_store {} { } method user_setup {} { #::qw::entry3::archetype_entry /* { If there is a database and corresponding user, we get several relevant fields here for convenience, including the user and username. */ } ::set _database [::sargs::get $_sargs .database]; ::if {$_database eq ""} { ::set _window [::sargs::get $_sargs .odb.object]; ::if {$_window ne ""} { ::set _database [$_window odb_database application]; } } ::if {[::qw::command_exists $_database]} { /* { If we have a database, set up some useful database-related variables. If it's an application database we probably have a user, and the user might have format options we can use. */ } ::set _database_path [$_database cpp_database_path]; ::set _database_id [$_database cpp_database_id]; ::set _database_type [$_database cpp_database_type]; ::if {$_database_type eq "application"} { ::set _user [$_database cpp_user_get]; ::if {$_user ne ""} { ::set _username [[$_user .name] odb_get]; } } } } 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 Callback [::sargs::get $_sargs .tooltip_get_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%]; ::set DefaultFocusWidget [::sargs::get $_sargs .default_focus_widget]; ::if {$DefaultFocusWidget ne ""} { ::set DefaultFocusWidget $_toplevel$DefaultFocusWidget; ::if {[::winfo exists $DefaultFocusWidget]} { ::focus $DefaultFocusWidget; } } ::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 toplevel_setup {} { #::qw::dialog3::modal ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog3::modal,toplevel_setup,1000.0,toplevel==[::sargs::get $_sargs .toplevel]";} ::set _toplevel [::sargs::get $_sargs .toplevel]; ::set Title [::sargs::get $_sargs .title]; ::if {$Title eq ""} { ::set Title "Dialog" } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog3::modal,toplevel_setup,1000.1";} ::wm title $_toplevel $Title; ::if {[::sargs::get $_sargs .width] ne ""} { $_toplevel configure -width [::sargs::get $_sargs.width]; } ::if {[::sargs::get $_sargs .sargs] ne ""} { $_toplevel configure -height [::sargs::get $_sargs .height]; } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog3::modal,toplevel_setup,1000.2";} ::wm protocol $_toplevel WM_DELETE_WINDOW [::itcl::code $this dialog_control_button_process .control_button .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_control_button_process .control_button .dismiss]; ::bind $_toplevel [::itcl::code $this dialog_control_button_process .control_button .dismiss]; ::bind $_toplevel [::itcl::code $this dialog_control_button_process .control_button .help] ::bind $_toplevel [::itcl::code $this dialog_control_button_process .control_button .dismiss]; ::bind $_toplevel [::itcl::code $this dialog_control_button_process .control_button .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";} ::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 menu_setup {} { #::qw::dialog3::modal } method popup_menu_setup {} { #::qw::dialog3::modal } method toolbar_setup {} { #::qw::dialog3::modal } method icon_setup {} { #::qw::dialog3::modal ::set ImagePath [::sargs::get $_sargs .image_path]; ::if {$ImagePath eq ""} { ::return; } ::if {![::file exists $ImagePath]} { ::return; } ::set _image_array(icon) [::image create photo -file $ImagePath]; ::ttk::label $_toplevel.icon \ -image $_image_array(icon) \ ; ::pack $_toplevel.icon -side left -padx 8 -pady 8; } method client_setup {} { #::qw::dialog3::modal ::ttk::frame $_toplevel.client; ::pack $_toplevel.client -side top -expand 1 -fill both; /* { We presume dialogs have a text area and supply either .text or .html arguments. If you don't want text displayed then don't use these arguments and none will be displayed. You can then take over the .client area entirely. */ } #::qw::dialog3::modal chain; /* { We can have both .text and .html for backward compatibility, but .html has precendence when both are found. */ } ::set Html [::sargs::get $_sargs .html]; ::set Text [::sargs::get $_sargs .text]; ::set TextType ""; ::if {$Text ne ""} { ::set TextType text; } ::if {$Html ne ""} { ::set TextType html; } ::switch -- $TextType { text { ::ttk::label $_toplevel.client.text \ -text [::sargs::get $_sargs .text] \ -justify left \ -font [::sargs::get $_sargs .text_font] \ ; # ::pack $_toplevel.client.icon -side left -padx 8 -pady 8; ::pack $_toplevel.client.text -side right -expand 1 -fill both -padx 8 -pady 8 # ::pack $_toplevel.client -side top -expand 1 -fill both; ::return; } html { ::package require Tkhtml 3.0; ::set Html [::sargs::get $_sargs .html.body]; ::set SArgs $_sargs; ::sargs::var::set SArgs .body $Html; ::set Body [::qw::html::format $SArgs]; # ::set Body [::sargs::get $_sargs .html.body]; # ::set Body [::qw::html::format $_sargs .body $Body]; ::set Height 3.0; ::set Width [::expr {$Height*1.6180339}]; ::set Height ${Height}i; ::set Width ${Width}i; ::if {[::sargs::get $_sargs .html.height] ne ""} { ::set Height [::sargs::get $_sargs .html.height]; } ::if {[::sargs::get $_sargs .html.width] ne ""} { ::set Width [::sargs::get $_sargs .html.width]; } ::set Body "$Body"; ::ttk::frame $_toplevel.client.html_frame; # needed for scrollbars ::set _html $_toplevel.client.html_frame.html; ::set _hsb $_toplevel.client.html_frame.hsb; ::set _vsb $_toplevel.client.html_frame.vsb; ::html $_html \ -width $Width \ -height $Height \ -xscrollcommand [::list $_hsb set] \ -yscrollcommand [::list $_vsb set] \ ; ::ttk::scrollbar $_vsb -orient vertical -command [::list $_html yview]; ::ttk::scrollbar $_hsb -orient horizontal -command [::list $_html xview]; $_html style [::subst -nocommands { html { background: $::qw::platform_dependent_color(SystemButtonFace); font-family: Helvetica; padding: 5px; } }]; $_html parse -final $Body; # ::pack $_toplevel.client.icon -side left -padx 8 -pady 8; ::pack $_toplevel.client.html_frame -side right -expand 1 -fill both -padx 8 -pady 8 # ::pack $_toplevel.client -side top -expand 1 -fill both ::grid $_html $_vsb -sticky nsew; ::grid $_hsb -sticky nsew; ::grid rowconfigure $_toplevel.client.html_frame $_html -weight 1; ::grid columnconfigure $_toplevel.client.html_frame $_html -weight 1; ::set _vsb_is_on 1; ::set _hsb_is_on 1; ::after idle [::subst -nocommands { ::if {[::winfo exists $_toplevel]} { $this configure_event; } }]; # ::after idle [::itcl::code $this configure_event]; ::return; } } # ::bind $_toplevel [::itcl::code $this dialog_ok]; } method popup_menu_post {sargs} { #::qw::dialog3::modal ::return; ::set X [::sargs::get $sargs .x]; ::set Y [::sargs::get $sargs .y]; ::tk_popup $_toplevel.popup_menu $X $Y; } method control_button_setup {} { #::qw::dialog3::modal /* { Goes through the .control_button subs in _sargs and creates a button widget for each defined button. Also creates the frame for the buttons and packs it. Finally, note that the each button is given a callback of a pre-defined form. The buttons themselves are packed right to left, putting the first defined button (help) to the far right. As additional button definitions are appended to $_sargs.controlbutton, they are packed to the left. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,control_button_setup,1000.0"}; ::if {![has_help]} { /* { If there is no help page specified, then remove the help button. There is nothing worse than hitting a help button only to find that help is not available. Note this is a performance hit as the help page is created (or not). If no, a page wi */ } ::if {$rwb1_debug} {::puts "rwb1_debug,control_button_setup,1000.2"}; ::sargs::var::unset _sargs .control_button.help; } ::if {$rwb1_debug} {::puts "rwb1_debug,control_button_setup,1000.3"}; ::set ButtonFields [::sargs::names .structure [::sargs::get $_sargs .control_button]]; ::if {$rwb1_debug} {::puts "rwb1_debug,control_button_setup,1000.4,ButtonFields==$ButtonFields"}; ::if {[::llength $ButtonFields]!=0} { ::frame $_toplevel.control_button; ::foreach Button $ButtonFields { ::ttk::button $_toplevel.control_button$Button \ -text [::sargs::get $_sargs .control_button$Button.text] \ -command [::itcl::code $this dialog_control_button_process .control_button $Button] \ ; ::pack $_toplevel.control_button$Button -side right -padx 2 -pady 2; } ::pack $_toplevel.control_button -fill x -side bottom; } ::if {$rwb1_debug} {::puts "rwb1_debug,control_button_setup,1000.5"}; } method has_help {} { ::set HelpPage [dialog_help_page]; ::if {[::string trim $HelpPage] ne ""} { ::return 1; } ::return 0; } method dialog_control_button_process {sargs} { #::qw::dialog3::modal ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,dialog_control_button_process,1000.0,sargs==$sargs";} ::set Button [::sargs::get $sargs .control_button]; ::switch -- $Button { .help { dialog_help_display; ::return; } } ::if {$rwb1_debug} {::puts "rwb1_debug,dialog_control_button_process,1000.1";} ::if {[::sargs::exists $_sargs .control_button${Button}.value]} { ::if {$rwb1_debug} {::puts "rwb1_debug,dialog_control_button_process,1000.2";} ::set _dialog_result [::sargs::get $_sargs .control_button${Button}.value]; ::if {$rwb1_debug} {::puts "rwb1_debug,dialog_control_button_process,1000.3";} ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,dialog_control_button_process,1000.4";} ::qw::warning 314120151013135732 "[::qw::methodname] - invalid .control_button \"$Button\"."; ::return [chain $sargs]; } method wait {} { #::qw::dialog3::modal /* { We add a binding tag to the toplevel and bind code to it that will raise the toplevel when it gets a button press. This reduces the chances it will get hidden beneath under windows and frustrate the user. This technique is found in Effective Tcl/Tk. To create a non-modal dialog, just override this method and do nothing. You will also have to override the code that handles exiting to destroy the window. Also, typically a non-modal dialog will not tend to return anything so the way the modal dialog returns a value through _dialog_result is not relevant. */ } ::bind $this { ::wm deiconify %W ::raise %W } ::if {[::lsearch [::bindtags $_toplevel] $this]<0} { /* { Prepend the tag if it doesn't already exist. */ } ::bindtags $_toplevel [::linsert [::bindtags $_toplevel] 0 $this]; } ::if {![::winfo exists $_toplevel]} { ::qw::bug 314120120115161938 "[::qw::methodname] ::wait - no toplevel."; } ::set GrabSave [::grab current $_toplevel]; ::grab set $_toplevel; ::update idletasks; # 2.28.0 - this was part of trying to speed up table refreshes #[::qw::system] cpp_enter_event_loop .vwait_varname [::itcl::scope _dialog_result]; ::vwait [::itcl::scope _dialog_result]; ::grab release $_toplevel; ::if {$GrabSave ne ""} { ::if {[::winfo exists $GrabSave]} { ::grab set $GrabSave; } } #::wm withdraw $Toplevel } method configure_event {} { #::qw::dialog3::modal /* { Managing Optional Dynamic Scollbars ----------------------------------- We added the _hsb and _vsb variables in the archetype and this code manages dynamic scroll bars. Note however, that for any widget that does not use scroll bars, this code does nothing at all. Furthermore, mega-widgets that have multiple components with scollbars would have to implement their own dynamic scrollbar management. Note that if we have scroll bars, we will assume they are dynamic. If you don't like this, or anything else, you are free to override. _hsb and _vsb are set to the scollbars. _hsb_is_on and _vsb_is_on indicate whether they are in the grid. We use the configure event to remove them from the grid or put them back. The "::grid remove" command is used because it remembers the scollbar's grid values (::grid forget forgets them). We turn the scollbars off whenever their values are "0.0 1.0" and turn them back on otherwise. */ } # ::return; ::if {[::winfo exists $_hsb]} { ::set Values [$_hsb get]; ::if {[::lindex $Values 0]==0.0&&[::lindex $Values 1]==1.0} { ::if {$_hsb_is_on} { ::grid remove $_hsb; ::set _hsb_is_on 0; } } else { ::if {!$_hsb_is_on} { ::grid $_hsb; ::set _hsb_is_on 1; } } } ::if {[::winfo exists $_vsb]} { ::set Values [$_vsb get]; ::if {[::lindex $Values 0]==0.0&&[::lindex $Values 1]==1.0} { ::if {$_vsb_is_on} { ::grid remove $_vsb; ::set _vsb_is_on 0; } } else { ::if {!$_vsb_is_on} { ::grid $_vsb; ::set _vsb_is_on 1; } } } } /* { method dialog_help_exists {} { /* { We need to know in advance whether help is available. We don't want to diplay the help button when there is no help. It just causes frustration. */ } ::set HelpId [::sargs::get $_sargs .help_id]; ::if {$HelpId ne ""} { ::if {[::string first "???" $HelpId]<0} { ::if {$HelpId ne "0"} { ::return 1; } } } ::set HelpPage [::sargs::get $_sargs .help_page]; ::if {$HelpPage ne ""} { ::if {[::sargs::get $HelpPage .body] ne ""} { ::return 1; } } ::set HelpPage [dialog_help_page]; ::if {$HelpPage ne ""} { ::if {[::sargs::get $HelpPage .body] ne ""} { ::return 1; } } ::return 0; } */ } method dialog_help_page {} { ::set HelpPage [::sargs::get $_sargs .help_page]; ::if {$HelpPage ne ""} { ::return $HelpPage; } ::set HelpId [::sargs::get $_sargs .help_id]; if {$HelpId ne ""} { ::set HelpPage [::qw::help::find_page_by_id $HelpId]; ::if {$HelpPage ne ""} { ::return $HelpPage; } } # ::set HelpPage [dialog_help_page]; ::return $HelpPage; } method dialog_help_display {} { /* { The caller can use .help_id or .help_page. The .help_page has priority over .help_id if both are supplied. I would like to get rid of .help_id but many of the old dialogs, including error dialogs, still use it. */ } ::set HelpPage [dialog_help_page]; ::if {$HelpPage eq ""} { ::set HelpPage { .id 314120151023143337 .body { [p { Help not available. }] } } } ::foreach Field [::sargs::names .structure $_sargs] { ::if {![::sargs::exists $HelpPage $Field]} { /* { We don't copy fields that the page already has. */ } ::sargs::var::set HelpPage $Field [::sargs::get $_sargs $Field]; } } ::if {![::sargs::exists $HelpPage .id]} { /* { Each page needs a unique id so if it isn't there we generate a unique id and set it in the help page. */ } ::sargs::var::set HelpPage .id 3141[::clock format [::clock seconds] -format %Y%m%d%H%M%S]; } ::qw::script::source \ .script.path [::file join $::qw_library doc qw_chtml_compile.qw_script] \ .structure $HelpPage \ ; } method tooltip_get {sargs} { #::qw::dialog3::modal ::set Widget [::sargs::get $sargs .widget]; ::switch -glob -- $Widget { *.control_button.* { /* { Gets the button name from the tail of the widget path and uses that to find related tooltip text in _sargs, if any. */ } ::set Button .[::lindex [::split $Widget .] end]; ::set Text [::sargs::get $_sargs .control_button$Button.tooltip.text]; ::return [::sargs .text $Text]; } } ::return [::sargs .text ""]; } /* { method mouse_wheel {Delta} { ::set OldPos [::lindex [$_canvas yview] 0]; ::set MoveBy [::expr {int($Delta/120)*-0.02}]; ::set NewPos [::expr {$OldPos+$MoveBy}]; $_canvas yview moveto $NewPos; } */ } method dialog_ok {sargs} { #::qw::dialog3::modal ::set _dialog_result ""; } method dialog_cancel {sargs} { #::qw::dialog3::modal ::set _dialog_result ""; } method dialog_exit {sargs} { #::qw::dialog3::modal ::set _dialog_result ""; } method application_exit {sargs} { #::qw::dialog3::modal } } # ------------------------------------------------------------ # ::qw::widget3::tablelist # ------------------------------------------------------------ ::proc ::qw::widget3::tablelist {sargs} { /* { */ } ::return [::qw::widget3::create_helper $sargs .tk_widget_class ::tablelist .widget_class ::qw::widget3::tablelist_class]; } ::itcl::class ::qw::widget3::tablelist_class { /* { We keep field definitions and column definitions. Data is kept in _data. */ } protected variable _sargs ""; protected variable _table ""; # protected variable _client ""; protected variable _data; protected variable _label_border_width 0.5m; protected variable _font {-family Arial -size 10 -weight normal}; protected variable _status_stack ""; protected variable _owner_tk_window ""; protected variable _default_background ""; protected variable _is_modeless 1; protected variable _column_definitions [::sargs]; protected variable _horizontal_scrollbar_is_enabled 0; constructor {} { ::array set _data {}; ::set Button [::button .button_3141201212031654421_temp]; ::set _default_background [$Button cget -background]; ::destroy $Button; } destructor { } method sargs_setup {sargs} { #chain; ::set _sargs $sargs; } method options_file {} { /* { */ } ::return ""; } method options_set {sargs} { /* { We are given our portion of the options in sargs. The toplevel loads a sargs from a file and then calls its sub-widgets with the appropriate sub-sargs and each load its portion of the options. */ } } method options_get {} { /* { We recursively build the options in sargs and return them. */ } } method options_load {} { /* { */ } ::set File [::file join $::qw_program_folder nv2.dat system server_hub_table.qw_options]; ::set Options [::sargs::file::get $File]; options_set $Options; } method options_store {} { ::set Options [options_get]; ::sargs::var::set Options .qw_release $::qw_release; ::if {[::winfo exists $_toplevel]} { ::sargs::var::set Options .toplevel.geometry [::wm geometry $_toplevel]; } ::set File [::file join $::qw_program_folder nv2.dat system server_hub_table.qw_options]; ::sargs::file::set $File $Options; } method client_setup {} { #chain; ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.0";} ::foreach Name [::sargs::names .structure $_column_definitions] { ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.1";} ::lappend ColumnOptionList \ [::sargs::integer_get $_column_definitions $Name.width] \ [::sargs::get $_column_definitions $Name.title_text] \ [::sargs::get $_column_definitions $Name.align] \ ; } # ::frame $_toplevel.client -borderwidth 0 -relief flat -background white; ::set Parent [::sargs::get $_sargs .parent]; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.1.0,parent==$Parent";} ::frame $Parent.table_frame -borderwidth 0 -relief flat; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.2";} ::set _table $Parent.table_frame.table; ::set _vsb $Parent.table_frame.vsb; ::if {$_horizontal_scrollbar_is_enabled} { ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.3";} ::set _hsb $Parent.table_frame.hsb; ::tablelist::tablelist $_table \ -columns $ColumnOptionList \ -height 5 \ -width 0 \ -background white \ -xscrollcommand [::list $_hsb set] \ -yscrollcommand [::list $_vsb set] \ -tooltipaddcommand [::itcl::code $this tablelist_tooltip_add_callback] \ -tooltipdelcommand DynamicHelp::delete \ ; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.4";} } else { ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.5";} ::tablelist::tablelist $_table \ -columns $ColumnOptionList \ -height 5 \ -width 0 \ -background white \ -yscrollcommand [::list $_vsb set] \ -tooltipaddcommand [::itcl::code $this tablelist_tooltip_add_callback] \ -tooltipdelcommand DynamicHelp::delete \ ; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.6";} } ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.7";} ::ttk::scrollbar $_vsb -orient vertical -command [::list $_table yview]; # ::ttk::scrollbar $_hsb -orient horizontal -command [::list $_table xview]; ::set Col 0; ::foreach Name [::sargs::names .structure $_column_definitions] { $_table columnconfigure $Col -name $Name; ::incr Col 1; } ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.8";} # $_table configure -stretch [::list .percent_done_graph]; ::grid $Parent.table_frame.table -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 $Parent.table_frame 0 -weight 1 ::grid columnconfigure $Parent.table_frame 0 -weight 1 ::grid $Parent.table_frame -row 0 -column 1 -sticky nsew; ::grid rowconfigure $Parent 0 -weight 1; ::grid columnconfigure $Parent 1 -weight 1; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.10";} # ::pack $Parent -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 $_table -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 dump_options {sargs} { ::if {[::winfo exists $_table]} { ::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: [$_table columnconfigure $Name $Option]"; } } } } method row_exists {sargs} { ::set RowId [::sargs::get $sargs .row_id]; ::qw::try { $_table rowcget $RowId -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 [$_table size]; ::for {::set Row 0} {$Row<$Size} {::incr Row} { ::if {$OperationId eq [$_table rowcget $Row -name]} { ::return 1; } } ::return 0; */ } } method field_exists {sargs} { ::set Field [::sargs::get $sargs .field]; ::qw::try { $_table 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 [$_table columncount]; ::for {::set Col 0} {$Col<$Size} {::incr Col} { ::if {$Field eq [$_table columncget $Col -name]} { ::return 1; } } ::return 0; */ } } method field_get {sargs} { /* { */ } ::set rwb1_debug 0; ::set RowId [::sargs::get $sargs .row_id]; ::if {![row_exists $sargs]} { ::qw::bug 314120160316094026 "[::namespace current]::[::qw::methodname] - no row \"$RowId\"."; } ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist,field_set,1000.1";} ::set Field [::sargs::get $sargs .field]; ::if {![field_exists $sargs]} { ::qw::bug 314120160316094027 "[::namespace current]::[::qw::methodname] - no field \"$Field\"."; } ::return [::sargs::get $_data $Field]; } method field_set {sargs} { /* { Note that we update some fields here because they aren't configured very often anyway. But the exception count and and sone count, if configured here are not configured in the tablelist cells. They are instead only updated to the cell once per second. */ } ::set rwb1_debug 0; ::set RowId [::sargs::get $sargs .row_id]; ::if {![row_exists $sargs]} { ::qw::bug 314120160316093505 "[::namespace current]::[::qw::methodname] - no row \"$RowId\"."; } ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist,field_set,1000.1";} ::foreach {Field After} $sargs { ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist,field_set,1000.2";} ::if {[::sargs::exists $_column_definitions $Field]} { ::set FieldType [::sargs::get $_column_definitions $Field.type]; ::switch -- $FieldType { integer { ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist,field_set,1000.3.0,Field==$Field,After==$After";} ::set After [::sargs::get $sargs $Field]; ::sargs::var::set _data($RowId) $Field $After; ::set Formatted [::qw::number::format_whole_number .value $After]; $_table cellconfigure $RowId,$Field -text $Formatted; } "" { ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist,field_set,1000.3.0,Field==$Field,After==$After";} ::set After [::sargs::get $sargs $Field]; ::sargs::var::set _data($RowId) $Field $After; $_table cellconfigure $RowId,$Field -text $After; } default { ::qw::bug 314120160316165447 "[::namespace current]::[::qw::methodname] - invalid field type \"$FieldType\"."; } } } ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist,field_set,1000.3";} } ::if {$rwb1_debug} {::puts "rwb1_debug,tablelist,field_set,1000.99";} } method operation_cget {sargs} { ::set OperationId [::sargs::get $sargs .operation_id]; ::if {$OperationId eq ""} { ::qw::bug 314120090619114947 "Encountered empty \".operation_id\"."; } ::set Field [::sargs::get $sargs .field]; ::if {$Field eq ""} { ::qw::bug 314120090619114948 "Encountered empty \".field\"."; } ::if {[find_row $sargs]<0} { ::return ""; } ::if {[find_col $sargs]<0} { ::return ""; } ::set After [::sargs::get $_data($OperationId) $Field]; ::return $After; } method row_create {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,row_create,1000.0,sargs==\n[::sargs::format $sargs]";} ::set RowId [::sargs::get $sargs .row_id]; ::if {[row_exists .server_node_id $RowId]} { ::qw::bug 314120160304144420 "[::namespace current]::[::qw::methodname] - row already exists for row id \"$RowId\"."; } ::if {$rwb1_debug} {::puts "rwb1_debug,row_create,1000.0";} ::set _data($RowId) $sargs; # $_toplevel.status configure -text [::sargs::get $sargs .status]; ::set RowNumber [$_table size]; $_table insert end [::list]; $_table rowconfigure $RowNumber -name $RowId; ::if {$rwb1_debug} {::puts "rwb1_debug,row_create,1000.1";} ::set Size [$_table columncount]; ::for {::set ColNumber 0} {$ColNumber<$Size} {::incr ColNumber} { ::set Field [$_table columncget $ColNumber -name]; ::set Value [::sargs::get $sargs $Field]; ::if {[field_exists .field $Field]} { $_table cellconfigure $RowId,$Field -text $Value; $_table cellconfigure $RowId,$Field \ -foreground black \ -background white \ -selectforeground white \ ; } } ::if {$rwb1_debug} {::puts "rwb1_debug,row_create,1000.1";} $_table see $RowId; ::if {$rwb1_debug} {::puts "rwb1_debug,row_create,1000.1";} ::raise $_toplevel; } 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 _data($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 $_data($RowId) .tick_handle] ne ""} { ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.3";} ::after cancel [::sargs::get $_data($RowId) .tick_handle]; } */ } ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.4";} ::unset _data($RowId); ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.5";} $_table delete $RowId; ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.6";} $_table 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 {[$_table size]>0} { ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.9";} ::set EndRowId [$_table rowcget -name]; $_toplevel.status configure -text [::sargs::get $_data($EndRowId) .status]; ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.10";} } */ } ::if {$rwb1_debug} {::puts "rwb1_debug,row_destroy,1000.11";} } } # ------------------------------------------------------------ # ::qw::widget3::tablelist # ------------------------------------------------------------ ::proc ::qw::server_hub_table {sargs} { /* { */ } ::return [::qw::widget3::create_helper $sargs .tk_widget_class ::tablelist .widget_class ::qw::server_hub_table_class]; } ::itcl::class ::qw::server_hub_table_class { inherit ::qw::widget3::tablelist_class; method options_set {sargs} { #chain $sargs ::set _column_definitions [::sargs::get $sargs .column_definitions]; ::if {[::sargs::size $_column_definitions]==0} { ::set _column_definitions { .column_definitions { .server_node_id { .name .server_node_id .title_text "NodeId" .align left .width 6 } .server_node_state { .name .server_node_state .title_text "State" .align left .width 20 } .database_path { .name .database_path .title_text "Path" .align left .width 35 } .server_node_nv2_port_number { .name .port_number .title_text "Port No" .align left .width 6 } .server_node_nv2_hostname { .name .port_number .title_text "Hostname" .align left .width 25 } .server_node_ping_count { .name .server_node_ping_count .title_text "Pings" .align left .width 10 } } } } } method options_get {} { ::return [::sargs \ .column_definitions $_column_definitions \ ]; /* { ::if {[::winfo exists $_toplevel]} { ::foreach Name [::sargs::names .structure $_column_definitions] { ::sargs::var::set _column_definitions $Name.width [$_table columncget $Name -width]; } } */ } } } ::proc ::qw::server_hub_toplevel {sargs} { ::set Result [::qw::dialog3::create_helper $sargs .prompt_class ::qw::server_hub_toplevel_class]; ::return $Result; } ::itcl::class ::qw::server_hub_toplevel_class { /* { This toplevel only has a tablelist widget in it to display the server_hub information. - options This widget would not know where to load or store options. It can load them or store them on request. The server_hub should keep a list of server_hub toplevels and store the options for them. You can derive toplevels that do know where to store their options an we could do that if we know there would be only one server_hub toplevel. */ } inherit ::qw::widget3::toplevel; protected variable _server_node_table ""; protected variable _server_hub ""; # displaying this server_hub constructor {} { } destructor { ::incr ::qw::control(window_kickout_is_enabled) -1; options_store; ::foreach OperationId [::array names _data] { ::if {[::sargs::get $_data($OperationId) .tick_handle] ne ""} { ::after cancel [::sargs::get $_data($OperationId) .tick_handle]; } } } method sargs_setup {} { #::qw::server_hub_progress #chain; ::sargs::var::+= _sargs { .title "Server Nodes" .text "" .resize_is_enabled 1 }; # ::sargs::var::set _sargs .image_path [::file join $::qw_library system images info.gif]; } method client_setup {} { chain; ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,server_node_dialog,client_setup,1000.0";} ::set _server_node_table [::qw::server_node_table .parent $_toplevel.client]; ::if {$rwb1_debug} {::puts "rwb1_debug,server_node_dialog,client_setup,1000.1";} $_server_node_table client_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,server_node_dialog,client_setup,1000.2";} } /* { method inners_create {} { ::set _server_node_table [::qw::server_node_table]; } */ } method options_file {} { ::return [::file join $::qw_program_folder nv2.dat system server_hub_table.qw_options]; } method options_set {sargs} { chain $sargs; $_server_node_table options_set [::sargs::get $sargs .server_node_table]; } method options_get {} { ::set Options [chain]; ::sargs::var::set Options .server_node_table [$_server_node_table options_get]; ::return $Options; } method options_load {} { /* { These should be moved to root dialog3. */ } ::set File [options_file]; ::if {$File ne ""} { ::set Options [::sargs::file::get $File]; options_set $Options; } } method options_store {} { ::set File [options_file]; ::if {$File ne ""} { ::set Options [options_get]; ::sargs::var::set Options .qw_release $::qw_release; /* { ::if {[::winfo exists $_toplevel]} { ::sargs::var::set Options .toplevel.geometry [::wm geometry $_toplevel]; } */ } ::sargs::file::set $File $Options; } } }