# ------------------------------------------------------------ # Copyright (c) 2015-2016 # Q.W.Page Associates Inc. # www.qwpage.com # All rights reserved. # ------------------------------------------------------------ /* { changes to qw_dialog85 - dialogs names are tk dot-compliant - tool tips supplied in sargs - help supplied in sargs - buttons are supplied in sargs - optional html body text todo - scrolled html - scrollbars don't appear until you shake it - put has_help or equivalent back in - get rid of .tooltip_get_callback Architecture ------------ First we design some pick dialogs, all derived from qw::dialog::modal. These are used to pick a date, file, pre-defined list, etc. Then we have a set of entry widgets, derived from ::qw::entry3::widget. Each collects a specific type. Then we have ::qw::dialog3::mru_list. This collects a single field, using an entry based on a field type argument. It will be used to replace the call to qw::dialog85::mru_list in edit_assist_item. */ } ::package require qw::winutil; /* { 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::dialog3 {}; ::proc ::qw::dialog3::create_helper {sargs} { /* { Flynt notes 20160322 -------------------- page 509 (1) ::label .l -text "original" (2) ::rename .l ::my_label; (3) ::pack .l; (4) ::my_label configure -text "new text"; (1) creates tk widget with name ".l" and also command ".l". (2) changes the widget command but leaves it's name as ".l". (3) proves the widget name is still ".l". (4) proves the widget command is ::my_label. 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 TkPath [::sargs::get $sargs .tkpath]; ::set PromptClass [::sargs::get $sargs .prompt_class]; ::set Unique 0; ::if {$TkPath eq ""} { ::while {[::winfo exists .qw_dialog3_$Unique]} { /* { Generate non-existing name for the toplevel. */ } ::incr Unique; } ::set TkPath .qw_dialog3_$Unique; } ::set Toplevel [::uplevel ::toplevel $TkPath]; ::uplevel #0 ::rename $TkPath $TkPath.toplevel; ::set Dialog [::namespace eval :: [::list $PromptClass $TkPath]]; ::if {[::sargs::boolean_get $sargs .is_modeless]} { $Dialog main $sargs .toplevel $Toplevel; ::return $Dialog; } ::set Result [$Dialog main $sargs .toplevel $Toplevel;] ::return $Result; } ::itcl::class ::qw::dialog3::modal { /* { You can derive from this class or else copy it and fill it in. The former is recommended but the latter is has its uses. One example is the error dialog which has this form but must be defined very early in the boot process. Another is when this is a good starting point but you really need significant modification. _sargs These are the options, merged with the incoming arguments. They are set up in sargs_setup. _dialog_result This is the wait variable. Assigning to this variable causes the dialog to be destroyed and the value that was assigned to this variable is returned as the result of the dialog. Note that some dialogs like notify don't need to return a result, but assigning something to this variable will still destroy the dialog. _toplevel The dialog is a toplevel widget, i.e. the path of the tk toplevel. It is created in toplevel_setup and is assigned to the _toplevel variable. The itcl object that contains the toplevel is not a widget. It's just a regular itcl object. We don't try to get fancy hear and attempt to create a mega-widget object that has a Tk path. That's the root cause of the complications of iTk and Snit. It's not necessary here. */ } protected variable _sargs ""; # original sargs but modified by script at will ::if {!$::qw::control(qw_dialog3_sargs_setup_fix)} { /* { 2.33.2 seems like we never actaully used this */ } protected variable _sargs_before ""; # original arguments passed to script } protected variable _dialog_result "seed"; # modal dialog waits on this and returns it as value 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 _previous_focus_widget ""; # 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,this==$this,_toplevel==$_toplevel";} ::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; } # ------------------------------------------------------------ # clean up the tooltips # ------------------------------------------------------------ ::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; } # ------------------------------------------------------------ # clean up the image array # ------------------------------------------------------------ ::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,_previous_focus_widget==$_previous_focus_widget";} # ------------------------------------------------------------ # raise the previous focus window # ------------------------------------------------------------ ::if {[::winfo exists $_previous_focus_widget]} { ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.6";} ::set Toplevel [::winfo toplevel $_previous_focus_widget]; ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.7,Toplevel==$Toplevel";} ::wm deiconify $Toplevel; ::raise $Toplevel; ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.8";} } ::if {$rwb1_debug} {::puts "rwb1_debug,dialog3::destructor,1000.99";} } method main {sargs} { #::qw::dialog3::modal /* { 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; ::set _previous_focus_widget [::focus]; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.0,_previous_focus_widget==$_previous_focus_widget"} ::if {$::qw::control(qw_dialog3_sargs_setup_fix)} { /* { user_setup may set _database and related member variables, which may be needed later by options_load because the database may have the options. */ } sargs_setup; ::sargs::var::+= _sargs $sargs; user_setup; options_load; boot_check; } else { /* { 2.33.2 seems like we never actuslly used _sargs_before - also moved options load to after user_setup because options_load might need _database which may be set in user_setup. */ } ::set _sargs_before $sargs; sargs_setup; options_load; ::sargs::var::+= _sargs $sargs; boot_check; user_setup; } /* { sargs_setup; ::if {$::qw::control(qw_dialog3_sargs_setup_fix)} { /* { 2.33.2 - moved from below */ } ::sargs::var::+= _sargs $sargs; # moved from below } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.1,sargs==\n[::sargs::format $sargs]"} ::if {$::qw::control(qw_dialog3_sargs_setup_fix)} { /* { 2.33.2 - moved from below, need this before options_load because options_load might need _database. */ } ::sargs::var::+= _sargs $sargs; # moved from below } options_load; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.1.0"} ::if {!$::qw::control(qw_dialog3_sargs_setup_fix)} { /* { 2.33.2 - moved above */ } ::sargs::var::+= _sargs $sargs; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.2,_sargs==\n[::sargs::format $_sargs]"} boot_check; ::if {!$::qw::control(qw_dialog3_sargs_setup_fix)} { /* { 2.33.2 - moved above to before options_load */ } user_setup; } */ } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.3"} toplevel_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.4"} menu_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.5"} toolbar_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.6"} control_button_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.7"} icon_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.8"} client_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.9"} popup_menu_setup; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.10"} #initialize; # initialize_after_idle has taken over ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.11"} ::if {[::sargs::boolean_get $sargs .is_modeless]} { ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.12"} ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.13"} ::if {![::sargs::boolean_get $sargs .is_modeless]} { #2.33.0 - added modeless for notify because of database_utilities_paf wait; } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.14"} ::set Result $_dialog_result; ::if {[::qw::command_exists $this]} { ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.15"} ::itcl::delete object $this; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.16"} } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog3::main,1000.99,result==$Result"} ::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_old system .text_font "-family Helvetica -size 12 -weight normal" .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. */ } # ------------------------------------------------------------ # tooltips # ------------------------------------------------------------ ::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%]; # ------------------------------------------------------------ # 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 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; ::set Geometry [::sargs::get $_sargs .geometry]; ::if {$Geometry ne ""} { ::wm geometry $_toplevel $Geometry; } /* { ::if {[::sargs::get $_sargs width] ne ""} { /* { I believe a frame doesn't have a -width option ??? */ } $_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_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 dialog_dismiss]; ::bind $_toplevel [::itcl::code $this dialog_help] ::bind $_toplevel [::itcl::code $this dialog_dismiss]; ::bind $_toplevel [::itcl::code $this dialog_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 ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.0";} ::ttk::frame $_toplevel.client; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.1";} ::pack $_toplevel.client -side top -expand 1 -fill both; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.2";} /* { 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; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.3";} /* { 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; } ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.4";} ::switch -- $TextType { text { ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.5";} ::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; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.6";} ::return; } html { ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.7";} ::package require Tkhtml 3.0; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.8";} ::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]; } ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.9";} ::set Body "$Body"; ::ttk::frame $_toplevel.client.html_frame; # needed for scrollbars ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.10";} ::set _html $_toplevel.client.html_frame.html; ::set _hsb $_toplevel.client.html_frame.hsb; ::set _vsb $_toplevel.client.html_frame.vsb; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.11";} ::if {0} { ::html $_html \ -width $Width \ -height $Height \ -xscrollcommand [::list $_hsb set] \ -yscrollcommand [::list $_vsb set] \ ; } ::if {1} { ::html $_html \ -shrink 1 \ -xscrollcommand [::list $_hsb set] \ -yscrollcommand [::list $_vsb set] \ ; } ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.12";} ::ttk::scrollbar $_vsb -orient vertical -command [::list $_html yview]; ::ttk::scrollbar $_hsb -orient horizontal -command [::list $_html xview]; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.13";} $_html style [::subst -nocommands { html { background: $::qw::platform_dependent_color(SystemButtonFace); font-family: Helvetica; padding: 5px; } }]; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.14";} $_html parse -final $Body; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.15.0";} # ::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 ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.15.1";} # ::pack $_toplevel.client -side top -expand 1 -fill both ::grid $_html $_vsb -sticky nsew; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.15.2";} ::grid $_hsb -sticky nsew; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.15.3";} # ::grid rowconfigure $_toplevel.client.html_frame $_html -weight 1; ::grid rowconfigure $_html 0 -weight 1; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.15.4";} # ::grid columnconfigure $_toplevel.client.html_frame $_html -weight 1; ::grid columnconfigure $_html 0 -weight 1; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.16";} ::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]; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.17";} ::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.control_button, 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; ::return; } .dismiss { dialog_dismiss; ::return; } .ok { dialog_ok; ::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 {} { /* { 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 Formatter [::qw::html::formatter #auto]; # ::qw::finally [::list ::itcl::delete object $Formatter]; ::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_dismiss {sargs} { #::qw::dialog3::modal ::set _dialog_result ""; } method dialog_exit {sargs} { #::qw::dialog3::modal ::set _dialog_result ""; } method application_exit {sargs} { #::qw::dialog3::modal } } ::proc ::qw::dialog3::set_button_list_bindings {sargs} { /* { .button_list - a list of buttons in the order we want the navigation keys. This proc simply sets up a few bindings on a set of buttons such as control buttons so that navigation keys work on them as expected. */ } ::set ButtonList [::sargs::get $sargs .button_list]; ::set Size [::llength $ButtonList]; ::if {$Size<2} { /* { If there are only 0 or 1 buttons then what's the point? Also, makes logic trivial when we know there are at least 2 buttons. */ } ::return; } ::set Last [::expr {$Size-1}]; ::set i 0; ::foreach Button $ButtonList { ::if {$i==0} { ::set Next [::lindex $ButtonList [::expr {$i+1}]]; ::set Prev [::lindex $ButtonList end]; } elseif {$i==$Last} { ::set Next [::lindex $ButtonList 0]; ::set Prev [::lindex $ButtonList [::expr {$i-1}]]; } else { ::set Next [::lindex $ButtonList [::expr {$i+1}]]; ::set Prev [::lindex $ButtonList [::expr {$i-1}]]; } ::bind $Button [::list ::focus $Next]; ::bind $Button [::list ::focus $Next]; ::bind $Button [::list ::focus $Prev]; ::bind $Button [::list ::focus $Prev]; ::bind $Button [::list $Button invoke]; ::bind $Button [::list $Button invoke]; ::incr i; } } # ------------------------------------------------------------ # ::qw::dialog3::notify # ------------------------------------------------------------ ::proc ::qw::dialog3::notify {sargs} { ::return [::qw::dialog3::create_helper $sargs .prompt_class ::qw::dialog3::notify1]; } ::itcl::class ::qw::dialog3::notify1 { /* { */ } inherit ::qw::dialog3::modal; method sargs_setup {} { #::qw::dialog3::notify chain; ::sargs::var::+= _sargs { .title "Notification" .text "" .resize_is_enabled 0 .minsize_is_enabled 0 .is_modeless 0 .control_button { .help { .text "Help" .tooltip { .text "(F1) - Help on this dialog." } } .dismiss { .text "Dismiss" .tooltip { .text "(Esc) - Dismiss this dialog." } .value "" } } .default_focus_widget .control_button.dismiss }; ::sargs::var::set _sargs .image_path [::file join $::qw_library system images info.gif]; } method toplevel_setup {} { #::qw::dialog3::notify # 2.34.0 chain; /* { Already have and bound to dismiss. But also makes sense for a notify. */ } ::bind $_toplevel [::itcl::code $this dialog_dismiss]; } method dialog_dismiss {} { #::qw::dialog3::notify ::if {[::sargs::get $_sargs .is_modeless]} { # 2.33.0 ::itcl::delete object $this; ::return "" } ::return [chain]; } } # ------------------------------------------------------------ # ::qw::dialog3::confirm # ------------------------------------------------------------ ::proc ::qw::dialog3::confirm {sargs} { ::return [::qw::dialog3::create_helper $sargs .prompt_class ::qw::dialog3::confirm1]; } ::itcl::class ::qw::dialog3::confirm1 { /* { */ } inherit ::qw::dialog3::modal; method sargs_setup {} { #::qw::dialog3::confirm chain; ::sargs::var::+= _sargs { .text "Please confirm." .title "Please confirm." .control_button { .help { .text "Help" .tooltip { .text "(F1) - Help on this dialog." } } .dismiss { .text "Dismiss" .tooltip { .text "(Esc) - Dismiss this dialog." } .value 0 } .ok { .text "Ok" .tooltip { .text "(Enter) - Confirm the message or operation." } .value 1 } } .default_focus_widget .control_button.ok }; ::sargs::var::set _sargs .image_path [::file join $::qw_library system images question.gif]; } method dialog_ok {} { ::set _dialog_result 1; } method toplevel_setup {} { #::qw::dialog3::confirm # 2.38.5 - added this method to make return key work chain; ::bind $_toplevel [::itcl::code $this dialog_ok]; } method dialog_dismiss {} { ::set _dialog_result 0; } } # ------------------------------------------------------------ # ::qw::dialog3::multiple_choice_buttons # ------------------------------------------------------------ ::proc ::qw::dialog3::multiple_choice_buttons {sargs} { ::return [::qw::dialog3::create_helper $sargs .prompt_class ::qw::dialog3::multiple_choice_buttons1] } ::itcl::class ::qw::dialog3::multiple_choice_buttons1 { /* { The cancel and help buttons are pre-installed. Cancel always returns empty. You can return empty for a button but if you do, the caller will treat it like an escape/abort. .control_button { .choice1 { .text "Choose 1" .value "your_result_for_1" .tooltip { .text "This will perform operation 1" } } .choice2 { .text "Choose 2" .value "your_result_for_2" .tooltip { .text "This will perform operation 2" } } } */ } inherit ::qw::dialog3::modal; method sargs_setup {} { #::qw::dialog3::multiple_choice_buttons_dialog chain; ::sargs::var::+= _sargs { .text "Pick a button" .title "Pick a Button" .control_button { .help { .text "Help" .tooltip { .text "(F1) - Help on this dialog." } } .dismiss { .text "Dismiss" .tooltip { .text "(Esc) - Dismiss this dialog." } } } } ::sargs::var::set _sargs .image_path [::file join $::qw_library system images question.gif]; } 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";} ::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";} ::return [chain $sargs]; } } # ------------------------------------------------------------ # ::qw::dialog3::date # ------------------------------------------------------------ ::proc ::qw::dialog3::date {sargs} { ::return [::qw::dialog3::create_helper $sargs .prompt_class ::qw::dialog3::date1] } ::itcl::class ::qw::dialog3::date1 { /* { Notes: Turned off ability to re-size window. It's not necessary. If we turn it back on then we should save the size in options. I might want to use a canvas before allowing a resize. - bbox - help - mru list - entry widget (maybe) - make underlying nv windows reappear when dialog toplevel raised or clicked - use a "real" toolbar - maybe use tk options database - save options such as window size */ } inherit ::qw::dialog3::modal; protected variable _active_date ""; protected variable _active_time ""; protected variable _maximum_day_number [::qw::date::to_number day 20361231]; protected variable _minimum_day_number [::qw::date::to_number day 19040101]; method sargs_setup {} { #::qw::dialog3::date chain; ::set _sargs { .title "Pick Date" .bbox "" .control_button { .help { .text "Help" .tooltip { .text "(F1) - Help on this dialog." } } .dismiss { .text "Dismiss" .tooltip { .text "(Esc) - Dismiss this dialog." } .value "" } .mru_list { .text "Recent List" .tooltip { .text "Most recently used dates and/or calendar." } } .ok { .text "Ok" .tooltip { .text "Pick the current date." } } } .help_id "" .help_page "" .weekday { .foreground black .background mistyrose2 } .weekend { .foreground black .background mistyrose3 } .not_in_month { .foreground black .background grey80 } .not_valid { .foreground black .background white } .active { .foreground white .background blue } .calendar { .title { .text "Pick Date" .font "-family Arial -size 12 -weight normal" .format "%a %b %d %Y" } .width 1.8i .height 1.2i .date { .font "-family Arial -size 10 -weight normal" .format "%d" } } .days {sun mon tue wed thu fri sat} .default {} .default_focus_widget .control_button.ok } ::set _active_date [::sargs::get $_sargs .default]; ::if {$_active_date eq ""} { ::set _active_date [::qw::date::from_number clock_second [::clock seconds]]; } ::if {[::string length $_active_date]>8} { ::set _active_time [::string range $_active_date 8 13]; ::set _active_date [::string range $_active_date 0 7]; } } method toolbar_setup {} { #::qw::dialog3::date chain; ::frame $_toplevel.toolbar_frame; ::set ButtonList [::list \ {.text "< Y" .button year_prev .command command_year_prev} \ {.text "< M" .button month_prev .command command_month_prev} \ {.text "M >" .button month_next .command command_month_next} \ {.text "Y >" .button year_next .command command_year_next} \ ]; ::set Width 0; ::foreach s $ButtonList { /* { Make the toolbar button as wide as it's longest text line. */ } ::set Text [::sargs::get $s .text]; ::if {[::string length $Text]>$Width} { ::set Width [::string length $Text]; } } ::foreach s $ButtonList { /* { */ } ::set Button [::sargs::get $s .button]; ::button $_toplevel.toolbar_frame.$Button \ -text [::sargs::get $s .text] \ -width $Width \ -font {-family Arial -size 8 -weight normal} \ -relief ridge \ -overrelief raised \ -borderwidth .25m \ -command [::itcl::code $this command_process .command [::sargs::get $s .command] .bbox_widget $_toplevel.toolbar_frame.${Button}] \ ; # ::pack $_toplevel.toolbar_frame.${Button} -fill y -side left -padx 2 -pady 2; } ::pack $_toplevel.toolbar_frame.year_prev -fill y -side left -padx 2 -pady 2; ::pack $_toplevel.toolbar_frame.month_prev -fill y -side left -padx 2 -pady 2; ::pack $_toplevel.toolbar_frame.year_next -fill y -side right -padx 2 -pady 2; ::pack $_toplevel.toolbar_frame.month_next -fill y -side right -padx 2 -pady 2; ::pack $_toplevel.toolbar_frame -side top -fill x; } method dialog_control_button_process {sargs} { #::qw::dialog3::date ::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 { .mru_list { } .ok { dialog_ok; ::return; } } ::return [chain $sargs]; } method dialog_ok {sargs} { #::qw::dialog3::date ::set _dialog_result [::sargs \ .result [::string range [active_date_get] 0 7] \ ]; } method client_setup {sargs} { #::qw::dialog3::date chain; ::button $_toplevel.client.title \ -font "-family Arial -size 10 -weight normal" \ -text none \ -relief solid \ -borderwidth 0 \ -command [::itcl::code $this command_process .command command_ok] \ ; ::canvas $_toplevel.client.canvas \ -width [::sargs::get $_sargs .calendar.width] \ -height [::sargs::get $_sargs .calendar.height] \ ; ::bind $_toplevel.client.canvas [::itcl::code $this canvas_draw]; ::bind $this [::itcl::code $this dialog_ok]; /* { Next line had to be removed when we added year/month prev/next buttons. Clicking too fast on those buttons resulted in a double-click and hence premature selection. Now attach binding to the day buttons. */ } # ::frame $_toplevel.client.table_frame.table; #::bind $this [::itcl::code $this pick]; ::pack $_toplevel.client.title -side top -fill x; ::pack $_toplevel.client.canvas -fill both -expand 1; # ::pack $_toplevel.client -side top -fill both -expand 1; ::bind $_toplevel [::itcl::code $this calendar_year_prev]; ::bind $_toplevel [::itcl::code $this calendar_year_next]; ::bind $_toplevel [::itcl::code $this calendar_week_prev]; ::bind $_toplevel [::itcl::code $this calendar_week_next]; ::bind $_toplevel [::itcl::code $this calendar_day_prev]; ::bind $_toplevel [::itcl::code $this calendar_day_next]; ::bind $_toplevel [::itcl::code $this calendar_month_prev]; ::bind $_toplevel [::itcl::code $this calendar_month_next]; ::bind $_toplevel [::itcl::code $this calendar_week_prev]; ::bind $_toplevel [::itcl::code $this calendar_week_next]; ::bind $_toplevel [::itcl::code $this calendar_day_prev]; ::bind $_toplevel [::itcl::code $this calendar_day_next]; ::bind $_toplevel [::itcl::code $this calendar_month_prev]; ::bind $_toplevel [::itcl::code $this calendar_month_next]; ::bind $_toplevel [::itcl::code $this calendar_month_day_first]; ::bind $_toplevel [::itcl::code $this calendar_month_day_last]; ::bind $_toplevel [::itcl::code $this calendar_year_day_first]; ::bind $_toplevel [::itcl::code $this calendar_year_day_last]; # ::bind $_toplevel [::itcl::code $this dialog_exit]; # ::bind $_toplevel [::itcl::code $this dialog_help_display]; ::bind $_toplevel [::itcl::code $this dialog_help_display]; # ::bind $_toplevel [::itcl::code $this dialog_exit]; # ::bind $_toplevel [::itcl::code $this dialog_exit]; /* { ::foreach {Sequence Command} { calendar_year_prev calendar_year_next calendar_week_prev calendar_week_next calendar_day_prev calendar_day_next calendar_month_prev calendar_month_next calendar_week_prev calendar_week_next calendar_day_prev calendar_day_next calendar_month_prev calendar_month_next calendar_month_day_first calendar_month_day_last calendar_year_day_first calendar_year_day_last dialog_exit dialog_help_display dialog_help_display dialog_exit dialog_exit } { ::bind $_toplevel $Sequence [::itcl::code $this $Command]; } */ } /* { We bind to the canvas and not the toplevel because the toplevel receives everything and that includes the toolbar and control buttons. We only want the double-click to work on the canvas area. */ } ::bind $_toplevel.client.canvas [::itcl::code $this dialog_ok]; ::bind $_toplevel [::itcl::code $this dialog_ok]; } method control_button_setup {} { #::qw::dialog3::date chain; ::set MruList [::sargs::get $_sargs .mru_list]; ::if {![::sargs::boolean_get $_sargs .mru_list_is_enabled]||[::llength $MruList]==0} { ::if {[::winfo exists $_toplevel.control_button.mru_list]} { ::pack forget $_toplevel.control_button.mru_list; } } } method tooltip_get {sargs} { #::qw::dialog85::date_dialog ::set Widget [::sargs::get $sargs .widget]; ::set Text ""; ::switch -glob -- $Widget { *.toolbar_frame.year_prev { ::append Text "Move back one year."; ::append Text "\nCtrl-PgUp -> move back one year."; ::append Text "\nCtrl-Home -> move to first day of this year."; ::return [::sargs .text $Text]; } *.toolbar_frame.year_next { ::append Text "Move ahead one year."; ::append Text "\nCtrl-PgDn -> move ahead one year."; ::append Text "\nCtrl-End -> move to last day of this year."; ::return [::sargs .text $Text]; } *.toolbar_frame.month_prev { ::append Text "Move back one month."; ::append Text "\nPgUp -> move back one month."; ::append Text "\nHome -> move to first day of this month."; ::return [::sargs .text $Text]; } *.toolbar_frame.month_next { ::append Text "Move ahead one month."; ::append Text "\nPgDn -> move ahead one month."; ::append Text "\nEnd -> move to last day of this month."; ::return [::sargs .text $Text]; } *.buttons.ok { ::append Text "Pick the date."; ::append Text "\n(Enter)"; ::return [::sargs .text $Text]; } *.buttons.dismiss - *.menubar.file.exit { ::append Text "Dismiss without picking a date."; ::append Text "\n(Esc)"; ::return [::sargs .text $Text]; } *.buttons.help - *.menubar.help.export { ::append Text "Help on date dialog."; ::append Text "\n(F1)"; ::return [::sargs .text $Text]; } } ::return [chain $sargs]; } method font_scale {sargs} { #::qw::dialog85::date_dialog ::set Font [::sargs::get $sargs .font]; ::return $Font; ::if {!$_resize_is_enabled} { ::return $Font; } ::set Scale 0.04; # was 0.05 for title font; ::array set FontArray $Font; ::set FrameHeight [::winfo height $_toplevel.client.canvas]; ::set Size [::expr {int(double($FrameHeight)*$Scale)}]; ::if {$Size==0} { ::set Size 1; } ::set FontArray(-size) $Size; ::return [::array get FontArray]; } method border_scale {sargs} { #::qw::dialog85::date_dialog ::set Size [::sargs::get $sargs .border_size]; ::return $Size; ::if {!$_resize_is_enabled} { ::return 1; } ::set BorderWidth [::sargs::get $sargs .border_size]; ::set ScaleFactor [::sargs::get $sargs .scale_factor]; ::if {$ScaleFactor eq ""} { ::set ScaleFactor 1.0; } ::set Scale [::expr {0.010*$ScaleFactor}]; ::set FrameHeight [::winfo height $_toplevel.client]; ::set Size [::expr {int(double($FrameHeight)*$Scale)}]; ::if {$Size==0} { ::set Size 1; } ::return $Size; } method canvas_draw {} { #::qw::dialog85::date_dialog $_toplevel.client.canvas delete all; ::set CanvasWidth [::winfo width $_toplevel.client.canvas]; ::set CanvasHeight [::winfo height $_toplevel.client.canvas]; ::if {$_active_date eq ""||$_active_date=="0"} { ::set _active_date [::qw::date::from_number clock_second [::clock seconds]]; } $_toplevel.client.title configure \ -text [::qw::date::format $_active_date [::sargs::get $_sargs .calendar.title.format]] \ -font [font_scale .font [::sargs::get $_sargs .calendar.title.font]] \ -borderwidth 0 \ -cursor arrow \ ; ::set DaysInMonth [::qw::date::get $_active_date days_in_month]; ::set FirstDayOfMonth [::qw::date::set $_active_date day 1]; ::set FirstDayOfWeek [::qw::date::get $FirstDayOfMonth day_of_week]; ::set FirstDayNumber [::qw::date::to_number day $FirstDayOfMonth]; ::set LastDayNumber [::expr {$FirstDayNumber+$DaysInMonth-1}]; ::for {::set i 0;::set DayNumber [::expr {$FirstDayNumber-$FirstDayOfWeek}];} {$i<42} {::incr i;::incr DayNumber} { ::set Row [::expr {$i/7}]; ::set Col [::expr {$i%7}]; ::set x0 [::expr {$Col*($CanvasWidth-7)/7+3}]; ::set y0 [::expr {$Row*($CanvasHeight-6)/6+3}]; ::set x1 [::expr {($Col+1)*($CanvasWidth-7)/7+3}]; ::set y1 [::expr {($Row+1)*($CanvasHeight-6)/6+3}]; ::if {$DayNumber<$_minimum_day_number||$DayNumber>$_maximum_day_number} { ::set Type .not_valid; ::continue } ::set Date [::qw::date::from_number day $DayNumber]; ::if {$Date eq $_active_date||![::qw::date::difference $Date $_active_date day]} { ::set Type .active; # ::focus $_toplevel.client.table.$i; # focus; } else { ::if {$DayNumber>=$FirstDayNumber&&$DayNumber<=$LastDayNumber} { ::if {$i%7==0||$i%7==6} { ::set Type .weekend; } else { ::set Type .weekday; } } else { ::set Type .not_in_month; } } $_toplevel.client.canvas create rectangle \ $x0 $y0 $x1 $y1 \ -outline [::sargs::get $_sargs $Type.foreground] \ -fill [::sargs::get $_sargs $Type.background] \ -tags [::list date_button-$Date date_buttons_all] \ ; $_toplevel.client.canvas create text \ [::expr {$x0+4}] [::expr {$y0+2}] \ -anchor nw \ -fill [::sargs::get $_sargs $Type.foreground] \ -font [::sargs::get $_sargs .calendar.date.font] \ -text [::qw::date::format $Date [::sargs::get $_sargs .calendar.date.format]] \ -tags [::list date_button-$Date date_buttons_all] \ ; $_toplevel.client.canvas bind date_button-$Date \ [::itcl::code $this active_date_set .date $Date] \ ; } } method active_date_get {} { #::qw::dialog85::date_dialog ::if {$_active_date eq ""} { ::return ""; } ::return $_active_date$_active_time; } method active_date_set {sargs} { #::qw::dialog85::date_dialog ::set Date [::sargs::get $sargs .date]; ::if {$Date eq $_active_date} { ::return; } ::set DayNumber [::qw::date::to_number day $Date]; ::if {$DayNumber>$_maximum_day_number} { ::set Date [::qw::date::from_number day $_maximum_day_number]; } ::if {$DayNumber<$_minimum_day_number} { ::set Date [::qw::date::from_number day $_minimum_day_number]; } /* { ::if {[option_get .ok.command] ne ""} { ::eval [option_get .ok.command]; } */ } # ::if {[option_get .select.command] ne ""} { # ::eval [option_get .select.command]; # } ::set _active_date $Date; canvas_draw; } method dialog_help_page {sargs} { #::qw::dialog85::date_dialog /* { The caller can provide a help page. */ } ::set HelpPage { .title "Date Pick Dialog" .id 314120111221155438 .tags "dialog" .body { [h2 "How to pick a date."] [p { You are being prompted to pick a date. Navigate to the desired date and double-click on it. You can also press the [qw_key Enter] key, or click the [qw_button [qw_s_args .ok_button.text]] button. }] [h2 "Navigating in the date dialog."] [p { Use the arrow keys to move around within a month. If you move to a date that isn't in the current month, the month will automatically change. }] [p { Use [qw_key PgUp][bold /][qw_key PgDn] to move back/ahead by a month. You can also use the corresponding toolbar buttons. }] [p { Use [qw_key Ctrl-PgUp][bold /][qw_key Ctrl-PgDn] to move back/ahead by a year. You can also use the corresponding toolbar buttons. }] [p { Use [qw_key Home][bold /][qw_key End] to move to the first/last day of the current month. }] [p { Use [qw_key Ctrl-Home][bold /][qw_key Ctrl-End] to move to the first/last day of the current year. }] [h2 "How to exit without picking a date."] [p { Click [qw_button [qw_s_args .dismiss_button.text]] or press [qw_key Esc] to dismiss the date dialog without picking a date. }] [h2 "Limitations"] [p { The calendar is currently limited to the date range Jan 01, 1904 to Dec 31, 2036. This limitation will eventually be eliminated. }] } } ::sargs::var::set HelpPage .ok_button.text [::sargs::get $_sargs .ok_button.text]; ::sargs::var::set HelpPage .dismiss_button.text [::sargs::get $_sargs .dismiss_button.text]; ::sargs::var::set HelpPage .help_button.text [::sargs::get $_sargs .help_button.text]; } method dialog_draw {} { draw; ::return; } method calendar_week_prev {} { active_date_set .date [::qw::date::add $_active_date day -7]; canvas_draw; ::return; } method calendar_week_next {} { active_date_set .date [::qw::date::add $_active_date day 7]; canvas_draw; ::return; } method calendar_day_prev {} { active_date_set .date [::qw::date::add $_active_date day -1]; canvas_draw; ::return; } method calendar_day_next {} { active_date_set .date [::qw::date::add $_active_date day 1]; canvas_draw; ::return; } method calendar_year_prev {} { ::set Date [::qw::date::add $_active_date year -1]; ::if {[::qw::date::get $_active_date "day"]==[::qw::date::get $_active_date days_in_month]} { ::set Date [::qw::date::set $Date day [::qw::date::get $Date days_in_month]]; } active_date_set .date $Date; canvas_draw; ::return; } method calendar_year_next {} { ::set Date [::qw::date::add $_active_date year 1]; ::if {[::qw::date::get $_active_date "day"]==[::qw::date::get $_active_date days_in_month]} { ::set Date [::qw::date::set $Date day [::qw::date::get $Date days_in_month]]; } active_date_set .date $Date; canvas_draw; ::return; } method calendar_month_prev {} { ::set Date [::qw::date::add $_active_date month -1]; ::if {[::qw::date::get $_active_date "day"]==[::qw::date::get $_active_date days_in_month]} { ::set Date [::qw::date::set $Date day [::qw::date::get $Date days_in_month]]; } active_date_set .date $Date; canvas_draw; ::return; } method calendar_month_next {} { ::set Date [::qw::date::add $_active_date month 1]; ::if {[::qw::date::get $_active_date "day"]==[::qw::date::get $_active_date days_in_month]} { ::set Date [::qw::date::set $Date day [::qw::date::get $Date days_in_month]]; } active_date_set .date $Date; canvas_draw; ::return; } method calendar_month_day_first {} { active_date_set .date [::qw::date::set $_active_date day 1]; canvas_draw; ::return; } method calendar_month_day_last {} { active_date_set .date [::qw::date::set $_active_date day [::qw::date::get $_active_date days_in_month]]; canvas_draw; ::return; } method calendar_year_day_first {} { active_date_set .date [::string range $_active_date 0 3]0101; canvas_draw; ::return; } method calendar_year_day_last {} { active_date_set .date [::string range $_active_date 0 3]1231; canvas_draw; ::return; } } # ------------------------------------------------------------ # ::qw::dialog3::file # ------------------------------------------------------------ #@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ::proc ::qw::dialog3::file {sargs} { ::return [::qw::dialog3::create_helper $sargs .prompt_class ::qw::dialog3::file1] } ::itcl::class ::qw::dialog3::file1 { /* { todo - return key - see not working in tcl 8.4 - should use mru_list - better tooltips */ } inherit ::qw::dialog3::modal; # protected variable _root_folder ""; protected variable _treeview ""; # protected variable _drive_list [::list]; # protected variable _view "details"; protected variable _view "none"; protected variable _node_array; /* { _node_array We keep various info in here. Note that you can also keep info in the columns (whether displayed or not) but we elect not to do that. .file_path - absolute path, case sensitive .node_id - lower cased absolute path and the _node_array index .file_size - size of file, files only .file_type - directory/file */ } method constructor {} { ::array set _node_array {}; } method sargs_setup {} { #::qw::dialog3::file chain; ::sargs::var::+= _sargs { .title "Pick File" .bbox "" .resize_is_enabled 1 .minsize_is_enabled 1 .control_button { .help { .text "Help" .tooltip { .text "(F1) - Help on this dialog." } } .dismiss { .text "Dismiss" .tooltip { .text "(Esc) - Dismiss this dialog." } } .mru_list { .text "Recent List" .tooltip { .text "Most recently selected files." } } .ok { .text "Ok" .tooltip { .text "Pick the current file." } } } .help_id "" .help_page "" .default {} .default_focus_widget .client.treeview } ::if {[::sargs::get $_sargs .geometry] eq ""} { ::sargs::var::set _sargs .geometry 400x[::expr {int(400*1.1618)}]+100+100; } ::set _image_array(closed_folder) [::image create photo -file [::file join $_default_folder folder_closed.gif]]; ::set _image_array(open_folder) [::image create photo -file [::file join $_default_folder folder_open.gif]]; ::set _image_array(file) [::image create photo -file [::file join $_default_folder file.gif]]; } method toolbar_setup {} { #::qw::dialog3::file chain; ::return; } method dialog_control_button_process {sargs} { #::qw::dialog3::file ::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 { .mru_list { } .ok { ::if {$rwb1_debug} {::puts "rwb1_debug,dialog_control_button_process,1000.1";} dialog_ok; ::if {$rwb1_debug} {::puts "rwb1_debug,dialog_control_button_process,1000.2";} ::return; } } ::return [chain $sargs]; } method dialog_ok {sargs} { #::qw::dialog3::file ::set Selection [$_treeview selection]; /* { There presumably could be many items in a selection but we will only return the first one. This works even if the selection is in fact limited to one item. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,dialog_ok,1000.0,sargs==$sargs";} ::set NodeId [::lindex $Selection 0]; ::if {$NodeId eq ""} { ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,dialog_ok,1000.1,NodeId==$NodeId";} ::set FilePath [::sargs::get $_node_array($NodeId) .file_path]; # 2.31.3 - made "::file type" call remote-safe ::switch -- [::sargs::get $_sargs .server] { "" { ::set FileType [::file type $FilePath]; } default { ::set FileType [[::qw::system] cpp_remote_tcl_interpreter_eval \ .server [::sargs::get $_sargs .server] \ .port [::sargs::get $_sargs .port] \ .script "::file type [::list $FilePath]" \ ]; } } ::if {$rwb1_debug} {::puts "rwb1_debug,dialog_ok,1000.3,FilePath==$FilePath,FileType==$FileType";} ::switch -- $FileType { "file" { /* { This wakes up the dialog and returns the value in _dialog_result. */ } ::set _dialog_result $FilePath; } "directory" { /* { The currently selected item is a folder. Toggle it open/closed. */ } ::if {[$_treeview item $NodeId -open]} { $_treeview selection set [::list $NodeId]; ::event generate $_treeview <>; ::update idletasks; } else { ::event generate $_treeview <>; } } default { ::qw::warning 314120161011084158 "[::qw::methodname] - invalid file type \"$FileType\"."; } } } method dialog_dismiss {sargs} { ::set _dialog_result ""; } method client_setup {} { #::qw::dialog3::file ::set rwb1_debug 0; chain; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.0,_toplevel==$_toplevel";} ::set Client $_toplevel.client; ::set _treeview $Client.treeview; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.0.0,_treeview==$_treeview";} ::switch -- $_view { "none" { ::ttk::treeview $Client.treeview \ -show [::list tree] \ -yscroll "$Client.vsb set" \ -xscroll "$Client.hsb set" \ ; } "details" { ::ttk::treeview $Client.treeview \ -columns {fullpath type size} \ -displaycolumns {size} \ -yscroll "$Client.vsb set" \ -xscroll "$Client.hsb set" \ ; $_treeview column size -anchor e; $Client.treeview heading \#0 -text "Path"; $Client.treeview heading size -text "Size"; $Client.treeview column size -stretch 0 -width 70; } } ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.1";} ::ttk::scrollbar $Client.vsb -orient vertical -command "$Client.treeview yview" ::ttk::scrollbar $Client.hsb -orient horizontal -command "$Client.treeview xview" ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.2";} populate_root; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.3";} # bind $Client.treeview <> [::itcl::code $this populate_node .parent_node_id \[%W focus\]]; ::bind $Client.treeview <> [::itcl::code $this populate_node]; ## Arrange the tree and its scrollbars in the toplevel ::lower [ttk::frame $Client.treeview_frame] ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.4";} ::pack $Client.treeview_frame -fill both -expand 1 ::grid $Client.treeview $Client.vsb -sticky nsew -in $Client.treeview_frame ::grid $Client.hsb -sticky nsew -in $Client.treeview_frame ::grid columnconfigure $Client.treeview_frame 0 -weight 1 ::grid rowconfigure $Client.treeview_frame 0 -weight 1; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.99";} # ::bind $_toplevel.client.canvas [::itcl::code $this dialog_ok]; # ::bind $_toplevel [::itcl::code $this dialog_ok]; ::if {[::sargs::exists $_sargs .default_path]} { ::set DefaultPath [::sargs::get $_sargs .default_path]; ::set DefaultPath [::string tolower $DefaultPath]; ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.5,DefaultPath==$DefaultPath";} ::after idle [::itcl::code $this position_on_path .path $DefaultPath]; } ::if {$rwb1_debug} {::puts "rwb1_debug,client_setup,1000.6";} ::bind $_treeview [::itcl::code $this dialog_ok]; ::bind $_treeview [::itcl::code $this dialog_ok]; } method position_on_path {sargs} { /* { We want the dialog positioned on a particular tree node, generally supplied by the caller as the default path, i.e. the current value of the field, or the most recent value in an mrulist. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,position_on_path,1000.0,_treeview==$_treeview,_sargs==\n[::sargs::format $_sargs]";} ::set Path [::sargs::get $sargs .path]; ::set Path [::string trim $Path]; ::set Path [::string tolower $Path]; ::set PathList [::file split $Path]; ::set NodeId [::list]; ::if {![$_treeview exists $NodeId]} { ::if {$rwb1_debug} {::puts "rwb1_debug,position_on_path,1000.1";} ::return; } ::foreach Item $PathList { ::set KidNodeId [::file join $NodeId $Item]; ::if {$rwb1_debug} {::puts "rwb1_debug,position_on_path,1000.2,NodeId==$NodeId,KidNodeId==$KidNodeId";} populate_node .parent_node_id $NodeId; ::if {$rwb1_debug} {::puts "rwb1_debug,position_on_path,1000.3,children==[$_treeview children $NodeId]";} $_treeview item $NodeId -open 1; ::if {$rwb1_debug} {::puts "rwb1_debug,position_on_path,1000.4";} ::set NewNodeId [::file join $NodeId $KidNodeId]; ::if {![$_treeview exists $NewNodeId]} { ::break; } ::set NodeId $NewNodeId; } # ::focus $_treeview $_treeview see $NodeId; $_treeview focus $NodeId; $_treeview selection set [::list $NodeId]; scrolldown_a_little .node_id $NodeId; } method scrolldown_a_little {sargs} { /* { position_on_path actually positions the selected item at the top of the window which is disorienting. When that happens we want to scroll the window a bit to move the selected item toward the middle of the window. I have set count to move the selected item to the 5th line but this is arbitrary. If the previous item is visible we do nothing. Otherwise we scroll until the count is reached or the previous item is visible. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,scrolldown_a_little,1000.0";} ::set NodeId [::sargs::get $sargs .node_id]; ::set Count 5; ::while {[::incr Count -1]>=0} { ::if {$rwb1_debug} {::puts "rwb1_debug,scrolldown_a_little,1000.1";} ::set PrevNodeId [$_treeview prev $NodeId]; ::if {$PrevNodeId eq ""} { ::if {$rwb1_debug} {::puts "rwb1_debug,scrolldown_a_little,1000.2";} ::set PrevNodeId [$_treeview parent $NodeId]; } ::if {$PrevNodeId eq ""} { ::if {$rwb1_debug} {::puts "rwb1_debug,scrolldown_a_little,1000.3";} ::return; } ::if {[$_treeview bbox $PrevNodeId] ne ""} { ::if {$rwb1_debug} {::puts "rwb1_debug,scrolldown_a_little,1000.4";} ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,scrolldown_a_little,1000.5";} $_treeview yview scroll -1 units; ::if {$rwb1_debug} {::puts "rwb1_debug,scrolldown_a_little,1000.6";} ::set NodeId $PrevNodeId; } ::if {$rwb1_debug} {::puts "rwb1_debug,scrolldown_a_little,1000.99";} } method control_button_setup {} { #::qw::dialog3::file chain; ::set MruList [::sargs::get $_sargs .mru_list]; ::if {![::sargs::boolean_get $_sargs .mru_list_is_enabled]||[::llength $MruList]==0} { ::if {[::winfo exists $_toplevel.control_button.mru_list]} { ::pack forget $_toplevel.control_button.mru_list; } } } method populate_root {sargs} { ::set rwb1_debug 0; ::if {[$_treeview exists {}]} { $_treeview delete [$_treeview children ""]; } ::set RootNodeId ""; ::sargs::var::set _node_array($RootNodeId) \ .node_id "" \ .file_type directory \ .file_path "" \ ; ::switch -- [::sargs::get $_sargs .server] { "" { ::set VolumeList [::lsort -dictionary [::file volumes]]; } default { ::set VolumeList [[::qw::system] cpp_remote_tcl_interpreter_eval \ .server [::sargs::get $_sargs .server] \ .port [::sargs::get $_sargs .port] \ .script "::file volumes" \ ]; } } ::foreach Volume $VolumeList { ::set KidNodeId [::string tolower $Volume]; $_treeview insert {} end \ -id $KidNodeId \ -text $Volume \ -values [::list $Volume directory] \ ; ::switch -- $_view { "none" { } "details" { $_treeview set $KidNodeId type directory; } } $_treeview item $KidNodeId -image $_image_array(closed_folder); $_treeview insert $KidNodeId 0 -text dummy ;# a dummy ::sargs::var::set _node_array($KidNodeId) \ .node_id $KidNodeId \ .file_type directory \ .file_path $Volume \ ; } } method populate_node {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,1000.0,sargs==$sargs";} ::set ParentNodeId [::sargs::get $sargs .parent_node_id]; ::if {$ParentNodeId eq ""} { ::if {![::sargs::exists $sargs .parent_node_id]} { /* { If .parent_node_id argument exists but is empty it could mean populate the root, but if it doesn't exist then we were called to open an item, and that will be the item that has focus. */ } ::set ParentNodeId [$_treeview focus]; } } ::if {$ParentNodeId eq ""} { populate_root; return; } ::if {[::sargs::get $_node_array($ParentNodeId) .file_type] ne "directory"} { ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,1000.1"} ::return; } /* { ::if {[::file type $ParentNodeId] ne "directory"} { ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,1000.1"} ::return; } */ } /* { ::if {[$_treeview set $ParentNodeId type] ne "directory"} { ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,1000.1"} ::return; } */ } ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,1000.2";} # ::set ParentPath [$_treeview set $ParentNodeId fullpath]; ::set ParentPath [::sargs::get $_node_array($ParentNodeId) .file_path]; $_treeview delete [$_treeview children $ParentNodeId]; ::qw::try { ::switch -- [::sargs::get $_sargs .server] { "" { ::set KidList [::glob -nocomplain [::file join $ParentPath *]]; } default { # ::set Script [::subst -nocommands { # ::glob -nocomplain [::file join {$ParentPath} *] # }]; ::set KidList [[::qw::system] cpp_remote_tcl_interpreter_eval \ .server [::sargs::get $_sargs .server] \ .port [::sargs::get $_sargs .port] \ .script [::list ::glob -nocomplain [::file join $ParentPath *]] \ ]; } } } catch Exception { $_treeview item $ParentNodeId -image $_image_array(closed_folder); ::qw::warning 314120160815134654 "[::qw::methodname] - exception:\"$Exception\""; # ::qw::throw $Exception; ::return; } $_treeview item $ParentNodeId -image $_image_array(open_folder); ::switch -- [::sargs::get $_sargs .server] { "" { ::set FolderList [::glob -nocomplain -types [::list d] [::file join $ParentPath *]]; } default { # ::set Script [::subst -nocommands { # ::glob -nocomplain -types [::list d] [::file join {$ParentPath} *]; # }]; ::set FolderList [[::qw::system] cpp_remote_tcl_interpreter_eval \ .server [::sargs::get $_sargs .server] \ .port [::sargs::get $_sargs .port] \ .script [::list ::glob -nocomplain -types [::list d] [::file join $ParentPath *]] \ ]; } } ::set FolderList [::lsort -dictionary [::string tolower $FolderList]]; #8.4 has no -nocase ::set FolderList [::lsort -dictionary -nocase $FolderList]; ::set FileList [::list]; ::foreach Pattern [::sargs::get $_sargs .pattern_list] { ::switch -- [::sargs::get $_sargs .server] { "" { ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,2000.0,Pattern==$Pattern";} ::set ResultList [::glob -nocomplain -types [::list f] [::file join $ParentPath $Pattern]]; ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,2000.2,ResultList==$ResultList";} ::set FileList [::concat $FileList $ResultList]; } default { ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,2000.0,Pattern==$Pattern";} # ::set Script [::subst -nocommands { # ::glob -nocomplain -types [::list f] [::file join {$ParentPath} {$Pattern}]; # }]; # ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,2000.1,script==$Script";} ::set ResultList [[::qw::system] cpp_remote_tcl_interpreter_eval \ .server [::sargs::get $_sargs .server] \ .port [::sargs::get $_sargs .port] \ .script [::list ::glob -nocomplain -types [::list f] [::file join $ParentPath $Pattern]] \ ]; ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,2000.2,ResultList==$ResultList";} ::set FileList [::concat $FileList $ResultList]; } } } /* { ::foreach Pattern [::sargs::get $_sargs .pattern_list] { ::switch -- [::sargs::get $_sargs .server] { "" { ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,2000.0,Pattern==$Pattern";} ::set ResultList [::glob -nocomplain -types [::list f] [::file join $ParentPath $Pattern]]; ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,2000.2,ResultList==$ResultList";} ::set FileList [::concat $FileList $ResultList]; } default { ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,2000.0,Pattern==$Pattern";} ::set Script [::subst -nocommands { ::glob -nocomplain -types [::list f] [::file join {$ParentPath} {$Pattern}]; }]; ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,2000.1,script==$Script";} ::set ResultList [[::qw::system] cpp_remote_tcl_interpreter_eval \ .server [::sargs::get $_sargs .server] \ .port [::sargs::get $_sargs .port] \ .script $Script \ ]; ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,2000.2,ResultList==$ResultList";} ::set FileList [::concat $FileList $ResultList]; } } } */ } # ::set FileList [::lsort -dictionary -nocase $FileList]; ::set FileList [::lsort -dictionary [::string tolower $FileList]]; ::if {[::llength [::concat $FolderList $FileList]]==0} { ::return; } ::foreach KidPath $FolderList { # ::set KidType [::file type $KidPath]; ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,1000.6,parent_path==$ParentPath,kid_type==directory,kid_path==$KidPath";} ::set KidNodeId [::string tolower $KidPath]; ::sargs::var::set _node_array($KidNodeId) \ .node_id $KidNodeId \ .file_path $KidPath \ .file_type directory \ ; $_treeview insert $ParentNodeId end \ -id $KidNodeId \ -text [::file tail $KidPath] \ -values [::list $KidPath directory] \ ; /* { Now we want to find out if the node has children in order to control the plus box. If the node has sub-folders, or if it has files that match a file pattern, then we add an artificial "dummy_tree_item" to cause the treeview widget to add the plus box. Note that we don't do that for the volumes when populating the root node. The reason is that querying for kids causes dvd drives to prompt to enter a disk. */ } ::set GrandKidList [::list]; ::qw::try { ::switch -- [::sargs::get $_sargs .server] { "" { ::set GrandKidList [::glob -nocomplain [::file join $KidPath *]]; ::if {[::llength $GrandKidList]==0} { ::foreach Pattern [::sargs::get $_sargs .pattern_list] { ::set GrandKidList [::glob -nocomplain -types [::list f] [::file join $ParentPath $Pattern]]; ::if {[::llength $GrandKidList]!=0} { ::break; } } } ::concat $FileList [::glob -nocomplain -types [::list f] [::file join {$ParentPath} {$Pattern}]]; } default { # ::set Script [::subst -nocommands { # ::glob -nocomplain [::file join {$KidPath} *] # }]; ::set GrandKidList [[::qw::system] cpp_remote_tcl_interpreter_eval \ .server [::sargs::get $_sargs .server] \ .port [::sargs::get $_sargs .port] \ .script [::list ::glob -nocomplain [::file join $KidPath *]] \ ]; ::if {[::llength $GrandKidList]==0} { ::foreach Pattern [::sargs::get $_sargs .pattern_list] { # ::set Script [::subst -nocommands { # ::glob -nocomplain -types [::list f] [::file join {$ParentPath} {$Pattern}] # }]; ::set GrandKidList [[::qw::system] cpp_remote_tcl_interpreter_eval \ .server [::sargs::get $_sargs .server] \ .port [::sargs::get $_sargs .port] \ .script [::list ::glob -nocomplain -types [::list f] [::file join $ParentPath $Pattern]] \ ]; ::if {[::llength $GrandKidList]!=0} { ::break; } } } } } ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,1000.6,parent_path==$ParentPath,kid_type==directory,kid_path==$KidPath";} } catch Exception { $_treeview delete $KidNodeId; ::qw::warning 314120160815134657 "[::qw::methodname] - KidPath==$KidPath,exception==\"$Exception\""; /* { If we get a permission denied error when attempting to excpand a folder, we simply skip the folder. rwb1_debug - for now we pretend folder has no children but we may skip folder altogether in furture. */ } ::continue; } ::if {[::llength $GrandKidList]>0} { /* { The directory has items below. We add a single dummy item so that the treeview widget will display a plus box. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,1000.6.0,::llength $GrandKidList==[::llength $GrandKidList],KidPath==$KidPath";} $_treeview insert $KidNodeId 0 -text dummy_tree_item; } else { ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,1000.6.1,::llength $GrandKidList==[::llength $GrandKidList],KidPath==$KidPath";} } ::switch -- $_view { "none" { } "details" { $_treeview set $KidNodeId type directory; } } $_treeview item $KidNodeId -text [::file tail $KidPath]; $_treeview item $KidNodeId -image $_image_array(closed_folder); } # ::set FileList [::glob -nocomplain -types [::list f] [::file join $ParentPath *]]; # ::set FileList [::lsort -dictionary -nocase $FileList]; ::foreach KidPath $FileList { ::set KidNodeId [::string tolower $KidPath]; ::sargs::var::set _node_array($KidNodeId) \ .node_id $KidNodeId \ .file_path $KidPath \ .file_type file \ .file_size ??? \ ; $_treeview insert $ParentNodeId end \ -id $KidNodeId \ -text [::file tail $KidPath] \ -values [::list $KidPath file] \ ; /* { Demo code we started with formatted the size. We don't bother. */ } /* { ::if {$FileSize >= 1024*1024*1024} { ::set FileSize [format %.1f\ GB [::expr {$FileSize/1024/1024/1024.}]]; } elseif {$FileSize >= 1024*1024} { ::set FileSize [format %.1f\ MB [::expr {$FileSize/1024/1024.}]]; } elseif {$FileSize >= 1024} { ::set FileSize [format %.1f\ kB [::expr {$FileSize/1024.}]]; } else { ::append FileSize " bytes" } */ } ::switch -- $_view { "none" { } "details" { $_treeview set $KidNodeId type file ::set FileSize [::file size $KidPath] $_treeview set $KidNodeId size [::qw::number::format $FileSize $::qw::number::formats(integer)]; } } # $_treeview set $KidNodeId size $FileSize; $_treeview item $KidNodeId -image $_image_array(file); } ::if {$rwb1_debug} {::puts "rwb1_debug,populate_node,1000.99";} } method tooltip_get {sargs} { #::qw::dialog85::date_dialog ::set Widget [::sargs::get $sargs .widget]; ::set Text ""; ::switch -glob -- $Widget { *.toolbar_frame.year_prev { ::append Text "Move back one year."; ::append Text "\nCtrl-PgUp -> move back one year."; ::append Text "\nCtrl-Home -> move to first day of this year."; ::return [::sargs .text $Text]; } *.toolbar_frame.year_next { ::append Text "Move ahead one year."; ::append Text "\nCtrl-PgDn -> move ahead one year."; ::append Text "\nCtrl-End -> move to last day of this year."; ::return [::sargs .text $Text]; } *.toolbar_frame.month_prev { ::append Text "Move back one month."; ::append Text "\nPgUp -> move back one month."; ::append Text "\nHome -> move to first day of this month."; ::return [::sargs .text $Text]; } *.toolbar_frame.month_next { ::append Text "Move ahead one month."; ::append Text "\nPgDn -> move ahead one month."; ::append Text "\nEnd -> move to last day of this month."; ::return [::sargs .text $Text]; } *.buttons.ok { ::append Text "Pick the date."; ::append Text "\n(Enter)"; ::return [::sargs .text $Text]; } *.buttons.dismiss - *.menubar.file.exit { ::append Text "Dismiss without picking a date."; ::append Text "\n(Esc)"; ::return [::sargs .text $Text]; } *.buttons.help - *.menubar.help.export { ::append Text "Help on date dialog."; ::append Text "\n(F1)"; ::return [::sargs .text $Text]; } } ::return [chain $sargs]; } method dialog_help_page {sargs} { #::qw::dialog85::date_dialog /* { The caller can provide a help page. */ } ::set HelpPage { .title "Date Pick Dialog" .id 314120111221155438 .tags "dialog" .body { [h2 "Pick a file."] [p { You are being prompted to pick a file. Navigate to the desired file and double-click on it. You can also press the [qw_key Enter] key, or click the [qw_button [qw_s_args .ok_button.text]] button. }] [h2 "Why not a normal windows dialog?"] [p { }] [h2 "Why don't I see all files?"] [p { }] [h2 "How to exit without picking a file."] [p { Click [qw_button [qw_s_args .dismiss_button.text]] or press [qw_key Esc] to dismiss the date dialog without picking a fie. }] } } ::sargs::var::set HelpPage .ok_button.text [::sargs::get $_sargs .ok_button.text]; ::sargs::var::set HelpPage .dismiss_button.text [::sargs::get $_sargs .dismiss_button.text]; ::sargs::var::set HelpPage .help_button.text [::sargs::get $_sargs .help_button.text]; } }