/* { To do: ------ - problem - error occurs. We no longer can destroy window. Ignores x button and ok and cancel buttons - error dialog - date dialog with combo date at bottom - date dialog with full year option. - add help - add html versus text - forget this - seems simple but ultimately unnecessary - what to do about resize - geometry options - grab - we are loosing the grab - suspect when we throw up an error we loose the grab - suspect that same is true when we bring up any modal dialog - maybe it's when we bring up tk_openfile... edit_assist rwb_todo - ties in editing, i.e. user types directly into field - help needed in mru_list dialog - we aren't sending/using the .parent argument. - should implement some home-in behaviour when typing text characters - what should we do when the user is currently editing the field when we F3 */ } ::if {!$::qw::control(tk_is_enabled)} { ::return; } #::package provide qw::dialog85 2.0; #just a convenient place for testing loading following packages /* { We could attempt to require these packages when truly needed from inside a method such as the constructor of each dialog. But instead we'll require them all here. Here is the reasoning behind this. If we need a dialog we're moving at "human" speed so speed is not an issue. We load them only once, and we have them all together instead of wondering what we'll need. If a dialog has special needs then it can always require additional packages. The tablelist started out that way but eventually so many dialogs needed tablelist that we require it here also. */ } ::package require qw::winutil; ::qw::packages::package_require_tablelist; /* { 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::dialog85 {}; ::itcl::class ::qw::dialog85::dialog_archetype { /* { 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. _options These are the options, merged with the incoming arguments. They are set up in options_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 arguments passed to script protected variable _options ""; # defaults with values potential overridden protected variable _dialog_result ""; # 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 _toolbar_button_font {-family Arial -size 8 -weight normal}; # protected variable _main_font {-family Arial -size 12 -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 _hsb ""; # only used if you have scollbars protected variable _vsb ""; protected variable _hsb_is_on 1; protected variable _vsb_is_on 1; protected variable _html_fontscale 0.75; # protected variable _default_focus_widget ""; constructor {} { #::qw::dialog85::dialog_archetype ::array set _image_array {}; } destructor { #::qw::dialog85::dialog_archetype ::if {$_toplevel ne ""} { ::qw::toplevel_remove .toplevel $_toplevel; } ::if {[::winfo exists $_toplevel]} { ::qw::tooltip::disable .widget $_toplevel; ::destroy $_toplevel; ::set _toplevel ""; } ::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 {} } } method toplevel {} { /* { 2.28.3 Added in order to allow the window to be raised. Auto_reconcile raises the current toplevel if you try to run it more than once. We won't need this command if we use the toplevel window path as the command path (flynt technique used in qw entry widgets). */ } ::return $_toplevel; } method main {sargs} { #::qw::dialog85::dialog_archetype /* { 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 options_setup or client_setup, etc., as slices. The main method calls these slices in a controlled order. options_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). */ } ::qw::bug 314120120611095523 "[::qw::methodname] - method must be overridden."; ::set _sargs $sargs; options_setup; ::sargs::var::+= _options $sargs; ::if {![has_help]} { ::sargs::var::unset _options .control_button.help; } toplevel_setup; menu_setup; toolbar_setup; control_button_setup; client_setup; popup_menu_setup; initialize; wait; ::set Result $_dialog_result; ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } ::return $Result; } method has_help {} { /* { */ } ::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 [::sargs::get $_options .help_page]; ::if {$HelpPage ne ""} { ::if {[::sargs::get $HelpPage .body] ne ""} { ::return 1; } } ::return 0; } method options_setup {} { #::qw::dialog85::dialog_archetype /* { The options_setup method should assign default values to the _options variable. After calling options_setup, we merge _options with the sargs received by main, effectively overriding _options values with those supplied by the caller. */ } } method initialize {sargs} { #::qw::dialog85::dialog_archetype /* { This method is called after setting up the dialog, just before going into the modal wait state. All the widgets should exist at this point. That is why we wait until now to set up the tooltips. For example, the file explorer dialog uses this method to position on the default item and move it into the visible area. */ } ::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 $_options .default_focus_widget]; ::if {$DefaultFocusWidget ne ""} { #::set DefaultFocusWidget "$_toplevel$DefaultFocusWidget"; ::after idle [::subst -nocommands { ::if {[::winfo exists $_toplevel$DefaultFocusWidget]} { ::focus $_toplevel$DefaultFocusWidget; } }]; } } method toplevel_setup {} { #::qw::dialog85::dialog_archetype ::set Unique 0; ::while {[::winfo exists .qw_dialog_$Unique]} { /* { Generate non-existing name for the toplevel. */ } ::incr Unique; } ::set _toplevel [::toplevel .qw_dialog_$Unique]; ::wm title $_toplevel [::sargs::get $_options .title]; ::if {[::sargs::get $_options .width] ne ""} { $_toplevel configure -width [::sargs::get $_options .width]; } ::if {[::sargs::get $_options .height] ne ""} { $_toplevel configure -height [::sargs::get $_options .height]; } ::wm protocol $_toplevel WM_DELETE_WINDOW [::itcl::code $this command_process .command command_exit]; ::wm group $_toplevel . ::bind $_toplevel {tk::TabToWindow [tk_focusNext %W]} ::bind $_toplevel <> {tk::TabToWindow [tk_focusPrev %W]} ::bind $_toplevel [::itcl::code $this command_process .command command_exit]; ::bind $_toplevel [::itcl::code $this command_process .command command_exit]; ::bind $_toplevel [::itcl::code $this command_process .command command_help]; ::bind $_toplevel [::list $this command_process .command command_exit]; ::bind $_toplevel [::list $this command_process .command command_exit]; ::after idle [::subst -nocommands { ::update idletasks; ::if {[::winfo exists $_toplevel]} { ::switch -- $_resize_is_enabled { 0 { ::wm resizable $_toplevel 0 0; } 1 { ::if {!$_reduce_size_is_enabled} { ::wm minsize $_toplevel [::winfo reqwidth $_toplevel] [::winfo reqheight $_toplevel]; } } } ::qw::winutil::edit_assist_position_toplevel {$_options} .toplevel $_toplevel; ::wm deiconify $_toplevel; ::raise $_toplevel; } }]; ::qw::toplevel_add .toplevel $_toplevel; /* { We withdraw the toplevel to reduce noise such as when the client area is set up. We schedule an after idle that will optionally position the toplevel and deiconify it. See above. */ } ::wm withdraw $_toplevel; ::bind $_toplevel [::itcl::code $this configure_event]; ::after 10 [::subst -nocommands { /* { 2.37.2 progress_blue window which is derived from dialog85, did not appear in database_download. This is the fix and probably works in general. */ } ::if {[::winfo exists $_toplevel]} { ::raise $_toplevel; } }]; } method menu_setup {sargs} { #::qw::dialog85::dialog_archetype } method popup_menu_setup {sargs} { #::qw::dialog85::dialog_archetype } method toolbar_setup {sargs} { #::qw::dialog85::dialog_archetype } method client_setup {sargs} { #::qw::dialog85::dialog_archetype } method popup_menu_post {sargs} { #::qw::dialog85::dialog_archetype ::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::dialog85::dialog_archetype /* { Goes through the .control_button subs in _options 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 $_options.controlbutton, they are packed to the left. */ } ::set ButtonFields [::sargs::names .structure [::sargs::get $_options .control_button]]; ::if {[::llength $ButtonFields]!=0} { ::frame $_toplevel.control_button; ::foreach Button $ButtonFields { ::set Suffix [::string range $Button 1 end]; # strip the leading dot ::ttk::button $_toplevel.control_button$Button \ -text [::sargs::get $_options .control_button$Button.text] \ -command [::itcl::code $this command_process .command command_$Suffix] \ ; ::pack $_toplevel.control_button$Button -side right -padx 2 -pady 2; } ::pack $_toplevel.control_button -fill x -side bottom; } } method wait {} { #::qw::dialog85::dialog_archetype /* { We add a binding tag to the toplevel and bind code to it that will raise the toplevel when it gets a buttonpress. 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; ::vwait [::itcl::scope _dialog_result]; ::grab release $_toplevel; ::if {$GrabSave ne ""} { ::if {[::winfo exists $GrabSave]} { ::grab set $GrabSave; } } } method configure_event {} { #::qw::dialog85::dialog_archetype /* { 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. */ } ::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; ::update; } } } ::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; ::update; } } } } method dialog_help_page {sargs} { ::return ""; } method command_process {sargs} { #::qw::dialog85::dialog_archetype ::set Command [::sargs::get $sargs .command]; ::switch -- $Command { command_control_button { ::qw::bug 314120121022144400 "Deprecated." ::set Button [::sargs::get $sargs .control_button]; ::switch -- $Button { .help { command_process .command command_help; ::return; } .cancel { command_process .command command_exit; ::return; } } } command_help { /* { The caller can use .help_id or .help_page. The .help_page has priority over .help_id if both are supplied. */ } # ::set Formatter [::qw::html::formatter #auto]; # ::qw::finally [::list ::itcl::delete object $Formatter]; ::set HelpId [::sargs::get $_options .help_id]; ::set HelpPage [::sargs::get $_options .help_page]; ::if {$HelpPage ne ""} { } if {$HelpId ne ""} { ::set HelpPage [::qw::help::find_page_by_id $HelpId]; } ::if {$HelpPage eq ""} { ::set HelpPage [dialog_help_page $sargs]; } ::if {$HelpPage eq ""} { ::set HelpPage { .body { [p { Help not available. }] } } } ::foreach Field [::sargs::names .structure $_options] { ::if {![::sargs::exists $HelpPage $Field]} { /* { We don't copy fields that the page already has. */ } ::sargs::var::set HelpPage $Field [::sargs::get $_options $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 \ ; ::return; } command_cancel { /* { Each dialog should have it's own command_exit because different dialogs will put difference values in the result. */ } ::return [command_process .command command_exit]; } command_ok { ::return [command_process .command command_ok]; } } ::qw::bug 314120120130150130 "[::qw::methodname] - [info class] - invalid command \"$Command\"."; } method tooltip_get {sargs} { #::qw::dialog85::dialog_archetype ::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 _options, if any. */ } ::set Button .[::lindex [::split $Widget .] end]; ::set Text [::sargs::get $_options .control_button$Button.tooltip.text]; ::return [::sargs .text $Text]; } } ::return [::sargs .text ""]; ::return [chain $sargs]; } /* { 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; } */ } } ::proc ::qw::dialog85::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::dialog85::notify_dialog # ------------------------------------------------------------ ::itcl::class ::qw::dialog85::notify_dialog { /* { Notes: */ } inherit ::qw::dialog85::dialog_archetype; constructor {} { #::qw::dialog85::notify_dialog } destructor { #::qw::dialog85::notify_dialog } method main {sargs} { #::qw::dialog85::notify_dialog ::set _sargs $sargs; options_setup; ::sargs::var::+= _options $sargs; ::if {![has_help]} { ::sargs::var::unset _options .control_button.help; } toplevel_setup; menu_setup; toolbar_setup; control_button_setup; client_setup; popup_menu_setup; initialize; wait; ::set Result $_dialog_result; ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } ::return $Result; } method options_setup {} { #::qw::dialog85::notify_dialog chain; ::sargs::var::+= _options { .title "Notify" .class "Notify" .sound "SystemAsterisk" .bitmap info .bbox "" .help { .help_id default_notify_dialog_help } .control_button { .help { .text "Help" .tooltip { .text "Help on this dialog window." } } .cancel { .text "Ok" .tooltip { .text "Dismiss dialog window." } } } .default_focus_widget .control_button.cancel }; } method initialize {sargs} { #::qw::dialog85::notify_dialog chain $sargs; } method client_setup {sargs} { #::qw::dialog85::notify_dialog chain $sargs; ::frame $_toplevel.client; ::set _image_array(info) [::image create photo -file [::file join $::qw_library system images info.gif]]; ::bind $_toplevel [::itcl::code $this command_process .command command_exit]; ::ttk::label $_toplevel.client.icon \ -image $_image_array(info) \ ; ::set Html [::sargs::get $_sargs .html]; ::if {$Html ne ""} { ::package require Tkhtml 3.0; ::set Body [::sargs::get $_sargs .html.body]; ::set Body [::qw::html::format .body $Body]; ::set Width [::sargs::get $_sargs .html.width]; ::if {$Width eq ""} { ::set Width 6i; } ::set Height [::sargs::get $_sargs .html.height]; ::if {$Height eq ""} { ::set Height 4i; } ::set Body "$Body"; ::html $_toplevel.client.text \ -width $Width \ -height $Height \ ; $_toplevel.client.text style [::subst -nocommands { html { background: $::qw::platform_dependent_color(SystemButtonFace); font-family: Helvetica; padding: 5px; } }]; $_toplevel.client.text parse -final $Body; } else { ::ttk::label $_toplevel.client.text \ -text [::sargs::get $_options .text] \ -justify left \ ; } ::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 } method control_button_setup {} { #::qw::dialog85::notify_dialog chain; } method command_process {sargs} { #::qw::dialog85::notify_dialog ::set Command [::sargs::get $sargs .command]; ::switch -- $Command { command_control_button { ::qw::bug 314120121022144401 "Deprecated." } command_exit { ::set _dialog_result [::sargs \ .result "" \ ]; ::return; } } ::return [chain $sargs]; } method tooltip_get {sargs} { #::qw::dialog85::notify_dialog ::return [chain $sargs]; } } # ------------------------------------------------------------ # ::qw::dialog85::confirm_dialog # ------------------------------------------------------------ ::itcl::class ::qw::dialog85::confirm_dialog { /* { */ } inherit ::qw::dialog85::dialog_archetype; constructor {} { #::qw::dialog85::confirm_dialog } destructor { #::qw::dialog85::confirm_dialog } method main {sargs} { #::qw::dialog85::confirm_dialog ::set _sargs $sargs; options_setup; ::sargs::var::+= _options $sargs; ::if {![has_help]} { ::sargs::var::unset _options .control_button.help; } toplevel_setup; menu_setup; toolbar_setup; control_button_setup; client_setup; popup_menu_setup Ssargs; initialize; wait; ::set Result $_dialog_result; ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } ::return $Result; } method options_setup {} { #::qw::dialog85::confirm_dialog chain; ::sargs::var::+= _options { .text "Confirm" .title "Confirm" .class "Confirm" .sound "SystemAsterisk" .bitmap info .bbox "" .help { .help_id default_confirm_dialog_help } .control_button { .help { .text "Help" .tooltip { .text "Help on this dialog window.\n(F1)" } } .cancel { .text "Dismiss" .tooltip { .text "Dismiss this dialog window without confirming.\n(Esc)" } } .ok { .text "OK" .tooltip { .text "Confirm operation by clicking this button.\n(Enter)" } } } .default_focus_widget .control_button.ok }; } method initialize {sargs} { #::qw::dialog85::confirm_dialog chain $sargs; } method client_setup {sargs} { #::qw::dialog85::confirm_dialog chain $sargs; ::frame $_toplevel.client; ::set _image_array(info) [::image create photo -file [::file join $::qw_library system images question.gif]]; ::ttk::label $_toplevel.client.icon \ -image $_image_array(info) \ ; ::set Html [::sargs::get $_sargs .html]; ::if {$Html ne ""} { ::package require Tkhtml 3.0; ::set Body [::sargs::get $_sargs .html.body]; ::set Body [::qw::html::format .body $Body]; ::set Width [::sargs::get $_sargs .html.width]; ::if {$Width eq ""} { ::set Width 6i; } ::set Height [::sargs::get $_sargs .html.height]; ::if {$Height eq ""} { ::set Height 4i; } ::set Body "$Body"; ::html $_toplevel.client.text \ -width $Width \ -height $Height \ ; $_toplevel.client.text style [::subst -nocommands { html { background: $::qw::platform_dependent_color(SystemButtonFace); font-family: Helvetica; padding: 5px; } }]; $_toplevel.client.text parse -final $Body; } else { ::ttk::label $_toplevel.client.text \ -text [::sargs::get $_options .text] \ -justify left \ ; } ::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 ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; ::return; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; } method control_button_setup {} { #::qw::dialog85::confirm_dialog chain; } method command_process {sargs} { #::qw::dialog85::confirm_dialog ::set Command [::sargs::get $sargs .command]; ::switch -- $Command { command_control_button { ::qw::bug 314120121022144402 "Deprecated." ::set Button [::sargs::get $sargs .control_button]; ::switch -- $Button { .help { command_process .command command_help; ::return; } .cancel { command_process .command command_exit; ::return; } .ok { command_process .command command_ok; ::return; } } } command_exit { /* { Note that for convenience, the confirm dialog does not return a structure, but instead returns a boolean. */ } ::set _dialog_result 0; ::return; } command_ok { ::set _dialog_result 1; ::return; } } ::return [chain $sargs]; } method tooltip_get {sargs} { #::qw::dialog85::confirm_dialog ::return [chain $sargs]; } } # ------------------------------------------------------------ # ::qw::dialog85::multiple_choice_buttons_dialog # ------------------------------------------------------------ ::itcl::class ::qw::dialog85::multiple_choice_buttons_dialog { /* { 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::dialog85::dialog_archetype; constructor {} { #::qw::dialog85::multiple_choice_buttons_dialog } destructor { #::qw::dialog85::multiple_choice_buttons_dialog } method main {sargs} { #::qw::dialog85::multiple_choice_buttons_dialog ::set _sargs $sargs; options_setup; ::sargs::var::+= _options $sargs; ::if {![has_help]} { ::sargs::var::unset _options .control_button.help; } toplevel_setup; menu_setup; toolbar_setup; control_button_setup; client_setup; popup_menu_setup; initialize; wait; ::set Result $_dialog_result; ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } ::return $Result; } method options_setup {} { #::qw::dialog85::multiple_choice_buttons_dialog chain; ::sargs::var::+= _options { .text "multiple_choice_buttons" .title "multiple_choice_buttons" .class "multiple_choice_buttons" .sound "SystemAsterisk" .bitmap info .bbox "" .help { .help_id default_multiple_choice_buttons_dialog_help } .control_button { .help { .text "Help" .tooltip { .text "Help on this dialog window." } } .cancel { .text "Dismiss" .tooltip { .text "Dismiss dialog window." } } } .default_focus_widget .control_button.cancel }; } method initialize {sargs} { #::qw::dialog85::multiple_choice_buttons_dialog chain $sargs; } method client_setup {sargs} { #::qw::dialog85::multiple_choice_buttons_dialog chain $sargs; ::frame $_toplevel.client; ::set _image_array(question) [::image create photo -file [::file join $::qw_library system images question.gif]]; ::ttk::label $_toplevel.client.icon \ -image $_image_array(question) \ ; ::ttk::label $_toplevel.client.text \ -text [::sargs::get $_options .text] \ -justify left \ ; ::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 ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; ::return; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; } method control_button_setup {} { #::qw::dialog85::multiple_choice_buttons_dialog chain; } method command_process {sargs} { #::qw::dialog85::multiple_choice_buttons_dialog ::set Command [::sargs::get $sargs .command]; ::switch -- $Command { command_control_button { ::qw::bug 314120121022144403 "Deprecated." ::set Button [::sargs::get $sargs .control_button]; ::switch -- $Button { .help { command_process .command command_help; ::return; } .cancel { command_process .command command_exit; ::return; } default { ::set _dialog_result [::sargs \ .result [::sargs::get $_options .control_button$Button.value] \ ]; ::return; } } } command_exit { ::set _dialog_result [::sargs \ .result "" \ ]; ::return; } default { ::set Suffix [::string map [::list "command_" ""] $Command]; ::if {[::sargs::exists $_options .control_button.$Suffix]} { ::set _dialog_result [::sargs \ .result [::sargs::get $_options .control_button.$Suffix.value] \ ]; ::return; } } } ::return [chain $sargs]; } method tooltip_get {sargs} { #::qw::dialog85::multiple_choice_buttons_dialog ::return [chain $sargs]; } } ::itcl::class ::qw::dialog85::field_prompt_dialog { /* { This dialog puts up a field with a "browse" button to the right of the field. The field browse button drops down an mru_list that also has a browse button. This is like edit assist except that the field that is being assisted is the one in our prompt instead of the one in an newviews table. scripts - script::run - stored in host fs - $::qw_library script_run.qw_options - backup - stored in application database stored in odb_file /odb/script_options in key $_script_id. f3 on fields, i.e. edit_assist - workstation file - print template - mail merge main document file - email log file save_as - mail merge custom script - bank eft file save_as can and usa - donor recipts file save_as - copy/paste file save_as - invoice information eft file save_as - donor statements - account html print */ } inherit ::qw::dialog85::dialog_archetype; protected variable _selected_value ""; protected variable _mru_list ""; constructor {} { #::qw::dialog85::field_prompt_dialog } destructor { #::qw::dialog85::field_prompt_dialog } method main {sargs} { #::qw::dialog85::field_prompt_dialog ::set _sargs $sargs; options_setup; ::sargs::var::+= _options $sargs; ::if {![has_help]} { ::sargs::var::unset _options .control_button.help; } toplevel_setup; menu_setup; toolbar_setup; control_button_setup; client_setup; popup_menu_setup; initialize; wait; ::set Result $_dialog_result; ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } ::return $Result; } method options_setup {} { #::qw::dialog85::field_prompt_dialog chain; ::sargs::var::+= _options { .title "Pick value" .class "FieldDialog" .bbox "" .caption_title "Enter value:" .control_button { .help { .text "Help" .tooltip { .text "F1 - Help on this dialog window." } } .cancel { .text "Dismiss" .tooltip { .text "Esc - Dismiss dialog window without picking a value." } } .mru_list { .text "List" .tooltip { .text "F3 - Pick from a list a recent values." } } .ok { .text "Ok" .tooltip { .text "Enter - Select currently selected value." } } } .default {} .mru_list {} .default_focus_widget .field.entry } } method initialize {sargs} { #::qw::dialog85::field_prompt_dialog chain $sargs; # ::focus $_toplevel.field.entry; $_toplevel.field.entry icursor end; } method client_setup {sargs} { #::qw::dialog85::field_prompt_dialog chain $sargs; #2.24.1 ::ttk::frame $_toplevel.client; ::if {[::sargs::exists $_sargs .text]} { ::ttk::label $_toplevel.text \ -text [::sargs::get $_options .text] \ -justify left \ ; ::pack $_toplevel.text -side top -expand 1 -fill both } ::ttk::labelframe $_toplevel.field -text [::sargs::get $_options .caption_title]; ::ttk::entry $_toplevel.field.entry -font $_folder_font -width 50 -validate key -textvariable [::itcl::scope _selected_value]; ::ttk::button $_toplevel.field.mru_list -image [Bitmap::get file] -command [::itcl::code $this command_process .command command_mru_list]; ::bind $_toplevel.field.entry [::itcl::code $this command_process .command command_ok]; ::pack $_toplevel.field.mru_list -side right -padx 4; ::pack $_toplevel.field.entry -side left -expand 1 -fill x -padx 4; ::pack $_toplevel.field -fill x -side top -pady 2m; ::set _mru_list [::sargs::get $_sargs .mru_list]; ::set _selected_value [::lindex $_mru_list 0]; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; ::bind $_toplevel [::itcl::code $this command_process .command command_mru_list]; } method control_button_setup {} { #::qw::dialog85::field_prompt_dialog chain; } method command_process {sargs} { #::qw::dialog85::field_prompt_dialog ::set Command [::sargs::get $sargs .command]; ::switch -- $Command { command_control_button { ::qw::bug 314120121022144404 "Deprecated." ::set Button [::sargs::get $sargs .control_button]; ::switch -- $Button { .help { command_process .command command_help; ::return; } .cancel { command_process .command command_exit; ::return; } .mru_list { command_process .command command_mru_list; ::return; } .ok { command_process .command command_ok; ::return; } } } command_exit { ::set _dialog_result [::sargs \ .result "" \ .mru_list $_mru_list \ ]; ::return; } command_ok { ::set _selected_value [::string trim $_selected_value]; ::set _mru_list [::qw::list::promote .list $_mru_list .element $_selected_value]; ::set _dialog_result [::sargs \ .result $_selected_value \ .mru_list $_mru_list \ ]; ::return; } command_mru_list { ::set ResultStructure [::qw::dialog85::mru_list $_sargs \ .mru_list $_mru_list \ .help.help_id ??? \ .bbox [::qw::winutil::bbox_from_widget .widget $_toplevel.field.entry] \ ]; /* { Note that we update the _mru_list whether anything was selected or not when we popped up the mru_list dialog. */ } ::set _mru_list [::sargs::get $ResultStructure .mru_list]; ::set Result [::sargs::get $ResultStructure .result]; /* { Everybody does the next line which is redundant but harmless. */ } ::set _mru_list [::qw::list::promote .list $_mru_list .element $Result]; ::if {$Result ne ""} { /* { If a value was selected we don't just fill in the field with it. We assume the user wants it and return it to the caller immediately. */ } ::set _selected_value $Result; ::set _dialog_result [::sargs \ .result $_selected_value \ .mru_list $_mru_list \ ]; } ::focus $_toplevel.field.entry; $_toplevel.field.entry icursor end; ::return; } } ::return [chain $sargs]; } method tooltip_get {sargs} { #::qw::dialog85::field_prompt_dialog ::set Widget [::sargs::get $sargs .widget]; ::set Text ""; ::switch -glob -- $Widget { *.field.mru_list - *.control_button.mru_list { ::append Text "F3 - Pick value from a list of recent values."; ::return [::sargs .text $Text]; } *.field - *.field.entry { ::append Text "F3 - Enter a value in this field"; ::append Text "\nOr click button to pick from list."; ::return [::sargs .text $Text]; } *.control_button.ok { ::append Text "Enter - Select current value."; ::return [::sargs .text $Text]; } *.control_button.cancel { ::append Text "Esc - Dismiss window without picking a value."; ::return [::sargs .text $Text]; } *.control_button.help - *.menubar.help.export { ::append Text "F1 - Help on this dialog."; ::return [::sargs .text $Text]; } } ::return [chain $sargs]; } } # ------------------------------------------------------------ # ::qw::dialog85::error_tree_dialog # ------------------------------------------------------------ ::itcl::class ::qw::dialog85::error_tree_dialog { /* { */ } inherit ::qw::dialog85::dialog_archetype; protected variable _table ""; protected variable _path_column 0; constructor {} { #::qw::dialog85::error_tree_dialog } method main {sargs} { #::qw::dialog85::error_tree_dialog ::set _sargs $sargs; options_setup; ::sargs::var::+= _options $sargs; ::if {![has_help]} { ::sargs::var::unset _options .control_button.help; } toplevel_setup; menu_setup; toolbar_setup; control_button_setup; client_setup; popup_menu_setup; initialize; #2.27.3 wait; ::set Result $_dialog_result; ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } ::return $Result; } method has_help {} { /* { We override help_setup because we check for help on any of the items in the tree and report true is any al all. */ } ::set Structure [::sargs::get $_sargs .structure]; ::set _path_list [::sargs::select_field .structure $Structure .field .text]; ::foreach Path $_path_list { ::set HelpId [::sargs::get $Structure $Path.help_id]; ::if {$HelpId ne ""} { ::if {[::string first "???" $HelpId]<0} { ::if {$HelpId ne "0"} { ::return 1; } } } ::set HelpPage [::sargs::get $Structure $Path.help_page]; ::if {$HelpPage ne ""} { ::if {[::sargs::get $HelpPage .body] ne ""} { ::return 1; } } } ::return 0; } method options_setup {} { #::qw::dialog85::error_tree_dialog chain; ::sargs::var::+= _options { .title "Pick File" .class "FileDialog" .bbox "" .control_button { .help { .text "Help" .tooltip { .text "Help on this dialog window." } } .clipboard { .text "Copy to Clipboard" .tooltip { .text "Copy error information to clipboard." } } .ok { .text "Ok" .tooltip { .text "Dismiss error window." } } } .default_focus_widget .control_button.ok .width 80 .height 10 } ::sargs::var::set _options .title "Error occurred in \"[::string tolower [::file normalize [::info nameofexecutable]]]\"."; ::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 initialize {sargs} { #::qw::dialog85::error_tree_dialog $_toplevel configure -background white; $_table expandall -fully; } method popup_menu_setup {sargs} { #::qw::dialog85::error_tree_dialog ::return; } method toolbar_setup {sargs} { #::qw::dialog85::error_tree_dialog ::return; } method client_setup {sargs} { #::qw::dialog85::error_tree_dialog chain $sargs; ::frame $_toplevel.client -borderwidth 0 -relief flat -background white; ::frame $_toplevel.client.table_frame -borderwidth 0 -relief flat; ::set _image_array(error) [::image create photo -file [::file join $::qw_library system images error.gif]]; ::ttk::label $_toplevel.client.icon \ -image $_image_array(error) \ -anchor n \ -background white \ -borderwidth 0 -relief flat \ ; ::set _table $_toplevel.client.table_frame.table; ::set _hsb $_toplevel.client.table_frame.hsb; ::set _vsb $_toplevel.client.table_frame.vsb; ::tablelist::tablelist $_table \ -columns { 75 "Error" left } \ -expandcommand [::itcl::code $this node_expand] \ -collapsecommand [::itcl::code $this node_collapse] \ -xscrollcommand [::list $_hsb set] \ -yscrollcommand [::list $_vsb set] \ -showlabels 0 \ -movablecolumns no \ -setgrid no \ -showseparators 0 \ -height [::sargs::get $_options .height] \ -width [::sargs::get $_options .width] \ -stripeheight 0 \ -borderwidth 0 \ -relief flat \ ; ::if {[$_table cget -selectborderwidth] == 0} { $_table configure -spacing 1 } $_table columnconfigure $_path_column \ -formatcommand [::itcl::code $this error_node_format] \ -sortmode dictionary \ -stretch 1 \ -font $_folder_font \ ; ::ttk::scrollbar $_vsb -orient vertical -command [::list $_table yview]; ::ttk::scrollbar $_hsb -orient horizontal -command [::list $_table xview]; ::set BodyTag [$_table bodytag]; ::bind $BodyTag <> [bind TablelistBody ]; ::bind $BodyTag <> +[bind TablelistBody ]; #::bind $BodyTag [::itcl::code $this putContentsOfSelFolder $_table]; # Grid the scroll bars. ::grid $_toplevel.client.table_frame.table -row 0 -column 0 -sticky news; ::grid $_vsb -row 0 -column 1 -sticky ns; ::grid $_hsb -row 1 -column 0 -sticky ew; ::grid rowconfigure $_toplevel.client.table_frame 0 -weight 1 ::grid columnconfigure $_toplevel.client.table_frame 0 -weight 1 # ::pack $_toplevel.client.icon -side left -fill y -expand 1 -padx 0 -pady 0; # ::pack $_toplevel.client.table_frame -side left -expand 1 -fill both -padx 0 -pady 0; ::grid $_toplevel.client.icon -row 0 -column 0 -sticky nsew; ::grid $_toplevel.client.table_frame -row 0 -column 1 -sticky nsew; ::grid rowconfigure $_toplevel.client 0 -weight 1; ::grid columnconfigure $_toplevel.client 1 -weight 1; ::pack $_toplevel.client -side top -expand 1 -fill both -padx 0 -pady 0; node_populate .path "" .parent_index root; # $_table expandall -fully; # ::bind $_toplevel.client.canvas [::itcl::code $this command_process .command command_pick]; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; # ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; #2.32.0 - eliminate bug_id 314120120130150130 #2.32.0 ::bind $_toplevel [::itcl::code $this command_process .command command_mru_list]; ::return; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; } method control_button_setup {} { #::qw::dialog85::error_tree_dialog chain; } method command_process {sargs} { #::qw::dialog85::error_tree_dialog ::set Command [::sargs::get $sargs .command]; ::switch -- $Command { command_control_button { ::qw::bug 314120121022144405 "Deprecated." ::set Button [::sargs::get $sargs .control_button]; ::switch -- $Button { .help { command_process .command command_help; ::return; } .clipboard { command_process .command command_clipboard; ::return; } .ok { command_process .command command_ok; ::return; } } } command_exit { ::set _dialog_result [::sargs \ .result "" \ ]; ::return; } command_ok { ::set _dialog_result [::sargs \ .result "" \ ]; ::return; } command_clipboard { ::clipboard clear; ::clipboard append \ -displayof . \ -format STRING \ -type STRING \ -- \ [::sargs::format [::sargs::get $_options .structure]] \ ; ::return; } command_contract { contract; ::return; } command_help { /* { An error message can look like the following: Example 1 .text "This is the error message 1." .help_page { .body { [p { This is help on the error message 1. }] } } /314120120214093125 { .text "This is the error message 2." .help_page { .body { [p { This is help on the error message 2. }] } } /314120120214093131 { .text "This is the error message 3." .help_page { .body { [p { This is help on the error message 3. }] } } } } Example 2 .text "This is the error message 1." .help_id 314120120214093125 /314120120214093125 { .text "This is the error message 2." .help_id 314120120214093125 /314120120214093125 { .text "This is the error message 2." .help_id 314120120214093131 } } Help is added using either .help_id or .help_page. placed in the .help field, whether it's the help associated with an error message, or with a dialog such as notify or confirm. Help Arguments -------------- Help pages can have embedded tcl code and this code has access to the sargs structure representing the page itself. The structure is accessed using the special qw_args_get command. For example, suppose the following error message is used Arguments are passed to a help page. The help page itself, through embedded tcl using the qw_args command */ } /* { We received a nested error structure in the .structure argument. Our goal is to find any and all help pages associated with the errors in this structure and append them end-to-end in a single help page body. The error message associated with each node (taken from .text) is placed at the top of body area for that error in a html header. We iterate through the paths in the order returned by the select statement. This is a top down forward traversal that conforms to order seen in the error tree. Most error messages are somewhat "linear" with one child at each level, but this algorithm will work even for nodes with multiple children, using a standard traversal. */ } ::set Formatter [::qw::html::formatter ::qw::html::formatter::#auto]; ::qw::finally [::list ::itcl::delete object $Formatter]; ::set NestedErrorStructure [::sargs::get $_sargs .structure]; /* { We find the path to each error node by selecting nodes that contain a .text inner field. These should be the error nodes. */ } ::set Paths [::sargs::select_field .structure $NestedErrorStructure .field .text]; ::set UniqueId 0; ::set Body ""; ::foreach Path $Paths { /* { We render the page associated with each error message as identified by its .help_id or .help_page and we append this page to the body. We are producing a single page whose body is the closure of all the pages associated with all error messages in the error structure. This is more convenient than forcing the user to click on each tree node. We generate one h2 header for each error message in the final body. */ } ::set ErrorNode [::sargs::get $NestedErrorStructure $Path]; ::set HelpId [::sargs::get $ErrorNode .help_id]; ::set HelpPage [::sargs::get $ErrorNode .help_page]; ::set Text [::sargs::get $ErrorNode .text]; ::set Title [::string map {"\"" ""} $Text]; ::set RenderedTitle [::subst -nobackslashes -nocommands {[h2 {$Title}]}]; ::append Body $RenderedTitle; # ::sargs::var::set NestedErrorStructure "$Path.title" $Title; # ::sargs::var::set NestedErrorStructure "$Path.id" "3141[::clock seconds][::incr UniqueId]"; ::if {$HelpPage eq ""} { ::if {$HelpId ne ""} { ::set HelpPage [::qw::help::find_page_by_id $HelpId]; } } ::if {$HelpPage eq ""} { /* { If there is no still no help for an error message we create an arbitrary body that says so in some way. We could instead leave it blank. The resulting help page will show the error message in a header regardless. */ } ::sargs::var::set HelpPage .body { [p { No help available. }] } } ::sargs::var::set HelpPage .title $Title; ::sargs::var::set HelpPage .id "3141[::clock seconds][::incr UniqueId]"; ::foreach Field [::sargs::names .structure $HelpPage .pattern .*] { ::if {![::sargs::exists $NestedErrorStructure $Path$Field]} { ::sargs::var::set NestedErrorStructure $Path$Field [::sargs::get $HelpPage $Field]; } } ::append Body [::sargs::get $HelpPage .body]; } ::foreach Path $Paths { /* { The body has been completely built as the closure of all the error help bodies at this point. Now we iterate through the tree structure that we will eventually pass the help compiler and give each node this body. This may be inefficient but it has not been a problem. What is important is that the user sees the tree in the left pane and the full help in the right pane regardless of what he/she clicks on in the left pane. */ } ::sargs::var::set NestedErrorStructure $Path.body $Body; } ::qw::script::source \ .script.path [::file join $::qw_library doc qw_chtml_compile.qw_script] \ .structure $NestedErrorStructure \ .compiler.command error \ ; ::return; ::set HelpArgs ""; ::sargs::var::set HelpArgs .tree.handle $Tree .tree.structure [::sargs::get $s_args .structure]; ::set HelpCommand [::list ::qw::help::launch_from_error_dialog $HelpArgs] $Controls.cancel configure -command {::set ::qw::dialog::result ""} $Controls.help configure -command $HelpCommand; } command_help_save { /* { An error message can look like the following: Example 1 .text "This is the error message 1." .help_page { .body { [p { This is help on the error message 1. }] } } /314120120214093125 { .text "This is the error message 2." .help_page { .body { [p { This is help on the error message 2. }] } } /314120120214093131 { .text "This is the error message 3." .help_page { .body { [p { This is help on the error message 3. }] } } } } Example 2 .text "This is the error message 1." .help_id 314120120214093125 /314120120214093125 { .text "This is the error message 2." .help_id 314120120214093125 /314120120214093125 { .text "This is the error message 2." .help_id 314120120214093131 } } Help is added using either .help_id or .help_page. placed in the .help field, whether it's the help associated with an error message, or with a dialog such as notify or confirm. Help Arguments -------------- Help pages can have embedded tcl code and this code has access to the sargs structure representing the page itself. The structure is accessed using the special qw_args_get command. For example, suppose the following error message is used Arguments are passed to a help page. The help page itself, through embedded tcl using the qw_args command */ } /* { We received a nested error structure in the .structure argument. Our goal is to find any and all help pages associated with the errors in this structure and appended them end-to-end in a single help page body. The error message associated with each node (taken from .text) is placed at the top of body area for that error in a html header. We iterate through the paths in the order returned by the select statement. This is a top down forward traversal that conforms to order seen in the error tree. Most error messages a somewhat "linear" with one child at each level, but this algoithm will work even for node with multiple childer, using a standard traversal. */ } ::set Formatter [::qw::html::formatter ::qw::html::formatter::#auto]; ::qw::finally [::list ::itcl::delete object $Formatter]; ::set NestedErrorStructure [::sargs::get $_sargs .structure]; /* { We find the path to each error node by selecting nodes that contain a .text inner field. These should be the error nodes. */ } ::set Paths [::sargs::select_field .structure $NestedErrorStructure .field .text]; ::set UniqueId 0; ::set Body ""; ::foreach Path $Paths { /* { We render the page associated with each error message as identified by its .help_id or .help_page and we append this page to the body. We are producing a single page whose body is the closure of all the pages associated with all error messages in the error structure. This is more convenient than forcing the user to click on each tree node. We generate one h2 header for each error message in the final body. */ } ::set ErrorNode [::sargs::get $NestedErrorStructure $Path]; ::set HelpId [::sargs::get $ErrorNode .help_id]; ::set HelpPage [::sargs::get $ErrorNode .help_page]; ::set Text [::sargs::get $ErrorNode .text]; ::set Title [::string map {"\"" ""} $Text]; ::set RenderedTitle [::subst -nobackslashes -nocommands {[h2 {$Title}]}]; ::append Body $RenderedTitle; ::sargs::var::set NestedErrorStructure "$Path.title" $Title; ::sargs::var::set NestedErrorStructure "$Path.id" "3141[::clock seconds][::incr UniqueId]"; ::if {$HelpPage eq ""} { ::if {$HelpId eq ""} { /* { If there is no help for an error message we create an arbitrary body that says so in some way. We could instead leave it blank. The resulting help page will show the error message in a header regardless. */ } ::append Body { [p { No help available. }] } ::continue; } ::set HelpPage [::qw::help::find_page_by_id $HelpId]; ::foreach Field [::sargs::names .structure $ErrorNode .pattern .*] { ::sargs::var::set HelpPage $Field [::sargs::get $ErrorNode $Field]; } } ::append Body [::sargs::get [$Formatter body_render $HelpPage] .body]; } ::foreach Path $Paths { /* { The body has been completely built as the closure of all the error help bodies at this point. Now we iterate through the tree structure that we will eventual pass the help compiler and give each node this body. This may be inefficient but it has not been a problem. What is important is that the user sees the tree in the left pane and the full help in the right pane regardless of what he/she clicks on in the left pane. */ } ::sargs::var::set NestedErrorStructure $Path.body $Body; } ::qw::script::source \ .script.path [::file join $::qw_library doc qw_chtml_compile.qw_script] \ .structure $NestedErrorStructure \ .compiler.command error \ ; ::return; ::set HelpArgs ""; ::sargs::var::set HelpArgs .tree.handle $Tree .tree.structure [::sargs::get $s_args .structure]; ::set HelpCommand [::list ::qw::help::launch_from_error_dialog $HelpArgs] $Controls.cancel configure -command {::set ::qw::dialog::result ""} $Controls.help configure -command $HelpCommand; } } ::return [chain $sargs]; } method tooltip_get {sargs} { #::qw::dialog85::error_tree_dialog ::set Widget [::sargs::get $sargs .widget]; ::set Text ""; ::switch -glob -- $Widget { *.control_button.ok { ::append Text "Enter - Pick the current file."; ::return [::sargs .text $Text]; } *.control_button.mru_list { ::append Text "F3 - Pick from a list of recently used files."; ::return [::sargs .text $Text]; } *.control_button.cancel - *.menubar.file.exit { ::append Text "Esc - Dismiss without picking a file."; ::return [::sargs .text $Text]; } *.control_button.help - *.menubar.help.export { ::append Text "F1 - Help on this dialog."; ::return [::sargs .text $Text]; } } ::return [chain $sargs]; } method debug_dump_table {} { #::qw::dialog85::error_tree_dialog ::return; ::puts "debug,table start ----------------------------------" ::set Row 0; ::foreach Item [$_table get 0 end] { ::puts "debug,Row:$Row==$Item"; ::incr Row; } ::puts "debug,table end ----------------------------------" } method node_populate {sargs} { #::qw::dialog85::error_tree_dialog /* { Outputs the contents of the folder into the tablelist, as child items of the one identified by nodeIdx. */ } ::set Folder [::sargs::get $sargs .path]; ::set NodeIdx [::sargs::get $sargs .parent_index]; ::set Structure [::sargs::get $_options .structure]; ::set ItemList [::list]; ::if {$NodeIdx eq "root"} { #debug we will get rid of double click on node to do what they did $_table delete 0 end ::set row 0; ::lappend ItemList [::list ""]; } else { ::set row [::expr {$NodeIdx+1}]; ::foreach SubName [::sargs::subs .structure [::sargs::get $Structure $Folder]] { ::lappend ItemList [::list $Folder$SubName]; } } /* { Build a list from the data of the sub-folders and files of the specified folder. */ } $_table insertchildlist $NodeIdx end $ItemList; # # ::foreach Item $ItemList { /* { Insert an image into the first cell of each newly inserted row */ } ::set Path [::lindex $Item 0]; $_table cellconfigure $row,$_path_column -image $_image_array(closed_folder) $_table rowattrib $row .path $Path; /* { Mark row as collapsed if it is a non-empty folder. */ } ::set SubCount [::llength [::sargs::subs .structure [::sargs::get $Structure $Path]]]; ::if {$SubCount!=0} { $_table collapse $row } ::incr row; } /* { if {$nodeIdx eq "root"} { /* { Re-configure the refresh and parent buttons. */ } ::if {[::winfo exists $_toplevel.toolbar_frame.parent]} { ::if {$Folder eq ""} { $_toplevel.toolbar_frame.parent configure -state disabled; } else { $_toplevel.toolbar_frame.parent configure -state normal; ::set ParentFolder [::file dirname $Folder]; ::if {$ParentFolder eq $Folder} { $_toplevel.toolbar_frame.parent configure -command [::itcl::code putContents "" $_table root] } else { $_toplevel.toolbar_frame.parent configure -command [::itcl::code putContents $ParentFolder $_table root] } } } } */ } debug_dump_table; } method putContents_save {Folder Table nodeIdx} { #::qw::dialog85::error_tree_dialog /* { Outputs the contents of the folder into the tablelist, as child items of the one identified by nodeIdx. */ } ::set Structure [::sargs::get $_options .structure]; ::set ItemList [::list]; ::if {$nodeIdx eq "root"} { #debug we will get rid of double click on node to do what they did $_table delete 0 end ::set row 0; ::lappend ItemList [::list ""]; } else { ::set row [::expr {$nodeIdx+1}]; ::foreach SubName [::sargs::subs .structure [::sargs::get $Structure $Folder]] { ::lappend ItemList [::list $Folder$SubName]; } } /* { Build a list from the data of the sub-folders and files of the specified folder. */ } $_table insertchildlist $nodeIdx end $ItemList; # # ::foreach Item $ItemList { /* { Insert an image into the first cell of each newly inserted row */ } ::set Path [::lindex $Item 0]; $_table cellconfigure $row,$_path_column -image $_image_array(closed_folder) $_table rowattrib $row .path $Path; /* { Mark row as collapsed if it is a non-empty folder. */ } ::set SubCount [::llength [::sargs::subs .structure [::sargs::get $Structure $Path]]]; ::if {$SubCount!=0} { $_table collapse $row } ::incr row; } if {$nodeIdx eq "root"} { /* { Re-configure the refresh and parent buttons. */ } ::if {[::winfo exists $_toplevel.toolbar_frame.parent]} { ::if {$Folder eq ""} { $_toplevel.toolbar_frame.parent configure -state disabled; } else { $_toplevel.toolbar_frame.parent configure -state normal; ::set ParentFolder [::file dirname $Folder]; ::if {$ParentFolder eq $Folder} { $_toplevel.toolbar_frame.parent configure -command [::itcl::code putContents "" $_table root] } else { $_toplevel.toolbar_frame.parent configure -command [::itcl::code putContents $ParentFolder $_table root] } } } } debug_dump_table; } method putContentsOfSelFolder {Table} { #::qw::dialog85::error_tree_dialog /* { Populates the contents of the selected folder into the tablelist. */ } ::set Row [$Table curselection]; if {[$Table hasrowattrib $Row .path]} { # folder node ::set Path [$Table rowattrib $Row .path]; ::set Nodestructor [::sargs::get $_options .structure$Path]; ::set Kids [::sargs::subs .structure $Nodestructor]; ::if {[::llength $Kids]!=0} { putContents $Path $Table $Row } } } method error_node_format {Path} { #::qw::dialog85::error_tree_dialog /* { We are give the path. We display the corresponding text from the error structure. */ } ::set Result [::sargs::get $_options .structure$Path.text]; ::return $Result; } method contract {} { #::qw::dialog85::error_tree_dialog } method popup_menu_post {sargs} { #::qw::dialog85::error_tree_dialog /* { Posts the pop-up menu .menu at the given screen position. Before posting the menu, the procedure enables/disables its only entry, depending upon whether the selected item represents a readable directory or not. */ } ::set X [::sargs::get $sargs .x]; ::set Y [::sargs::get $sargs .y]; set Row [$_table curselection] if {[$_table hasrowattrib $Row .path]} { # folder node set dir [$_table rowattrib $Row .path]; if {[::file isdirectory $dir] && [file_is_readable $dir]} { if {[::llength [::glob -nocomplain -types {d f} -directory $dir *]]==0} { $_toplevel.popup_menu entryconfigure 0 -state disabled; } else { $_toplevel.popup_menu entryconfigure 0 -state normal; } } else { ::qw::throw \ .text "Can't read folder \"[file nativename $dir]\"." \ .help_id ??? \ ; bell tk_messageBox -title "Error" -icon error -message \ "Cannot read directory \"[file nativename $dir]\"" return "" } ::set ParentFolder [::file dirname $Folder]; ::if {$ParentFolder eq ""} { $_toplevel.popup_menu entryconfigure 1 -state disabled; } else { $_toplevel.popup_menu entryconfigure 1 -state enabled; } } else { ;# file item # file node $_toplevel.popup_menu entryconfigure 0 -state disabled; } ::tk_popup $_toplevel.popup_menu $X $Y; } method restoreExpandedStates {Table nodeIdx expandedFoldersName} { #::qw::dialog85::error_tree_dialog /* { Expands subs of the parent identified by nodeIdx that display folders whose path names are the names of the elements of the array specified by the last argument. */ } ::upvar $expandedFoldersName expandedFolders ::foreach Row [$Table childkeys $nodeIdx] { ::set Path [$Table rowattrib $Row .path] ::if {$Path ne "" && [::info exists expandedFolders($Path)]} { $Table expand $Row -partly; restoreExpandedStates $Table $Row expandedFolders; } } } method node_expand {Table Row} { #::qw::dialog85::error_tree_dialog /* { Can't use command_process as this is a hard-wired callback from the tablelist. Outputs the contents of the folder whose leaf name is displayed in the first cell of the specified row. The items are the child items of the item identified by row. The updates the image displayed in that cell. */ } ::if {[$Table childcount $Row]==0} { ::set Folder [$Table rowattrib $Row .path]; node_populate .path $Folder .parent_index $Row; } ::if {[$Table childcount $Row]!=0} { /* { After the expand, only if the node has subs, we set it to the open image. */ } $Table cellconfigure $Row,$_path_column -image $_image_array(open_folder); } } method node_collapse {Table Row} { #::qw::dialog85::error_tree_dialog /* { This callback is called before the row is collapsed. Can't use command_process as this is a hard-wired callback from the tablelist. Updates the image displayed in the first cell of the specified row of the tablelist. */ } $Table cellconfigure $Row,$_path_column -image $_image_array(closed_folder); } } # ------------------------------------------------------------ # ::qw::dialog85::error_flat_dialog # ------------------------------------------------------------ ::itcl::class ::qw::dialog85::error_flat_dialog { /* { Notes: */ } inherit ::qw::dialog85::dialog_archetype; protected variable _has_details 0; protected variable _path_list [::list]; constructor {} { #::qw::dialog85::error_flat_dialog } destructor { #::qw::dialog85::error_flat_dialog } method main {sargs} { #::qw::dialog85::error_flat_dialog ::set _sargs $sargs; options_setup; ::sargs::var::+= _options $sargs; ::if {![has_help]} { ::sargs::var::unset _options .control_button.help; } toplevel_setup; menu_setup; toolbar_setup; control_button_setup; client_setup; popup_menu_setup; initialize; wait; ::set Result $_dialog_result; ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } ::return $Result; } method options_setup {} { #::qw::dialog85::error_flat_dialog chain; ::sargs::var::+= _options { .title "Error Message" .class "Notify" .sound "SystemAsterisk" .bitmap info .bbox "" .help { .help_id default_error_flat_dialog_help } .control_button { .help { .text "Help" .tooltip { .text "Help on this dialog window." } } .details { .text "Details" .tooltip { .text "More details on this message." } } .cancel { .text "Ok" .tooltip { .text "Dismiss dialog window." } } } .default_focus_widget .control_button.cancel }; ::if {[::string match -nocase "benn*" [::info hostname]]} { ::if {!$::qw::control(is_release)} { ::sargs::var::set _options .title "[::file tail [::info nameofexecutable]] - [::sargs::get $_options .title] - $::qw::control(app_name)"; } } } method has_help {} { /* { We override help_setup because for help on a flat error message we only look at the leaf item in the tree. */ } ::set Structure [::sargs::get $_sargs .structure]; ::set _path_list [::sargs::select_field .structure $Structure .field .text]; ::set LastStructure [::sargs::get $Structure [::lindex $_path_list end]]; ::set HelpId [::sargs::get $LastStructure .help_id]; ::if {$HelpId ne ""} { ::if {[::string first "???" $HelpId]<0} { ::if {$HelpId ne "0"} { ::return 1; } } } ::set HelpPage [::sargs::get $LastStructure .help_page]; ::if {$HelpPage ne ""} { ::if {[::sargs::get $HelpPage .body] ne ""} { ::return 1; } } ::return 0; } method initialize {sargs} { #::qw::dialog85::error_flat_dialog chain $sargs; } method client_setup {sargs} { #::qw::dialog85::error_flat_dialog chain $sargs; ::frame $_toplevel.client; ::set _image_array(error) [::image create photo -file [::file join $::qw_library system images warning.gif]]; ::bind $_toplevel [::itcl::code $this command_process .command command_exit]; # ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; ::set Structure [::sargs::get $_sargs .structure]; ::set LastStructure [::sargs::get $Structure [::lindex $_path_list end]]; /* { ::if {[::sargs::exists $_sargs .html.body]} { /* { This was just and experiment to see what problems would come up if we used a tkhtml3 widget. Everything seems fine except: - resizing exposes borders, padding etc. - don't know what size to make it */ } ::package require Tkhtml 3.0; ::set BgColor [::sargs::get $_sargs .background]; ::if {$BgColor eq ""} { ::set BgColor white; } ::ttk::label $_toplevel.client.icon \ -image $_image_array(error) \ -background $BgColor \ ; ::html $_toplevel.client.html \ -fontscale $_html_fontscale \ -width 6i \ -height 4i \ ; #-shrink 1 ::set Body ""; ::append Body ""; ::append Body [::sargs::get $_sargs .html.body]; $_toplevel.client.html parse -final $Body; ::pack $_toplevel.client.icon -anchor n -side left -fill y -expand 1; ::pack $_toplevel.client.html -side right -expand 1 -fill both; ::pack $_toplevel.client -side top -expand 1 -fill both; ::return; } */ } ::if {[::sargs::exists $_sargs .html.body]} { /* { This was just and experiment to see what problems would come up if we used a tkhtml3 widget. Everything seems fine except: - resizing exposes borders, padding etc. - don't know what size to make it Why all the extra frames? I put the icon and the html inside frames that expand in order to keep the background white when stretching. */ } ::package require Tkhtml 3.0; ::set BgColor [::sargs::get $_sargs .background]; ::if {$BgColor eq ""} { ::set BgColor white; } ::frame $_toplevel.client.frame \ -background $BgColor ; ::frame $_toplevel.client.frame.icon_frame \ -background $BgColor ; ::frame $_toplevel.client.frame.html_frame \ -background $BgColor ; ::ttk::label $_toplevel.client.frame.icon_frame.icon \ -image $_image_array(error) \ -background $BgColor \ ; ::html $_toplevel.client.frame.html_frame.html \ -fontscale $_html_fontscale \ -shrink 1 \ ; ::set Body ""; ::append Body ""; ::append Body [::sargs::get $_sargs .html.body]; $_toplevel.client.frame.html_frame.html parse -final $Body; ::pack $_toplevel.client.frame -side left -fill both -expand 1; ::pack $_toplevel.client.frame.icon_frame -side left -fill both -expand 1; ::pack $_toplevel.client.frame.html_frame -side right -fill both -expand 1; ::pack $_toplevel.client.frame.icon_frame.icon -side top -fill x -expand 1; ::pack $_toplevel.client.frame.html_frame.html -side left -fill x -expand 1; ::pack $_toplevel.client -side top -expand 1 -fill both; ::return; } ::set Text [::sargs::get $LastStructure .text]; ::if {$Text eq ""} { ::set Text $LastStructure; } ::ttk::label $_toplevel.client.icon \ -image $_image_array(error) \ ; ::ttk::label $_toplevel.client.text \ -text $Text \ -justify left \ ; ::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 # ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; } method client_setup1 {sargs} { #::qw::dialog85::error_flat_dialog chain $sargs; ::frame $_toplevel.client; ::set _image_array(error) [::image create photo -file [::file join $::qw_library system images info.gif]]; ::ttk::label $_toplevel.client.icon \ -image $_image_array(error) \ ; ::ttk::label $_toplevel.client.text \ -text [::sargs::get $_options .text] \ -justify left \ ; ::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 ::bind $_toplevel [::itcl::code $this command_process .command command_exit]; ::return; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; } method control_button_setup {} { #::qw::dialog85::error_flat_dialog chain; } method command_process {sargs} { #::qw::dialog85::error_flat_dialog ::set Command [::sargs::get $sargs .command]; ::switch -- $Command { command_control_button { ::qw::bug 314120121022144406 "Deprecated." ::set Button [::sargs::get $sargs .control_button]; ::switch -- $Button { .details { command_process .command command_details; ::return; } } } command_exit { ::set _dialog_result 1; ::return; } command_details { ::qw::dialog85::error_tree $_sargs; ::return; } command_help { /* { Since this is a flat error message we only want any help associated with the last (leaf) error in the tree. An error message can look like the following: Example 1 .text "This is the error message 1." .help_page { .body { [p { This is help on the error message 1. }] } } /314120120214093125 { .text "This is the error message 2." .help_page { .body { [p { This is help on the error message 2. }] } } /314120120214093131 { .text "This is the error message 3." .help_page { .body { [p { This is help on the error message 3. }] } } } } Example 2 .text "This is the error message 1." .help_id 314120120214093125 /314120120214093125 { .text "This is the error message 2." .help_id 314120120214093125 /314120120214093125 { .text "This is the error message 2." .help_id 314120120214093131 } } Help is added using either .help_id or .help_page. placed in the .help field, whether it's the help associated with an error message, or with a dialog such as notify or confirm. Help Arguments -------------- Help pages can have embedded tcl code and this code has access to the sargs structure representing the page itself. The structure is accessed using the special qw_args_get command. For example, suppose the following error message is used Arguments are passed to a help page. The help page itself, through embedded tcl using the qw_args command */ } /* { We received a nested error structure in the .structure argument. Our goal is to find any and all help pages associated with the errors in this structure and append them end-to-end in a single help page body. The error message associated with each node (taken from .text) is placed at the top of body area for that error in a html header. We iterate through the paths in the order returned by the select statement. This is a top down forward traversal that conforms to order seen in the error tree. Most error messages are somewhat "linear" with one child at each level, but this algorithm will work even for nodes with multiple children, using a standard traversal. */ } ::set Formatter [::qw::html::formatter ::qw::html::formatter::#auto]; ::qw::finally [::list ::itcl::delete object $Formatter]; ::set Structure [::sargs::get $_sargs .structure]; ::set LastStructure [::sargs::get $Structure [::lindex $_path_list end]]; ::set Count 0; ::foreach Path $_path_list { ::incr Count; } ::set NestedErrorStructure [::sargs::get $Structure [::lindex $_path_list end]]; # ::set NestedErrorStructure [::sargs::get $_sargs .structure]; /* { We find the path to each error node by selecting nodes that contain a .text inner field. These should be the error nodes. */ } ::set Paths [::sargs::select_field .structure $NestedErrorStructure .field .text]; ::set UniqueId 0; ::set Body ""; ::foreach Path $Paths { /* { We render the page associated with each error message as identified by its .help_id or .help_page and we append this page to the body. We are producing a single page whose body is the closure of all the pages associated with all error messages in the error structure. This is more convenient than forcing the user to click on each tree node. We generate one h2 header for each error message in the final body. */ } ::set ErrorNode [::sargs::get $NestedErrorStructure $Path]; ::set HelpId [::sargs::get $ErrorNode .help_id]; ::set HelpPage [::sargs::get $ErrorNode .help_page]; ::set Text [::sargs::get $ErrorNode .text]; ::set Title [::string map {"\"" ""} $Text]; ::set RenderedTitle [::subst -nobackslashes -nocommands {[h2 {$Title}]}]; ::append Body $RenderedTitle; # ::sargs::var::set NestedErrorStructure "$Path.title" $Title; # ::sargs::var::set NestedErrorStructure "$Path.id" "3141[::clock seconds][::incr UniqueId]"; ::if {$HelpPage eq ""} { ::if {$HelpId ne ""} { ::set HelpPage [::qw::help::find_page_by_id $HelpId]; } } ::if {$HelpPage eq ""} { /* { If there is no still no help for an error message we create an arbitrary body that says so in some way. We could instead leave it blank. The resulting help page will show the error message in a header regardless. */ } ::sargs::var::set HelpPage .body { [p { No help available. }] } } ::sargs::var::set HelpPage .title $Title; ::sargs::var::set HelpPage .id "3141[::clock seconds][::incr UniqueId]"; ::foreach Field [::sargs::names .structure $HelpPage .pattern .*] { ::if {![::sargs::exists $NestedErrorStructure $Path$Field]} { ::sargs::var::set NestedErrorStructure $Path$Field [::sargs::get $HelpPage $Field]; } } ::append Body [::sargs::get $HelpPage .body]; } ::foreach Path $Paths { /* { The body has been completely built as the closure of all the error help bodies at this point. Now we iterate through the tree structure that we will eventually pass the help compiler and give each node this body. This may be inefficient but it has not been a problem. What is important is that the user sees the tree in the left pane and the full help in the right pane regardless of what he/she clicks on in the left pane. */ } ::sargs::var::set NestedErrorStructure $Path.body $Body; } ::qw::script::source \ .script.path [::file join $::qw_library doc qw_chtml_compile.qw_script] \ .structure $NestedErrorStructure \ .compiler.command error \ ; ::return; ::set HelpArgs ""; ::sargs::var::set HelpArgs .tree.handle $Tree .tree.structure [::sargs::get $s_args .structure]; ::set HelpCommand [::list ::qw::help::launch_from_error_dialog $HelpArgs] $Controls.cancel configure -command {::set ::qw::dialog::result ""} $Controls.help configure -command $HelpCommand; } } ::return [chain $sargs]; } method tooltip_get {sargs} { #::qw::dialog85::error_flat_dialog ::return [chain $sargs]; } } # ------------------------------------------------------------ # ::qw::dialog85::file_explorer # ------------------------------------------------------------ ::itcl::class ::qw::dialog85::file_explorer_dialog { /* { */ } inherit ::qw::dialog85::dialog_archetype; protected variable _table ""; protected variable _use_file_readable 0; protected variable _current_root_path ""; # current contents are subs of this folder protected variable _path_column 0; protected variable _selected_file ""; # just the default, really. constructor {} { #::qw::dialog85::file_explorer_dialog /* { Collects a file/folder path. Returns "" if nothing was selected. From 2.22.2 on, we can return a list if the .multiple_items_allowed .default Positions on this path. .files 0/1 If 1 then displays files, otherwise just directories. .pattern_list Only file/folders matching patterns in this list of patterns are displayed. .type file \ .title "Select Database" \ .default $Default \ .files 1 \ .pattern_list *.nv2 \ .default_expand 1 \ .help.help_id 314120050330175634 \ Notes: (1) Prefix column contents with D or F. We prepend a "D" or "F" to each cell's contents so that when sorted, the folders are seprated from the files. The leading character is removed by the corresponding format callback. (2) We put the full path in the first column and then hide that column. This way we can use the first column for searching, which we need to do in order to position on the default. */ } } method main {sargs} { #::qw::dialog85::file_explorer_dialog ::set _sargs $sargs; options_setup; ::sargs::var::+= _options $sargs; ::if {![has_help]} { ::sargs::var::unset _options .control_button.help; } toplevel_setup; menu_setup; toolbar_setup; control_button_setup; client_setup; popup_menu_setup; initialize; wait; ::set Result $_dialog_result; ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } ::return $Result; } method options_setup {} { #::qw::dialog85::file_explorer_dialog chain; ::sargs::var::+= _options { .title "Pick File" .class "FileDialog" .bbox "" .control_button { .help { .text "Help" .tooltip { .text "Help on this dialog window." } } .cancel { .text "Dismiss" .tooltip { .text "Dismiss dialog window." } } .mru_list { .text "Recent List" .tooltip { .text "Pick from list of recently used values." } } .ok { .text "Ok" .tooltip { .text "Pick currently selected value." } } } .default {} .files 1 .pattern_list * .mru_list_is_enabled 0 .mru_list {} .default_focus_widget .control_button.ok } # ::source [::file join $ScriptFolder option.tcl] #BWIDGET::LIBRARY ::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]]; ::set Title [::sargs::get $_sargs .title]; ::if {$Title eq ""} { ::switch -- [::sargs::boolean_get $_options .files] { 0 {::sargs::var::set _options .title "Pick Folder";} 1 {::sargs::var::set _options .title "Pick File";} } } } method initialize {sargs} { #::qw::dialog85::file_explorer_dialog position_on_absolute_path .path [::sargs::get $_options .default]; see_nice } destructor { #::qw::dialog85::file_explorer_dialog } method popup_menu_setup {sargs} { #::qw::dialog85::file_explorer_dialog ::return; } method toolbar_setup {sargs} { #::qw::dialog85::file_explorer_dialog ::return; } method file_is_readable {Path} { #::qw::dialog85::file_explorer_dialog ::if {$_use_file_readable} { ::return [::file readable $Path]; } ::return 1; } method putContents {Folder Table nodeIdx} { #::qw::dialog85::file_explorer_dialog /* { Outputs the contents of the folder into the tablelist, as child items of the one identified by nodeIdx. */ } #- doesn't work - sets wait cursor permanently /* { We save the current cursor and use ::qw::finally to restore the it's value on exit. Note that we have to call ::update ti make the cursor take effect. */ } ::set CursorSave [$_table cget -cursor]; ::qw::finally [::subst -nocommands { ::if {[::winfo exists $_table]} { /* { Note: The cursor must be quoted in the next line because because we are using ::subst and if the value is Cursor is empty it will not show up as an argument. */ } $_table configure -cursor "$CursorSave"; } }]; $_table configure -cursor $::qw::control(wait_cursor); ::update; ::if {$Table ne $_table} { ::qw::bug 314120120105152216 "[::qw::methodname] - invalid table \"$Table\"."; } ::if {$Folder ne ""&&(![::file isdirectory $Folder]||![file_is_readable $Folder])} { /* { This check is necessary because this procedure can be invoked by the refresh and parent buttons. Used to put up a confirm, but what's the point of that. */ } ::while {![::file isdirectory $Folder]||![file_is_readable $Folder]} { ::set Folder [::file dirname $Folder] } } ::if {$nodeIdx eq "root"} { #debug we will get rid of double click on node to do whet they did if {$Folder eq ""} { # ::wm title $_toplevel "Contents of the Workspace"; } else { # ::wm title $_toplevel "Contents of the Directory \"[::file nativename $Folder]\""; } $_table delete 0 end set row 0 } else { ::set row [::expr {$nodeIdx + 1}]; } /* { Build a list from the data of the sub-folders and files of the specified folder. Kludge alert: Prepend a "D" or "F" to each entry's name and modification date & time, for sorting purposes (it will be removed by formatString). This separates the folders from the files just like in a windows explorer. */ } ::set ItemList [::list]; ::if {$Folder eq ""} { ::set VolumeList [::file volumes]; ::foreach Volume $VolumeList { /* { name,size,date, size<0 is not desiplayed and "D" is simple placeholder for date. Don't know what the last element is for. */ } ::lappend ItemList [::list "V$Volume"]; } } else { /* { We get all of the sub-folders, but for files we get only those that match the pattern list. The pattern list defaults to "*", meaning all. */ } ::set PatternList [::sargs::get $_options .pattern_list]; ::if {$PatternList eq ""} { ::set PatternList [::list *]; } ::set FolderList [::glob -nocomplain -types [::list d] -directory $Folder *]; ::if {$::tcl_version==8.4} { ::set FileList [::eval ::glob -nocomplain -types [::list f] -directory [::list $Folder] $PatternList]; } else { ::set FileList [::eval ::glob -nocomplain -types [::list f] -directory [::list $Folder] $PatternList]; } ::foreach AbsoluteFilePath [::concat $FolderList $FileList] { ::qw::try { ::set ModTime [::file mtime $AbsoluteFilePath]; } catch Dummy { ::continue; } ::if {[::file isdirectory $AbsoluteFilePath]} { # ::lappend ItemList [::list D[::file tail $AbsoluteFilePath] -1 D[::clock format $ModTime -format "%Y-%m-%d %H:%M"] "D$AbsoluteFilePath"]; ::lappend ItemList [::list "D$AbsoluteFilePath"]; } else { # ::lappend ItemList [::list F[::file tail $AbsoluteFilePath] [::file size $AbsoluteFilePath] F[::clock format $ModTime -format "%Y-%m-%d %H:%M"] "F$AbsoluteFilePath"]; ::lappend ItemList [::list "F$AbsoluteFilePath"]; } } } # # Sort the above list and insert it into the tablelist widget # tbl as list of children of the row identified by nodeIdx # ::set ItemList [$_table applysorting $ItemList]; $_table insertchildlist $nodeIdx end $ItemList; # # Insert an image into the first cell of each newly inserted row # ::foreach Item $ItemList { ::set AbsoluteFilePath [::string range [::lindex $Item end] 1 end]; ::set Type [::string range [::lindex $Item $_path_column] 0 0]; ::switch -- $Type { F { # this is a file $_table cellconfigure $row,$_path_column -image $_image_array(file); $_table rowattrib $row .path $AbsoluteFilePath; } V - D { # this is a folder $_table cellconfigure $row,$_path_column -image $_image_array(closed_folder) $_table rowattrib $row .path $AbsoluteFilePath; /* { Mark row as collapsed if it is a non-empty folder. */ } ::if {[file_is_readable $AbsoluteFilePath]} { /* { We determine whether the node has subs or not and collapse if it does. */ } ::set HasSubs [::llength [::glob -nocomplain -types [::list d] -directory $AbsoluteFilePath *]] ::if {$HasSubs==0} { ::if {$::tcl_version==8.4} { ::set HasSubs [::llength [::eval ::glob -nocomplain -types [::list f] -directory [::list $AbsoluteFilePath] [::sargs::get $_options .pattern_list]]]; } else { ::set HasSubs [::llength [::eval ::glob -nocomplain -types [::list f] -directory [::list $AbsoluteFilePath] [::sargs::get $_options .pattern_list]]]; } } ::if {$HasSubs!=0} { $_table collapse $row } } else { } } } ::incr row; } /* { foreach item $ItemList { set name [lindex $item end] if {[string compare $name ""] == 0} { ;# file $_table cellconfigure $row,0 -image fileImg } else { ;# directory $_table cellconfigure $row,0 -image folder_closedImg $_table rowattrib $row .path $name # # Mark the row as collapsed if the directory is non-empty # if {[file readable $name] && [llength \ [glob -nocomplain -types {d f} -directory $name *]] != 0} { $_table collapse $row } } incr row } */ } if {$nodeIdx eq "root"} { /* { Re-configure the refresh and parent buttons. */ } ::if {[::winfo exists $_toplevel.toolbar_frame.refresh]} { $_toplevel.toolbar_frame.refresh configure -command [::itcl::code $this refreshView $Folder $_table]; } ::if {[::winfo exists $_toplevel.toolbar_frame.parent]} { ::if {$Folder eq ""} { $_toplevel.toolbar_frame.parent configure -state disabled; } else { $_toplevel.toolbar_frame.parent configure -state normal; ::set ParentFolder [::file dirname $Folder]; ::if {$ParentFolder eq $Folder} { $_toplevel.toolbar_frame.parent configure -command [::itcl::code putContents "" $_table root] } else { $_toplevel.toolbar_frame.parent configure -command [::itcl::code putContents $ParentFolder $_table root] } } } } } method format_tail {AbsolutePath} { #::qw::dialog85::file_explorer_dialog /* { Strips the first character which is a D or F. The leading D/F causes the folders to sort separate from the files. */ } ::if {[::string index $AbsolutePath 0] eq "V"} { /* { Strip training "/" if this is a volume. */ } ::set Drive [::string range $AbsolutePath 1 end-1]; ::set Label ""; ::qw::try { /* { Lot's can go wrong here and we just ignore it. Unfortunately this also caused me to miss the fact that twapi wasn't loaded, which is not a good thing. Turned out we got tablelist 5.4 working in tcl 8.4 by bring it back from tcl 8.5 and turning modules (.tm) back into pacjages (pkgIndex.tcl). But we were unable (or at least not willing to expend the effort), to get a version of twapi working in tcl, so this also serves to keep the dialog working without twapi. */ } ::if {$::tcl_platform(platform) eq "windows"} { # ::qw::packages::package_require_twapi; ::set Label [::twapi::get_volume_info $Drive -label]; } } catch dummy {} ::if {$Label eq ""} { ::return $Drive; } ::set Label [::lindex $Label 1]; ::return "$Label ($Drive)"; } ::set AbsolutePath [::string range $AbsolutePath 1 end]; ::return [::file tail $AbsolutePath]; } method format_file_size {Size} { #::qw::dialog85::file_explorer_dialog /* { Returns an empty string if the specified value is negative and the value itself in user-friendly format otherwise. */ } ::if {$Size<0} { ::return ""; } ::if {$Size<1024} { ::return "$Size bytes" } ::if {$Size<1048576} { ::return [::format "%.1f KB" [::expr {$Size/1024.0}]]; } ::if {$Size<1073741824} { ::return [::format "%.1f MB" [::expr {$Size/1048576.0}]] } ::return [format "%.1f GB" [expr {$Size/1073741824.0}]] } method client_setup {sargs} { #::qw::dialog85::file_explorer_dialog chain $sargs; ::frame $_toplevel.client ::set _table $_toplevel.client.table; ::set _hsb $_toplevel.client.hsb; ::set _vsb $_toplevel.client.vsb; ::tablelist::tablelist $_table \ -columns { 75 "File/Folder" left } \ -expandcommand [::itcl::code $this node_expand] \ -collapsecommand [::itcl::code $this node_collapse] \ -xscrollcommand [::list $_hsb set] \ -yscrollcommand [::list $_vsb set] \ -showlabels 0 \ -movablecolumns no \ -setgrid no \ -showseparators 0 \ -height 28 \ -width 80 \ -stripeheight 0 \ ; ::if {[$_table cget -selectborderwidth] == 0} { $_table configure -spacing 1 } $_table columnconfigure $_path_column -formatcommand [::itcl::code $this format_tail] -sortmode dictionary -stretch 1; ::ttk::scrollbar $_vsb -orient vertical -command [::list $_table yview]; ::ttk::scrollbar $_hsb -orient horizontal -command [::list $_table xview]; # # Create a pop-up menu with one command entry; bind the script # associated with its entry to the event, too # ::set BodyTag [$_table bodytag]; ::bind $BodyTag <> [bind TablelistBody ]; ::bind $BodyTag <> +[bind TablelistBody ]; # ::bind $BodyTag [::itcl::code $this putContentsOfSelFolder $_table]; # Grid the scroll bars. ::grid $_table -row 0 -column 0 -sticky news ::grid $_vsb -row 0 -column 1 -sticky ns; ::grid $_hsb -row 1 -column 0 -sticky ew; ::grid rowconfigure $_toplevel.client 0 -weight 1 ::grid columnconfigure $_toplevel.client 0 -weight 1 ::pack $_toplevel.client -side top -expand 1 -fill both # # Populate the tablelist with the contents of the given directory # $_table sortbycolumn $_path_column; putContents "" $_table root # ::bind $_toplevel.client.canvas [::itcl::code $this command_process .command command_pick]; ::set _selected_file [::sargs::get $_options .default]; ::if {$_selected_file eq ""} { ::set _selected_file [::file dirname $::qw_program_folder]; } ::if {[::file pathtype $_selected_file] eq "relative"} { ::set _selected_file [::file join $::qw_program_folder $_selected_file]; } ::if {[::string index $_selected_file 0] eq "/"} { /* { Drive is missing so use the ::qw_library's drive. */ } ::set _selected_file "[::string range $::qw_library 0 1]$_selected_file"; } ::while {$_selected_file ne ""&&![::file exists $_selected_file]} { /* { We go up the directory system until we find something that exists. */ } ::if {$_selected_file eq [::qw::file dirname $_selected_file]} { /* { The ::file dirname has a problem that the dirname of c:/ is c:/ which would mean we would go into an infinite loop if c:/ does not exist. */ } ::break; } ::set _selected_file [::qw::file dirname $_selected_file]; } ::if {$_selected_file eq ""} { /* { If we never find the default then set it to the working directory, whatever that may be. */ } ::set _selected_file [::pwd]; } ::if {![::file exists $_selected_file]} { ::set _selected_file [::pwd]; } ::if {![::file isdirectory $_selected_file]} { /* { If the default is a directory, we already know it exists and we should use it. But if it is a file, although it exists, the masks may have changed and it might not match the masks when we put up the directory window. This actually happened and we crashed. So here we see if the default, a file, matches the masks and if not, we use it's directory, which must exist because the file exists. */ } ::set Masks [::sargs::get $_options .pattern_list]; ::set MatchFound 0; ::if {$Masks ne ""} { ::foreach Mask $Masks { ::if {[::string match $Mask [::file tail $_selected_file]]} { ::set MatchFound 1; ::break; } } ::if {!$MatchFound} { ::set _selected_file [::file dirname $_selected_file]; } } } ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; ::bind $_toplevel [::itcl::code $this command_process .command command_mru_list]; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; } method putContentsOfSelFolder {Table} { #::qw::dialog85::file_explorer_dialog /* { Populates the contents of the selected folder into the tablelist. */ } ::set Row [$Table curselection]; if {[$Table hasrowattrib $Row .path]} { # folder node ::set dir [$Table rowattrib $Row .path]; if {[::file isdirectory $dir] && [file_is_readable $dir]} { if {[llength [glob -nocomplain -types {d f} -directory $dir *]]==0} { bell } else { putContents $dir $Table root } } else { ::qw::throw \ .text "Can't read folder \"[file nativename $dir]\"." \ .help_id ??? \ ; } } else { # file node ::bell } } method see_nice {sargs} { #::qw::dialog85::file_explorer_dialog /* { Just using the "see" method is not good enough because this places the selected item at the top of window and we can't see what's above. Let's try to put the current item in the center of the window. */ } $_table yview scroll [::expr {-int([$_table cget -height]/2)}] units; ::return; ::set yView [$_table yview]; ::set Top [::lindex $yView 0]; ::set Bottom [::lindex $yView 1]; ::set CurrentRow [$_table curselection]; ::set Size [$_table size]; ::set RegionSize [::expr {$Size*($Bottom-$Top)}] ::set CurrentPos [::expr {double($CurrentRow)/double($Size)}]; ::set Delta -0.1; # $_table yView [::list [::expr {[::lindex $yView 0]+$Delta}] [::expr {[::lindex $yView 1]+$Delta}]]; ::set Delta [::expr {-int($RegionSize/2)}]; # $_table yview scroll $Delta units; $_table yview scroll [::expr {-int([$_table cget -height]/2)}] units; } method position_on_absolute_path {sargs} { #::qw::dialog85::file_explorer_dialog /* { Takes a path as an argument. Positions on the path, expanding nodes as necessary. */ } ::set AbsolutePath [::sargs::get $sargs .path]; ::if {$AbsolutePath eq ""} { ::return; } ::set Path1 $AbsolutePath; ::while {1} { /* { Find the longest sub-path of the given path that exists. That is, if the path doesn't exists we go up through parent folders until we find a folder (i.e. sub-path) that does exist. */ } ::if {[::file exists $Path1]} { ::break; } ::if {[::file dirname $Path1] eq $Path1} { ::return; } ::set Path1 [::file dirname $Path1]; } ::set SplitList [::file split $Path1]; ::set ParentNodeIndex root; ::for {::set i 0} {$i<[::llength $SplitList]} {::incr i} { ::if {$::tcl_version==8.4} { ::set Path [::eval ::file join [::lrange $SplitList 0 $i]]; } else { ::set Path [::eval ::file join [::lrange $SplitList 0 $i]]; } ::set NodeIndex [$_table searchcolumn $_path_column "?$Path" -nocase -glob -parent $ParentNodeIndex]; ::if {$NodeIndex eq ""||$NodeIndex<0} { ::return; } debug_dump_table; ::if {$i==[::expr {[::llength $SplitList]-1}]} { $_table selection clear 0 end; $_table selection set [::list $NodeIndex]; # $_table activate $NodeIndex; $_table see $NodeIndex; } else { $_table expand $NodeIndex -partly; } # putContents $Path $_table $NodeIndex; # node_expand $_table $NodeIndex; debug_dump_table; ::set ParentNodeIndex $NodeIndex; } } method debug_dump_table {} { #::qw::dialog85::file_explorer_dialog # ::return; ::puts "debug,table start ----------------------------------" ::set Row 0; ::foreach Item [$_table get 0 end] { ::puts "debug,Row:$Row==$Item"; ::incr Row; } ::puts "debug,table end ----------------------------------" } method contract {} { #::qw::dialog85::file_explorer_dialog } method popup_menu_post {sargs} { #::qw::dialog85::file_explorer_dialog /* { Posts the pop-up menu .menu at the given screen position. Before posting the menu, the procedure enables/disables its only entry, depending upon whether the selected item represents a readable directory or not. */ } ::set X [::sargs::get $sargs .x]; ::set Y [::sargs::get $sargs .y]; set Row [$_table curselection] if {[$_table hasrowattrib $Row .path]} { # folder node set dir [$_table rowattrib $Row .path]; if {[::file isdirectory $dir] && [file_is_readable $dir]} { if {[::llength [::glob -nocomplain -types {d f} -directory $dir *]]==0} { $_toplevel.popup_menu entryconfigure 0 -state disabled; } else { $_toplevel.popup_menu entryconfigure 0 -state normal; } } else { ::qw::throw \ .text "Can't read folder \"[file nativename $dir]\"." \ .help_id ??? \ ; bell tk_messageBox -title "Error" -icon error -message \ "Cannot read directory \"[file nativename $dir]\"" return "" } ::set ParentFolder [::file dirname $Folder]; ::if {$ParentFolder eq ""} { $_toplevel.popup_menu entryconfigure 1 -state disabled; } else { $_toplevel.popup_menu entryconfigure 1 -state enabled; } } else { ;# file item # file node $_toplevel.popup_menu entryconfigure 0 -state disabled; } ::tk_popup $_toplevel.popup_menu $X $Y; } method refreshView {Folder Table} { #::qw::dialog85::file_explorer_dialog /* { Redisplays the contents of the directory dir and restores the expanded states of the folders as well as the vertical view. */ } # # Save the vertical view and get the path names # of the folders displayed in the expanded rows # ::set yView [$Table yview] ::foreach Row [$Table expandedkeys] { ::set Path [$Table rowattrib $Row .path] ::set expandedFolders($Path) 1 } # # Redisplay the directory's (possibly changed) contents and restore # the expanded states of the folders, along with the vertical view # putContents $Folder $Table root restoreExpandedStates $Table root expandedFolders $Table yview moveto [lindex $yView 0] } method restoreExpandedStates {Table nodeIdx expandedFoldersName} { #::qw::dialog85::file_explorer_dialog /* { Expands subs of the parent identified by nodeIdx that display folders whose path names are the names of the elements of the array specified by the last argument. */ } ::upvar $expandedFoldersName expandedFolders ::foreach Row [$Table childkeys $nodeIdx] { ::set Path [$Table rowattrib $Row .path] ::if {$Path ne "" && [::info exists expandedFolders($Path)]} { $Table expand $Row -partly; restoreExpandedStates $Table $Row expandedFolders; } } } method control_button_setup {} { #::qw::dialog85::file_explorer_dialog chain; ::set MruList [::sargs::get $_options .mru_list]; ::if {![::sargs::boolean_get $_options .mru_list_is_enabled]||[::llength $MruList]==0} { ::if {[::winfo exists $_toplevel.control_button.mru_list]} { ::pack forget $_toplevel.control_button.mru_list; } } /* { ::if {$FileList eq ""} { ::pack forget $_toplevel.control_button.mru_list; } else { $Controls.list configure -command [::subst -nocommands { ::qw::dialog::list {.title {Most Recently Used List} .list {$FileList} .options_file {$OptionsFile}}; ::if {\$::qw::dialog::list_dialog_result ne {}} { ::set ::qw::dialog::file_explorer_result \$::qw::dialog::list_dialog_result; } else { ::if {[::winfo exists $Toplevel]} { ::raise {$Toplevel}; } } }]; } */ } /* { Can't call button_list_bindings_setup because conflicts with calendar navigation. ::qw::dialog::button_list_bindings_setup .button_list [::list \ $_toplevel.buttons.ok \ $_toplevel.buttons.cancel \ $_toplevel.buttons.help \ ]; */ } } method node_expand {Table Row} { #::qw::dialog85::file_explorer_dialog /* { Can't use command_process as this is a hard-wired callback from the tablelist. Outputs the contents of the folder whose leaf name is displayed in the first cell of the specified row. The items are the child items of the item identified by row. The updates the image displayed in that cell. */ } if {[$Table childcount $Row]==0} { ::set Folder [$Table rowattrib $Row .path]; putContents $Folder $Table $Row; } if {[$Table childcount $Row]!=0} { /* { After the expand, only if the node has subs, we set it to the open image. */ } $Table cellconfigure $Row,$_path_column -image $_image_array(open_folder); } } method node_collapse {Table Row} { #::qw::dialog85::file_explorer_dialog /* { This callback is called before the row is collapsed. Can't use command_process as this is a hard-wired callback from the tablelist. Updates the image displayed in the first cell of the specified row of the tablelist. */ } $Table cellconfigure $Row,$_path_column -image $_image_array(closed_folder); } method command_process {sargs} { #::qw::dialog85::file_explorer_dialog ::set Command [::sargs::get $sargs .command]; ::switch -- $Command { command_control_button { ::qw::bug 314120121022144407 "Deprecated." ::set Button [::sargs::get $sargs .control_button]; ::switch -- $Button { .help { command_process .command command_help; ::return; } .cancel { command_process .command command_exit; ::return; } .mru_list { command_process .command command_mru_list; ::return; } .ok { command_process .command command_ok; ::return; } } } command_exit { ::set _dialog_result [::sargs \ .result "" \ .mru_list [::sargs::get $_options .mru_list] \ ]; ::return; } command_ok { ::set CurSelectionList [$_table curselection]; ::set Row [::lindex $CurSelectionList 0]; ::set SelectedPath [$_table rowattrib $Row .path]; ::set MruList [::sargs::get $_options .mru_list]; ::set Index [::lsearch [::string tolower $MruList] [::string tolower $SelectedPath]]; ::if {$Index>=0} { ::set MruList [::lreplace $MruList $Index $Index]; } ::set MruList [::linsert $MruList 0 $SelectedPath]; ::set _dialog_result [::sargs \ .result $SelectedPath \ .mru_list $MruList \ ]; ::return; } command_mru_list { ::set ReturnStructure [::qw::dialog85::mru_list \ .mru_list [::sargs::get $_options .mru_list] \ .bbox [::qw::winutil::bbox_from_widget .widget $_toplevel.control_button.mru_list] \ ]; ::sargs::var::set _options .mru_list [::sargs::get $ReturnStructure .mru_list]; ::set SelectedPath [::sargs::get $ReturnStructure .result]; ::if {$SelectedPath eq ""} { /* { The mru_list dialog was cancelled. The user could have changed the mru_list but they did not actually select an item. We will keep the file dialog up. */ } ::if {[winfo exists $_toplevel]} { /* { It's always a good idea to keep the dialog on top. */ } ::raise $_toplevel; } ::return; } ::set _dialog_result $ReturnStructure; ::return; } command_contract { contract; ::return; } } ::return [chain $sargs]; } method tooltip_get {sargs} { #::qw::dialog85::file_explorer_dialog ::set Widget [::sargs::get $sargs .widget]; ::set Text ""; ::switch -glob -- $Widget { *.control_button.ok { ::append Text "Pick the current file."; ::append Text "(Enter)"; ::return [::sargs .text $Text]; } *.control_button.mru_list { ::append Text "F3 - Pick from a list of recently used files."; ::return [::sargs .text $Text]; } *.control_button.cancel - *.menubar.file.exit { ::append Text "Esc - Dismiss without picking a file."; ::return [::sargs .text $Text]; } *.control_button.help - *.menubar.help.export { ::append Text "F1 - Help on this dialog."; ::return [::sargs .text $Text]; } } ::return [chain $sargs]; } } ::proc ::qw::dialog85::mru_list_update {sargs} { /* { Writes the .mru_list to a record in a file. The main job here is to generate the record key. Generally, the class and field paths are used, and when the field is within a structure, the structure path is also used. Example: ::qw::dialog85::mru_list_update \ .workstation_database $WorkstationDatabase \ .window_class_path $WindowClassPath \ .window_column_name $ColumnName \ .mru_list $MruList \ ; */ } ::set WindowClassPath [::sargs::get $sargs .window_class_path]; ::if {$WindowClassPath eq ""} { ::qw::bug 314120120513090326 "[::qw::methodname] - no window class path."; } ::set WindowColumnName [::sargs::get $sargs .window_column_name]; ::if {$WindowColumnName eq ""} { ::qw::bug 314120120518152205 "[::qw::methodname] - no window column name."; } ::set WorkstationDatabase [::sargs::get $sargs .workstation_database]; ::if {$WorkstationDatabase eq ""} { ::qw::bug 314120120513090327 "[::qw::methodname] - no workstation database."; } ::if {![::sargs::exists $sargs .mru_list]} { ::qw::bug 314120120513090328 "[::qw::methodname] - no mru list."; } ::set MruList [::sargs::get $sargs .mru_list]; /* { Truncate the list to 20 elements. We could have done this anywhere but when storing seems like as good a place as any. */ } ::set MruList [::lrange $MruList 0 [::expr {$::qw::control(edit_assist_mru_list_limit)-1}]]; ::if {![$WorkstationDatabase cpp_file_exists .path /odb/edit_assist]} { # 2.28.0 - added the .schema field in line belodw $WorkstationDatabase cpp_file_create .path /odb/edit_assist .schema {.key string .amounts .count}; } ::set Key $WindowClassPath$WindowColumnName; ::set Before [::sargs]; ::set Before [$WorkstationDatabase cpp_file_record_read \ .path /odb/edit_assist \ .key [::list string $Key] \ ]; ::if {[::sargs::size $Before]!=0} { ::set After $Before; ::sargs::var::set After .data.mru_list $MruList; $WorkstationDatabase cpp_file_record_write \ .path /odb/edit_assist \ .before $Before \ .after $After \ ; ::return; } ::set After [::sargs \ .key [list string $Key] \ .amounts [::list .count 1.0] \ .data [::sargs .mru_list $MruList] \ ]; $WorkstationDatabase cpp_file_record_insert \ .path /odb/edit_assist \ .after $After \ ; } ::proc ::qw::dialog85::mru_list_read {sargs} { /* { Returns the field'window column's mru_list or empty if not found. ::qw::dialog85::mru_list_read \ .workstation_database [odb_database] \ .window_class_path $WindowClassPath \ .column_name $ColumnName \ ; */ } ::set WindowClassPath [::sargs::get $sargs .window_class_path]; ::if {$WindowClassPath eq ""} { ::qw::bug 314120120513090328 "[::qw::procname] - no .window_class_path argument."; } ::set WindowColumnName [::sargs::get $sargs .window_column_name]; ::if {$WindowColumnName eq ""} { ::qw::bug 314120120513090329 "[::qw::procname] - no .window_column_name argument."; } ::set WorkstationDatabase [::sargs::get $sargs .workstation_database]; ::if {$WorkstationDatabase eq ""} { ::qw::bug 314120120513090310 "[::qw::procname] - no .workstation_database argument."; } ::if {![$WorkstationDatabase cpp_file_exists .path /odb/edit_assist]} { ::return [::list]; } ::set Key $WindowClassPath$WindowColumnName; ::set Before [::sargs]; ::set Before [$WorkstationDatabase cpp_file_record_read \ .path /odb/edit_assist \ .key [::list string $Key] \ ]; ::return [::sargs::get $Before .data.mru_list]; } ::proc ::qw::dialog85::mru_list_promote {sargs} { /* { Takes an element as an argument and promotes it to the front of the list. If the element is empty nothing is done. If the element is in the list then it is promoted. Otherwise it is preprended. ::qw::dialog85::mru_list_promote \ .workstation_database $WorkstationDatabase \ .window_class_path $WindowClassPath \ .window_column_name $ColumnName \ .element $CellValue \ ; */ } ::if {![::sargs::exists $sargs .element]} { ::qw::bug 314120120515091321 "[::qw::procname] - no .element argument."; } ::set Element [::sargs::get $sargs .element]; ::if {$Element eq ""} { ::return; } ::set MruList [::qw::dialog85::mru_list_read $sargs]; ::set MruList [::qw::list::promote .list $MruList .element $Element]; ::qw::dialog85::mru_list_update $sargs .mru_list $MruList; } ::itcl::class ::qw::dialog85::mru_list_dialog { /* { The mru_list is a most recently used list of values. The mru_list is a creature of the window system, not the object database. The values in the list are taken from cell values, not odb fields. Each window column has a separate list. The list is stored in a structure in an ifs record. The record key is the window class path followed by the column name. This is implmented in the following methods ::qw::dialog85::mru_list_read - reads mru_list for cell - - used by edit_assist_item ::qw::dialog85::mru_list_update - writes mru_list for cell - used by edit_assist_item ::qw::dialog85::mru_list_promote - prepends cell value to mru_list - used when cell is edited Each time a cell value is chosen by edit_assist, or entered directly into a field, the value is prepended - moved to the front of the mru_list if already in the list, or added to list if not. The list is limited to 20 items using ::qw::control(edit_assist_mru_list_limit). When edit assist is popped up, the current cell value is prepended to the list. The mru_list has a .browse_type and the edit assist window has a browse button if .browse_type is specified. The user can add to the list from an appropriate browser, i.e. file explorer, calendar, etc. */ } inherit ::qw::dialog85::dialog_archetype; protected variable _table ""; constructor {} { #::qw::dialog85::mru_list_dialog } destructor { } method main {sargs} { #::qw::dialog85::mru_list_dialog ::set _sargs $sargs; ::if {[::llength [::sargs::get $_sargs .mru_list]]==0} { ::qw::finally [::list ::itcl::delete object $this]; ::return [empty_mru_list $sargs]; } options_setup; ::sargs::var::+= _options $sargs; ::if {![has_help]} { ::sargs::var::unset _options .control_button.help; } toplevel_setup; menu_setup; toolbar_setup; control_button_setup; client_setup; popup_menu_setup; initialize; wait; ::set Result $_dialog_result; ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } ::return $Result; } method empty_mru_list {sargs} { #::qw::dialog85::mru_list_dialog /* { Users complained that putting up an empty list was confusing. So instead, we either put up a notify message (less harsh than an error message), or we put up a browser, i.e. equivalent of what would appear if the browse button had been clicked. So the code below was copied in from command_process for the browse button and then adjusted for an empty default. We pass on the sargs to the callee. So a file or date browser will still attempt to position itself around the original field, if any. This even applies to the notify that tells the user to type the field in manually when there is no borwser. */ } ::set BrowseType [::sargs::get $_sargs .browse_type]; ::switch -- $BrowseType { date { /* { The dates in the mru list are in edit (typing) format. The calendar dialog expects yyyymmdd format. It also returns this format. So we have to scan from typable to yyyymmdd when we pop the calendar up, and we have to format the result from yyyymmdd back into typeable. */ } /* { ::set RowIndexList [$_table curselection]; ::set ActiveIndex ""; ::if {[::llength $RowIndexList]!=0} { ::set ActiveIndex [::lindex $RowIndexList 0]; } #::set ActiveIndex [$_table index active]; ::set Default ""; ::set MruList [get_mru_list]; ::if {$ActiveIndex ne ""} { ::set Default [$_table rowattrib $ActiveIndex .text]; ::set MruList [::qw::list::promote .list $MruList .element $Default]; } */ } # rwb_todo - when there is no item (activeindex is empty) we will # still need a default dir and file ::set Default [::sargs::get $_sargs .default]; ::if {$Default eq ""} { /* { Not even a default specified. Use the system clock. */ } ::set Default [::clock format [::clock seconds] -format "%d%b%Y"]; } ::set Default1 [::clock scan $Default]; ::set Default [::clock format $Default1 -format "%Y%m%d"]; ::set ResultStructure [::qw::dialog85::date $_sargs .default $Default]; ::set SelectedDate [::sargs::get $ResultStructure .result]; ::set MruList [::list]; ::if {$SelectedDate ne ""} { ::set SelectedDate [::qw::date::format $SelectedDate "%d%b%Y"]; ::lappend MruList $SelectedDate; } ::set _dialog_result [::sargs \ .result $SelectedDate \ .mru_list $MruList \ ]; ::return $_dialog_result; } number { } tk_getSaveFile - tk_getOpenFile { /* { */ } /* { ::set RowIndexList [$_table curselection]; ::set ActiveIndex ""; ::if {[::llength $RowIndexList]!=0} { ::set ActiveIndex [::lindex $RowIndexList 0]; } ::set Default ""; ::set MruList [get_mru_list]; ::if {$ActiveIndex ne ""} { ::set Default [$_table rowattrib $ActiveIndex .text]; } */ } # ::set Default [::sargs::get $_sargs .default]; ::set OptionList [::list] /* { .filetypes is a list of two-element lists of description/extension pairs as required by the tk_getOpenFile/tk_getSaveFile procs. You can also add a list of extensions in .pattern_list (and/or .patterns). They are missing descriptions but those are looked up using the file_type_from_pattern call. */ } ::set FileTypes [::sargs::get $_sargs .filetypes]; ::foreach Pattern [::concat [::sargs::get $_sargs .pattern_list] [::sargs::get $_sargs .patterns]] { ::lappend FileTypes [::qw::winutil::file_type_from_pattern .pattern $Pattern]; } ::if {[::llength $FileTypes]!=0} { ::lappend OptionList -filetypes $FileTypes; } ::set DefaultExtension [::sargs::get $_sargs .defaultextension]; ::if {$DefaultExtension ne ""} { ::lappend OptionList -defaultextension $DefaultExtension; } ::set DefaultFolder [::sargs::get $sargs .default_folder]; ::if {$DefaultFolder eq ""} { ::set DefaultFolder $::qw_program_folder } ::lappend OptionList -initialdir $DefaultFolder; ::lappend OptionList -initialfile ""; ::set Title [::sargs::get $_sargs .title]; ::if {$Title ne ""} { ::lappend OptionList -title $Title; } ::switch -- $BrowseType { tk_getSaveFile { ::set SelectedFile [::eval ::tk_getSaveFile $OptionList]; } tk_getOpenFile { ::set SelectedFile [::eval ::tk_getOpenFile $OptionList]; } } ::set MruList [::list]; ::set SelectedFile [::string trim $SelectedFile]; # 2.34.0 ::if {$SelectedFile ne ""} { ::lappend MruList $SelectedFile; } ::set _dialog_result [::sargs \ .result $SelectedFile \ .mru_list $MruList \ ]; ::return $_dialog_result; } tk_chooseDirectory { /* { ::set RowIndexList [$_table curselection]; ::set ActiveIndex ""; ::if {[::llength $RowIndexList]!=0} { ::set ActiveIndex [::lindex $RowIndexList 0]; } ::set Default ""; ::if {$ActiveIndex ne ""} { ::set Default [$_table rowattrib $ActiveIndex .text]; } */ } # 2.32.2 - next 2 lines added, otherwise got error "can't read MruList". ::set Default ""; ::set MruList [::list]; ::set MruList [::qw::list::promote .list $MruList .element $Default]; ::set OptionList [::list] ::set Title [::sargs::get $_sargs .title]; ::if {$Title ne ""} { ::lappend OptionList -title $Title; } ::lappend OptionList -parent $_toplevel; ::lappend OptionList -initialdir $::qw_program_folder; ::lappend OptionList -mustexist [::sargs::boolean_get $_sargs .mustexist]; ::set SelectedFolder [::eval ::tk_chooseDirectory $OptionList]; ::set SelectedFolder [::string trim $SelectedFolder]; ::set MruList [::list]; ::if {$SelectedFolder ne ""} { ::lappend MruList $SelctedFolder; } ::if {$SelectedFolder ne ""} { ::set _dialog_result [::sargs \ .result $SelectedFolder \ .mru_list $MruList \ ]; } ::return $_dialog_result; } "" { ::qw::dialog85::notify $sargs \ .title "The pick box of recently used values is empty." \ .text "There is nothing in the pick box of recently used values.\n\nYou are going to have to type in the first value yourself." \ .help_page { .body {

