# ------------------------------------------------------------ # Copyright (c) 2003-2009 # Q.W.Page Associates Inc. # www.qwpage.com # All rights reserved. # ------------------------------------------------------------ ::package require $::qw::control(package_iwidgets); #::package require Iwidgets; ::set ::TestLabel [::label .test_label]; ::set ::FrameBackground [$::TestLabel cget -background]; ::destroy $::TestLabel; ::namespace eval ::qw::widget {}; ::set ::qw::widget::options_test [::subst { .font {-family Arial -size 10 -weight normal} .foreground black .background white .relief solid .border { .width 0 } .pad { .internal { .x 1m .y 1m } .external { .x 0m .y 0m } } .padx 0m .pady 0m .ipadx 1m .ipady 1m /frame { .background {$FrameBackground} .border { .width 0 } .relief solid /controls { .height 2 .border { .width 0m } } /info { .height 2 .border { .width 0m } } } /button { .text "" .border { .width .5m } .relief raised .padx 1m .pady 1m .command { ::qw::throw {Button command not specified.} } /control { .padx 4m .pady 1m /help { .text "Help" } /ok { .text "Ok" } /cancel { .text "Cancel" } } } /selection { .foreground white .background RoyalBlue4 } /scroll { .mode dynamic /horizontal {} /vertical {} } }]; # ------------------------------------------------------------ # ::qw::dialog namespace # ------------------------------------------------------------ ::namespace eval ::qw::dialog {} ::set ::qw::dialog::result ""; ::proc ::qw::dialog::create {sargs} { /* { deprecated - replaced by ::qw::dialog::toplevel_create This method created the toplevel but then went on to create the frame for the control buttons. Eventually we needed modal dialogs without control buttons, say with menus and toolbars, perhaps status etc., but not necessarily control buttons. The database_backup was the first modal dialog to stray from the original course. */ } ::set Args { .class Toplevel .title "Dialog" .bbox "" .path "" }; ::set sargs [::sargs::+= $Args $sargs]; ::set Path ""; ::if {[::sargs::get $sargs .path] eq ""} { ::set Count 0; ::set Path ".dialog[incr Count]"; ::while {[::winfo exists $Path]} { ::set Path ".dialog[::incr Count]"; } ::sargs::var::set sargs .path $Path; } ::set Path [::sargs::get $sargs .path]; ::set BBox [::sargs::get $sargs .bbox]; ::set Geometry [::sargs::get $sargs .geometry]; ::toplevel $Path -class [::sargs::get $sargs .class]; ::wm withdraw $Path; #// attempting to reduce noise while positioning ::frame $Path.info \ -relief solid \ -borderwidth 0 \ ; /* { ::frame $Path.info \ -relief solid \ -borderwidth 0 \ -background [::sargs::get_poly $sargs /frame/info.background] \ ; */ } ::frame $Path.controls \ -borderwidth 0 \ -relief solid \ -padx 0 \ -pady 0 \ ; ::pack $Path.info -expand yes -fill both -padx 4 -pady 4 /* { pgq eliminates bindings on "all" for whatever reason but this turns off tab-key functionality for all basic tk windows, not just ours. At least here we can turn them back on for our toplevels, i.e dialogs. */ } ::bind $Path {tk::TabToWindow [tk_focusNext %W]} ::bind $Path <> {tk::TabToWindow [tk_focusPrev %W]} ::pack $Path.controls \ -fill x \ -padx 0 \ -pady 0 \ ; ::wm title $Path [::sargs::get $sargs .title]; ::wm group $Path . ::after idle [::subst -nocommands {::update idletasks;::qw::dialog::position -path {$Path} -bbox {$BBox} -geometry {$Geometry};}]; ::qw::toplevel_add .toplevel $Path; ::return $Path; } # ------------------------------------------------------------ # ::qw::dialog::position # ------------------------------------------------------------ /* { .bbox field If the Args include a non-empty .bbox field we assume that the dialog should be positioned under the region specified by that .bbox field. .bbox is a standard bounding box defining the upper left and lower right corners. We first attempt to position under the bbox, left justified. If the dialog doesn't fit there we position it elsewhere, such as above. If all else fails, we position it at 0,0. */ } ::proc ::qw::dialog::position {args} { ::qw::try { ::array set Args $args; } catch Exception { ::qw::throw "Expected arguments to be a well-formed list of name/value pairs."; } ::set Path $Args(-path); ::if {![::winfo exists $Path]} { ::return; } ::set BBox ""; ::if {[::info exists Args(-bbox)]} { ::set BBox $Args(-bbox); # ::puts "Setting the bbox to: $BBox"; ::unset Args(-bbox); } ::set Geometry ""; ::if {[::info exists Args(-geometry)]} { ::set Geometry $Args(-geometry); # ::puts "Setting the Geometry to: $Geometry"; ::unset Args(-geometry); } ::wm minsize $Path [::winfo reqwidth $Path] [::winfo reqheight $Path]; ::if {$BBox eq ""} { ::wm deiconify $Path; # Kludge alert. For tree widget we want to see selected item if any. # We have to wait until now to call see because now at least the toplevel # has a requested size. ::if {[::winfo exists ${Path}.info.tree]} { #${Path}.info.tree draw; ${Path}.info.tree see; } return; } ::if {$Geometry ne ""} { ::lset BBox 2 [::lindex [::split [::lindex [::split $Geometry +] 0] x] 0]; ::lset BBox 3 [::lindex [::split [::lindex [::split $Geometry +] 0] x] 1]; } ::set ulx [::lindex $BBox 0]; ::set uly [::lindex $BBox 1]; ::set lrx [::expr $ulx+[::lindex $BBox 2]]; ::set lry [::expr $uly+[::lindex $BBox 3]]; ::set DialogX $ulx; ::set DialogY $lry; #nv2.28.3 (bug fix) - ::qw::dialog::position - replaced [::winfo screenwidth $Path] with [::lindex [::wm maxsize $Path] 0] - for dual and multiple monitor #::set ScreenWidth [::winfo screenwidth $Path]; #::set ScreenHeight [::winfo screenheight $Path]; ::set ScreenWidth [::lindex [::wm maxsize $Path] 0]; ::set ScreenHeight [::lindex [::wm maxsize $Path] 1]; ::switch -- $Geometry { "" { ::set DialogWidth [::winfo reqwidth $Path]; ::set DialogHeight [::winfo reqheight $Path]; } default { ::set DialogWidth [::lindex [::split [::lindex [::split $Geometry +] 0] x] 0]; ::set DialogHeight [::lindex [::split [::lindex [::split $Geometry +] 0] x] 1]; } } ::if {[::expr {$DialogX+$DialogWidth}]>$ScreenWidth} { # Kludge Alert: Need to add the border width but don't have it. ::set DialogX [::expr $ScreenWidth-$DialogWidth-15] } ::if {$DialogX<0} { ::set DialogX 0; } ::if {[::expr {$DialogY+$DialogHeight}]>$ScreenHeight} { # Kludge Alert: Need to add the title height but don't have it. ::set DialogY [::expr $uly-$DialogHeight-27] } ::if {$DialogY<0} { ::set DialogY 0; } ::wm geometry $Path +$DialogX+$DialogY; ::wm deiconify $Path; /* { Kludge alert. For tree widget we want to see selected item if any. We have to wait until now to call see because now at least the toplevel has a requested size. */ } ::if {[::winfo exists ${Path}.info.tree]} { # ${Path}.info.tree draw; ${Path}.info.tree see; } ::raise $Path; } ::proc ::qw::toplevel_position {args} { /* { Positions a toplevel, moving it if necessary so that it fits on the screen. Arguments .toplevel .x .y Calls reqheight/reqwidth on the toplevel to gets it's size so you don't supply the size as an argument. Call it as an idle task. Typical cal;l follows: ::after idle [::list ::qw::toplevel_position $Position .toplevel $Toplevel]; or ::after idle [::list ::qw::toplevel_position .x $x .y $y .toplevel $Toplevel]; */ } ::qw::s_args_marshal; ::update idletasks; ::set Toplevel [::sargs::get $s_args .toplevel]; ::if {$Toplevel eq ""} { ::qw::bug 3141200802071555245 "Encountered empty toplevel."; } ::if {![::winfo exists $Toplevel]} { /* { Since this method is usually invaked as an idletask, the widget could in fact be gone by now. */ } ::return; } ::wm minsize $Toplevel [::winfo reqwidth $Toplevel] [::winfo reqheight $Toplevel]; ::set X [::sargs::integer_get $s_args .x]; ::set Y [::sargs::integer_get $s_args .y]; #nv2.28.3 (bug fix) - ::qw::dialog::position - replaced [::winfo screenwidth $Path] with [::lindex [::wm maxsize $Path] 0] - for dual and multiple monitor #::set ScreenWidth [::winfo screenwidth $Toplevel]; #::set ScreenHeight [::winfo screenheight $Toplevel]; ::set ScreenWidth [::lindex [::wm maxsize $Toplevel] 0]; ::set ScreenHeight [::lindex [::wm maxsize $Toplevel] 1]; ::set Width [::winfo reqwidth $Toplevel]; ::set Height [::winfo reqheight $Toplevel]; ::if {[::expr {$X+$Width}]>$ScreenWidth} { # Kludge Alert: Need to add the border width but don't have it. ::set X [::expr {$ScreenWidth-$Width-15}] } ::if {$X<0} { ::set X 0; } ::if {[::expr {$Y+$Height}]>$ScreenHeight} { # Kludge Alert: Need to add the title height but don't have it. ::set Y [::expr $Y-$Height-27] } ::if {$Y<0} { ::set Y 0; } ::wm geometry $Toplevel +$X+$Y; ::wm deiconify $Toplevel; ::raise $Toplevel; } ::proc ::qw::dialog::position_toplevel_around_bbox {sargs} { /* { .bbox {x y w h} .toplevel .x Positions a toplevel around a bbox. By default we position the toplevel, usually a modal dialog box, under the bbox but if it doesn't fit we position it elsewhere until it does. If the bounding box is not specified then we do nothing. Note: this is essentially same as ::qw::dialog::position but was updated to take sargs. Notes on bbox. canvas item -> x1 y1 x2 y2 entry -> x y w h list item -> x y w h spinbox -> x y w h text -> x y w h grid -> x y w h tktable cell -> x y w h */ } ::set Toplevel [::sargs::get $sargs .toplevel]; ::if {![::winfo exists $Toplevel]} { ::return; } ::set BBox [::sargs::get $sargs .bbox]; ::if {[::llength $BBox]==4} { ::set ulx [::lindex $BBox 0]; ::set uly [::lindex $BBox 1]; ::set lrx [::expr {$ulx+[::lindex $BBox 2]}]; ::set lry [::expr {$uly+[::lindex $BBox 3]}]; ::set DialogX $ulx; ::set DialogY $lry; #nv2.28.3 (bug fix) - ::qw::dialog::position - replaced [::winfo screenwidth $Path] with [::lindex [::wm maxsize $Path] 0] - for dual and multiple monitor #::set ScreenWidth [::winfo screenwidth $Toplevel]; #::set ScreenHeight [::winfo screenheight $Toplevel]; ::set ScreenWidth [::lindex [::wm maxsize $Toplevel] 0]; ::set ScreenHeight [::lindex [::wm maxsize $Toplevel] 1]; ::set DialogWidth [::winfo reqwidth $Toplevel]; ::set DialogHeight [::winfo reqheight $Toplevel]; ::if {[::expr {$DialogX+$DialogWidth}]>$ScreenWidth} { /* { Kludge Alert: Need to add the border width but don't have it. */ } ::set DialogX [::expr $ScreenWidth-$DialogWidth-15] } ::if {$DialogX<0} { ::set DialogX 0; } ::if {[::expr {$DialogY+$DialogHeight}]>$ScreenHeight} { /* { Kludge Alert: Need to add the title height but don't have it. */ } ::set DialogY [::expr $uly-$DialogHeight-27] } ::if {$DialogY<0} { ::set DialogY 0; } ::wm geometry $Toplevel +$DialogX+$DialogY; } ::wm deiconify $Toplevel; ::if {[::winfo exists ${Toplevel}.info.tree]} { /* { Kludge alert. For tree widget we want to see selected item if any. We have to wait until now to call see because now at least the toplevel has a requested size. */ } #${Toplevel}.info.tree draw; ${Toplevel}.info.tree see; } ::raise $Toplevel; } ::proc ::qw::dialog::wait {sargs} { ::qw::dialog::safeguard $sargs ::set Toplevel [::sargs::get $sargs .toplevel]; ::set Variable [::sargs::get $sargs .variable]; ::if {$Toplevel eq ""} { ::qw::bug 314120080222113924 "::qw::dialog::wait - empty .toplevel argument."; } ::if {$Variable eq ""} { ::qw::bug 314120080222113925 "::qw::dialog::wait - empty .variable argument."; } # ::set x [expr [::winfo rootx .]+50] # ::set y [expr [::winfo rooty .]+50] # ::wm geometry $Toplevel "+$x+$y" # ::wm deiconify $Toplevel ::switch -- $::tcl_platform(platform) { "windows" { } "unix" { /* { 2.37.2 On linux only. The confirn dialog had the following error message when calling wait: "grab failed: window not viewable" Deiconifying fixes it. I fix it here instead of in the confirm code in case it is a problem for other dialogs. */ } ::wm deiconify $Toplevel; } } ::grab set $Toplevel; ::update idletasks; ::vwait $Variable; ::grab release $Toplevel; # ::wm withdraw $Toplevel } ::bind qw_gui_dialog_modal { ::wm deiconify %W ::raise %W } ::proc ::qw::dialog::safeguard {sargs} { ::set Toplevel [::sargs::get $sargs .toplevel]; ::if {[::lsearch [::bindtags $Toplevel] qw_gui_dialog_modal]<0} { ::bindtags $Toplevel [::linsert [::bindtags $Toplevel] 0 qw_gui_dialog_modal] } } # ------------------------------------------------------------ # ::qw::dialog::notify # ------------------------------------------------------------ #dialog ::proc ::qw::dialog::notify {sargs} { ::if {$::qw::control(run_as_service)} { #2.28.0 ::return; } ::if {[::sargs::get $sargs /button/cancel] ne ""} { ::sargs::var::set sargs /button/control/ok [::sargs::get $sargs /button/cancel]; ::sargs::var::unset sargs /button/cancel; #2.35.0 ::puts [::sargs .warning_id 314120091211110026 .text "Deprecated dialog button override for /button/ok."]; } ::if {[::sargs::get $sargs /button/help] ne ""} { ::sargs::var::set sargs /button/control/help [::sargs::get $sargs /button/help]; ::sargs::var::unset sargs /button/help; #2.35.0 ::puts [::sargs .warning_id 314120091211110027 .text "Deprecated dialog button override for /button/help."]; } ::qw::try { ::set Toplevel ""; ::set Args [::sargs::+= $::qw::widget::options_test [::sargs \ .text "Notify" \ .title "Notify" \ .class "Notify" \ .sound "SystemAsterisk" \ .bitmap info \ .bbox "" \ .help { .help_id default_notify_dialog_help } \ /frame { /info { .background_save wheat2 } } \ /button { /control { /ok { .text "Dismiss" } /help { .text Help } } } \ ]]; ::set sargs [::sargs::+= $Args $sargs]; /* { In 2.10 decided to add .help_page and move .help.help_id to just .help_id; */ } ::set HelpPage [::sargs::get $sargs .help_page]; ::if {$HelpPage ne ""} { ::set HelpTree $HelpPage; } else { ::set HelpId [::sargs::get $Args .help_id] ::if {$HelpId eq ""} { ::set HelpId [::sargs::get $Args .help.help_id] } ::sargs::var::set HelpTree .title [::sargs::get $Args .title]; ::sargs::var::set HelpTree .help_id $HelpId; ::if {[::sargs::get $sargs .help] ne ""} { ::if {[::sargs::get $sargs .help.title] eq ""} { ::sargs::var::set sargs .help.title [::sargs::get $sargs .title]; } ::sargs::var::set HelpTree "/0" [::sargs::get $sargs .help]; } } ::sargs::var::+= Args $sargs; ::foreach Path [::sargs::select_field .structure $HelpTree .field .help_id] { ::sargs::var::set HelpTree ${Path}.button_ok [::sargs::get $Args /button/ok.text]; } # ::sargs::var::+= Args $sargs; ::set Toplevel [::qw::dialog::create $Args]; ::set Info ${Toplevel}.info; ::set DialogImage [::image create photo -file [::file join $::qw_library system images info.gif]]; ::label $Info.icon \ -image $DialogImage \ -background [::sargs::get_poly $Args /frame/info.background] \ ; ::pack $Info.icon -side left -padx 8 -pady 8; /* { ::if {[::sargs::get $Args .bitmap] ne ""} { ::label $Info.icon \ -bitmap [::sargs::get $Args .bitmap] \ -background [::sargs::get_poly $Args /frame/info.background] \ ; ::pack $Info.icon -side left -padx 8 -pady 8; } */ } ::label $Info.text \ -text [::sargs::get_poly $Args .text] \ -font [::sargs::get_poly $Args .font] \ -background [::sargs::get_poly $Args /frame/info.background] \ -justify left \ ; ::pack $Info.text -side right -expand 1 -fill both -padx 8 -pady 8 ::set Controls ${Toplevel}.controls; ::foreach Button {help ok} { ::button $Controls.$Button \ -text [::sargs::get_poly $sargs /button/control/$Button.text] \ -padx [::sargs::get_poly $sargs /button/control/$Button.padx] \ -pady [::sargs::get_poly $sargs /button/control/$Button.pady] \ ; ::pack $Controls.$Button -side right -padx 4 -pady 4; } ::sargs::var::set Args .help.button_ok [::sargs::get $Args /button/ok.text]; ::set HelpCommand [::list ::qw::help::launch_from_dialog1 [::sargs .structure $HelpTree]]; # ::set HelpCommand [::list ::qw::help::launch_from_dialog [::sargs::get $Args .help]]; $Controls.ok configure -command {::set ::qw::dialog::result ""} $Controls.help configure -command $HelpCommand; ::wm protocol $Toplevel WM_DELETE_WINDOW [::list $Controls.ok invoke]; ::bind $Toplevel [::list $Controls.ok invoke]; ::bind $Toplevel [::list $Controls.ok invoke]; ::bind $Toplevel [::list $Controls.help invoke]; ::raise $Toplevel; ::focus $Controls.ok; ::qw::dialog::button_list_bindings_setup .button_list [::list \ $Controls.ok \ $Controls.help \ ]; ::qw::sound::play [::sargs::get $Args .sound]; ::qw::dialog::wait .toplevel $Toplevel .variable ::qw::dialog::result; ::destroy $Toplevel ::return $::qw::dialog::result; } catch Exception { ::qw::try { ::destroy $Toplevel; } catch Dummy {} ::qw::throw [::qw::exception::parent $Exception "Could not create a notify dialog with arguments \"$sargs\"."]; } } ::proc ::qw::dialog::button_list_bindings_setup {args} { /* { Takes a horizontal list of buttons in left-to-right order and binds the arrow movement keys to them in such a way that they move between the buttons and wrap around the ends. */ } ::qw::s_args_marshal; ::set ButtonList [::sargs::get $s_args .button_list]; ::for {::set i 0} {$i<[::llength $ButtonList]} {::incr i} { ::if {$i==[::expr {[::llength $ButtonList]-1}]} { ::set Next [::lindex $ButtonList 0]; } else { ::set Next [::lindex $ButtonList [::expr {$i+1}]]; } ::bind [::lindex $ButtonList $i] [::list ::focus $Next]; ::bind [::lindex $ButtonList $i] [::list ::focus $Next]; ::if {$i==0} { ::set Prev [::lindex $ButtonList end]; } else { ::set Prev [::lindex $ButtonList [::expr {$i-1}]]; } ::bind [::lindex $ButtonList $i] [::list ::focus $Prev]; ::bind [::lindex $ButtonList $i] [::list ::focus $Prev]; } } # ------------------------------------------------------------ # ::qw::dialog::confirm # ------------------------------------------------------------ #dialog ::proc ::qw::dialog::confirm {args} { ::if {$::qw::control(run_as_service)} { #2.28.0 ::return 1; } ::qw::s_args_marshal; ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog::confirm,1000.0,s_args==\n[::sargs::format $s_args]";} ::if {[::sargs::boolean_get $s_args .extended]} { ::return [::qw::dialog::confirm_multiple_choice $s_args]; } ::foreach Button {ok cancel help} { ::if {[::sargs::get $s_args /button/$Button.text] ne ""} { ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog::confirm,1000.1,Button==$Button";} ::sargs::var::set s_args /button/control/$Button.text [::sargs::get $s_args /button/$Button.text]; # ::sargs::var::set s_args .button_$Button [::sargs::get $s_args /button/$Button.text]; # ::sargs::var::set s_args /button/control/$Button.text [::sargs::get $s_args /button/$Button.text]; # ::sargs::var::unset s_args /button/$Button.text; #2.32.0 ::puts [::sargs .warning_id 314120091211110026 .text "Deprecated dialog button override for /button/$Button."]; } } ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog::confirm,1000.2,s_args==\n[::sargs::format $s_args]";} ::qw::try { ::set Args $::qw::widget::options_test; ::sargs::var::+= Args [::sargs \ .text "Confirm" \ .title "Confirm" \ .class "Confirm" \ .sound SystemExclamation \ .bitmap question \ .bbox "" \ .help { .help_id default_confirm_dialog_help } \ /frame/info.background1 \$Background \ /frame/info/old.background yellow2 \ /button { .text "Text not specified." .command {} /control { /ok { .text Ok } /cancel { .text Cancel } /help { .text Help } } } \ ]; ::set s_args [::sargs::+= $Args $s_args]; ::sargs::var::+= s_args [::sargs::get $s_args .help]; ::if {$rwb1_debug} {::puts "rwb1_debug,qw::dialog::confirm,1000.3,s_args==\n[::sargs::format $s_args]";} # ::sargs::var::unset Args .help; ::set Toplevel [::qw::dialog::create $s_args]; ::set Info ${Toplevel}.info; /* { The next lines are temporary until we completely remove .button_ok etc. */ } ::sargs::var::set s_args .button_ok [::sargs::get $s_args /button/ok.text]; ::sargs::var::set s_args .button_cancel [::sargs::get $s_args /button/cancel.text]; ::sargs::var::set s_args .button_help [::sargs::get $s_args /button/help.text]; ::set HelpCommand [::list ::qw::help::launch_from_dialog_confirm $s_args]; ::set DialogImage [::image create photo -file [::file join $::qw_library system images question.gif]]; ::label $Info.icon \ -image $DialogImage \ -background [::sargs::get_poly $s_args /frame/info.background] \ -padx 2m \ -pady 2m \ ; /* { ::if {[::sargs::get $s_args .bitmap] ne ""} { ::label $Info.icon \ -bitmap [::sargs::get $s_args .bitmap] \ -background [::sargs::get_poly $s_args /frame/info.background] \ ; ::pack $Info.icon -side left -padx 8 -pady 8 } */ } ::label $Info.text \ -text [::sargs::get_poly $s_args .text] \ -font [::sargs::get_poly $s_args .font] \ -background [::sargs::get_poly $s_args /frame/info.background] \ -justify left \ -padx 2m \ -pady 2m \ ; ::set Controls ${Toplevel}.controls; ::foreach Button {help cancel ok} { ::button $Controls.$Button \ -text [::sargs::get_poly $s_args /button/control/$Button.text] \ -padx [::sargs::get_poly $s_args /button/control/$Button.padx] \ -pady [::sargs::get_poly $s_args /button/control/$Button.pady] \ ; ::pack $Controls.$Button -side right -padx 4 -pady 4; } ::pack $Info.icon -side left -expand 1 -fill both; ::pack $Info.text -side right -expand 1 -fill both; # ::set HelpCommand [::list ::qw::help::launch_from_dialog1 [::sargs .structure $HelpTree]]; # ::set HelpCommand [::list ::qw::help::launch_from_dialog [::sargs::get $Args .help]]; $Controls.ok configure -command {::set ::qw::dialog::result 1} $Controls.cancel configure -command {::set ::qw::dialog::result 0} $Controls.help configure -command $HelpCommand; ::raise $Toplevel; #nv2.28.3 () ::set SaveFocus [::focus]; #//::puts "pgq,debug...::qw::dialog::confirm ::focus before==[::focus]"; #//::puts "pgq,debug...::qw::dialog::confirm ::focus -d .==[::focus -displayof .]"; #//::puts "pgq,debug...::qw::dialog::confirm ::focus -d T==[::focus -displayof $Toplevel]"; #//::puts "pgq,debug...::qw::dialog::confirm ::qw_gui_global_focus_window before==$::qw_gui_global_focus_window"; ::focus $Controls.ok; ::wm protocol $Toplevel WM_DELETE_WINDOW [::list $Controls.cancel invoke]; ::bind $Toplevel [::list $Controls.cancel invoke]; ::bind $Toplevel [::list $Controls.help invoke]; ::bind $Controls.ok [::list ::focus $Controls.cancel]; ::bind $Controls.ok [::list ::focus $Controls.cancel]; ::bind $Controls.ok [::list ::focus $Controls.help]; ::bind $Controls.ok [::list ::focus $Controls.help]; ::bind $Controls.ok [::list $Controls.ok invoke]; ::bind $Controls.cancel [::list ::focus $Controls.help]; ::bind $Controls.cancel [::list ::focus $Controls.help]; ::bind $Controls.cancel [::list ::focus $Controls.ok]; ::bind $Controls.cancel [::list ::focus $Controls.ok]; ::bind $Controls.cancel [::list $Controls.cancel invoke]; ::bind $Controls.help [::list ::focus $Controls.ok]; ::bind $Controls.help [::list ::focus $Controls.ok]; ::bind $Controls.help [::list ::focus $Controls.cancel]; ::bind $Controls.help [::list ::focus $Controls.cancel]; ::bind $Controls.help [::list $Controls.help invoke]; ::qw::sound::play [::sargs::get $s_args .sound]; ::qw::dialog::wait .toplevel $Toplevel .variable ::qw::dialog::result; ::set Result $::qw::dialog::result; #//::puts "pgq,debug...::qw::dialog::confirm ::focus before ::destroy==[::focus]"; #//::puts "pgq,debug...::qw::dialog::confirm ::focus -d .==[::focus -displayof .]"; #//::puts "pgq,debug...::qw::dialog::confirm ::focus -d T==[::focus -displayof $Toplevel]"; #//::puts "pgq,debug...::qw::dialog::confirm ::qw_gui_global_focus_window before==$::qw_gui_global_focus_window"; #nv2.28.3 () ::focus $SaveFocus; ;#// does work! #//::puts "pgq,debug...::qw::dialog::confirm ::focus after SaveFocus before ::destroy==[::focus]"; #//::puts "pgq,debug...::qw::dialog::confirm ::focus -d .==[::focus -displayof .]"; #//::puts "pgq,debug...::qw::dialog::confirm ::qw_gui_global_focus_window before==$::qw_gui_global_focus_window"; ::destroy $Toplevel #::focus $SaveFocus; ;#// doesn't work #//::puts "pgq,debug...::qw::dialog::confirm ::focus after ::destroy==[::focus]"; #//::puts "pgq,debug...::qw::dialog::confirm ::focus -d .==[::focus -displayof .]"; #//::puts "pgq,debug...::qw::dialog::confirm ::qw_gui_global_focus_window before==$::qw_gui_global_focus_window"; ::return $Result; } catch Exception { ::qw::try { ::destroy $Toplevel; } catch Dummy {} ::qw::throw [::qw::exception::parent $Exception "Could not create a confirm dialog with arguments \"$s_args\"."]; } } ::namespace eval ::qw::help {} ::proc ::qw::help::launch_from_dialog_confirm {sargs} { /* { This must be extended to all dialogs. We are eliminating .button_ok/cancel/help from all dialogs. They are automatic. In the help .button_ok -> /button/ok.text We are also adding .help_path We should move .help.help_id up into the sargs of the dialog calls. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,launch_from_dialog_confirm,1000.00,sargs==\n[::sargs::format $sargs]";} ::foreach Sub [::sargs::subs .structure $sargs] { ::sargs::var::unset sargs $Sub; } ::set HelpPage [::sargs::get $sargs .help_page]; ::if {$rwb1_debug} {::puts "rwb1_debug,launch_from_dialog_confirm,1000.01";} ::if {$HelpPage ne ""} { ::if {$rwb1_debug} {::puts "rwb1_debug,launch_from_dialog_confirm,1000.02";} ::qw::script::source \ .script.path [::file join $::qw_library doc qw_chtml_compile.qw_script] \ .structure $HelpPage \ .compiler.command error \ ; ::return; ::set HelpPage [::sargs::get $sargs .help_page]; ::set Text [::sargs::get $sargs .text]; ::set Title [::string map [::list "\"" ""] $Text]; ::set RenderedTitle [::subst -nobackslashes -nocommands {[h2 {$Title}]}]; ::append Body $RenderedTitle; # ::sargs::var::set ErrorMessageStructure "$Path.title" $Title; # ::sargs::var::set ErrorMessageStructure "$Path.id" "3141[::clock seconds][::incr UniqueId]"; ::append Body [::sargs::get [$Formatter body_render $HelpPage] .body]; } ::if {$rwb1_debug} {::puts "rwb1_debug,launch_from_dialog_confirm,1000.03";} ::if {[::sargs::get $sargs .help_path] ne ""} { ::sargs::var::set sargs .path [::sargs::get $sargs .help_path]; ::set Structure [::qw::help::page_load $sargs]; ::sargs::var::+= Structure $sargs; ::sargs::var::set sargs .structure $Structure; ::sargs::var::set sargs .script.path [::file join $::qw_library doc qw_chtml_compile.qw_script]; ::qw::script::source $sargs; ::return; ::qw::script::source [::sargs \ .script.path [::file join $::qw_library doc qw_chtml_compile.qw_script] \ .structure $Structure \ ]; ::return; } ::if {$rwb1_debug} {::puts "rwb1_debug,launch_from_dialog_confirm,1000.04,sargs==\n[::sargs::format $sargs]";} ::qw::help::launch_help_page $sargs; ::if {$rwb1_debug} {::puts "rwb1_debug,launch_from_dialog_confirm,1000.99";} } # ------------------------------------------------------------ # ::qw::dialog::confirm_multiple_choice # ------------------------------------------------------------ #dialog ::proc ::qw::dialog::controls_setup {args} { ::qw::s_args_marshal; ::set Controls [::sargs::subs .structure [::sargs::get $s_args .info]]; ::set Subs [::sargs::subs .structure [::sargs::get $s_args /button]]; ::set Subs [::string map [::list "/" ""] $Subs]; ::set Column 0; ::array set ButtonsByNumber {}; ::set ButtonList ""; ::foreach Sub $Subs { ::set Button [::string tolower $Sub]; ::lappend ButtonList $Button; ::button $Controls.${Button} \ -text [::sargs::get_poly $s_args /button/${Button}.text] \ -font [::sargs::get_poly $s_args /button/${Button}.font] \ -relief [::sargs::get_poly $s_args /button/${Button}.relief] \ -borderwidth [::sargs::get_poly $s_args /button/${Button}.border.width] \ -borderwidth [::sargs::get_poly $s_args /button.border.width] \ ; ::grid $Controls.${Button} -row 0 -column $Column -sticky nesw \ -padx [::sargs::get_poly $s_args /button/${Button}.pad.external.x] \ -pady [::sargs::get_poly $s_args /button/${Button}.pad.external.y] \ ; ::grid columnconfigure $Controls $Column -weight 1; ::switch -- $Button { help { } default { $Controls.$Button configure -command [::list ::set ::qw::dialog::result [::sargs::get $s_args /button/${Sub}.value]]; } } ::incr Column; } /* { ::foreach {Column Button} {0 ok 1 cancel 2 help} { ::button $Controls.${Button} \ -text [::sargs::get_poly $s_args /button/${Button}.text] \ -font [::sargs::get_poly $s_args /button/${Button}.font] \ -relief [::sargs::get_poly $s_args /button/${Button}.relief] \ -borderwidth [::sargs::get_poly $s_args /button/${Button}.border.width] \ -borderwidth [::sargs::get_poly $s_args /button.border.width] \ ; ::grid $Controls.${Button} -row 0 -column $Column -sticky nesw \ -padx [::sargs::get_poly $s_args /button/${Button}.pad.external.x] \ -pady [::sargs::get_poly $s_args /button/${Button}.pad.external.y] \ ; ::grid columnconfigure $Controls $Column -weight 1; } */ } # ::set HelpCommand [::list ::qw::help::launch_from_dialog1 [::sargs .structure $HelpTree]]; # ::set HelpCommand [::list ::qw::help::launch_from_dialog [::sargs::get $Args .help]]; # $Controls.ok configure -command {::set ::qw::dialog::result 1} # $Controls.cancel configure -command {::set ::qw::dialog::result 0} $Controls.help configure -command $HelpCommand; ::raise $Toplevel; ::focus $Controls.[::lindex $ButtonList 0]; ::wm protocol $Toplevel WM_DELETE_WINDOW [::list $Controls.cancel invoke]; ::bind $Toplevel [::list $Controls.cancel invoke]; ::bind $Toplevel [::list $Controls.help invoke]; ::set Index 0; ::foreach Button $ButtonList { ::bind $Controls.${Button} [::list $Controls.${Button} invoke]; ::if {$Index==0} { ::set ButtonPrev [::lindex $ButtonList [::expr {[::llength $ButtonList]-1}]]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonPrev}]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonPrev}]; } else { ::set ButtonPrev [::lindex $ButtonList [::expr {$Index-1}]]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonPrev}]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonPrev}]; } ::if {$Index==[::expr {[::llength $ButtonList]-1}]} { ::set ButtonNext [::lindex $ButtonList 0]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonNext}]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonNext}]; } else { ::set ButtonNext [::lindex $ButtonList [::expr {$Index+1}]]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonNext}]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonNext}]; } ::incr Index; } } ::proc ::qw::dialog::confirm_multiple_choice {args} { ::qw::s_args_marshal; ::qw::try { ::set Toplevel ""; ::set Args [::sargs::get $::qw::options .window]; ::sargs::var::+= Args { .text "Confirm" .title "Confirm" .class "Confirm" .sound SystemExclamation .bitmap question .bbox "" .help { .help_id default_confirm_dialog_help } /frame { /info { .background_old yellow2 } } } /* { /button { .text "Text not specified." .command {} /choice1 { .text "Choose 1" .value 1 } /choice2 { .text "Choose 2" .value 2 } /cancel { .text "Cancel" .value "" } } */ } ::if {[::sargs::get $s_args /button] eq ""} { ::qw::bug 314120071017140912 "Encountered empty /button field."; } ::set s_args [::sargs::+= $Args $s_args]; ::if {![::sargs::exists $s_args .help_id]} { ::sargs::var::+= s_args [::sargs::get $s_args .help]; } ::sargs::var::unset Args .help; ::sargs::var::set Args /button/help.text "Help"; ::sargs::var::set Args /button/help.command "???"; ::set Toplevel [::qw::dialog::create $s_args]; ::set Info ${Toplevel}.info; /* { The next lines are temporary until we completely remove .button_ok etc. */ } # ::sargs::var::set s_args .button_ok [::sargs::get $s_args /button/ok.text]; # ::sargs::var::set s_args .button_cancel [::sargs::get $s_args /button/cancel.text]; # ::sargs::var::set s_args .button_help [::sargs::get $s_args /button/help.text]; ::set HelpCommand [::list ::qw::help::launch_from_dialog_confirm $s_args]; ::set DialogImage [::image create photo -file [::file join $::qw_library system images question.gif]]; ::label $Info.icon \ -image $DialogImage \ ; ::pack $Info.icon -side left -padx 8 -pady 8 /* { ::if {[::sargs::get $s_args .bitmap] ne ""} { ::label $Info.icon \ -bitmap [::sargs::get $s_args .bitmap] \ -background [::sargs::get_poly $s_args /frame/info.background] \ ; ::pack $Info.icon -side left -padx 8 -pady 8 } */ } ::label $Info.text \ -text [::sargs::get_poly $s_args .text] \ -justify left \ ; /* { ::label $Info.text \ -text [::sargs::get_poly $s_args .text] \ -font [::sargs::get_poly $s_args .font] \ -background [::sargs::get_poly $s_args /frame/info.background] \ -justify left \ ; */ } ::pack $Info.icon -side left -padx 8 -pady 8 ::pack $Info.text -side right -expand 1 -fill both -padx 8 -pady 8 ::set Controls ${Toplevel}.controls; ::set Subs [::sargs::subs .structure [::sargs::get $s_args /button]]; ::set Subs [::string map [::list "/" ""] $Subs]; ::set Column 0; ::array set ButtonsByNumber {}; ::set ButtonList ""; ::foreach Sub $Subs { ::set Button [::string tolower $Sub]; ::lappend ButtonList $Button; ::button $Controls.${Button} \ -text [::sargs::get_poly $s_args /button/${Button}.text] \ -font [::sargs::get_poly $s_args /button/${Button}.font] \ -relief [::sargs::get_poly $s_args /button/${Button}.relief] \ -borderwidth [::sargs::get_poly $s_args /button/${Button}.border.width] \ -borderwidth [::sargs::get_poly $s_args /button.border.width] \ ; ::grid $Controls.${Button} -row 0 -column $Column -sticky nesw \ -padx [::sargs::get_poly $s_args /button/${Button}.pad.external.x] \ -pady [::sargs::get_poly $s_args /button/${Button}.pad.external.y] \ ; ::grid columnconfigure $Controls $Column -weight 1; ::switch -- $Button { help { } default { $Controls.$Button configure -command [::list ::set ::qw::dialog::result [::sargs::get $s_args /button/${Sub}.value]]; } } ::incr Column; } /* { ::foreach {Column Button} {0 ok 1 cancel 2 help} { ::button $Controls.${Button} \ -text [::sargs::get_poly $s_args /button/${Button}.text] \ -font [::sargs::get_poly $s_args /button/${Button}.font] \ -relief [::sargs::get_poly $s_args /button/${Button}.relief] \ -borderwidth [::sargs::get_poly $s_args /button/${Button}.border.width] \ -borderwidth [::sargs::get_poly $s_args /button.border.width] \ ; ::grid $Controls.${Button} -row 0 -column $Column -sticky nesw \ -padx [::sargs::get_poly $s_args /button/${Button}.pad.external.x] \ -pady [::sargs::get_poly $s_args /button/${Button}.pad.external.y] \ ; ::grid columnconfigure $Controls $Column -weight 1; } */ } # ::set HelpCommand [::list ::qw::help::launch_from_dialog1 [::sargs .structure $HelpTree]]; # ::set HelpCommand [::list ::qw::help::launch_from_dialog [::sargs::get $Args .help]]; # $Controls.ok configure -command {::set ::qw::dialog::result 1} # $Controls.cancel configure -command {::set ::qw::dialog::result 0} $Controls.help configure -command $HelpCommand; ::raise $Toplevel; ::focus $Controls.[::lindex $ButtonList 0]; ::wm protocol $Toplevel WM_DELETE_WINDOW [::list $Controls.cancel invoke]; ::bind $Toplevel [::list $Controls.cancel invoke]; ::bind $Toplevel [::list $Controls.help invoke]; ::set Index 0; ::foreach Button $ButtonList { ::bind $Controls.${Button} [::list $Controls.${Button} invoke]; ::if {$Index==0} { ::set ButtonPrev [::lindex $ButtonList [::expr {[::llength $ButtonList]-1}]]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonPrev}]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonPrev}]; } else { ::set ButtonPrev [::lindex $ButtonList [::expr {$Index-1}]]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonPrev}]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonPrev}]; } ::if {$Index==[::expr {[::llength $ButtonList]-1}]} { ::set ButtonNext [::lindex $ButtonList 0]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonNext}]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonNext}]; } else { ::set ButtonNext [::lindex $ButtonList [::expr {$Index+1}]]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonNext}]; ::bind $Controls.${Button} [::list ::focus $Controls.${ButtonNext}]; } ::incr Index; } /* { ::bind $Controls.ok [::list ::focus $Controls.cancel]; ::bind $Controls.ok [::list ::focus $Controls.cancel]; ::bind $Controls.ok [::list ::focus $Controls.help]; ::bind $Controls.ok [::list ::focus $Controls.help]; ::bind $Controls.ok [::list $Controls.ok invoke]; ::bind $Controls.cancel [::list ::focus $Controls.help]; ::bind $Controls.cancel [::list ::focus $Controls.help]; ::bind $Controls.cancel [::list ::focus $Controls.ok]; ::bind $Controls.cancel [::list ::focus $Controls.ok]; ::bind $Controls.cancel [::list $Controls.cancel invoke]; ::bind $Controls.help [::list ::focus $Controls.ok]; ::bind $Controls.help [::list ::focus $Controls.ok]; ::bind $Controls.help [::list ::focus $Controls.cancel]; ::bind $Controls.help [::list ::focus $Controls.cancel]; ::bind $Controls.help [::list $Controls.help invoke]; */ } ::qw::sound::play [::sargs::get $s_args .sound]; ::qw::dialog::wait .toplevel $Toplevel .variable ::qw::dialog::result; #nv2.28.4 (new feature) - column_fill.qw_script - >Tools >Manipulate Column ::if {[::sargs::get $s_args .options_file] ne ""} { ::sargs::file::+= [::sargs::get $s_args .options_file] [::sargs .x [::winfo x $Toplevel] .y [::winfo y $Toplevel]]; } ::destroy $Toplevel ::return $::qw::dialog::result; } catch Exception { ::if {$Toplevel ne ""&&[::winfo exists $Toplevel]} { ::qw::try { ::destroy $Toplevel; } catch Dummy {} } ::qw::throw [::qw::exception::parent $Exception "Could not create a multiple choice confirm dialog with arguments \"$s_args\"."]; } } # ------------------------------------------------------------ # ::qw::dialog::list # ------------------------------------------------------------ #dialog ::set ::qw::dialog::list_dialog_result ""; ::proc ::qw::dialog::list {args} { # next line was just to find out every key's keysym # bind all {puts "You pressed the key called \"%K\""} ::qw::s_args_marshal; ::qw::try { ::set Toplevel ""; ::set Args [::sargs::get $::qw::options .window]; ::sargs::var::+= Args { .title "Select from list." .class "List" .list "" .sound "" .bbox "" .default "" .help { .help_id default_list_dialog_help } /button { .text "Text not specified." .command {} /ok { .text Select } /cancel { .text Cancel } /help { .text Help } } } /* { 2.11.3 Added inline pages. */ } ::set HelpPage [::sargs::get $s_args .help_page]; ::if {$HelpPage ne ""} { ::set HelpTree $HelpPage; } else { ::set HelpId [::sargs::get $Args .help_id] ::if {$HelpId eq ""} { ::set HelpId [::sargs::get $Args .help.help_id] } ::sargs::var::set HelpTree .title [::sargs::get $Args .title]; ::sargs::var::set HelpTree .help_id $HelpId; ::if {[::sargs::get $s_args .help] ne ""} { ::if {[::sargs::get $s_args .help.title] eq ""} { ::sargs::var::set s_args .help.title [::sargs::get $s_args .title]; } ::sargs::var::set HelpTree "/0" [::sargs::get $s_args .help]; } } ::sargs::var::+= Args $s_args; ::foreach Path [::sargs::select_field .structure $HelpTree .field .help_id] { ::sargs::var::set HelpTree ${Path}.button_cancel [::sargs::get $Args /button/cancel.text]; } # ::sargs::var::+= Args $s_args; /* { ::sargs::var::set HelpTree .title [::sargs::get $Args .title] .help_id [::sargs::get $Args .help.help_id]; ::if {[::sargs::get $s_args .help] ne ""} { ::if {[::sargs::get $s_args .help.title] eq ""} { ::sargs::var::set s_args .help.title [::sargs::get $s_args .title]; } ::sargs::var::set HelpTree "/0" [::sargs::get $s_args .help]; } ::sargs::var::+= Args $s_args; ::foreach Path [::qw::_structure::select_name [::sargs .structure $HelpTree .name .help_id]] { ::sargs::var::set HelpTree ${Path}.button_ok [::sargs::get $Args /button/ok.text]; ::sargs::var::set HelpTree ${Path}.button_cancel [::sargs::get $Args /button/cancel.text]; } */ } ::set s_args $Args; ::set Toplevel [::qw::dialog::create $Args]; /* { Sending toplevel to the list widget so he can access the title. Note that this is necessary only because we have a rather bad design here. Hope to fix it some day. */ } ::sargs::var::set s_args .toplevel $Toplevel; # ::set ListBox [::eval ::QW::WIDGET::LIST $Toplevel.info.list $s_args]; # ::pack $Toplevel.info.list -expand 1 -fill both; ::set Controls $Toplevel.controls; # $ListBox option_set .command [::sargs .doubleclick "$Controls.ok invoke"]; ::set Controls ${Toplevel}.controls; ::foreach Button {help cancel ok} { ::button $Controls.$Button \ -text [::sargs::get_poly $s_args /button/$Button.text] \ -padx [::sargs::get_poly $s_args /button/$Button.padx] \ -pady [::sargs::get_poly $s_args /button/$Button.pady] \ ; # ::pack $Controls.$Button -side right -padx 4 -pady 4; } ::label $Controls.typed_string \ -text "" \ -padx [::sargs::get_poly $s_args /button/$Button.padx] \ -pady [::sargs::get_poly $s_args /button/$Button.pady] \ -anchor w \ ; ::sargs::var::set s_args .typed_string_label $Controls.typed_string; ::set ListBox [::eval ::QW::WIDGET::LIST $Toplevel.info.list $s_args]; $ListBox option_set .command [::sargs .doubleclick "$Controls.ok invoke"]; ::pack $Toplevel.info.list -expand 1 -fill both; ::foreach Button {help cancel ok} { ::pack $Controls.$Button -side right -padx 4 -pady 4; } ::if {!$::qw::control(spacebar_invokes_button_enabled)} { ::foreach Button {help cancel ok} { ::bind $Controls.$Button ""; ::bind $Controls.$Button ""; } # ::bind . ""; # ::bind . ""; # ::bind all ""; # ::bind all ""; ::bind Button ""; ::bind Button ""; } ::pack $Controls.typed_string -side right -expand 1 -fill x; /* { ::foreach {Column Button} {0 ok 1 cancel 2 help} { ::button $Controls.${Button} \ -text [::sargs::get_poly $Args /button/${Button}.text] \ -font [::sargs::get_poly $Args /button/${Button}.font] \ -borderwidth [::sargs::get_poly $Args /button.border.width] \ ; ::grid $Controls.${Button} -row 0 -column $Column -sticky nesw \ -padx [::sargs::get_poly $Args /button/${Button}.pad.external.x] \ -pady [::sargs::get_poly $Args /button/${Button}.pad.external.y] \ ; ::grid columnconfigure $Controls $Column -weight 1; } */ } ::set HelpCommand [::list ::qw::help::launch_from_dialog1 [::sargs .structure $HelpTree]]; # ::sargs::var::set Args .help.button_ok [::sargs::get $Args /button/ok.text]; # ::sargs::var::set Args .help.button_cancel [::sargs::get $Args /button/cancel.text]; # ::set HelpCommand [::list ::qw::help::launch_from_dialog [::sargs::get $Args .help]]; $Controls.ok configure -command [::subst -nocommands {::set ::qw::dialog::list_dialog_result [$ListBox selected]}]; $Controls.cancel configure -command { ::set ::qw::dialog::list_dialog_result ""; } $Controls.help configure -command $HelpCommand; ::bind $Toplevel [::list $Controls.cancel invoke]; ::bind $Toplevel [::list $Controls.help invoke]; ::set OptionsFile [::sargs::get $s_args .options_file]; ::set DialogGeometry [::sargs::file::get $OptionsFile .list_dialog_geometry]; ::if {$DialogGeometry eq ""} { /* { # 1.618 is the so-called golden number. ::set ScreenWidth [::expr {double([::winfo screenwidth .])}]; ::set Width [::expr {$ScreenWidth/4.0}]; ::set Length [::expr {$Width*1.618}]; ::set Width [::expr {int($Width)}]; ::set Length [::expr {int($Length)}]; ::set FileDialogGeometry ${Width}x${Length}; */ } } else { ::wm geometry $Toplevel $DialogGeometry; } ::raise $Toplevel; ::focus $Controls.ok; ::wm protocol $Toplevel WM_DELETE_WINDOW [::list $Controls.cancel invoke]; ::bind $Toplevel [::list $Controls.cancel invoke]; ::bind $Toplevel [::list $Controls.help invoke]; ::bind $ListBox [::list $Controls.ok invoke]; ::bind $ListBox [::list $Controls.ok invoke]; # ::bind $Controls.ok "$Controls.ok invoke"; # ::bind $Controls.cancel "$Controls.cancel invoke"; # ::bind $Controls.help $HelpCommand; ::bind $Controls.ok [::list ::focus $Controls.cancel]; ::bind $Controls.ok [::list ::focus $Controls.cancel]; ::bind $Controls.ok [::list ::focus $Controls.help]; ::bind $Controls.ok [::list ::focus $Controls.help]; ::bind $Controls.ok [::list $Controls.ok invoke]; ::bind $Controls.cancel [::list ::focus $Controls.help]; ::bind $Controls.cancel [::list ::focus $Controls.help]; ::bind $Controls.cancel [::list ::focus $Controls.ok]; ::bind $Controls.cancel [::list ::focus $Controls.ok]; ::bind $Controls.cancel [::list $Controls.cancel invoke]; ::bind $Controls.help [::list ::focus $Controls.ok]; ::bind $Controls.help [::list ::focus $Controls.ok]; ::bind $Controls.help [::list ::focus $Controls.cancel]; ::bind $Controls.help [::list ::focus $Controls.cancel]; ::bind $Controls.help [::list $Controls.help invoke]; ::qw::dialog::wait .toplevel $Toplevel .variable ::qw::dialog::list_dialog_result; ::if {[::sargs::get $s_args .options_file] ne ""} { ::set ListFileGeometry [::wm geometry $Toplevel]; ::sargs::file::+= [::sargs::get $s_args .options_file] [::sargs .list_dialog_geometry $ListFileGeometry]; } ::destroy $Toplevel ::return $::qw::dialog::list_dialog_result; } catch Exception { ::if {$Toplevel ne ""&&[::winfo exists $Toplevel]} { ::qw::try { ::destroy $Toplevel; } catch Dummy {} } ::qw::throw "Could not create a list dialog with arguments \"$s_args\"." $Exception; } } # ------------------------------------------------------------ # ::QW::WIDGET::LIST class # ------------------------------------------------------------ itcl::class ::QW::WIDGET::LIST { inherit ::itk::Widget protected variable _selectionbox ""; protected variable _scrolledlistbox ""; protected variable _listbox ""; protected variable _entryfield ""; protected variable _current ""; protected variable _options ""; protected variable _toplevel ""; protected variable _typed_string ""; protected variable _typed_string_label ""; # protected variable _list ""; protected variable _unsorted_list ""; protected variable _sorted_list ""; method select {Date} { ::qw::bug 314120030918120155; return $this; } method selected {} { ::return [$_scrolledlistbox getcurselection]; } method select_index {Index} { ::return [select $_table($Index-date)]; } method option_get {Path} { ::return [::sargs::get_poly $_options $Path]; } method option_set {args} { ::qw::s_args_marshal; ::sargs::var::+= _options $s_args; } method constructor {args} { ::qw::s_args_marshal; ::set _options $::qw::widget::options_test; ::sargs::var::+= _options [::subst { .default {} }]; ::sargs::var::+= _options $args; ::set Me $itk_interior; ::set _selectionbox [::iwidgets::selectionbox $Me.selectionbox -height 0 -width 0]; # ::set _selectionbox [::iwidgets::scrolledlistbox $Me.selectionbox -height 0 -width 0]; ::set _scrolledlistbox [$_selectionbox component items]; ::set _listbox [$_scrolledlistbox component listbox]; ::set _entryfield [$_selectionbox component selection]; ::set _toplevel [::sargs::get $s_args .toplevel]; ::set _typed_string_label [::sargs::get $s_args .typed_string_label]; # Cannot set this command until we have the scrolled list box widget. # ::set Args [::sargs::set $Args /button/select.command [::format {::set ::qw::dialog::result [%s getcurselection]} $ScrolledListBox]]; ::pack $_selectionbox -expand 1 -fill both $_scrolledlistbox configure \ -vscrollmode [option_get /scroll/vertical.mode] \ -hscrollmode [option_get /scroll/horizontal.mode] \ -selectbackground [option_get /selection.background] \ -selectforeground [option_get /selection.foreground] \ ; $_selectionbox configure \ -selectionon 0 -itemslabel "" \ ; ::set Items ""; ::foreach Item [option_get .list] { ::if {[::lsearch -exact -dictionary $Items $Item]<0} { ::lappend Items $Item; } } ::set Height 10; ::if {[::llength $Items]<$Height} {::set Height [::llength $Items];} ::set Width 0; ::foreach Item $Items { ::if {[::string length $Item]>$Width} { ::set Width [::string length $Item]; } $_selectionbox insert items end $Item; } ::set TitleWidth [::string length [::wm title $_toplevel]]; # ::set TitleWidth [::llength $Title]; ::incr TitleWidth 15; ::if {$TitleWidth>$Width} { /* { 2.21.1 The title didn't completely show when it was wider than the widest item. Here we pretend the title is one of the items. We also add a bit to its length to compensate for the This should fix it. */ } ::set Width $TitleWidth; } $_scrolledlistbox configure -visibleitems ${Width}x${Height}; $_listbox configure -font [option_get .font]; ::if {[option_get .default] ne ""} { ::set Index [::lsearch -exact -dictionary $Items [option_get .default]]; ::if {$Index<0} {::set Index 0;} $_entryfield insert 0 [::lindex $Items $Index]; $_scrolledlistbox selection set $Index; $_listbox activate $Index; $_listbox see $Index; } else { ::if {[::llength $Items]>0} { $_scrolledlistbox selection set 0; } } ::bind $_listbox [::itcl::code $this doubleclick 1]; # $_selectionbox configure -dblclickcommand "$Controls.select invoke"; ::set Toplevel [::lindex [bindtags $itk_component(hull)] end-1]; ::foreach {Sequence Method} { cursor_up cursor_down cursor_left cursor_right page_down page_up cursor_up cursor_down cursor_left cursor_right page_down page_up end_page_up end_page_down } { ::bind $Toplevel $Sequence [::itcl::code $this $Method]; } ::bind $Toplevel [::itcl::code $this typed_string_char .keysym %K .char %A]; ::bind $Toplevel [::itcl::code $this typed_string_backspace]; #nv2.28.0 (new feature) - mouse wheel for old dialog list boxes ::bind $Toplevel [::itcl::code $this mouse_wheel [::QW::GUI::EVENT::MOUSE::WHEEL::mask]]; ::eval itk_initialize; # ::set _unsorted_list [$_listbox get 0 end]; # ::set _sorted_list [::lsort -] # ::set _list [$_listbox get 0 end]; ::set _unsorted_list [$_listbox get 0 end]; ::set _unsorted_list [::string tolower $_unsorted_list]; ::set _sorted_list [::lsort $_unsorted_list]; } #nv2.28.0 (new feature) - mouse wheel for list boxes method mouse_wheel {args} { ::qw::s_args_marshal; #//::puts "pgq,debug...qw_dialog listbox mouse_wheel enter s_args==(\n[::sargs::format .structure $s_args]\n)"; /* { ...qw_dialog listbox mouse_wheel enter s_args==( .windowPath .dialog1.controls.ok .type 38 .serialNumber 1833 .send -1 .state 0 .subWindowHex 0x00000000 .time 704679604 .x -179 .y -90 .xRoot 1164 .yRoot 935 .delta -120 ) */} ::set Delta [::sargs::get $s_args .delta]; ::switch -exact -- $Delta { "-120" {$_listbox yview scroll 1 units;} "120" {$_listbox yview scroll -1 units;} "-240" {$_listbox xview scroll 1 units;} "240" {$_listbox xview scroll -1 units;} } ::return; } method typed_string_char {args} { ::qw::s_args_marshal; ::set KeySym [::qw:::structure::get $s_args .keysym]; ::set Char [::qw:::structure::get $s_args .char]; ::if {![::string is print $Char]} { ::return; } ::append _typed_string $Char; typed_string_process; } method typed_string_backspace {args} { ::qw::s_args_marshal; ::set _typed_string [::string range $_typed_string 0 end-1]; typed_string_process; } method typed_string_process_old {} { ::set List [$_listbox get 0 end]; ::set Count 0; ::foreach Item $List { ::puts "rwgb_debug,listbox line,[::incr Count],$Item"; } } method typed_string_reset {} { ::set _typed_string ""; $_typed_string_label configure -text $_typed_string; } method typed_string_process {} { $_typed_string_label configure -text $_typed_string; ::if {$_typed_string eq ""} { ::set Index -1; } else { ::set Index [type_string_search]; } ::if {$Index<0} { ::set Index 0; } # $_entryfield insert 0 [::lindex $Items $Index]; ::set OldIndex [$_listbox index active]; $_listbox selection clear $OldIndex; $_scrolledlistbox selection set $Index; $_listbox activate $Index; $_listbox see $Index; } method type_string_search {} { ::set Pos [type_string_binary_search]; ::set Value [::lindex $_sorted_list $Pos]; ::set Pos [::lsearch $_unsorted_list $Value]; ::if {$Pos<0} { ::set Pos 0; } ::return $Pos; } method type_string_binary_search {} { /* { Here is the algorithm. First note, we operate only in lower case so the list and the typed_string are always converted to lower case. (1) Create unsorted and sorted lists. (both in lower case). The basic idea is to make the typed_string mechanism work whether the list we are given is sorted or not. This allows it to work on all existing list boxes with no change at all. We keep two versions of the list: unsorted and sorted. We were given the unsorted list and the list is presented in the unsorted order. Note that the unsorted list may in fact be sorted but the whole idea here is to make the algorithm work whether or not the original list was sorted. So it probably just works a bit faster if already sorted. (2) Search the sorted list using binary search. We find the item to position on using a binary search on the sorted list. This gives us the position in the sorted list, and thus the value we want to land on. (3) Search unsorted list. We linearly search the unsorted list for the value found in the sorted list binary search produced in the previous step. This gives us the position in the unsorted list. (4) Position on the item detemined by the position found in step 3. The basic binary search was taken from the btree system but there is a difference. Instead of returning the insert position (i.e. position we want to insert in front of) we return the append position (i.e. the position we want to insert after). This is just to make the positioning behaviour what the user would expect. */ } ::set Key $_typed_string; ::set Size [::llength $_sorted_list]; ::if {$Size==0} { ::qw::throw "The list is empty."; } ::set Beg 0; ::set End [::expr {$Size-1}]; ::set Pos undefined; ::set Compare undefined; ::while {$Beg<=$End} { ::set Pos [::expr {($Beg+$End)/2}]; ::set Compare [::string compare -nocase $Key [::lindex $_sorted_list $Pos]]; ::if {$Compare>0} { ::set Beg [::expr {$Pos+1}]; ::continue; } ::if {$Compare<0} { ::set End [::expr {$Pos-1}]; ::continue; } ::return $Pos; } ::set CurrentValue [::lindex $_sorted_list $Pos]; ::if {$Compare>0} { /* { We try to keep the item active where the string is always greater than or equal to it. Otherwise we move on to the next item. This is different behaviour than when finding the insert position in the file system. */ } ::if {$Pos>=0&&[::expr {$Pos+1}]<$Size} { ::set NextValue [::lindex $_sorted_list [::expr $Pos+1]]; ::set NextValue [::string range $NextValue 0 [::expr {[::llength $Key]-1}]]; ::if {[::string compare -nocase $Key $NextValue]>=0} { ::incr Pos 1; } } } ::if {$Pos==[::llength $_sorted_list]} { ::incr Pos -1; } ::if {$Pos>=[::llength $_sorted_list]} { ::qw::bug 314120110919144447 "Invalid record index \"$Pos\"."; } ::return $Pos; } method cursor_up {} { typed_string_reset; ::set Index [$_listbox index active]; $_listbox selection clear $Index; tk::ListboxUpDown $_listbox -1 ::set Index [$_listbox index active]; $_listbox selection set $Index; $_listbox see $Index; } method cursor_down {} { typed_string_reset; ::set Index [$_listbox index active]; $_listbox selection clear $Index; tk::ListboxUpDown $_listbox 1 ::set Index [$_listbox index active]; $_listbox selection set $Index; $_listbox see $Index; } method cursor_left {} {::return;} method cursor_right {} {::return;} method page_up {} { typed_string_reset; ::set Index [$_listbox index active]; $_listbox selection clear $Index; $_listbox yview scroll -1 pages $_listbox activate @0,0 ::set Index [$_listbox index active]; $_listbox selection set $Index; $_listbox see $Index; } method page_down {} { # This does not work yet. At least not on small windows. /* { 2.21 Got page_down working but still primitive. Could implement a reasonable screen machine if we knew the number of visible rows. There are too many layers here to deal with. */ } typed_string_reset; ::set Index [$_listbox index active]; $_listbox selection clear $Index; $_listbox yview scroll 1 pages $_listbox activate @0,0 ::set Index [$_listbox index active]; # $_listbox activate $Index; $_listbox selection set $Index; $_listbox see $Index; } method end_page_up {} { typed_string_reset; ::set OldIndex [$_listbox index active]; $_listbox selection clear $OldIndex; # $_listbox yview scroll -1 pages # $_listbox activate @0,0 ::set Index 0; $_listbox activate $Index; $_listbox selection set $Index; $_listbox see $Index; } method end_page_down {} { # This does not work yet. At least not on small windows. # ::return; typed_string_reset; ::set OldIndex [$_listbox index active]; $_listbox selection clear $OldIndex; # $_listbox yview scroll 1 pages # $_listbox activate @0,0 ::set Index [::expr {[::llength $_unsorted_list]-1}]; # ::set Index [$_listbox index active]; $_listbox activate $Index $_listbox selection set $Index; $_listbox see $Index; } method doubleclick {Button} { typed_string_reset; ::if {$Button==1} { ::if {[option_get ".command.doubleclick"] ne ""} { ::uplevel #0 [option_get ".command.doubleclick"]; } } } } # ------------------------------------------------------------ # ::qw::dialog::error # ------------------------------------------------------------ #dialog ::proc ::qw::dialog::error {sargs} { /* { We are passed the error as a structure. Therefore there are no other arguments intended to control the error widget itself. This is historical. Errors were implemented ion the early stages and used a lot so are very hard to change. What we should have done was wrap the error structure in a separate argument field such as .error. */ } ::set rwb1_debug 0; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_dialog::error,1000.00,sargs==\n[::sargs::format $sargs]";} ::if {$::qw::control(dialog85_error)} { ::if {[::sargs::is_primitive $sargs]} { ::set sargs [::sargs::set .text $sargs]; } ::set Result [::qw::dialog85::error .structure $sargs]; ::return $Result; } ::qw::try { ::set Toplevel ""; ::if {[::sargs::is_primitive $sargs]} { ::set sargs [::sargs::set .text $sargs]; } ::set Args $::qw::widget::options_test; ::sargs::var::+= Args { .title "" .class "ErrorDialog" .sound "AppGPFault" .bbox "" .default "" /button { .text "Text not specified." .command {} /control { /clipboard { .text "Copy to Clipboard" } /cancel { .text "Dismiss" } /help { .text Help } } } .width 7.5i \ .height 2.5i \ } ::sargs::var::set Args .structure $sargs; ::sargs::var::+= Args [::sargs .title "Error occurred in \"[::string tolower [::file normalize [::info nameofexecutable]]]\"."]; ::set sargs $Args; # ::sargs::var::set sargs .title "Error occurred in \"[::string tolower [::file normalize [::info nameofexecutable]]]\"."; ::set Toplevel [::qw::dialog::create $sargs]; $Toplevel.info configure -background white; ::after idle [::list ::raise $Toplevel]; ::label $Toplevel.info.icon \ -image [::image create photo -file [::file join $::qw_library system images error.gif]] \ -background white \ -anchor ne \ ; ::pack $Toplevel.info.icon -side left -fill y -padx 8 -pady 8; ::set Tree [::eval ::QW::WIDGET::TREE::FRACTAL $Toplevel.info.tree $sargs]; ::set Width [::sargs::get_poly $sargs .width]; ::set Height [::sargs::get_poly $sargs .height]; $Tree configure -width $Width -height $Height; ::pack $Tree -expand 1 -fill both -pady 8; $Tree draw; # $Tree option_set /button/help.command [::list ::qw::dialog::error_render_help $Tree]; ::set Controls ${Toplevel}.controls; ::foreach Button {help clipboard cancel} { ::button $Controls.$Button \ -text [::sargs::get_poly $sargs /button/control/$Button.text] \ -padx [::sargs::get_poly $sargs /button/control/$Button.padx] \ -pady [::sargs::get_poly $sargs /button/control/$Button.pady] \ ; ::pack $Controls.$Button -side right -padx 4 -pady 4; } ::set HelpArgs ""; ::sargs::var::set HelpArgs .tree.handle $Tree .tree.structure [::sargs::get $sargs .structure]; ::set HelpCommand [::list ::qw::help::launch_from_error_dialog $HelpArgs] $Controls.cancel configure -command {::set ::qw::dialog::result ""} $Controls.help configure -command $HelpCommand; $Controls.clipboard configure -command "::clipboard clear;::clipboard append -displayof . -format STRING -type STRING -- {[::sargs::format .structure [::sargs::get $sargs .structure]]};" # $Controls.clipboard configure -command "::clipboard clear;::clipboard append -displayof . -format STRING -type STRING -- {Hello From the Clipboard};" ::raise $Toplevel; ::focus $Controls.cancel; ::wm protocol $Toplevel WM_DELETE_WINDOW "$Controls.cancel invoke"; ::bind $Toplevel [::list $Controls.cancel invoke]; ::bind $Toplevel [::list $Controls.help invoke]; ::bind $Controls.cancel [::list ::focus $Controls.clipboard]; ::bind $Controls.cancel [::list ::focus $Controls.clipboard]; ::bind $Controls.cancel [::list ::focus $Controls.help]; ::bind $Controls.cancel [::list ::focus $Controls.help]; ::bind $Controls.cancel [::list $Controls.cancel invoke]; ::bind $Controls.clipboard [::list ::focus $Controls.help]; ::bind $Controls.clipboard [::list ::focus $Controls.help]; ::bind $Controls.clipboard [::list ::focus $Controls.cancel]; ::bind $Controls.clipboard [::list ::focus $Controls.cancel]; ::bind $Controls.clipboard [::list $Controls.clipboard invoke]; ::bind $Controls.help [::list ::focus $Controls.cancel]; ::bind $Controls.help [::list ::focus $Controls.cancel]; ::bind $Controls.help [::list ::focus $Controls.clipboard]; ::bind $Controls.help [::list ::focus $Controls.clipboard]; ::bind $Controls.help [::list $Controls.help invoke]; $Tree draw; $Tree expand_all; ::qw::sound::play [::sargs::get $sargs .sound]; # 2.32.3 lines added to force error message to screen ::if {$rwb1_debug} {::puts "rwb1_debug,qw_dialog::error,1000.10";} ::qw::toplevel_add .toplevel $Toplevel; # added 2.32.3 ::if {$rwb1_debug} {::puts "rwb1_debug,qw_dialog::error,1000.11";} ::qw::dialog::wait .toplevel $Toplevel .variable ::qw::dialog::result; ::if {$rwb1_debug} {::puts "rwb1_debug,qw_dialog::error,1000.12";} ::qw::toplevel_remove .toplevel $Toplevel; # added 2.32.3 ::if {$rwb1_debug} {::puts "rwb1_debug,qw_dialog::error,1000.13";} ::destroy $Toplevel ::if {$rwb1_debug} {::puts "rwb1_debug,qw_dialog::error,1000.14";} ::return $::qw::dialog::result; } catch Exception { /* { Throwing here is a bad idea. The whole point is that we are displaying an error. It seems like a reasonable time to panic. */ } ::if {$Toplevel ne ""&&[::winfo exists $Toplevel]} { ::qw::try { ::destroy $Toplevel; } catch Dummy {} } ::puts "::qw::panic,1000.0,Error==$sargs"; ::puts "::qw::panic,1000.1,Exception==$Exception"; ::qw::panic "Error occurred in ::qw::dialog::error with arguments \"$sargs\"."; } } /* { ::proc ::qw::dialog::error_help {s_args} { puts "314120030511,error_render_help 1" ::set Formatter [::itcl::local ::qw::html::formatter #auto]; # ::set Path [::lindex [$Tree selecteds] 0]; # puts "314120030511,selected path:$Path" # ::if {$Path eq ""} {::return;} # ::set TreeStructure [$Tree option_get .structure] ::set TreeStructure [::sargs::get $s_args .tree.structure]; puts "314120030511,the error tree structure:$TreeStructure" ::set MainHelpStructure [::qw::help::all]; ::set TargetHelpStructure ""; ::set TreePaths [::qw::_structure::s_select_name [::sargs .structure $TreeStructure .name .text]]; ::puts "TreePaths:$TreePaths"; ::foreach TreePath $TreePaths { ::set Node [::sargs::get $TreeStructure $TreePath]; ::set HelpId [::sargs::get $Node .id]; ::set HelpPage [::qw::help::find_page_by_id $MainHelpStructure $HelpId]; # The chtml help system cannot handle quotes. ::set Text [::sargs::get $HelpPage .text]; ::set Title [::string map {"\"" ""} $Text]; ::sargs::var::set HelpPage .text $Title; /* { We generate the help page header here so that it will have the actual values displayed in the help window such as which database could not be opened or what value a field could not be set to. But we replace any quotes in the help message text so that the help page processor does not choke on them. */ } # We generate the replace quotes in the h # ::set Quote {"}; # ::set Text [::string map {"\"" $Quote} $Text]; ::set Text [::string map [::list "\"" "\\\""] $Text]; ::sargs::var::set HelpPage .body "\[h2 \"$Text\"\]\n[::sargs::get $HelpPage .body]"; ::sargs::var::set TargetHelpStructure $TreePath $HelpPage; } ::qw::help::launch $TargetHelpStructure; } */ } /* { ::proc ::qw::dialog::error_render_help {Tree} { puts "314120030511,error_render_help 1" ::set Formatter [::itcl::local ::qw::html::formatter #auto]; ::set Path [::lindex [$Tree selecteds] 0]; puts "314120030511,selected path:$Path" ::if {$Path eq ""} {::return;} ::set TreeStructure [$Tree option_get .structure] puts "314120030511,the error tree structure:$TreeStructure" ::set HelpId [::sargs::get $TreeStructure $Path.id]; puts "314120030511,error_render_help 2" ::if {$HelpId eq ""} { puts "314120030511,error_render_help 3" ::qw::warning 314120031118181331 "Could not find help for error:\"[::sargs::get $TreeStructure $Path.text]\""; ::return; } ::set MainHelpStructure [::qw::help::page_load [::sargs .path $::qw_library]]; puts "314120030511,error_render_help 4" ::set Paths [::qw::_structure::s_select_name_value [::sargs .structure $MainHelpStructure .name .id .value $HelpId]]; puts "314120030511,error_render_help 5" ::switch -- [::llength $Paths] { 0 { puts "314120030511,error_render_help 6" ::qw::warning 31412003111813719 "Could not find halp page for help id $HelpId."; ::return; } 1 { } default { puts "314120030511,error_render_help 7" ::qw::warning 3141200311182759 "Encountered duplicate help bage for help id $HelpId."; ::return; } } ::set HelpPagePath [::lindex $Paths 0]; puts "314120030511,error_render_help 8" ::set HelpPage [::sargs::get $MainHelpStructure $HelpPagePath]; puts "314120030511,error_render_help 9" ::set Args ""; puts "314120030511,error_render_help 10" ::sargs::var::set Args .script.path [::file join $::qw_library doc qw_chtml_compile.qw_script]; puts "314120030511,error_render_help 11" ::sargs::var::set Args .structure $HelpPage; puts "314120030511,error_render_help 12" ::qw::script::source $Args; puts "314120030511,error_render_help 13" } */ } /* { Removing the two-paned error dialog in favour of a simply tree and separate help. # ------------------------------------------------------------ # ::qw::dialog::error # ------------------------------------------------------------ #dialog ::proc ::qw::dialog::error {args} { ::qw::try { ::set Args [::sargs::get $::qw::options .window]; ::sargs::var::+= Args [::sargs::get $::qw::options .window.dialog.error]; # ::sargs::var::+= Args $args; ::if {[::sargs::is_primitive $args]} {::set args [::list .text $args];} ::sargs::var::set Args .structure $args; ::if {[::sargs::get $Args .title] eq ""} { ::if {[::info script] ne ""} { ::sargs::var::set Args .title "Error occurred in \"[::string tolower [::info script]]\"."; } else { ::sargs::var::set Args .title "Error occurred in \"[::string tolower [::info nameofexecutable]]\"."; } } ::set Toplevel [::eval ::qw::dialog::create $Args]; ::after idle [::list ::raise $Toplevel]; ::set Info ${Toplevel}.info; ::set Width 6; ::set Height $Width; ::set Paned [::iwidgets::panedwindow $Info.paned -width ${Width}i -height ${Height}i]; ::pack $Paned -padx 0 -pady 0 -expand yes -fill both; ::pack $Paned -expand yes -fill both; $Paned add "top"; ::set PaneLeft [$Paned childsite "top"]; ::set Tree [::eval ::QW::WIDGET::TREE::FRACTAL $PaneLeft.l $Args]; ::pack $Tree -expand 1 -fill both; # $Tree option_set .font [::sargs::get_poly .font]; # $_tree option_set .command [::list .select [::itcl::code $this node_selected]]; $Tree draw; $Paned add "bottom"; ::set PaneRight [$Paned childsite "bottom"]; ::switch -- scrolledhtml { tkhtml { ::set Html [::QW::WIDGET::HTML $PaneRight.l] } scrolledtext { # ::set _html [::iwidgets::scrolledtext $_pane_right.l -hscrollmode [option_get /scroll/horizontal.mode] -vscrollmode [option_get /scroll/vertical.mode]]; ::set Html [::iwidgets::scrolledtext $PaneRight.l -hscrollmode [option_get /scroll/horizontal.mode] -vscrollmode dynamic]; } scrolledhtml { ::set Html [::iwidgets::scrolledhtml $PaneRight.l -hscrollmode [::sargs::get_poly $Args /scroll/horizontal.mode] -vscrollmode [::sargs::get_poly $Args /scroll/vertical.mode]]; $Html configure -fontname helvetica $Html configure -fontsize large } } ::pack $Html -expand 1 -fill both; # render [::sargs::get $_help ".body"]; # ::set OptionMenu [::iwidgets::optionmenu $_me.orient]; # $OptionMenu configure -labeltext "Orientation:" -command [::list $_paned configure -orient [$OptionMenu get]]; # ::pack $OptionMenu -padx 4 -pady 4 # $OptionMenu insert end horizontal vertical $Paned configure -orient horizontal; # ::set Left [::expr int((1.0/2.618)*100.0)]; ::set Left 50; ::set Right [::expr {100-$Left}]; $Paned fraction $Left $Right; puts "Paned window complete"; # ::wm geometry $Toplevel [::sargs::get_poly $Args .width]x[::sargs::get_poly $Args .height]; # ::pack $Info.tree -expand 1 -fill both ::set Controls ${Toplevel}.controls; ::foreach {Column Button} {0 ok 1 help} { ::button $Controls.${Button} \ -text [::sargs::get_poly $Args /button/${Button}.text] \ -command [::sargs::get_poly $Args /button/${Button}.command] \ -font [::sargs::get_poly $Args /button/${Button}.font] \ -borderwidth [::sargs::get_poly $Args /button.border.width] \ ; ::grid $Controls.${Button} -row 0 -column $Column -sticky nesw \ -padx [::sargs::get_poly $Args /button/${Button}.pad.external.x] \ -pady [::sargs::get_poly $Args /button/${Button}.pad.external.y] \ ; ::grid columnconfigure $Controls $Column -weight 1; } ::set Option ""; ::sargs::var::set Option .select [::list ::qw::dialog::error_render_help $Tree $Html]; $Tree option_set .command $Option; # $Tree option_set .command ".select [::list ::qw::dialog::error_render_help $Tree $PaneRight]"; ::raise $Toplevel; ::focus $Controls.ok; ::wm protocol $Toplevel WM_DELETE_WINDOW "$Controls.ok invoke"; ::bind $Toplevel "$Controls.ok invoke"; ::bind $Toplevel "$Controls.ok invoke"; ::bind $Toplevel "$Controls.ok invoke"; $Tree draw; $Tree expand_all; ::qw::sound::play [::sargs::get $Args .sound]; ::qw::dialog::wait $Toplevel ::qw::dialog::result; ::destroy $Toplevel ::return $::qw::dialog::result; } catch Exception { /* { Throwing here is a bad idea. The whole point is that we are displaying an error. It seems like a reasonable time to panic. */ } ::qw::panic "Error occurred in ::qw::dialog::error with arguments \"$args\". $Exception"; } } ::proc ::qw::dialog::error_render_help {Tree Html} { ::set Formatter [::itcl::local ::qw::html::formatter #auto]; ::set Path [::lindex [$Tree selecteds] 0]; ::if {$Path eq ""} {::return;} ::set Field [$Tree option_get .structure] puts "314120030511,the structure:$Field" # ::set Script [::sargs::get $Field "$Path.help"]; /* { We load a recursive help structure rooted at the page specified in the .help.path field. If there is no help path then we load all of the help by assuming the path to the root directory is $::qw_library. So specifying a help path is mainly for efficiency in finding the help page. After loading the structure from the root page we then search the structure for the specific help page as identified by the .help.id field. The help id is the name of the sought field in the structure. */ } ::set Help [::sargs::get $Field "$Path.help"]; ::set HelpId [::sargs::get $Help .id]; ::if {$HelpId eq ""} {::return;} ::set HelpPath [::sargs::get $Help .path]; ::set HelpRoot $::qw_library; ::if {$HelpPath ne ""} {::set HelpRoot [::file join $HelpRoot $HelpPath];} # ::if {$HelpRootPath eq ""} {::return;} puts "314120030511,help id:$HelpId" ::set Structure [::qw::help::page_load [::sargs .path $HelpRoot .extension .qw_help]]; puts "314120030515 error help loaded:" puts "[::sargs::format .structure $Structure]" ::set Paths [::sargs::select_value .structure $Structure .value $HelpId]; ::if {[::llength $Paths] != 1} { ::puts "Could not load help with .id \"$HelpId\""; ::qw::bug 314120030918120212; } ::set HelpPath [::lindex $Paths 0]$HelpId; ::set Page ""; ::if {$HelpPath ne ""} { # ::set Page [::qw::help::page_load .path $HelpPath]; ::set Page [::sargs::get $Structure $HelpPath]; } else { # ::set Page [::subst $HelScript]; } ::if {$Page eq ""} {::return;} # puts "314120030511,the help page:$Page" ::set Body [::sargs::get $Page .body]; /* { Using the error message. We retrieve the error message from the selected node in the error tree window and we use it for two purposes. We make the error message the title of the html help window. We also repeat the error message at the top of the html help window body. So the user sees the error message again in the help. We can format this error message any way we want. For example we might bold it and display it in typewriter font. */ } ::set Title [::sargs::get $Field "$Path.text"]; ::set Body "\[bold \[typewriter \{$Title\}\]\]\n$Body" ::set Body [$Formatter render $Body]; # puts "314120030511,the body:$Body" ::switch -- scrolledhtml { tkhtml { [$Html component tkhtml] clear; [$Html component tkhtml] parse $Body; } scrolledtext { $Html delete 1.0 end; $Html insert end "$Body\n"; } scrolledhtml { $Html clear; $Html render $Body; } } } */ } /* { # ------------------------------------------------------------ # ::QW::WIDGET::ERROR class # ------------------------------------------------------------ itcl::class ::QW::WIDGET::ERROR { inherit itk::Toplevel; protected variable _me; protected variable _paned ""; protected variable _pane_left ""; protected variable _pane_right ""; protected variable _tree ""; protected variable _html ""; protected variable _options ""; protected variable _help ""; protected variable _formatter ""; method constructor {args} { ::set WindowType scrolledhtml; # ::set WindowType tkhtml; # ::set WindowType scrolledtext; ::set Defaults [::sargs::+= $::qw::widget::options_test [::subst { .title "NewViews Help" .class "HelpToplevel" .sound "" .bbox "" .file "" .default "" .files 1 .orient vertical /button { .text "Text not specified." .command {} /select { .text Select } /cancel { .text Cancel .command {::set ::qw::dialog::result ""} } /help { .text Help } } .window $WindowType }]]; ::set _options $Defaults; ::sargs::var::+= _options $args; ::set _help [option_get .page]; # ::if {[option_get ".file"] ne ""} { # ::set _help [::structure_load [option_get ".file"]]; # } ::set _formatter [::qw::html::formatter #auto]; /* { We render the titles now because the tree widget knows nothing about subst. */ } ::foreach Path [::sargs::select_field .structure $_help .field .text] { ::sargs::var::set _help $Path [$_formatter render [::sargs::get $_help $Path]]; } ::set _options [::sargs::set $_options .structure $_help]; ::set _options [::sargs::set $_options .command.select [::itcl::code $this node_selected]]; ::set _me $itk_component(hull); # ::wm geometry $Toplevel 300x[::expr {int(300.0*1.618)}]; ::set Width 6; ::set Height $Width; # ::set Height [::expr {int($Width*1.618)}]; ::set _paned [::iwidgets::panedwindow $_me.pw -width ${Width}i -height ${Height}i]; # ::pack $_paned -padx 4 -pady 4 -expand yes -fill both; ::pack $_paned -padx 0 -pady 0 -expand yes -fill both; $_paned add "top" ::set _pane_left [$_paned childsite "top"]; # ::set _help [::structure_load c:/qw/lib/help_newviews.structure]; # ::set _tree [::QW::WIDGET::TREE::HELP $_pane_left.l]; ::set _tree [::eval ::QW::WIDGET::TREE::FRACTAL $_pane_left.l $_options]; # $_tree toplevel $this; # $_tree configure -structure $_help; ::pack $_tree -expand 1 -fill both; ::if {[option_get .default] eq ""} { # [$_tree node ""] expand } else { # $_tree select_path [::sargs::get $Args .default]; # $_tree select_path ""; } $_tree option_set .font [option_get .font]; # $_tree option_set .command [::list .select [::itcl::code $this node_selected]]; $_tree draw; $_paned add "bottom"; ::set _pane_right [$_paned childsite "bottom"]; ::switch -- [option_get ".window"] { tkhtml { ::set _html [::QW::WIDGET::HTML $_pane_right.l] } scrolledtext { # ::set _html [::iwidgets::scrolledtext $_pane_right.l -hscrollmode [option_get /scroll/horizontal.mode] -vscrollmode [option_get /scroll/vertical.mode]]; ::set _html [::iwidgets::scrolledtext $_pane_right.l -hscrollmode [option_get /scroll/horizontal.mode] -vscrollmode dynamic]; } scrolledhtml { ::set _html [::iwidgets::scrolledhtml $_pane_right.l -hscrollmode [option_get /scroll/horizontal.mode] -vscrollmode [option_get /scroll/vertical.mode]]; $_html configure -fontname helvetica $_html configure -fontsize large } } ::pack $_html -expand 1 -fill both; render [::sargs::get $_help ".body"]; # ::set OptionMenu [::iwidgets::optionmenu $_me.orient]; # $OptionMenu configure -labeltext "Orientation:" -command [::list $_paned configure -orient [$OptionMenu get]]; # ::pack $OptionMenu -padx 4 -pady 4 # $OptionMenu insert end horizontal vertical configure -title [option_get ".title"] $_paned configure -orient [option_get ".orient"]; ::set Left [::expr int((1.0/2.618)*100.0)]; ::set Right [::expr {100-$Left}]; $_paned fraction $Left $Right; puts "Paned window complete"; } destructor { ::qw::try { ::destroy $_html;::set _html ""; ::destroy $_pane_right;::set _pane_right ""; ::destroy $_tree;::set _tree ""; ::destroy $_pane_left;::set _pane_left ""; ::itcl::delete object $_formatter; ::set _formatter ""; } catch Exception { ::qw::warning 314120040817103132 "Help window destructor caught exception:$Exception"; } } method option_get {Path} {::return [::sargs::get_poly $_options $Path];} method option_set {args} { ::qw::s_args_marshal; ::sargs::var::+= _options $s_args; } method render {Body} { ::set Body [$_formatter render .body $Body]; ::switch -- [option_get ".window"] { tkhtml { [$_html component tkhtml] clear; [$_html component tkhtml] parse $Body; } scrolledtext { $_html delete 1.0 end; $_html insert end "$Body\n"; } scrolledhtml { $_html clear; $_html render $Body; } } ::return $Body; } /* { method html_recreate {} { ::if {$_html ne ""} { ::destroy $_html; ::set _html [::QW::WIDGET::HTML $_pane_right.l] ::pack $_html -expand 1 -fill both; } } */ } /* { method html_set {Path} { # html_recreate puts "html display a" ::set Script [::sargs::set $_help $Path.body]; puts "html display b" ::set Body [render $Script]; puts "Going to display html:" puts $Body; puts "html display 1" [$_html component tkhtml] clear; # ::set Html [::itcl::scope [$_html component tkhtml]]; # ::set Html [$_html component tkhtml]; puts "html display 2" [$_html component tkhtml] parse $Body; # ::after idle "[::itcl::scope $Html clear];[::itcl::scope $Html parse $Body];" # ::after idle "$Html clear;$Html parse {$Body};" puts "html display 3" } */ } /* { method html_set {Path} { # html_recreate puts "html display a" ::set Body [::sargs::set $_help $Path.body]; $_html delete 1.0 end; $_html insert end "$Body\n"; # ::set Html [::itcl::scope [$_html component tkhtml]]; # ::set Html [$_html component tkhtml]; puts "html display 3" } */ } method node_selected {} { puts "node_selected 1" puts "tree selecteds:\"[$_tree selecteds]\"" ::set Path [::lindex [$_tree selecteds] 0]; ::set Body [::sargs::set $_help $Path.body]; render $Body; puts "node_selected 3" } } */ } # ------------------------------------------------------------ # ::qw::dialog::file # ------------------------------------------------------------ /* { Collects a file/folder path. Returns "" if nothing was selected. .dafault Positions on this path. .files If 1 then displays files, otherwise just directories. .patterns Only file/folders matching patterns are displayed. */ } #dialog ::set ::qw::dialog::file_default [::pwd]; #::set ::qw::dialog::file_default ""; ::set ::qw::dialog::file_dialog_result ""; ::proc ::qw::dialog::file {args} { ::qw::s_args_marshal; ::qw::try { ::set Toplevel ""; ::set Args [::sargs::get $::qw::options .window]; ::sargs::var::+= Args { .title "" .class "FileDialog" .sound "" .bbox "" .default {} .files 1 .patterns "" .help { .help_id default_file_dialog_help } /button { .text "Text not specified." .command {} /ok { .text Select } /cancel { .text Cancel } /list { .text List } /help { .text Help } } } ::set s_args [::sargs::+= $Args $s_args]; ::sargs::var::set HelpTree .title [::sargs::get $s_args .title] .help_id [::sargs::get $s_args .help.help_id]; ::if {[::sargs::get $s_args .help] ne ""} { ::if {[::sargs::get $s_args .help.title] eq ""} { ::sargs::var::set s_args .help.title [::sargs::get $s_args .title]; } # ::sargs::var::set HelpTree "/0" [::sargs::get $s_args .help]; } ::foreach Path [::sargs::select_field .structure $HelpTree .field .help_id] { ::sargs::var::set HelpTree ${Path}.button_ok [::sargs::get $s_args /button/ok.text]; ::sargs::var::set HelpTree ${Path}.button_cancel [::sargs::get $s_args /button/cancel.text]; } ::if {[::sargs::get $s_args .title] eq ""} { ::switch -- [::sargs::get $s_args .files] { 0 {::sargs::var::set s_args .title "Select Folder";} 1 {::sargs::var::set s_args .title "Select File";} } } ::set HelpCommand [::list ::qw::help::launch_from_dialog1 [::sargs .structure $HelpTree]]; ::set DefaultPath [::sargs::get $s_args .default]; ::if {$DefaultPath eq ""} { ::set DefaultPath $::qw::dialog::file_default; } ::if {[::file pathtype $DefaultPath] eq "relative"} { ::set DefaultPath [::file join [::file dirname $::qw_library] $DefaultPath]; } ::if {[::string index $DefaultPath 0] eq "/"} { ::set DefaultPath "[::string range [::pwd] 0 1]$DefaultPath"; } ::while {$DefaultPath ne ""&&![::file exists $DefaultPath]} { /* { We go up the directory system until we find the default. */ } ::if {$DefaultPath eq [::qw::file dirname $DefaultPath]} { /* { 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 DefaultPath [::qw::file dirname $DefaultPath]; } ::if {$DefaultPath eq ""} { /* { If we never find the default then set it to the working directory, what that may be. */ } ::set DefaultPath $::qw::dialog::file_default; } ::if {![::file exists $DefaultPath]} { ::set DefaultPath $::qw::dialog::file_default; } ::if {![::file isdirectory $DefaultPath]} { /* { 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 $s_args .patterns]; ::set MatchFound 0; ::if {$Masks ne ""} { ::foreach Mask $Masks { ::if {[::string match $Mask [::file tail $DefaultPath]]} { ::set MatchFound 1; ::break; } } ::if {!$MatchFound} { ::set DefaultPath [::file dirname $DefaultPath]; } } } ::sargs::var::set s_args .default $DefaultPath; # 2.14.4 added the $ to s_args ::set BBox [::sargs::get $s_args .bbox]; ::set OptionsFile [::sargs::get $s_args .options_file]; ::set DialogGeometry [::sargs::file::get $OptionsFile .file_dialog_geometry]; ::if {$DialogGeometry eq ""} { # 1.618 is the so-called golden number. ::set ScreenWidth [::expr {double([::winfo screenwidth .])}]; ::set Width [::expr {$ScreenWidth/4.0}]; ::set Length [::expr {$Width*1.618}]; ::set Width [::expr {int($Width)}]; ::set Length [::expr {int($Length)}]; ::set DialogGeometry ${Width}x${Length}; } ::sargs::var::set s_args .geometry $DialogGeometry; ::set Toplevel [::qw::dialog::create $s_args]; ::after idle [::subst -nocommands {::if {[::winfo exists $Toplevel]} {::raise $Toplevel;}}]; ::set Info ${Toplevel}.info; ::wm geometry $Toplevel $DialogGeometry; # $Toplevel.info configure -height 400 -width 250; ::set Tree [::eval ::QW::WIDGET::TREE::DOS $Info.tree $s_args]; ::pack $Info.tree -expand 1 -fill both ::set Controls ${Toplevel}.controls; # $Tree configure -font [::sargs::get $s_args .font] -height 400 -width 250 -doubleclickcommand "$Controls.select invoke" -files [::sargs::get $s_args .files]; # [$Tree canvas] configure -height 400 -width 250; $Tree option_set .files [::sargs::get $s_args .files]; $Tree option_set .command [::list .doubleclick "$Controls.ok invoke"]; $Tree option_set .font [::sargs::get $s_args .font]; $Tree draw; ::foreach Button {help cancel list ok} { ::button $Controls.$Button \ -text [::sargs::get_poly $s_args /button/$Button.text] \ -padx [::sargs::get_poly $s_args /button/$Button.padx] \ -pady [::sargs::get_poly $s_args /button/$Button.pady] \ ; ::pack $Controls.$Button -side right -padx 4 -pady 4; } /* { ::foreach {Column Button} {0 ok 1 list 2 cancel 3 help} { ::button $Controls.${Button} \ -text [::sargs::get_poly $s_args /button/${Button}.text] \ -command [::sargs::get_poly $s_args /button/${Button}.command] \ -font [::sargs::get_poly $s_args /button/${Button}.font] \ -borderwidth [::sargs::get_poly $s_args /button.border.width] \ ; ::grid $Controls.${Button} -row 0 -column $Column -sticky nesw \ -padx [::sargs::get_poly $s_args /button.pad.external.x] \ -pady [::sargs::get_poly $s_args /button.pad.external.y] \ ; ::grid columnconfigure $Controls $Column -weight 1; } */ } ::set FileList [::sargs::get $s_args .file_list]; ::if {$FileList eq ""} { ::grid forget $Controls.list; ::grid columnconfigure $Controls 1 -weight 0; } 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::f ile_dialog_result \$::qw::dialog::list_dialog_result; } else { ::if {[::winfo exists $Toplevel]} { ::raise {$Toplevel}; } } }]; } ::sargs::var::set s_args .help.button_ok [::sargs::get $s_args /button/ok.text]; ::sargs::var::set s_args .help.button_cancel [::sargs::get $s_args /button/cancel.text]; # ::set HelpCommand [::list ::qw::help::launch_from_dialog [::sargs::get $s_args .help]]; $Controls.ok configure -command [::subst -nocommands {::set ::qw::dialog::file_dialog_result [::lindex [$Tree selecteds] 0]}]; $Controls.cancel configure -command {::set ::qw::dialog::file_dialog_result ""} $Controls.help configure -command $HelpCommand; ::wm protocol $Toplevel WM_DELETE_WINDOW [::subst -nocommands {::if {[::winfo exists $Controls.cancel]} {$Controls.cancel invoke}}]; ::bind $Toplevel "$Controls.ok invoke"; ::bind $Toplevel "$Controls.cancel invoke"; ::bind $Controls.ok "$Controls.ok invoke"; ::bind $Controls.cancel "$Controls.cancel invoke"; ::bind $Controls.help $HelpCommand; ::bind $Toplevel $HelpCommand; ::bind $Controls.ok [::list ::focus $Controls.list]; ::bind $Controls.ok [::list ::focus $Controls.list]; ::bind $Controls.ok [::list ::focus $Controls.help]; ::bind $Controls.ok [::list ::focus $Controls.help]; ::bind $Controls.ok [::list $Controls.ok invoke]; ::bind $Controls.list [::list ::focus $Controls.cancel]; ::bind $Controls.list [::list ::focus $Controls.cancel]; ::bind $Controls.list [::list ::focus $Controls.ok]; ::bind $Controls.list [::list ::focus $Controls.ok]; ::bind $Controls.list [::list $Controls.list invoke]; ::bind $Controls.cancel [::list ::focus $Controls.help]; ::bind $Controls.cancel [::list ::focus $Controls.help]; ::bind $Controls.cancel [::list ::focus $Controls.list]; ::bind $Controls.cancel [::list ::focus $Controls.list]; ::bind $Controls.cancel [::list $Controls.cancel invoke]; ::bind $Controls.help [::list ::focus $Controls.ok]; ::bind $Controls.help [::list ::focus $Controls.ok]; ::bind $Controls.help [::list ::focus $Controls.cancel]; ::bind $Controls.help [::list ::focus $Controls.cancel]; ::bind $Controls.help [::list $Controls.help invoke]; ::if {[::sargs::get $s_args .default] eq ""} { [$Tree node ""] expand } else { $Tree select_path [::sargs::get $s_args .default]; ::if {[::sargs::boolean_get $s_args .default_expand]} { ::set Selecteds [$Tree selecteds]; ::if {[::llength $Selecteds]} { [$Tree node [::lindex $Selecteds 0]] expand; } } } ::raise $Toplevel; ::focus $Controls.ok; # ::set BBox [::sargs::get $s_args .bbox]; # ::qw::dialog::position -path $Toplevel -bbox $BBox; ::qw::sound::play [::sargs::get $s_args .sound]; ::qw::dialog::wait .toplevel $Toplevel .variable ::qw::dialog::file_dialog_result; ::if {[::sargs::get $s_args .options_file] ne ""} { ::set DialogFileGeometry [::wm geometry $Toplevel]; ::sargs::file::+= [::sargs::get $s_args .options_file] [::sargs .file_dialog_geometry $DialogFileGeometry]; } ::destroy $Toplevel ::if {$::qw::dialog::file_dialog_result ne ""} { ::set ::qw::dialog::file_default $::qw::dialog::file_dialog_result; } ::return $::qw::dialog::file_dialog_result; } catch Exception { ::if {$Toplevel ne ""&&[::winfo exists $Toplevel]} { ::qw::try { ::destroy $Toplevel; } catch Dummy {} } ::qw::throw [::qw::exception::parent $Exception "Could not create a file dialog with arguments \"$s_args\"."]; } } # ------------------------------------------------------------ # ::qw::dialog::date # ------------------------------------------------------------ ::itcl::class ::qw::dialog::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 */ } protected variable _sargs ""; protected variable _options_file ""; protected variable _options ""; protected variable _toplevel ""; protected variable _toolbar_button_font {-family Arial -size 8 -weight normal}; 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]; protected variable _resize_is_enabled 1; method constructor {sargs} { ::set _sargs { .title "Pick Date" .class "DateDialog" .sound "" .bbox "" .ok_button { .text "Pick" } .cancel_button { .text "Dismiss" } .help_button { .text "Help" } .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 {} } ::set _sargs [::sargs::+= $_sargs $sargs]; # ::array set _table {}; ::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]; } options_load $sargs; toplevel_create $sargs; /* { We withdraw the toplevel and deiconify it later to reduce noise. The call the deiconify also causes the dialog to be activated and turn the title "blue". */ } ::wm withdraw $_toplevel; menu_create $sargs; toolbar_create $sargs; client_create $sargs; buttons_create $sargs; /* { Regardless of the fact we already did this, we have to do it again to get the dialog activated. There are ways we could have done it before that wouldhave worked to sctivate the dialog, but the same sequnce interfered with the requested sizes used in the min/maxsize. */ } # ::wm withdraw $_toplevel; # ::wm deiconify $_toplevel; ::qw::dialog::balloon_help .command enable .widget $_toplevel .text_callback [::itcl::code $this balloon_help_get]; ::qw::dialog::wait .toplevel $_toplevel .variable ::qw::dialog::date_dialog::_dialog_result; ::if {[::qw::command_exists $this]} { ::itcl::delete object $this; } } method destructor {} { # options_cancel; ::qw::try { options_store; } catch Dummy {} ::if {[::winfo exists $_toplevel]} { ::destroy $_toplevel; # ::set _toplevel ""; } ::if {$_toplevel ne ""} { ::qw::toplevel_remove .toplevel $_toplevel; } ::set Namespace [::sargs::get $_sargs .script.namespace]; # ::after idle [::list ::namespace delete $Namespace]; ::after idle [::subst -nocommands { ::namespace delete $Namespace; }]; # ::set ${::qw::script::namespace}::dialog_result ""; } method options_load {sargs} { ::return; ::set _options_file [::qw::script::options_file $sargs]; ::set _options [::sargs::file::get $_options_file]; } method options_store {} { ::return; ::sargs::file::set $_options_file $_options; } method toplevel_create {sargs} { ::set Unique 0; ::while {[::winfo exists .date_dialog_$Unique]} { ::incr Unique; } ::set _toplevel [::toplevel .date_dialog_$Unique]; ::set Title [::sargs::get $sargs .title]; ::if {$Title eq ""} { ::set Title "Pick Date"; } ::wm title $_toplevel $Title; ::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_pick]; ::bind $_toplevel [::itcl::code $this command_process .command command_help]; ::bind $_toplevel [::list $this command_process command_application_exit]; ::bind $_toplevel [::list $this command_process command_application_exit]; # ::bind $_toplevel [::itcl::code $this command_process .command command_pick]; #::after idle [::subst -nocommands {::update idletasks;::qw::dialog::position -path {$_toplevel} -bbox {$BBox} -geometry {$Geometry};}]; # ::bind $_toplevel [::itcl::code $this export_file_select]; # ::bind $_toplevel [::list $this configure_event $_toplevel]; ::after idle [::subst -nocommands { /* { A lot of tricks are used here. There was always some noise until we position in an area that will not show up on the screen and thus at least the noise is not visible. */ } #wb_debug ::wm geometry $_toplevel +-1000+-1000; ::update idletasks; ::switch -- $_resize_is_enabled { 0 { ::wm resizable $_toplevel 0 0; /* { Don;t need this because of wm resizable call above ::if {[::winfo exists $_toplevel]} { ::wm minsize $_toplevel [::winfo reqwidth $_toplevel] [::winfo reqheight $_toplevel]; ::wm maxsize $_toplevel [::winfo reqwidth $_toplevel] [::winfo reqheight $_toplevel]; } */ } } 1 { ::if {[::winfo exists $_toplevel]} { ::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 menu_create {sargs} { ::return; ::menu $_toplevel.menubar -tearoff 0 $_toplevel configure -menu $_toplevel.menubar ::menu $_toplevel.menubar.file -tearoff 0 $_toplevel.menubar add cascade -label "File" -menu $_toplevel.menubar.file -underline 0 $_toplevel.menubar.file add command -label "Export" -command [::itcl::code $this command_process .command command_export]; $_toplevel.menubar.file add command -label "Exit" -command [::itcl::code $this command_process .command command_exit]; ::menu $_toplevel.menubar.help -tearoff 0 $_toplevel.menubar add cascade -label "Help" -menu $_toplevel.menubar.help -underline 0 $_toplevel.menubar.help add command -label "Export" -command [::itcl::code $this command_process .command command_help]; ::tooltip::tooltip $_toplevel.menubar.file -index 0 [balloon_help_get .path $_toplevel.menubar.file.export]; ::tooltip::tooltip $_toplevel.menubar.file -index 1 [balloon_help_get .path $_toplevel.menubar.file.exit]; ::tooltip::tooltip $_toplevel.menubar.help -index 0 [balloon_help_get .path $_toplevel.menubar.help.export]; } method toolbar_create {sargs} { ::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 -side top -fill x; } method client_create {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_pick] \ ; ::canvas $_toplevel.client.canvas \ -width [::sargs::get $_sargs .calendar.width] \ -height [::sargs::get $_sargs .calendar.height] \ ; ::bind $_toplevel.client.canvas [::itcl::code $this canvas_draw]; ::bind $this [::itcl::code $this command_process .command command_pick]; /* { 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_application_exit command_application_exit } { #::bind $this $Sequence [::itcl::code $this command_process .command $Command .mask [::QW::GUI::EVENT::KEYBOARD::mask]]; #2.28.3 - this was in qw_gui.tcl #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_pick]; } method buttons_create {sargs} { ::frame $_toplevel.buttons; ::foreach {Button Command} { .help_button command_help .cancel_button command_exit .ok_button command_pick } { ::button $_toplevel.buttons$Button \ -text [::sargs::get $_sargs $Button.text] \ -padx 1m \ -pady .25m \ -command [::itcl::code $this command_process .command $Command] \ ; ::pack $_toplevel.buttons$Button -side right -padx 2 -pady 2; } ::pack $_toplevel.buttons -fill x -side bottom; /* { 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 \ ]; */ } ::after idle [::subst -nocommands { ::if {[::winfo exists $_toplevel.buttons.ok]} { ::focus $_toplevel.buttons.ok; } }] } method balloon_help_get {sargs} { ::set Path [::sargs::get $sargs .path]; ::set Text ""; ::switch -glob -- $Path { *.toolbar_frame.year_prev { ::append Text "Move back one year."; ::append Text "(Ctrl-PgUp)"; } *.toolbar_frame.year_next { ::append Text "Move ahead one year."; ::append Text "(Ctrl-PgDn)"; } *.toolbar_frame.month_prev { ::append Text "Move back one month."; ::append Text "(PgUp)"; } *.toolbar_frame.month_next { ::append Text "Move ahead one month."; ::append Text "(PgDn)"; } *.buttons.ok_button { ::append Text "Pick the date."; ::append Text "(Enter)"; } *.buttons.cancel_button - *.menubar.file.exit { ::append Text "Dismiss without picking a date."; ::append Text "(Esc)"; } *.buttons.help_button - *.menubar.help.export { ::append Text "Help on date dialog."; ::append Text "(F1)"; } } ::return $Text; } method font_scale {sargs} { ::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} { ::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 {} { $_toplevel.client.canvas delete all; ::set CanvasWidth [::winfo width $_toplevel.client.canvas]; ::set CanvasHeight [::winfo height $_toplevel.client.canvas]; ::if {$_active_date eq ""||$_active_date=="0"} { ::set _active_date [::qw::date::from_number clock_second [::clock seconds]]; } $_toplevel.client.title configure \ -text [::qw::date::format $_active_date [::sargs::get $_sargs .calendar.title.format]] \ -font [font_scale .font [::sargs::get $_sargs .calendar.title.font]] \ -borderwidth 0 \ -cursor arrow \ ; ::set DaysInMonth [::qw::date::get $_active_date days_in_month]; ::set FirstDayOfMonth [::qw::date::set $_active_date day 1]; ::set FirstDayOfWeek [::qw::date::get $FirstDayOfMonth day_of_week]; ::set FirstDayNumber [::qw::date::to_number day $FirstDayOfMonth]; ::set LastDayNumber [::expr {$FirstDayNumber+$DaysInMonth-1}]; ::for {::set i 0;::set DayNumber [::expr {$FirstDayNumber-$FirstDayOfWeek}];} {$i<42} {::incr i;::incr DayNumber} { ::set Row [::expr {$i/7}]; ::set Col [::expr {$i%7}]; ::set x0 [::expr {$Col*($CanvasWidth-7)/7+3}]; ::set y0 [::expr {$Row*($CanvasHeight-6)/6+3}]; ::set x1 [::expr {($Col+1)*($CanvasWidth-7)/7+3}]; ::set y1 [::expr {($Row+1)*($CanvasHeight-6)/6+3}]; ::if {$DayNumber<$_minimum_day_number||$DayNumber>$_maximum_day_number} { ::set Type .not_valid; ::continue } ::set Date [::qw::date::from_number day $DayNumber]; ::if {$Date eq $_active_date||![::qw::date::difference $Date $_active_date day]} { ::set Type .active; # ::focus $_toplevel.client.table.$i; # focus; } else { ::if {$DayNumber>=$FirstDayNumber&&$DayNumber<=$LastDayNumber} { ::if {$i%7==0||$i%7==6} { ::set Type .weekend; } else { ::set Type .weekday; } } else { ::set Type .not_in_month; } } $_toplevel.client.canvas create rectangle \ $x0 $y0 $x1 $y1 \ -outline [::sargs::get $_sargs $Type.foreground] \ -fill [::sargs::get $_sargs $Type.background] \ -tags [::list date_button-$Date date_buttons_all] \ ; $_toplevel.client.canvas create text \ [::expr {$x0+4}] [::expr {$y0+2}] \ -anchor nw \ -fill [::sargs::get $_sargs $Type.foreground] \ -font [::sargs::get $_sargs .calendar.date.font] \ -text [::qw::date::format $Date [::sargs::get $_sargs .calendar.date.format]] \ -tags [::list date_button-$Date date_buttons_all] \ ; $_toplevel.client.canvas bind date_button-$Date \ [::itcl::code $this active_date_set .date $Date] \ ; } } method active_date_get {} { ::if {$_active_date eq ""} { ::return ""; } ::return $_active_date$_active_time; } method active_date_set {sargs} { ::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} { /* { 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 $_sargs .ok_button.text]; ::sargs::var::set HelpPage .cancel_button.text [::sargs::get $_sargs .cancel_button.text]; ::sargs::var::set HelpPage .help_button.text [::sargs::get $_sargs .help_button.text]; } method command_process {sargs} { ::set Command [::sargs::get $sargs .command]; ::switch -- $Command { command_exit { ::set ::qw::dialog::date_dialog::_dialog_result ""; # ::itcl::delete object $this; } command_application_exit { ::set ::qw::dialog::date_dialog::_dialog_result ""; # ::itcl::delete object $this; ::qw::shutdown; } command_pick { #::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. */ } ::set ::qw::dialog::date_dialog::_dialog_result [active_date_get]; } command_draw { draw; } command_week_prev { active_date_set .date [::qw::date::add $_active_date day -7]; canvas_draw; } command_week_next { active_date_set .date [::qw::date::add $_active_date day 7]; canvas_draw; } command_day_prev { active_date_set .date [::qw::date::add $_active_date day -1]; canvas_draw; } command_day_next { active_date_set .date [::qw::date::add $_active_date day 1]; canvas_draw; } 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; } 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; } 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; } 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; } command_month_day_first { active_date_set .date [::qw::date::set $_active_date day 1]; canvas_draw; } command_month_day_last { active_date_set .date [::qw::date::set $_active_date day [::qw::date::get $_active_date days_in_month]]; canvas_draw; } command_year_day_first { active_date_set .date [::string range $_active_date 0 3]0101; canvas_draw; } command_year_day_last { active_date_set .date [::string range $_active_date 0 3]1231; canvas_draw; } command_help { ::qw::script::source \ .script.path [::file join $::qw_library doc qw_chtml_compile.qw_script] \ .structure [dialog_help_page $_sargs] \ .window_title [::sargs::get $_sargs .title] \ ; } default { ::qw::bug 314120080124131202 "Encountered invalid command \"$Command\"."; } } } } ::set ::qw::dialog::date_dialog::_dialog_result ""; # ------------------------------------------------------------ # ::qw::dialog::date # ------------------------------------------------------------ ::proc ::qw::dialog::date {sargs} { ::qw::dialog::date_dialog .#auto $sargs; ::return $::qw::dialog::date_dialog::_dialog_result; } # ------------------------------------------------------------ # ::qw::dialog::bbox # ------------------------------------------------------------ ::proc ::qw::dialog::bbox {args} { /* { ::qw::dialog::bbox .widget .xxx; This should be a more generally available method. Also, it's really not compatibile with a true tk bbox (x1 x2 y1 y2) because it is x1 y1 width height. We should correct this in nv3. */ } ::qw::s_args_marshal; ::set Widget [::sargs::get $s_args .widget]; ::set x1 [::winfo rootx $Widget]; ::set y1 [::winfo rooty $Widget]; ::set Width [::winfo width $Widget]; ::set Height [::winfo height $Widget]; ::set Result [::list $x1 $y1 $Width $Height]; ::return $Result; } # ------------------------------------------------------------ # balloon help # ------------------------------------------------------------ ::proc ::qw::dialog::balloon_help {args} { /* { To set up and turn on balloon help: ::qw::dialog::balloon_help .command enable .widget $Widget .text_callback $CallbackCmd To unset and disable balloon help: ::qw::dialog::balloon_help .command enable .widget $Widget .text_callback $CallbackCmd The callback looks something like: method balloon_help_text {args} { ::qw::s_args_marshal; ::set Widget [::sargs::get $s_args .widget]; ::switch -glob -- $Widget { *.year_next_button { ::return "Move to next year.\nAlso +"; } ... *.button_frame.ok* { ::return "Pick the current date.\n Also double-click or ."; } *.client.formatted_date* { ::return "Calendar is currently positioned on this date."; } *.client.column_titles* - *.calendar_buttons.* { ::return "Move to desired date and click