The pick pox is empty.

When you have used a field in the past, the pick box will display a list of recently used values. However, in this case there are no recently used values so the pick box is empty. Instead, you're going to have to enter the first value by typing it [qw_quoted manually] into the field.

} } \ ; ::set _dialog_result [::sargs \ .result "" \ .mru_list [::list] \ ]; /* { ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } */ } ::return $_dialog_result; } default { ::qw::bug 314120120713073759 "[::qw::methodname] - Invalid type \"$BrowseType\"."; } } } method options_setup {} { #::qw::dialog85::mru_list_dialog /* { Example of using tooltips: ::set Result [::qw::odb::mru_list \ .browse_type "" \ .title "Select user name" \ .mru_list $MruList \ .help.help_id ??? \ .control_button.help.tooltip.text "Help on this dialog.\n\[F1\]" \ .control_button.cancel.tooltip.text "Dismiss without picking a user name.\n\[Esc\]" \ .control_button.ok.tooltip.text "Pick the selected user name.\n\[Enter\]." \ ]; ::return $Result; */ } chain; ::sargs::var::+= _options { .title "Recently Used List" .class "MruListDialog" .bbox "" .control_button { } .default_focus_widget .control_button.ok } ::sargs::var::set _options .control_button.help { .text "Help" .tooltip { .text "Help on this dialog window. [F1]" } } ::sargs::var::set _options .control_button.cancel { .text "Dismiss" .tooltip { .text "Dismiss dialog window without picking. [Esc]" } } ::set BrowseType [::sargs::get $_sargs .browse_type]; ::switch -- $BrowseType { number { ::sargs::var::unset _options .control_button.browse; } date - tk_chooseDirectory - tk_getOpenFile - tk_getSaveFile { ::sargs::var::set _options .control_button.browse { .text "Browse" .tooltip { .text "F3 - Pick from a browse window.\nTry browsing if the item you want\nisn't in this recently used list." } } } qw_file { ::sargs::var::unset _options .control_button.browse; } "" { ::sargs::var::unset _options .control_button.browse; } default { ::qw::bug 314120120511183407 "[::qw::methodname] - Invalid type \"$BrowseType\"."; } } ::sargs::var::set _options .control_button.ok { .text "Ok" .tooltip { .text "Pick current item. [Enter] or [Double-Click]\nYou are picking from recently used values." } } ::foreach Button { .help .cancel .browse .ok } { ::if {[::sargs::get $_sargs .control_button$Button.tooltip.text] ne ""} { ::sargs::var::set _options .control_button$Button.tooltip.text [::sargs::get $_sargs .control_button$Button.tooltip.text]; } } # ::sargs::var::set _options .pattern_list [::list *.qw_script *.qw_tcl]; } method toplevel_setup {} { #::qw::dialog85::mru_list_dialog chain; } method menu_setup {sargs} { #::qw::dialog85::mru_list_dialog ::return; } method toolbar_setup {sargs} { #::qw::dialog85::mru_list_dialog ::return; } method format_string {String} { #::qw::dialog85::mru_list_dialog /* { */ } ::switch -- [::sargs::get $_sargs .browse_type] { date { #::return [::qw::date::format $String "%a %b %d %Y"]; } } ::return $String; } method client_setup {sargs} { #::qw::dialog85::mru_list_dialog chain $sargs; /* { Why not put the mru_list read/update functionality in the edit assist dialog? The answer is that we would like to update the mru_lists when the user types directly into the field, and not just when he uses edit assist. */ } ::set SrcMruList [::sargs::get $_options .mru_list]; ::set CharWidth 0; ::set LineNumberWidth 0; ::set TableMruList [::list]; ::set Row 0; ::foreach Item $SrcMruList { /* { Build TableMruList, the list of line number/value rows, and while doing so, get the maximum line width in characters. */ } ::if {[::string length $Item]>$CharWidth} { ::set CharWidth [::string length $Item]; } ::if {[::string length $Row]>$LineNumberWidth} { ::set LineNumberWidth [::string length $Row]; } ::lappend TableMruList [::list $Row $Item]; ::incr Row; } ::set Size [::llength $SrcMruList]; ::set Height 20; ::if {$Size<20} { ::set Height $Size; ::set _has_vsb 0; } ::set Width 100; ::set LineWidth [::expr {$CharWidth+$LineNumberWidth+6}]; ::if {$LineWidth<100} { ::set Width $LineWidth; } ::ttk::frame $_toplevel.client ::set _table $_toplevel.client.table; ::set Width [::expr {$CharWidth+$LineNumberWidth+10}]; ::set _hsb $_toplevel.client.hsb; ::set _vsb $_toplevel.client.vsb; ::tablelist::tablelist $_table \ -columns [::list $LineNumberWidth "Line" right $CharWidth "Most Recently Used" left] \ -xscrollcommand [::list $_hsb set] \ -yscrollcommand [::list $_vsb set] \ -showlabels 0 \ -movablecolumns 0 \ -setgrid no \ -showseparators 0 \ -width $Width \ -height $Height \ -stripeheight 0 \ ; ::if {[$_table cget -selectborderwidth] == 0} { $_table configure -spacing 1; } $_table columnconfigure 0 -showlinenumbers 1; $_table columnconfigure 1 -formatcommand [::itcl::code $this format_string] -stretch 1; ::ttk::scrollbar $_vsb -orient vertical -command [::list $_table yview]; ::ttk::scrollbar $_hsb -orient horizontal -command [::list $_table xview]; ::set LineCount 0; ::if {$::tcl_version==8.4} { ::eval $_table insert end $TableMruList; } else { ::eval $_table insert end $TableMruList; } ::set Row 0; ::foreach Item $SrcMruList { /* { It would be misleading to put the row number in the structure since it can change due to deletions. */ } $_table rowattrib $Row .text $Item; ::incr Row; } $_table selection clear 0 end; /* { Select the most recently used item. */ } $_table selection set 0; #2.23.0 $_table activate 0; $_table seecell 0,0; ::set bodyTag [$_table bodytag]; ::bind $bodyTag <> [bind TablelistBody ]; ::bind $bodyTag <> +[bind TablelistBody ]; ::bind $bodyTag <> +[::itcl::code $this popup_menu_post [::sargs .rootx %X .rooty %Y]]; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; ::bind $_toplevel [::itcl::code $this command_process .command command_help]; /* { 2.36.0 When the double-click was bound to the toplevel we executed when clicking on the scroll bar buttons too fast. The script was run but then we got an error invalid command name ".qw_dialog1.client.vsb (or .hsb). Moved the binding to $bodyTag (value==body.qw_dialog_1.client.table). Note: Tried binding to $_toplevel.client and $_table. They fixed the error but did not evel the script. */ } #2.36.0 ::bind $_toplevel.client [::itcl::code $this command_process .command command_ok]; ::bind $bodyTag [::itcl::code $this command_process .command command_ok]; ::bind $_toplevel [::itcl::code $this command_process .command command_delete_selected_rows]; /* { By default we give focus to a button so the arrow keys don't work. So we pass focus to the table list when the up/down arrow keys are pressed. We also call the appropriate method to make the action happen in the tablelist. Finally, we have to unbind the arrow keys from the toplevel or there will be too many scripts trying to move the current row. */ } ::bind $_toplevel [::subst -nocommands { ::focus $_table; ::tablelist::priorNext $_table -1; $this clear_binding_redirections; }]; ::bind $_toplevel [::subst -nocommands { ::focus $_table; ::tablelist::priorNext $_table 1; $this clear_binding_redirections; }]; ::bind $_toplevel [::subst -nocommands { ::focus $_table; ::tablelist::upDown $_table -1; $this clear_binding_redirections; }]; ::bind $_toplevel [::subst -nocommands { ::focus $_table; ::tablelist::upDown $_table 1; $this clear_binding_redirections; }]; ::if {[::winfo exists $_toplevel.control_button.browse]} { /* { Some fields, say description for example, do not have a browse button. */ } ::bind $_toplevel [::itcl::code $this command_process .command command_browse]; } #debug map this to pick /* { # # Create three buttons within a frame child of the main widget # set bf .bf frame $bf set b1 $bf.b1 set b2 $bf.b2 set b3 $bf.b3 button $b1 -width 10 -text "Refresh" button $b2 -width 10 -text "Parent" button $b3 -width 10 -text "Close" -command exit */ } # # Manage the widgets # grid $_table -row 0 -column 0 -sticky news ::grid $_vsb -row 0 -column 1 -sticky ns; ::grid $_hsb -row 1 -column 0 -sticky ew; ::grid rowconfigure $_toplevel.client 0 -weight 1; ::grid columnconfigure $_toplevel.client 0 -weight 1; # pack $b1 $b2 $b3 -side left -expand 1 -pady 10 # pack $bf -side bottom -fill x ::pack $_toplevel.client -side top -expand 1 -fill both # # Populate the tablelist with the contents of the given directory # $_table sortbycolumn 0 # putContents $dir $_table root #debug # putContents c:/ $_table root #mru_list putContents "" $_table root # putContents c:/rwb $_table root # ::bind $_toplevel.client.canvas [::itcl::code $this command_process .command command_ok]; /* { ::after idle [::subst -nocommands { ::update idletasks; ::if {[::winfo exists $_toplevel]} { ::switch -- $_resize_is_enabled { 0 { ::wm resizable $_toplevel 0 0; } 1 { ::wm minsize $_toplevel [::winfo reqwidth $_toplevel] [::winfo reqheight $_toplevel]; } } ::qw::dialog::position_toplevel_around_bbox {$sargs} .toplevel $_toplevel; ::wm deiconify $_toplevel; } }]; ::qw::toplevel_add .toplevel $_toplevel; */ } } method clear_binding_redirections {} { /* { We pass focus to the table when arrow movement occurs. From then on we have to stop processing the arrows in the toplevel because the table will handle them. Or we could simply remove the bindings from the table and forget passing focus altogether. */ } ::bind $_toplevel {} ::bind $_toplevel {} ::bind $_toplevel {} ::bind $_toplevel {} } method debug_dump_table {} { #::qw::dialog85::mru_list_dialog ::return; ::puts "debug,table start ----------------------------------" ::set Row 0; ::foreach Item [$_table get 0 end] { ::puts "debug,Row:$Row==$Item"; ::incr Row; } ::puts "debug,table end ----------------------------------" } method popup_menu_setup {sargs} { #::qw::dialog85::mru_list_dialog chain $sargs; ::menu $_toplevel.popup_menu -tearoff 0; $_toplevel.popup_menu add command -label "Delete Row" -command [::itcl::code $this command_process .command command_delete_selected_rows]; ::bind [$_table bodytag] <> +[::itcl::code $this popup_menu_post .rootx %X .rooty %Y]; } method popup_menu_post {sargs} { #::qw::dialog85::mru_list_dialog /* { Posts the pop-up menu .menu at the given screen position. Before posting the menu, the procedure enables/disables its only entry, depending upon whether the selected item represents a readable directory or not. */ } ::set RootX [::sargs::integer_get $sargs .rootx]; ::set RootY [::sargs::integer_get $sargs .rooty]; #f::set Row [$_table curselection] ::tk_popup $_toplevel.popup_menu $RootX $RootY; } method control_button_setup {} { #::qw::dialog85::mru_list_dialog chain; } method get_mru_list {} { #::qw::dialog85::mru_list_dialog /* { The table rows are each a list a cell values. What we want is a simple list of "scalars", which we maintain in the ".text" row attribute. We extract the scalars to produce the mru_list in this method. */ } ::set RowList [$_table get 0 end]; ::set Result [::list]; ::set Row 0; ::foreach Item $RowList { ::lappend Result [$_table rowattrib $Row .text]; ::incr Row; } ::return $Result; } method command_process {sargs} { #::qw::dialog85::mru_list_dialog ::set Command [::sargs::get $sargs .command]; ::switch -- $Command { command_control_button { ::qw::bug 314120121022144408 "Deprecated." ::set Button [::sargs::get $sargs .control_button]; ::switch -- $Button { .help { command_process .command command_help; ::return; } .cancel { command_process .command command_exit; ::return; } .browse { command_process .command command_browse; ::return; } .ok { command_process .command command_ok; ::return; } } } command_ok { ::set ActiveIndex [$_table index active]; ::set PickValue ""; ::set MruList [get_mru_list]; ::if {[::llength $MruList]==0} { ::set _dialog_result [::sargs \ .result "" \ .mru_list $MruList \ ]; ::return; } ::if {$ActiveIndex ne ""} { /* { Promote picked value to front of mru list is it exists. Otherwise insert it at front. */ } ::set PickValue [$_table rowattrib $ActiveIndex .text]; ::set MruList [::qw::list::promote .list $MruList .element $PickValue]; } ::set _dialog_result [::sargs \ .result $PickValue \ .mru_list $MruList \ ]; ::return; } command_browse { ::set BrowseType [::sargs::get $_sargs .browse_type]; ::switch -- $BrowseType { date { /* { The dates in the mru list are in edit (typing) format. The calendar dialog expects yyyymmdd format. It also returns this format. So we have to scan from typable to yyyymmdd when we pop the calendar up, and we have to format the result from yyyymmdd back into typeable. */ } ::set RowIndexList [$_table curselection]; ::set ActiveIndex ""; ::if {[::llength $RowIndexList]!=0} { ::set ActiveIndex [::lindex $RowIndexList 0]; } #::set ActiveIndex [$_table index active]; ::set Default ""; ::set MruList [get_mru_list]; ::if {$ActiveIndex ne ""} { ::set Default [$_table rowattrib $ActiveIndex .text]; ::set MruList [::qw::list::promote .list $MruList .element $Default]; } # rwb_todo - when there is no item (activeindex is empty) we will # still need a default dir and file ::if {$Default eq ""} { /* { If the mru_list is empty, and that also means the field we are picking for is empty, then we resort to the .default argument. */ } ::set Default [::sargs::get $_sargs .default]; } ::if {$Default eq ""} { /* { Not even a default specified. Use the nv installation folder. */ } ::set Default [::clock format [::clock seconds] -format "%d%b%Y"]; } ::set Default1 [::clock scan $Default]; ::set Default [::clock format $Default1 -format "%Y%m%d"]; ::set ResultStructure [::qw::dialog85::date $_sargs .default $Default .bbox [::qw::winutil::bbox_from_widget .widget $_table]]; ::set SelectedDate [::sargs::get $ResultStructure .result]; ::if {$SelectedDate ne ""} { ::set SelectedDate [::qw::date::format $SelectedDate "%d%b%Y"]; ::set MruList [::qw::list::promote .list $MruList .element $SelectedDate]; ::set _dialog_result [::sargs \ .result $SelectedDate \ .mru_list $MruList \ ]; } ::return; } number { } tk_getSaveFile - tk_getOpenFile { /* { */ } ::set RowIndexList [$_table curselection]; ::set ActiveIndex ""; ::if {[::llength $RowIndexList]!=0} { ::set ActiveIndex [::lindex $RowIndexList 0]; } ::set Default ""; ::set MruList [get_mru_list]; ::if {$ActiveIndex ne ""} { ::set Default [$_table rowattrib $ActiveIndex .text]; } ::if {$Default eq ""} { /* { If the mru_list is empty, and that also means the field we are picking for is empty, then we resort to the .default argument. */ } ::set Default [::sargs::get $_sargs .default]; } ::if {$Default eq ""} { /* { Not even a default specified. Use the nv installation folder. */ } ::set Default $::qw_program_folder; } ::if {[::file pathtype $Default] eq "relative"} { ::set Default [::file join $::qw_program_folder $Default]; } ::set MruList [::qw::list::promote .list $MruList .element $Default]; ::set OptionList [::list] /* { .filetypes is a list of two-element lists of description/extension pairs as required by the tk_getOpenFile/tk_getSaveFile procs. You can also add a list of extensions in .pattern_list (and/or .patterns). They a remissings descriptions but those are looked up using the file_type_from_pattern call. */ } ::set FileTypes [::sargs::get $_sargs .filetypes]; ::foreach Pattern [::concat [::sargs::get $_sargs .pattern_list] [::sargs::get $_sargs .patterns]] { ::lappend FileTypes [::qw::winutil::file_type_from_pattern .pattern $Pattern]; } ::if {[::llength $FileTypes]!=0} { ::lappend OptionList -filetypes $FileTypes; } ::set DefaultExtension [::sargs::get $_sargs .defaultextension]; ::if {$DefaultExtension ne ""} { ::lappend OptionList -defaultextension $DefaultExtension; } ::while {1} { ::if {$Default eq ""} { ::break; } ::if {[::file exists $Default]} { ::if {[::file isdirectory $Default]} { ::lappend OptionList -initialdir $Default; ::lappend OptionList -initialfile ""; ::break; } ::if {[::file isfile $Default]} { ::lappend OptionList -initialdir [::file dirname $Default]; ::lappend OptionList -initialfile [::file tail $Default]; ::break; } ::break; } ::if {[::file dirname $Default] eq $Default} { ::set Default ""; ::break; } ::set Default [::file dirname $Default]; } ::if {$Default eq ""} { ::lappend OptionList -initialdir $::qw_program_folder; ::lappend OptionList -initialfile ""; } # ::set Parent [::sargs::get $_sargs .parent]; ::lappend OptionList -parent $_toplevel; ::set Title [::sargs::get $_sargs .title]; ::if {$Title ne ""} { ::lappend OptionList -title $Title; } ::switch -- $BrowseType { tk_getSaveFile { ::set SelectedFile [::eval ::tk_getSaveFile $OptionList]; } tk_getOpenFile { ::set SelectedFile [::eval ::tk_getOpenFile $OptionList]; } } ::set MruList [::qw::list::promote .list $MruList .element $SelectedFile]; ::if {$SelectedFile ne ""} { ::set _dialog_result [::sargs \ .result $SelectedFile \ .mru_list $MruList \ ]; } ::return; } tk_chooseDirectory { ::set RowIndexList [$_table curselection]; ::set ActiveIndex ""; ::if {[::llength $RowIndexList]!=0} { ::set ActiveIndex [::lindex $RowIndexList 0]; } ::set Default ""; ::set MruList [get_mru_list]; ::if {$ActiveIndex ne ""} { ::set Default [$_table rowattrib $ActiveIndex .text]; } ::if {$Default eq ""} { /* { If the mru_list is empty, and that also means the field we are picking for is empty, then we resort to the .default argument. */ } ::set Default [::sargs::get $_sargs .default]; } ::if {$Default eq ""} { /* { Not even a default specified. Use the nv installation folder. */ } ::set Default $::qw_program_folder; } ::if {[::file pathtype $Default] eq "relative"} { ::set Default [::file join $::qw_program_folder $Default]; } ::set MustExist [::sargs::boolean_get $_sargs .must_exist]; ::if {$MustExist} { ::while {1} { ::if {$Default eq ""} { ::break; } ::if {[::file exists $Default]} { ::if {[::file isdirectory $Default]} { ::break; } ::if {[::file isfile $Default]} { ::set Default [::file dirname $Default]; ::break; } ::break; } ::if {[::file dirname $Default] eq $Default} { ::set Default ""; ::break; } ::set Default [::file dirname $Default]; } } ::if {$Default eq ""} { ::set Default $::qw_program_folder; } ::set MruList [::qw::list::promote .list $MruList .element $Default]; ::set OptionList [::list] ::lappend OptionList -initialdir $Default; ::set Title [::sargs::get $_sargs .title]; ::if {$Title ne ""} { ::lappend OptionList -title $Title; } ::lappend OptionList -parent $_toplevel; ::lappend OptionList -initialdir $Default; ::lappend OptionList -mustexist $MustExist; ::set SelectedFolder [::eval ::tk_chooseDirectory $OptionList]; ::set MruList [::qw::list::promote .list $MruList .element $SelectedFolder]; ::if {$SelectedFolder ne ""} { ::set _dialog_result [::sargs \ .result $SelectedFolder \ .mru_list $MruList \ ]; } ::return; } "" { } default { ::qw::bug 314120120511183408 "[::qw::methodname] - Invalid type \"$BrowseType\"."; } } ::return; } command_exit { ::set _dialog_result [::sargs \ .result "" \ .mru_list [get_mru_list] \ ]; ::return; } command_delete_selected_rows { /* { Delete the currently selected rows. */ } ::set MruList [$_table get 0 end]; ::set RowIndexList [$_table curselection]; ::set ActiveRowIndex [$_table index active]; $_table delete $RowIndexList; ::set RowCount [$_table size]; ::if {$RowCount==0} { ::return; } ::if {$ActiveRowIndex>=$RowCount} { ::set ActiveRowIndex [::expr {$RowCount-1}]; } $_table activate $ActiveRowIndex; $_table selection set $ActiveRowIndex; ::return; } default { } } ::return [chain $args]; } method tooltip_get {sargs} { #::qw::dialog85::mru_list_dialog ::set Widget [::sargs::get $sargs .widget]; ::set Text ""; /* { ::switch -glob -- $Widget { *.control_button.ok { ::append Text "Pick the current file."; ::append Text "(Enter)"; ::return [::sargs .text $Text]; } *.control_button.cancel - *.menubar.file.exit { ::append Text "Dismiss without picking a file."; ::append Text "(Esc)"; ::return [::sargs .text $Text]; } *.control_button.help - *.menubar.help.export { ::append Text "Help on this dialog."; ::append Text "(F1)"; ::return [::sargs .text $Text]; } } */ } ::return [chain $sargs]; } } # ------------------------------------------------------------ # ::qw::dialog85::date_dialog # ------------------------------------------------------------ ::itcl::class ::qw::dialog85::date_dialog { /* { 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::dialog85::dialog_archetype; 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]; constructor {} { #::qw::dialog85::date_dialog } method destructor {} { #::qw::dialog85::date_dialog } method main {sargs} { #::qw::dialog85::date_dialog ::set _sargs $sargs; options_setup; ::sargs::var::+= _options $sargs; ::if {![has_help]} { ::sargs::var::unset _options .control_button.help; } toplevel_setup; menu_setup; toolbar_setup; control_button_setup; client_setup; popup_menu_setup; initialize; wait; ::set Result $_dialog_result; ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } ::return $Result; } method options_setup {} { #::qw::dialog85::date_dialog chain; ::sargs::var::+= _options { .title "Pick Date" .class "DateDialog" .sound "" .bbox "" .control_button { .help { .text "Help" .tooltip { .text "Help on this dialog window." } } .cancel { .text "Dismiss" .tooltip { .text "Dismiss dialog within picking a date." } } .mru_list { .text "Recent List" .tooltip { .text "Pick the currently selected date." } } .ok { .text "Ok" .tooltip { .text "Pick the currently selected 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 menu_setup {sargs} { #::qw::dialog85::date_dialog ::return; } method toolbar_setup {sargs} { #::qw::dialog85::date_dialog ::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 $_toolbar_button_font \ -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 client_setup {sargs} { #::qw::dialog85::date_dialog chain $sargs; ::frame $_toplevel.client; ::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 $_options .calendar.width] \ -height [::sargs::get $_options .calendar.height] \ ; ::bind $_toplevel.client.canvas [::itcl::code $this canvas_draw]; ::bind $this [::itcl::code $this command_process .command command_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; ::foreach {Sequence Command} { command_year_prev command_year_next command_week_prev command_week_next command_day_prev command_day_next command_month_prev command_month_next command_week_prev command_week_next command_day_prev command_day_next command_month_prev command_month_next command_month_day_first command_month_day_last command_year_day_first command_year_day_last command_exit command_help command_help command_exit command_exit } { #::bind $this $Sequence [::itcl::code $this command_process .command $Command .mask [::QW::GUI::EVENT::KEYBOARD::mask]]; #2.28.3 ::bind $_toplevel $Sequence [::itcl::code $this command_process .command $Command .mask [::QW::GUI::EVENT::KEYBOARD::mask]]; ::bind $_toplevel $Sequence [::itcl::code $this command_process .command $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 command_process .command command_ok]; ::bind $_toplevel [::itcl::code $this command_process .command command_ok]; } method control_button_setup {} { #::qw::dialog85::date_dialog chain; ::set MruList [::sargs::get $_options .mru_list]; ::if {![::sargs::boolean_get $_options .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.cancel - *.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 $args]; } 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 ::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 $_options .calendar.title.format]] \ -font [font_scale .font [::sargs::get $_options .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 $_options $Type.foreground] \ -fill [::sargs::get $_options $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 $_options $Type.foreground] \ -font [::sargs::get $_options .calendar.date.font] \ -text [::qw::date::format $Date [::sargs::get $_options .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 .cancel_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 $_options .ok_button.text]; ::sargs::var::set HelpPage .cancel_button.text [::sargs::get $_options .cancel_button.text]; ::sargs::var::set HelpPage .help_button.text [::sargs::get $_options .help_button.text]; } method command_process {sargs} { #::qw::dialog85::date_dialog ::set Command [::sargs::get $sargs .command]; ::switch -- $Command { command_control_button { ::qw::bug 314120121022144409 "Deprecated." ::set Button [::sargs::get $sargs .control_button]; ::switch -- $Button { .help { command_process .command command_help; ::return; } .cancel { command_process .command command_exit; ::return; } .ok { command_process .command command_ok; ::return; } } } command_exit { ::set _dialog_result ""; ::return; } command_ok { #::if {[option_get .pick.command] ne ""} { # ::eval [option_get .pick.command]; #} /* { Add next line in 2.10 when month/year +/- buttons were added. This esposed serious problem with double-cliking which was ignored in the widget and implemented in the dialog. This entire widget should really be moved into the dialog. */ } /* { 2.23.0 - return the string range 0 - 7 - keeps elements in the mru_list unique - otherwise, because there are also seconds, there appear to be duplicate dates - (the dates are only formatted to the day). */ } ::set _dialog_result [::sargs \ .result [::string range [active_date_get] 0 7] \ ]; ::return; } command_draw { draw; ::return; } command_week_prev { active_date_set .date [::qw::date::add $_active_date day -7]; canvas_draw; ::return; } command_week_next { active_date_set .date [::qw::date::add $_active_date day 7]; canvas_draw; ::return; } command_day_prev { active_date_set .date [::qw::date::add $_active_date day -1]; canvas_draw; ::return; } command_day_next { active_date_set .date [::qw::date::add $_active_date day 1]; canvas_draw; ::return; } command_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; } command_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; } command_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; } command_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; } command_month_day_first { active_date_set .date [::qw::date::set $_active_date day 1]; canvas_draw; ::return; } command_month_day_last { active_date_set .date [::qw::date::set $_active_date day [::qw::date::get $_active_date days_in_month]]; canvas_draw; ::return; } command_year_day_first { active_date_set .date [::string range $_active_date 0 3]0101; canvas_draw; ::return; } command_year_day_last { active_date_set .date [::string range $_active_date 0 3]1231; canvas_draw; ::return; } command_help { ::qw::script::source \ .script.path [::file join $::qw_library doc qw_chtml_compile.qw_script] \ .structure [dialog_help_page $_options] \ .window_title [::sargs::get $_options .title] \ ; ::return; } } ::return [chain $sargs]; } } ::proc ::qw::dialog85::notify {sargs} { ::if {$::qw::control(run_as_service)} { #2.28.0 ::return; } ::set Object [::qw::dialog85::notify_dialog .#auto]; ::return [$Object main $sargs]; } ::proc ::qw::dialog85::confirm {sargs} { ::if {$::qw::control(run_as_service)} { #2.28.0 ::return 1; } ::set Object [::qw::dialog85::confirm_dialog .#auto]; ::return [$Object main $sargs]; } ::proc ::qw::dialog85::multiple_choice_buttons {sargs} { ::set Object [::qw::dialog85::multiple_choice_buttons_dialog .#auto]; ::return [$Object main $sargs]; } ::proc ::qw::dialog85::field_prompt {sargs} { ::set Object [::qw::dialog85::field_prompt_dialog .#auto]; ::set Result [$Object main $sargs]; ::return $Result; ::return [$Object main $sargs]; } ::proc ::qw::dialog85::error_tree {sargs} { # 2.38.0 - now raise caller window on exit ::set FocusWindow [::focus]; # extract the caller toplevel ::set FocusToplevel .[::lindex [::split $FocusWindow .] 1]; ::set Script [::subst -nocommands { ::if {[::winfo exists "$FocusToplevel"]} { ::after 100 [::list ::raise $FocusToplevel]; } }]; ::qw::finally $Script; ::set Object [::qw::dialog85::error_tree_dialog .#auto]; ::return [$Object main $sargs]; } ::proc ::qw::dialog85::error_flat {sargs} { /* { # 2.38.0 - raise caller window on exit We find out which window had focus when we were called (i.e. the caller window), and we raise it's toplevel when we're done. Otherwise the caller window might not be visible to the user when the dialog is dismissed and this would be disorienting. Why we had to use the after command is unknown, but we had to use it to make it work. */ } ::set FocusWindow [::focus]; ::set FocusToplevel .[::lindex [::split $FocusWindow .] 1]; ::if {![[::qw::system] cpp_is_broken]} { # 2.38.2 wrapped finally so invoked only when not broken ::set Script [::subst -nocommands { ::if {[::winfo exists "$FocusToplevel"]} { ::after 100 [::list ::raise $FocusToplevel]; } }]; ::qw::finally $Script; } ::set Object [::qw::dialog85::error_flat_dialog .#auto]; ::set Result [$Object main $sargs]; ::return $Result; ::return [$Object main $sargs]; } ::proc ::qw::dialog85::error {sargs} { ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog85::error,1000.0";} ::if {!$::qw::control(tk_is_enabled)} { /* { When tk is not enabled we are going to assume that anyone trying to put up an error dialog is a problem and the program must exit. We could visit all calls to the error dialog and test tk_is_enabled at the source of the call but they will all turn out to want to exist. If tk_is_enabled then nothing changes but here are some examples where the error dialog might be called with tk not enabled: stub, hub, node: When bg_error is reached we call bug_process which exits. booting: qw_dll.cpp But what is we're booting a stub, hub or node? Will we restart? bg_error: If anything reaches bgerror with tk disabled it must be a problem. We assume here that it is note a bug but we will turn it into a bug. */ } ::if {[::qw::exception::is_bug $sargs]} { /* { qw::bug_process does not call us so this can't actually happen. */ } ::puts "314120240427112644, qw::dialog85::error was not expecting a bug:\n$sargs"; ::return; } ::sargs::var::set Bug .bug_id "314120240427113529"; ::sargs::var::set Bug .text "::qw::dialog::error was called when tk_is_disabled."; ::sargs::var::set Bug .exception [sargs [::sargs::get $sargs .structure]]; ::qw::bug_process $Bug; ::puts "314120240427112645, qw::dialog85::error - invalid code execution."; } ::if {![::sargs::exists $sargs .bbox]} { /* { 2.28.3 Position errors properly on multiple monitors. */ } ::if {![::qw::exception::is_bug $sargs]} { /* { 2.28.4 Skip bugs because find_window_with_focus may try to look at databases and databases are not accessible after a bug. This caused what looked like a freeze and may have been the source of freezes reported by users. */ } ::qw::try { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog85::error,1000.1";} ::set Fwindow [::qw::winutil::find_window_with_focus]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog85::error,1000.2";} ::if {$Fwindow ne ""} { ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog85::error,1000.3";} ::set xyPosition [::QW::GUI::POINT::+ [[[$Fwindow nv_toplevel] .frame] positionInScreen] ".x 30 .y 30"]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog85::error,1000.4";} ::set BBox [::list [::sargs::integer_get $xyPosition .x] [::sargs::integer_get $xyPosition .y] 0 0]; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog85::error,1000.5";} ::sargs::var::set sargs .bbox $BBox; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog85::error,1000.6";} } } catch Dummy { /* { We can't afford any error in find_window_with_focus and it could happen, in addition to a bug, possibly if we loose a connection and a database is broken. */ } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog85::error,1000.6,Dummy==$Dummy";} } } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog85::error,1000.7";} } ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog85::error,1000.8";} ::qw::dialog85::error_flat $sargs; ::if {$rwb1_debug} {::puts "rwb1_debug,::qw::dialog85::error,1000.9";} } ::proc ::qw::dialog85::file_explorer {sargs} { ::set Object [::qw::dialog85::file_explorer_dialog .#auto]; ::return [$Object main $sargs]; } ::proc ::qw::dialog85::mru_list {sargs} { ::set Object [::qw::dialog85::mru_list_dialog .#auto]; ::return [$Object main $sargs]; } ::proc ::qw::dialog85::date {sargs} { ::set Object [::qw::dialog85::date_dialog .#auto]; ::return [$Object main $sargs]; }