diff --git a/CHANGELOG.md b/CHANGELOG.md index 732fa36..b784f0f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,6 +11,9 @@ Version `3.4.6 (8 Dec'21)` - BUGFIX: -initialdir option for file chooser - BUGFIX: default/classic/alt theme & dark CS: selected check/radio buttons' bg - BUGFIX: treeview's ttk::style for CS=-2 (i.e. if no CS) + - BUGFIX: display redefined Ctrl+Y/D, F3 + - NEW : ::apave::writeTextFile option of deleting empty files instead of saving + - NEW : ::apave::bindToEvent - NEW : -method option to define a method in apave object - NEW : tooltip for notebook tab - NEW : unit tree for apave.tcl @@ -26,6 +29,7 @@ Version `3.4.6 (8 Dec'21)` - NEW : -padx, -pady options for entry fields of choosers - NEW : topmost attribute in showModal depending on a window's ancestors - NEW : cs_Active to set/get flag "no CS changes" + - CHANGE: sourcing baltip.tcl modified - CHANGE: csMainColors includes e_menu colors - CHANGE: test0, test1, test2 modified - CHANGE: klnd.tcl refactored (unit tree, inits) diff --git a/apave.tcl b/apave.tcl index 2e871ba..b6ebb05 100755 --- a/apave.tcl +++ b/apave.tcl @@ -147,6 +147,7 @@ namespace eval ::apave { set _AP_VARS(MODALWIN) [list] set _AP_VARS(LINKFONT) [list -underline 1] set _AP_VARS(INDENT) " " + set _AP_VARS(KEY,F3) F3 set _AP_VARS(KEY,CtrlD) [list Control-D Control-d] set _AP_VARS(KEY,CtrlY) [list Control-Y Control-y] set _AP_VARS(KEY,AltQ) [list Alt-Q Alt-q] @@ -468,9 +469,13 @@ namespace eval ::apave { } ;# ::apave -# ________________________ source obbit.tcl _________________________ # +# ________________________ source *.tcl _________________________ # + +# Let the *.tcl be sourced here just to ensure +# that apave's stuff available for them and vice versa. source [file join $::apave::apaveDir obbit.tcl] +source [file join $::apave::apaveDir baltip baltip.tcl] # ________________________ Creating APave oo::class _________________________ # @@ -1419,14 +1424,14 @@ oo::class create ::apave::APave { ttk::menubutton $w -menu $w.m -text [set $vname] -style TMenuButtonWest {*}$mbopts if {$tip ne {}} { set tip [my MC $tip] - catch {::baltip tip $w $tip} + ::baltip tip $w $tip } menu $w.m -tearoff 0 my OptionCascade_add $w.m $vname $items $precom {*}$args trace var $vname w \ "$w config -text \"\[[self] optionCascadeText \${$vname}\]\" ;\#" lappend ::apave::_AP_VARS(_TRACED_$w) $vname - bind $w "+ focus $w" + ::apave::bindToEvent $w focus $w return $w.m } #_______________________ @@ -2417,11 +2422,12 @@ oo::class create ::apave::APave { } elseif {![string match "#*" $fr]} { set attr [my GetMC $attr] set attr [subst $attr] - lassign [::apave::extractOptions attr -tip {} -tooltip {}] t1 t2 + lassign [::apave::extractOptions attr -tip {} -tooltip {}] tip t2 set wt $w.$fr $w add [ttk::frame $wt] {*}$attr - if {[append t1 $t2] ne {}} { - catch {::baltip::tip $w $t1 -nbktab $wt} + if {[append tip $t2] ne {}} { + set tip [my MC $tip] + ::baltip::tip $w $tip -nbktab $wt } } } @@ -2456,7 +2462,7 @@ oo::class create ::apave::APave { -callF2 { if {[llength $v]==1} {set w2 $v} {set w2 [string map $v $w]} if {[string first $w2 [bind $w ""]] < 0} { - bind $w [list + $w2 invoke] + ::apave::bindToEvent $w $w2 invoke } } -timeout { @@ -2729,8 +2735,9 @@ oo::class create ::apave::APave { lassign [split [string map [list $_pav(edge) $::apave::UFF] $v] $::apave::UFF] v tt vz set tt [string map [list %l $txt] $tt] set v [string map [list %l $txt %t $tt] $v] - if {$tt ne ""} { - catch {::baltip tip $lab $tt} + if {$tt ne {}} { + set tt [my MC $tt] + ::baltip tip $lab $tt lappend ::apave::_AP_VARS(TIMW) $lab } if {$inv} { @@ -2878,10 +2885,10 @@ oo::class create ::apave::APave { if {[bind $wt <>] eq ""} { set res " \ - bind $wt <> {+ [self] pasteText $wt} ;\ - bind $wt {+ [self] onKeyTextM $wt %K %s} ;\ - bind $wt {+ [self] onKeyTextM $wt %K %s} ;\ - catch {bind $wt {+ [self] onKeyTextM $wt %K}}" + ::apave::bindToEvent $wt <> [self] pasteText $wt ;\ + ::apave::bindToEvent $wt [self] onKeyTextM $wt %K %s ;\ + ::apave::bindToEvent $wt [self] onKeyTextM $wt %K %s ;\ + catch {::apave::bindToEvent $wt [self] onKeyTextM $wt %K}" } foreach k [::apave::getTextHotkeys CtrlD] { append res " ; bind $wt <$k> {[self] doubleText $wt}" diff --git a/apavedialog.tcl b/apavedialog.tcl index 40f959b..f9fcb6a 100644 --- a/apavedialog.tcl +++ b/apavedialog.tcl @@ -594,12 +594,13 @@ oo::class create ::apave::APaveDialog { # com1 - user's command "find first" # com2 - user's command "find next" + set accF3 [::apave::KeyAccelerator [::apave::getTextHotkeys F3]] if {$com1 eq ""} {set com1 "[self] InitFindInText 0 $txt; focus \[[self] Entfind\]"} if {$com2 eq ""} {set com2 "[self] findInText 1 $txt"} return "\$pop add separator \$pop add command [my iconA find] -accelerator Ctrl+F -label \"Find First\" \\ -command {$com1} - \$pop add command [my iconA none] -accelerator F3 -label \"Find Next\" \\ + \$pop add command [my iconA none] -accelerator $accF3 -label \"Find Next\" \\ -command {$com2}" } @@ -611,10 +612,12 @@ oo::class create ::apave::APaveDialog { # pop - path to the menu # txt - path to the text + set accD [::apave::KeyAccelerator [::apave::getTextHotkeys CtrlD]] + set accY [::apave::KeyAccelerator [::apave::getTextHotkeys CtrlY]] return "\$pop add separator - \$pop add command [my iconA add] -accelerator Ctrl+D -label \"Double Selection\" \\ + \$pop add command [my iconA add] -accelerator $accD -label \"Double Selection\" \\ -command \"[self] doubleText {$txt} 0\" - \$pop add command [my iconA delete] -accelerator Ctrl+Y -label \"Delete Line\" \\ + \$pop add command [my iconA delete] -accelerator $accY -label \"Delete Line\" \\ -command \"[self] deleteLine {$txt} 0\" \$pop add command [my iconA up] -accelerator Alt+Up -label \"Line(s) Up\" \\ -command \"[self] linesMove {$txt} -1 0\" @@ -680,7 +683,7 @@ oo::class create ::apave::APaveDialog { $w tag configure hilited -foreground #1f0000 -background #ffa073 $w tag configure hilited2 -foreground #1f0000 -background #ff6b85 bind $w [list [self] highlight_matches $w] - bind $w [list + [self] unhighlight_matches $w] + ::apave::bindToEvent $w [self] unhighlight_matches $w bind $w "[self] seek_highlight $w 0 ; break" bind $w "[self] seek_highlight $w 1 ; break" foreach k [::apave::getTextHotkeys AltQ] { diff --git a/apaveinput.tcl b/apaveinput.tcl index dfe7ba8..f011cfb 100644 --- a/apaveinput.tcl +++ b/apaveinput.tcl @@ -34,7 +34,7 @@ package require Tk -package provide apave 3.4.6b16 +package provide apave 3.4.6b19 source [file join [file dirname [info script]] apavedialog.tcl] diff --git a/baltip/README.md b/baltip/README.md index e169eff..ea71647 100644 --- a/baltip/README.md +++ b/baltip/README.md @@ -8,16 +8,19 @@ The original code has been modified to make the tip: * be faded/destroyed after an interval defined by a caller * be enabled/disabled for all or specific widgets + * be disabled for a while ("sleep") * be usable with labels, menus, text/canvas tags, notebook tabs, listbox/treeview items etc. * be displayed at the screen's edges * be displayed under the host widget * be displayed as a stand-alone balloon message at given coordinates * be displayed with given font, colors, paddings, border, relief, opacity, bell * have -image and -compound options to display images + * have -command option to be displayed in a status bar instead of a balloon + * have -maxexp option to limit the number of tip's expositions * have configure/cget etc. wrapped in Tcl ensemble for convenience The video introduction to *baltip* is presented by - [baltip-1.3.mp4](https://github.com/aplsimple/baltip/releases/download/baltip-1.3/baltip-1.3.mp4) (16 Mb). + [baltip-1.3.1.mp4](https://github.com/aplsimple/baltip/releases/download/baltip-1.3.1/baltip-1.3.1.mp4) (17 Mb). Below are several pictures just to glance at *baltip*. @@ -64,6 +67,10 @@ The *treeview* can have tips per item and/or column as well as for a whole treev +The *-command* option allows to display tips in a status bar instead of a balloon. + + + *Configurable tips*. The tip configuration can be global or local (for a specific tip). The configuring can include: font, colors, paddings, border, relief, exposition time, opacity, image (with -compound), bell. @@ -155,6 +162,13 @@ If you need to switch between "per item" and "per widget" tip of listbox and tre ::baltip::tip .treeview {Common tip} -reset yes ;# sets a usual tip ::baltip::tip .treeview {::treTip %i %c} -reset yes ;# sets a callback +Some GUI objects (notebook tabs, listbox items, treeview items) have not <Enter> nor <Leave> event bindings, so that those bindings are imitated by *baltip*. Hence a problem with popup menus: when you right-click those GUI objects, *baltip::tip* and *tk_popup* might both fire, which results in a mess. + +To avoid this, use *::baltip::sleep* before *tk_popup*, for example: + + ::baltip::sleep 1000 ;# disables tips for 1000 milliseconds + tk_popup $popupmenu $X $Y ;# calls a popup menu at $X $Y coordinates + ## Balloon @@ -179,6 +193,46 @@ For example: set text "The balloon at the right edge of the window" ::baltip tip .win $text -geometry $geom -pause 2000 -fade 2000 + +## Command + +The "-command" option allows to display tips in other places, for example in a status bar. At that, the command can include %t and %w wildcards, meaning "text" and "widget path". Such tips are well fit for menu items, as seen in *test.tcl*. + +For example: + + proc ::Status {tip} { + .labelstatus configure -text $tip + } + ::baltip::tip .menu "File actions" -index 0 -command {::Status {%t}} + ::baltip::tip .menu "Help, hints, Q&A, about etc." -index 1 -command {::Status {%t}} + +Also, this option can be used if you need to fire some code when the mouse pointer enters or leaves a GUI object. + +**Note**: the *baltip* is available for a few of GUI objects that have not <Enter> nor <Leave> bindings. + +The only line + + baltip::tip $w $tip -command $command + +might save you other lines to fire the command at entering/leaving a GUI object. E.g. the command might highlight a GUI object entered, save its ID and unhighlight the object at leaving it. + +For example: + + proc ::SomeProc {tip} { + lassign [split $tip] obj ID column + if {[info exists ::OBJsaved]} { + puts "$::OBJsaved object ID=[set ::IDsaved] is left... unhighlighted..." + unset ::OBJsaved + } + if {$obj eq {}} return + set ::OBJsaved $obj + set ::IDsaved $ID + puts "Now processing $obj object with ID=$ID column=$column" + } + ::baltip::tip .listbox {Listbox %i} -command {::SomeProc {%t}} + ::baltip::tip .treeview {Treeview %i %c} -command {::SomeProc {%t}} + + ## Options Below are listed the *baltip* options that are set with `tip` and `configure` and got with `cget`: @@ -210,7 +264,9 @@ The following options are special: * `-ctag` - name of canvas tag to tip; * `-nbktab` - path to ttk::notebook tab to tip; * `-geometry` - geometry (+X+Y) of the balloon; - * `-reset` - "-reset true" may be useful to set a new tip (callback or text) for listbox and treeview. + * `-reset` - "-reset true" may be useful to set a new tip (callback or text) for listbox and treeview; + * `-command` - a command to be executed, with %t (tip's text) and %w (widget's path) wildcards; + * `-maxexp` - maximum number of tip's expositions. If `-global yes` option is used alone, it applies all global options to all registered tips. If `-global yes` option is used along with other options, only those options are applied to all registered tips. @@ -224,6 +280,12 @@ The `-index` option may have numeric (0, 1, 2...) or symbolic form (active, end, ::baltip repaint .win.popupMenu -index active ::baltip::tip .menu "File actions" -index 0 +There may be useful to define options in *text* argument of *::baltip::tip*. + +For this, provide the *text* argument as a list of pairs of uppercased options' name / value including *-BALTIP* option for *tip*. For example: + + ::baltip tip .text "-BALTIP {Sort of diary, todos etc.} -MAXEXP 1" + As seen in the above examples, *baltip* can be used as Tcl ensemble, so that the commands may be shortened. See more examples in *test.tcl* of [baltip.zip](https://chiselapp.com/user/aplsimple/repository/baltip/download). @@ -236,7 +298,7 @@ The *baltip* package has been developed with help of these kind people: * [Nicolas Bats](https://github.com/sl1200mk2) prompted to add canvas tags' tips - * [Csaba Nemethi](https://www.nemethi.de/) sent several bug fixes and advices, incl. on listbox and treeview tips + * [Csaba Nemethi](https://www.nemethi.de/) sent several bug fixes and advices, especially on listbox, treeview and menu tips ## Links @@ -246,4 +308,4 @@ The *baltip* package has been developed with help of these kind people: * [Reference](https://aplsimple.github.io/en/tcl/baltip/baltip.html) - * [Demo of baltip v1.3](https://github.com/aplsimple/baltip/releases/download/baltip-1.3/baltip-1.3.mp4) + * [Demo of baltip v1.3.1](https://github.com/aplsimple/baltip/releases/download/baltip-1.3.1/baltip-1.3.1.mp4) diff --git a/baltip/baltip.tcl b/baltip/baltip.tcl old mode 100755 new mode 100644 index 33adc0b..0e28a29 --- a/baltip/baltip.tcl +++ b/baltip/baltip.tcl @@ -1,4 +1,3 @@ -#! /usr/bin/env tclsh ########################################################### # Name: baltip.tcl # Author: Alex Plotnikov (aplsimple@gmail.com) @@ -7,7 +6,7 @@ # License: MIT. ########################################################### -package provide baltip 1.3.0 +package provide baltip 1.3.2 package require Tk @@ -15,7 +14,8 @@ package require Tk namespace eval ::baltip { - namespace export configure cget tip update hide repaint + namespace export configure cget tip update hide repaint \ + optionlist tippath clear sleep namespace ensemble create namespace eval my { @@ -37,6 +37,7 @@ namespace eval ::baltip { set ttdata(image) {} set ttdata(compound) {} set ttdata(relief) {} + variable GEOACTIVE {-} } } @@ -50,7 +51,7 @@ proc ::baltip::configure {args} { variable my::ttdata set force no set index -1 - lassign {} geometry tag ctag nbktab reset + lassign {} geometry tag ctag nbktab reset command maxexp set global [expr {[dict exists $args -global] && [dict get $args -global]}] foreach {n v} $args { set n1 [string range $n 1 end] @@ -60,7 +61,8 @@ proc ::baltip::configure {args} { -on - -padx - -pady - -padding - -bell - -under - -font - -image - -compound { set my::ttdata($n1) $v } - -force - -geometry - -index - -tag - -global - -ctag - -nbktab - -reset { + -force - -geometry - -index - -tag - -global - -ctag - -nbktab - -reset - \ + -command - -maxexp { set $n1 $v } default {return -code error "baltip: invalid option \"$n\""} @@ -72,7 +74,7 @@ proc ::baltip::configure {args} { } } } - return [list $force $geometry $index $tag $ctag $nbktab $reset] + return [list $force $geometry $index $tag $ctag $nbktab $reset $command $maxexp] } #_______________________ @@ -83,9 +85,7 @@ proc ::baltip::cget {args} { variable my::ttdata if {![llength $args]} { - lappend args -on -per10 -fade -pause -fg -bg -bd -padx -pady -padding \ - -font -alpha -text -index -tag -bell -under -image -compound -relief \ - -ctag -nbktab -reset + lappend args {*}[optionlist] } set res [list] foreach n $args { @@ -98,6 +98,15 @@ proc ::baltip::cget {args} { } #_______________________ +proc ::baltip::optionlist {} { + # All options of baltip. + + return [list -on -per10 -fade -pause -fg -bg -bd -padx -pady -padding \ + -font -alpha -text -index -tag -bell -under -image -compound -relief \ + -ctag -nbktab -reset -command -maxexp] +} +#_______________________ + proc ::baltip::tippath {w} { # Gets a tip window's path. # w - widget's path @@ -118,12 +127,16 @@ proc ::baltip::tip {w text args} { set arrsaved [array get my::ttdata] set optvals [::baltip::my::CGet {*}$args] # block of related lines for special options - lassign $optvals forced geo index ttag ctag nbktab reset - set optvals [lrange $optvals 7 end] ;# get rid of special options + lassign $optvals forced geo index ttag ctag nbktab reset command maxexp + set optvals [lrange $optvals 9 end] ;# get rid of special options # end of block - set my::ttdata(optvals,$w) [dict set optvals -text $text] - set my::ttdata(on,$w) [expr {[string length $text] && $my::ttdata(on)}] set my::ttdata(global,$w) no + set my::ttdata(command,$w) $command + set my::ttdata(maxexp,$w) $maxexp + set text [my::OptionsFromText $w $text] ;# may reset -command and -maxexp + set onopt [expr {[string length $text] && $my::ttdata(on)}] + set my::ttdata(optvals,$w) [dict set optvals -text $text] + set my::ttdata(on,$w) $onopt if {$text ne {}} { if {$forced || $geo ne {}} {::baltip::my::Show $w $text yes $geo $optvals} if {$geo ne {}} { @@ -140,21 +153,27 @@ proc ::baltip::tip {w text args} { bind Tooltip$w "::baltip::hide $w" if {$index>-1} { # tip for menu items - set my::ttdata($w,$index) $text set my::ttdata(LASTMITEM) {} - bind $w <> [list + ::baltip::my::MenuTip $w %W $optvals] + set wt [my::Clonename $w] + foreach w2 [list $w $wt] { + set my::ttdata(on,$w2) $onopt + set my::ttdata($w2,$index) $optvals + set my::ttdata(command,$w2) $command + set my::ttdata(global,$w2) no + } + my::BindToEvent Menu <> ::baltip::my::MenuTip %W } elseif {$ttag ne {}} { # tip for text tags set my::ttdata($w,$ttag) $text - $w tag bind $ttag [list + ::baltip::my::TagTip $w $ttag $optvals] + my::BindTextagToEvent $w $ttag ::baltip::my::TagTip $w $ttag $optvals foreach event {Leave KeyPress Button} { - $w tag bind $ttag <$event> [list + ::baltip::my::TagTip $w] + my::BindTextagToEvent $w $ttag <$event> ::baltip::my::TagTip $w } } elseif {$ctag ne {}} { # tip for canvas tags set my::ttdata($w,$ctag) $text - $w bind $ctag [list + ::baltip::my::TagTip $w $ctag $optvals] - $w bind $ctag [list + ::baltip::my::TagTip $w] + my::BindCantagToEvent $w $ctag ::baltip::my::TagTip $w $ctag $optvals + my::BindCantagToEvent $w $ctag ::baltip::my::TagTip $w } elseif {$nbktab ne {}} { # tip for notebook tabs configure -SPECTIP$nbktab $text @@ -218,6 +237,13 @@ proc ::baltip::hide {{w ""}} { # w - widget's path # Returns 1, if the window was really hidden. + variable my::ttdata + variable my::GEOACTIVE + if {$w eq $my::GEOACTIVE || $w eq {}} { + ;# unlock tips after a balloon message + set my::GEOACTIVE {-} + } + my::Command $w {} return [expr {![catch {destroy [tippath $w]}]}] } #_______________________ @@ -231,6 +257,16 @@ proc ::baltip::clear {w args} { catch {bind Tooltip$w <$ev> {}} } } +#_______________________ + +proc ::baltip::sleep {msec} { + # Disables tips for a while. + # msec - time to sleep, in msec + # This is useful esp. before calling a popup menu on listbox/treeview. + + configure -on no + after $msec "::baltip::configure -on yes" +} # _____________________ Internals ____________________ # proc ::baltip::my::CGet {args} { @@ -263,8 +299,112 @@ proc ::baltip::my::WidCoord {w} { set inside [expr {$x>-1 && $x<$width && $y>-1 && $y<$height}] return [list $x $y $inside] } +#_______________________ + +proc ::baltip::my::Clonename {mnu} { + # Gets a clone name of a menu. + # mnu - the menu's path + # This procedure is borrowed from BWidget's utils.tcl. + + set path [set menupath {}] + set found 0 + foreach widget [lrange [split $mnu .] 1 end] { + if {$found || [winfo class "$path.$widget"] eq {Menu}} { + set found 1 + append menupath # $widget + append path . $menupath + } else { + append menupath # $widget + append path . $widget + } + } + return $path +} +#_______________________ + +proc ::baltip::my::OptionsFromText {w txt} { + # Extracts options from "text" argument of baltip::tip. + # w - widget's path + # txt - "-text" option's value + # Options can be set in the "text" argument as uppercased-name / value pairs: + # "-BALTIP {True tip's text} -MAXEXP 1 -COMMAND {::mycom %i %c}" + # In this case, *txt* must be a correct list of name/value sequences. + # Returns an original *txt* or a value of -BALTIP option from *txt*. + + variable ttdata + if {[string first {-BALTIP } $txt] >-1 && \ + !([catch {set lst [list {*}$txt]}] || [expr {[llength $lst] % 2 }])} { + set ol [::baltip::optionlist] + lappend ol -baltip + foreach o $ol {lappend OL [string toupper $o]} + foreach {o v} $lst { + if {[set i [lsearch -exact $OL $o]]>-1} { + set n1 [string range [lindex $ol $i] 1 end] + set ttdata($n1,$w) $v + if {$o eq {-BALTIP}} {set txt $v} + } + } + } + return $txt +} + +## ________________________ Binds _________________________ ## + +proc ::baltip::my::BindToEvent {w event args} { + # Binds an event on a widget to a command. + # w - the widget's path + # event - the event + # args - the command + + if {[string first $args [bind $w $event]]<0} { + bind $w $event [list + {*}$args] + } +} +#_______________________ + +proc ::baltip::my::BindTextagToEvent {w tag event args} { + # Binds an event on a text tag to a command. + # w - the widget's path + # tag - the tag + # event - the event + # args - the command + + if {[string first $args [$w tag bind $tag]]<0} { + $w tag bind $tag $event [list + {*}$args] + } +} +#_______________________ + +proc ::baltip::my::BindCantagToEvent {w tag event args} { + # Binds an event on a canvas tag to a command. + # w - the widget's path + # tag - the tag + # event - the event + # args - the command + + if {[catch {set bound [$w bind $tag $event]}]} {set bound {}} + if {[string first $args $bound]<0} { + $w bind $tag $event [list + {*}$args] + } +} -## ________________________ Show _________________________ ## +## ________________________ Shows _________________________ ## + +proc ::baltip::my::Command {w text} { + # Executes a command set for a window. + # w - the widget's path + # text - the tip text + # The command allows wildcards: + # %w - window's path + # %t - text of the tip + + variable ttdata + if {![info exists ttdata(command,$w)] || $ttdata(command,$w) eq {}} {return no} + set com [string map [list %w $w %t $text] $ttdata(command,$w)] + if {[catch {eval $com} e]} {return no} + return yes +} +#_______________________ proc ::baltip::my::ShowWindow {win} { # Shows a window of tip. @@ -317,14 +457,17 @@ proc ::baltip::my::Show {w text force geo optvals} { # See also: Fade, ShowWindow, ::baltip::update variable ttdata + variable GEOACTIVE if {$w ne {} && ![winfo exists $w]} return + if {$geo eq {} && $GEOACTIVE ne {-}} return ;# tips locked at a balloon message set win [::baltip::tippath $w] # keep the label's colors untouched (for apave package) catch {::apave::obj untouchWidgets $win.label} set px [winfo pointerx .] set py [winfo pointery .] - if {$geo ne {}} { ;# balloons not related to widgets + if {$geo ne {}} { ;# balloons not related to widgets array set data $optvals + set GEOACTIVE $w ;# lock other tips } elseif {$ttdata(global,$w)} { ;# flag 'use global settings' array set data [::baltip::cget] } else { @@ -341,14 +484,21 @@ proc ::baltip::my::Show {w text force geo optvals} { if {[catch {set widgetclass [winfo class $w]}]} { set widgetclass {} } - if {!$force && $geo eq {} && $widgetclass ne {Menu} && \ - ([winfo exists $win] || ![info exists ttdata(on,$w)] || !$ttdata(on,$w) || \ - ![string match $w* [winfo containing $px $py]])} { - return + if {!$force && $geo eq {}} { + if {![info exists ttdata(on,$w)] || !$ttdata(on,$w)} return + if {$widgetclass ne {Menu} && \ + ([winfo exists $win] || ![string match $w* [winfo containing $px $py]])} { + return + } } - ::baltip::hide $w + if {$geo eq {}} {::baltip::hide $w} set icount [string length [string trim $text]] if {!$icount || (!$ttdata(on) && !$data(-on))} return + if {[Command $w $text]} return + if {[info exists ttdata(maxexp,$w)] && \ + [string is integer -strict $ttdata(maxexp,$w)]} { + if {[incr ttdata(maxexp,$w) -1]<0} return + } lappend ttdata(REGISTERED) $w foreach wold [lrange $ttdata(REGISTERED) 0 end-1] {::baltip::hide $wold} if {$data(-fg) eq {} || $data(-bg) eq {}} { @@ -458,7 +608,8 @@ proc ::baltip::my::FadeNext {w aint fint icount alpha show geo {geos ""}} { if {$al>0} { if {[catch {wm attributes $w -alpha $al}]} {set al 0} } - if {$al<=0 || ![winfo exists $w]} { + if {$al<=0.001 || ![winfo exists $w]} { + ::baltip::hide catch {destroy $w} return } @@ -511,21 +662,24 @@ proc ::baltip::my::TagTip {w {tag ""} {optvals ""}} { ### ________________________ Menu _________________________ ### -proc ::baltip::my::MenuTip {w wt optvals} { +proc ::baltip::my::MenuTip {wt} { # Shows a menu's tip. - # w - the menu's path - # wt - the menu's path (incl. tearoff menu) - # optvals - settings of tip + # wt - the menu's path (incl. cloned menu) variable ttdata - ::baltip::hide $w + if {[string match .tearoff* $wt]} { + # not implemented for tear-offed menus + return + } + ::baltip::hide $wt set index [$wt index active] - set mit "$w/$index" + set mit "$wt/$index" if {$index eq {none}} return - if {[info exists ttdata($w,$index)] && ([::baltip::hide $w] || \ + if {[info exists ttdata($wt,$index)] && ([::baltip::hide $wt] || \ ![info exists ttdata(LASTMITEM)] || $ttdata(LASTMITEM) ne $mit)} { - set text $ttdata($w,$index) - ::baltip::my::Show $w $text no {} $optvals + set optvals $ttdata($wt,$index) + set text [dict get $optvals -text] + ::baltip::my::Show $wt $text no {} $optvals } set ttdata(LASTMITEM) $mit } @@ -571,14 +725,16 @@ proc ::baltip::my::PrepareNbkTip {w x y} { if {$tab ne {} && $tab ne $tab2} { ::baltip hide $w lassign [::baltip cget -SPECTIP$nbktab] -> tip - set optafter -SPECTIPafter$w - catch { - after cancel [lindex [::baltip cget $optafter] 1] + if {![Command $w $tip]} { + set optafter -SPECTIPafter$w + catch { + after cancel [lindex [::baltip cget $optafter] 1] + } + set aftid [after $pause "::baltip::my::ShowNbkTip $w {$tip}"] + ::baltip configure $optafter $aftid } - set aftid [after $pause "::baltip::my::ShowNbkTip $w {$tip}"] - ::baltip configure $optafter $aftid } - ::baltip configure $optid $tab ;# tab's doen't fully imitate + ::baltip configure $optid $tab } } @@ -600,6 +756,23 @@ proc ::baltip::my::LbxCoord {w} { } #_______________________ +proc ::baltip::my::LbxTip {w idx whole} { + # Gets a text of a listbox' tip. + # w - the listbox's path + # idx - index of listbox's item + # whole - flag "tip for a whole listbox, not per item" + + lassign [::baltip cget -SPECTIP$w] - com + if {$whole} { + set tip [string map "%%i %i" $com] + } else { + set com [string map [list %i $idx] $com] + if {[catch {set tip [eval $com]}]} {set tip $com} + } + return $tip +} +#_______________________ + proc ::baltip::my::ShowLbxTip {w optid idx whole} { # Shows a tip for a listbox. # w - the listbox's path @@ -610,13 +783,7 @@ proc ::baltip::my::ShowLbxTip {w optid idx whole} { catch { lassign [LbxCoord $w] x y idx inside if {$inside} { - lassign [::baltip cget -SPECTIP$w] - com - if {$whole} { - set tip [string map "%%i %i" $com] - } else { - set com [string map [list %i $idx] $com] - if {[catch {set tip [eval $com]}]} {set tip {}} - } + set tip [LbxTip $w $idx $whole] ::baltip configure $optid $idx ::baltip tip $w $tip -force yes ::baltip repaint $w @@ -649,14 +816,18 @@ proc ::baltip::my::PrepareLbxTip {w x y} { set com [string map "%%i \u0001" $com] set whole [expr {[string first %i $com]==-1}] set com [string map "\u0001 %i" $com] + set text [LbxTip $w $idx $whole] if {$whole && $idx2 ne {}} { + Command $w $text return ;# tip for a whole listbox at entering } ::baltip hide $w - set optafter -SPECTIPafter$w - catch {after cancel [lindex [::baltip cget $optafter] 1]} - set aftid [after $pause "::baltip::my::ShowLbxTip $w $optid $idx $whole"] - ::baltip configure $optafter $aftid + if {![Command $w $text]} { + set optafter -SPECTIPafter$w + catch {after cancel [lindex [::baltip cget $optafter] 1]} + set aftid [after $pause "::baltip::my::ShowLbxTip $w $optid $idx $whole"] + ::baltip configure $optafter $aftid + } ::baltip configure $optid $idx } } @@ -664,9 +835,10 @@ proc ::baltip::my::PrepareLbxTip {w x y} { ### ________________________ Treeview _________________________ ### -proc ::baltip::my::TreCoord {w} { +proc ::baltip::my::TreCoord {w whole} { # Gets treeview's coordinate data. # w - path to the treeview + # whole - flag "tip for a whole treeview, not per item" # Returns a list of: # x - X coordinate # y - Y coordinate @@ -677,10 +849,32 @@ proc ::baltip::my::TreCoord {w} { lassign [WidCoord $w] x y inside set id [$w identify item $x $y] set c [$w identify column $x $y] + if {!$whole && [$w identify region $x $y] eq {heading}} { + set inside no + } return [list $x $y $id $c $inside] } #_______________________ +proc ::baltip::my::TreTip {w id c whole} { + # Gets a text of a treeview' tip. + # w - the treeview's path + # id - ID of item + # c - column of item + # whole - flag "tip for a whole treeview, not per item" + + lassign [::baltip cget -SPECTIP$w] - com + if {$whole} { + set tip [string map "%%i %i %%c %c" $com] + } else { + set tip {} + set com [string map [list %i $id %c $c] $com] + if {$id ne {} && [catch {set tip [eval $com]}]} {set tip $com} + } + return $tip +} +#_______________________ + proc ::baltip::my::ShowTreTip {w optid id whole} { # Shows a tip for a treeview. # w - the treeview's path @@ -689,15 +883,9 @@ proc ::baltip::my::ShowTreTip {w optid id whole} { # whole - flag "tip for a whole treeview, not per item" catch { - lassign [TreCoord $w] x y id c inside + lassign [TreCoord $w $whole] x y id c inside if {$inside} { - lassign [::baltip cget -SPECTIP$w] - com - if {$whole} { - set tip [string map "%%i %i %%c %c" $com] - } else { - set com [string map [list %i $id %c $c] $com] - if {[catch {set tip [eval $com]}]} {set tip {}} - } + set tip [TreTip $w $id $c $whole] ::baltip configure $optid [list $id $c] ::baltip tip $w $tip -force yes ::baltip repaint $w @@ -724,23 +912,27 @@ proc ::baltip::my::PrepareTreTip {w x y} { lassign [::baltip cget -pause] -> pause set optid -SPECTIPid$w lassign [lindex [::baltip cget $optid] 1] id2 c2 - lassign [TreCoord $w] x y id c inside lassign [::baltip cget -SPECTIP$w] - com set com [string map "%%i \u0001 %%c \u0002" $com] set isid [expr {[string first %i $com]>-1}] set isc [expr {[string first %c $com]>-1}] set whole [expr {!$isid && !$isc}] set com [string map "\u0001 %i \u0002 %c" $com] - if {$inside && $id ne {} && $c ne {} && - ($whole || ($isid && $id ne $id2) || ($isc && $c ne $c2))} { + lassign [TreCoord $w $whole] x y id c inside + if {$whole || ($inside && $id ne {} && $c ne {} && + (($isid && $id ne $id2) || ($isc && $c ne $c2)))} { + set text [TreTip $w $id $c $whole] if {$whole && $id2 ne {}} { + Command $w $text return ;# tip for a whole treeview at entering } - ::baltip hide $w - set optafter -SPECTIPafter$w - catch {after cancel [lindex [::baltip cget $optafter] 1]} - set aftid [after $pause "::baltip::my::ShowTreTip $w $optid $id $whole"] - ::baltip configure $optafter $aftid + if {![Command $w $text]} { + ::baltip hide $w + set optafter -SPECTIPafter$w + catch {after cancel [lindex [::baltip cget $optafter] 1]} + set aftid [after $pause "::baltip::my::ShowTreTip $w $optid {$id} $whole"] + ::baltip configure $optafter $aftid + } ::baltip configure $optid [list $id $c] } elseif {$id eq {}} { ::baltip hide $w @@ -750,5 +942,8 @@ proc ::baltip::my::PrepareTreTip {w x y} { } # ________________________________ EOF __________________________________ # + #RUNF1: ./test.tcl #RUNF2: ../tests/test2_pave.tcl +#EXEC1: ~/PG/github/freewrap/tclkit-8.6.11 /home/apl/PG/github/pave/tests/test2_pave.tcl +#EXEC1: ~/PG/github/freewrap/tclkit-8.6.11 /home/apl/PG/github/baltip/test.tcl diff --git a/baltip/pkgIndex.tcl b/baltip/pkgIndex.tcl index f85e29b..72367ed 100644 --- a/baltip/pkgIndex.tcl +++ b/baltip/pkgIndex.tcl @@ -1,7 +1,6 @@ -package ifneeded baltip 1.3.0 [list source [file join $dir baltip.tcl]] +package ifneeded baltip 1.3.2 [list source [file join $dir baltip.tcl]] namespace eval ::baltip { - variable _ruff_preamble { It's a Tcl/Tk tip widget inspired by: @@ -13,16 +12,19 @@ The original code has been modified to make the tip: * be faded/destroyed after an interval defined by a caller * be enabled/disabled for all or specific widgets - * be usable with labels, menus, text tags, canvas tags, notebook tabs etc. + * be disabled for a while ("sleep") + * be usable with labels, menus, text/canvas tags, notebook tabs, listbox/treeview items etc. * be displayed at the screen's edges * be displayed under the host widget * be displayed as a stand-alone balloon message at given coordinates - * be displayed with given opacity, font, paddings, relief, colors + * be displayed with given font, colors, paddings, border, relief, opacity, bell * have -image and -compound options to display images + * have -command option to be displayed in a status bar instead of a balloon + * have -maxexp option to limit the number of tip's expositions * have configure/cget etc. wrapped in Tcl ensemble for convenience The video introduction to *baltip* is presented by - [baltip-1.3.mp4](https://github.com/aplsimple/baltip/releases/download/baltip-1.3/baltip-1.3.mp4) (16 Mb). + [baltip-1.3.1.mp4](https://github.com/aplsimple/baltip/releases/download/baltip-1.3.1/baltip-1.3.1.mp4) (17 Mb). Below are several pictures just to glance at *baltip*. @@ -40,10 +42,14 @@ Below are several pictures just to glance at *baltip*. +The *tags of canvas* have tips too. + + + *Tips of menu items*. The menu items can have their own tips. The popup menus may be *tear-off* at that. -The menu tips are useful e.g. when the items are displayed as short names of files, while -the tips are wanted to be their full names. +The menu tips are useful e.g. when the items are displayed as short names, while +the tips are wanted to be full names. @@ -53,25 +59,25 @@ the tips are wanted to be their full names. -The tags of canvas have tips too. - - - -The tabs of notebook are also supplied with tips. +The *tabs of notebook* are also supplied with tips. -The listbox can have tips per item as well as for a whole listbox widget. +The *listbox* can have tips per item as well as for a whole listbox widget. -The treeview can have tips per item and/or column as well as for a whole treeview widget. +The *treeview* can have tips per item and/or column as well as for a whole treeview widget. +The *-command* option allows to display tips in a status bar instead of a balloon. + + + *Configurable tips*. The tip configuration can be global or local (for a specific tip). -The configuring can include: font, colors, paddings, border, exposition time, opacity, relief, image (with -compound), bell. +The configuring can include: font, colors, paddings, border, relief, exposition time, opacity, image (with -compound), bell. @@ -145,7 +151,7 @@ The "text" for *listbox* can contain %i wildcard - and in such cases the text me } ::baltip tip .listbox {::lbxTip %i} -The "text" for *treeview* can contain %i and %c wildcards - and in such cases the text means a callback receiving ID of item and/or column of item to tip: +The "text" for *treeview* can contain %i and/or %c wildcards - and in such cases the text means a callback receiving ID of item and/or column of item to tip: proc ::treTip {id c} { set item [.treeview item $id -text] @@ -160,6 +166,13 @@ If you need to switch between "per item" and "per widget" tip of listbox and tre ::baltip::tip .treeview {Common tip} -reset yes ;# sets a usual tip ::baltip::tip .treeview {::treTip %i %c} -reset yes ;# sets a callback +Some GUI objects (notebook tabs, listbox items, treeview items) have not <Enter> nor <Leave> event bindings, so that those bindings are imitated by *baltip*. Hence a problem with popup menus: when you right-click those GUI objects, *baltip::tip* and *tk_popup* might both fire, which results in a mess. + +To avoid this, use *::baltip::sleep* before *tk_popup*, for example: + + ::baltip::sleep 1000 ;# disables tips for 1000 milliseconds + tk_popup $popupmenu $X $Y ;# calls a popup menu at $X $Y coordinates + ## Balloon @@ -184,6 +197,46 @@ For example: set text "The balloon at the right edge of the window" ::baltip tip .win $text -geometry $geom -pause 2000 -fade 2000 + +## Command + +The "-command" option allows to display tips in other places, for example in a status bar. At that, the command can include %t and %w wildcards, meaning "text" and "widget path". Such tips are well fit for menu items, as seen in *test.tcl*. + +For example: + + proc ::Status {tip} { + .labelstatus configure -text $tip + } + ::baltip::tip .menu "File actions" -index 0 -command {::Status {%t}} + ::baltip::tip .menu "Help, hints, Q&A, about etc." -index 1 -command {::Status {%t}} + +Also, this option can be used if you need to fire some code when the mouse pointer enters or leaves a GUI object. + +**Note**: the *baltip* is available for a few of GUI objects that have not <Enter> nor <Leave> bindings. + +The only line + + baltip::tip $w $tip -command $command + +might save you other lines to fire the command at entering/leaving a GUI object. E.g. the command might highlight a GUI object entered, save its ID and unhighlight the object at leaving it. + +For example: + + proc ::SomeProc {tip} { + lassign [split $tip] obj ID column + if {[info exists ::OBJsaved]} { + puts "$::OBJsaved object ID=[set ::IDsaved] is left... unhighlighted..." + unset ::OBJsaved + } + if {$obj eq {}} return + set ::OBJsaved $obj + set ::IDsaved $ID + puts "Now processing $obj object with ID=$ID column=$column" + } + ::baltip::tip .listbox {Listbox %i} -command {::SomeProc {%t}} + ::baltip::tip .treeview {Treeview %i %c} -command {::SomeProc {%t}} + + ## Options Below are listed the *baltip* options that are set with `tip` and `configure` and got with `cget`: @@ -215,7 +268,9 @@ The following options are special: * `-ctag` - name of canvas tag to tip; * `-nbktab` - path to ttk::notebook tab to tip; * `-geometry` - geometry (+X+Y) of the balloon; - * `-reset` - "-reset true" may be useful to set a new tip (callback or text) for listbox and treeview. + * `-reset` - "-reset true" may be useful to set a new tip (callback or text) for listbox and treeview; + * `-command` - a command to be executed, with %t (tip's text) and %w (widget's path) wildcards; + * `-maxexp` - maximum number of tip's expositions. If `-global yes` option is used alone, it applies all global options to all registered tips. If `-global yes` option is used along with other options, only those options are applied to all registered tips. @@ -229,6 +284,12 @@ The `-index` option may have numeric (0, 1, 2...) or symbolic form (active, end, ::baltip repaint .win.popupMenu -index active ::baltip::tip .menu "File actions" -index 0 +There may be useful to define options in *text* argument of *::baltip::tip*. + +For this, provide the *text* argument as a list of pairs of uppercased options' name / value including *-BALTIP* option for *tip*. For example: + + ::baltip tip .text "-BALTIP {Sort of diary, todos etc.} -MAXEXP 1" + As seen in the above examples, *baltip* can be used as Tcl ensemble, so that the commands may be shortened. See more examples in *test.tcl* of [baltip.zip](https://chiselapp.com/user/aplsimple/repository/baltip/download). @@ -241,7 +302,7 @@ The *baltip* package has been developed with help of these kind people: * [Nicolas Bats](https://github.com/sl1200mk2) prompted to add canvas tags' tips - * [Csaba Nemethi](https://www.nemethi.de/) sent several bug fixes and advices, incl. on listbox and treeview tips + * [Csaba Nemethi](https://www.nemethi.de/) sent several bug fixes and advices, especially on listbox, treeview and menu tips ## Links @@ -251,7 +312,7 @@ The *baltip* package has been developed with help of these kind people: * [Reference](https://aplsimple.github.io/en/tcl/baltip/baltip.html) - * [Demo of baltip v1.3](https://github.com/aplsimple/baltip/releases/download/baltip-1.3/baltip-1.3.mp4) + * [Demo of baltip v1.3.1](https://github.com/aplsimple/baltip/releases/download/baltip-1.3.1/baltip-1.3.1.mp4) } } diff --git a/baltip/test.tcl b/baltip/test.tcl old mode 100644 new mode 100755 index e3885b1..2a25613 --- a/baltip/test.tcl +++ b/baltip/test.tcl @@ -1,6 +1,12 @@ #! /usr/bin/env tclsh -# -# It's a test for baltip package. +########################################################### +# Name: test.tcl +# Author: Alex Plotnikov (aplsimple@gmail.com) +# Date: 12/06/2021 +# Brief: Handles a test for baltip package. +# License: MIT. +########################################################### + # ____________________________________ auto_path ______________________________________ # cd [file dirname [info script]] @@ -73,6 +79,22 @@ proc ::TreTipC {c} { return "Tip for column=$c" } +proc ::Status {tip args} { + .status configure -text [string map [list \n { }] $tip] {*}$args +} + +proc ::SomeProc {tip} { + lassign [split $tip] obj ID column + if {[info exists ::OBJsaved]} { + puts "$::OBJsaved object ID=[set ::IDsaved] is left... unhighlighted..." + unset ::OBJsaved + } + if {$obj eq {}} return + set ::OBJsaved $obj + set ::IDsaved $ID + puts "Now processing $obj object with ID=$ID column=$column" +} + # _____________________________________ Images _____________________________________ # set tclimg {iVBORw0KGgoAAAANSUhEUgAAAEgAAABICAMAAABiM0N1AAAABlBMVEUAAAC1CgZ1fsiLAAAAAnRS @@ -143,6 +165,8 @@ foreach idx {0 1 2 3 4 5} { set ::on 1 checkbutton .cb -text "Tips on" -variable ::on -command ::chbComm +label .status -relief sunken -anchor w + # _____________________________________ Pack _____________________________________ # pack .b .l .b2 @@ -150,6 +174,7 @@ pack .t -expand 1 -fill x pack .lb -expand 1 -fill x pack .tre -expand 1 -fill both pack .cb +pack .status -fill x update set ww [winfo width .] set wh [winfo height .] @@ -161,11 +186,11 @@ set m [menu .popupMenu] $m add command -label \ "Global settings: -fg $::fg1 -bg $::bg1 -relief raised -alpha 0.8" -command " \ ::baltip config -fg $::fg1 -bg $::bg1 -global yes -relief raised -alpha 0.8; \ - if {\[$m entryconfigure active\] eq {}} {::baltip repaint $m -index active}" + ::Status {Set new colors of all tips} -font {[font actual TkTooltipFont] -weight bold}" $m add command -label \ "Global settings: -fg $::fg0 -bg $::bg0 -relief solid -alpha 1.0" -command " \ ::baltip config -fg $::fg0 -bg $::bg0 -global yes -relief solid -alpha 1.0; \ - if {\[$m entryconfigure active\] eq {}} {::baltip repaint $m -index 2}" + ::Status {Restored colors of all tips} -font TkTooltipFont" bind .l {tk_popup .popupMenu %X %Y} menu .menu -tearoff 0 @@ -200,22 +225,25 @@ bind . {.b2 invoke} ::baltip::tip .l "Calls a popup tearoff menu.\nThis tip is switched by the button\nto an alert/message." ::baltip::tip .b2 "Displays a message at top right corner, having\ \ncoordinates set with \"-geometry $geo\" option." +::baltip::tip .status "Status bar for tips." -command {::Status {%t}} ::baltip::tip .popupMenu "Sets new colors of all tips" -index 1 ::baltip::tip .popupMenu "Restores colors of all tips" -index 2 -::baltip::tip .menu "File actions" -index 0 -::baltip::tip .menu "Help actions" -index 1 -::baltip::tip .menu.file "Opens a file\n(stub)" -index 0 -::baltip::tip .menu.file "Creates a file\n(stub)" -index 1 -::baltip::tip .menu.file "Saves a file\n(stub)" -index 2 -::baltip::tip .menu.file "Shows a balloon\nat right top corner" -index 4 -::baltip::tip .menu.file "Closes the test" -index 6 -::baltip::tip .menu.help "Info on the package\ndisplayed in terminal" -index 0 +::baltip::tip .menu "File actions" -index 0 -command {::Status {%t}} +::baltip::tip .menu "Help actions" -index 1 -command {::Status {%t}} +::baltip::tip .menu.file "Opens a file\n(stub)" -index 0 -command {::Status {%t}} +::baltip::tip .menu.file "Creates a file\n(stub)" -index 1 -command {::Status {%t}} +::baltip::tip .menu.file "Saves a file\n(stub)" -index 2 -command {::Status {%t}} +::baltip::tip .menu.file "Shows a balloon\nat right top corner" -index 4 -command {::Status {%t}} +::baltip::tip .menu.file "Closes the test" -index 6 -command {::Status {%t}} +::baltip::tip .menu.help "Info on the package\ndisplayed in terminal" -index 0 -command {::Status {%t}} ::baltip::tip .t "There are two tags\nwith their own tips." -under 0 ::baltip::tip .t "1st tag's tip!" -tag UnderLine1 ::baltip::tip .t "2nd tag's tip!" -tag UnderLine2 ::baltip::tip .cb "Switches all tips on/off\nexcept for balloons with \"-on yes\"." ::baltip::tip .lb {::LbxTip %i} ::baltip::tip .tre {::TreTip %i %c} ;# per line & column +#::baltip::tip .lb {Listbox %i} -command {::SomeProc {%t}} +#::baltip::tip .tre {Treeview %i %c} -command {::SomeProc {%t}} ;# Fire some proc #::baltip::tip .tre {::TreTipId %i} ;# per line #::baltip::tip .tre {::TreTipC %c} ;# per column #::baltip::tip . "Testing tip for . path:\nsort of application tip.\n\nNot of much taste, though." diff --git a/bartabs/bartabs.tcl b/bartabs/bartabs.tcl index 72c4903..7b0c489 100644 --- a/bartabs/bartabs.tcl +++ b/bartabs/bartabs.tcl @@ -1585,7 +1585,7 @@ method _runBound_ {w ev args} { if {[catch {my {*}$args}]} { ;# failed binding => remove it foreach b [split [bind $w $ev] \n] { if {[string first $args $b]==-1} { - if {[incr is1]==1} {bind $w $ev $b} {bind $w $ev +$b} + if {[incr is1]==1} {bind $w $ev $b} {my bindToEvent $w $ev $b} } } } @@ -1955,6 +1955,18 @@ method closeAll {BID TID func args} { 3 {my $BID Tab_CloseFew $TID no} } } +#_______________________ + +method bindToEvent {w event args} { + # Binds an event on a widget to a command. + # w - the widget's path + # event - the event + # args - the command + + if {[string first $args [bind $w $event]]<0} { + bind $w $event [list + {*}$args] + } +} } ;# bartabs::Bar @@ -2080,7 +2092,7 @@ method create {barCom {barOpts ""} {tab1 ""}} { if {$wbase ne {}} { after 1 [list \ my $BID configure -BINDWBASE [list $wbase [bind $wbase ]] ; \ - bind $wbase [list + [self] _runBound_ $wbase $BID NeedDraw]] + my $BID bindToEvent $wbase [self] _runBound_ $wbase $BID NeedDraw] } if {!$noComm} { proc $barCom {args} "return \[[self] $BID {*}\$args\]" diff --git a/hl_tcl/hl_c.tcl b/hl_tcl/hl_c.tcl index a181bf7..9b40be6 100755 --- a/hl_tcl/hl_c.tcl +++ b/hl_tcl/hl_c.tcl @@ -582,7 +582,7 @@ proc ::hl_c::hl_init {txt args} { hl_readonly $txt $::hl_c::my::data(READONLY,$txt) } if {[string first ::hl_c:: [bind $txt]]<0} { - bind $txt [list + ::hl_c::my::ShowCurrentLine $txt] + ::hl_tcl::my::BindToEvent $txt ::hl_c::my::ShowCurrentLine $txt } set ::hl_c::my::data(_INSPOS_,$txt) {} my::MemPos $txt @@ -617,12 +617,12 @@ proc ::hl_c::hl_text {txt} { catch {$txt tag raise hilited; $txt tag raise hilited2} ;# for apave package my::HighlightAll $txt if {![info exists ::hl_c::my::data(BIND_TXT,$txt)]} { - bind $txt [list + ::hl_c::my::MemPos $txt] - bind $txt [list + ::hl_c::my::MemPos1 $txt yes %K %s] - bind $txt [list + ::hl_c::my::MemPos $txt] - bind $txt [list + ::hl_c::my::MemPos $txt] + ::hl_tcl::my::BindToEvent $txt ::hl_c::my::MemPos $txt + ::hl_tcl::my::BindToEvent $txt ::hl_c::my::MemPos1 $txt yes %K %s + ::hl_tcl::my::BindToEvent $txt ::hl_c::my::MemPos $txt + ::hl_tcl::my::BindToEvent $txt ::hl_c::my::MemPos $txt foreach ev {Enter KeyRelease ButtonRelease-1} { - bind $txt <$ev> [list + ::hl_tcl::my::HighlightBrackets $txt] + ::hl_tcl::my::BindToEvent $txt <$ev> ::hl_tcl::my::HighlightBrackets $txt } set ::hl_c::my::data(BIND_TXT,$txt) yes } diff --git a/hl_tcl/hl_tcl.tcl b/hl_tcl/hl_tcl.tcl index 2d3bdce..afadc0d 100755 --- a/hl_tcl/hl_tcl.tcl +++ b/hl_tcl/hl_tcl.tcl @@ -7,7 +7,7 @@ # License: MIT. ########################################################### -package provide hl_tcl 0.9.27 +package provide hl_tcl 0.9.28 # ______________________ Common data ____________________ # @@ -75,7 +75,7 @@ namespace eval ::hl_tcl { set data(RE0) {(^|[\{\}\[;])+\s*([:\w*]+)(\s|\]|\}|\\|$)} set data(RE1) {([\{\}\[;])+\s*([:\w*]+)(\s|\]|\}|\\|$)} - set data(RE5) {(^|[^\\])(\[|\]|\$|\{|\})+} + set data(RE5) {(^|[^\\])(\[|\]|\$|\{|\})} set data(LBR) {\{(\[} set data(RBR) {\})\]} @@ -248,10 +248,11 @@ proc ::hl_tcl::my::HighlightStr {txt p1 p2} { lassign $lc i1 i2 incr i2 while {$i1<$i2} { + incr i1 if {[string first [string index $st $i1] "\[\]\$\{\}"]>-1} { - $txt tag add tagVAR "$p1 +$i1 char" "$p1 +$i2 char" + set i12 [expr {$i1+1}] + $txt tag add tagVAR "$p1 +$i1 char" "$p1 +$i12 char" } - incr i1 } } return @@ -394,6 +395,18 @@ proc ::hl_tcl::my::CoroHighlightAll {txt} { set ::hl_tcl::my::data(REG_TXT,$txt) {1} return } +#_____ + +proc ::hl_tcl::my::BindToEvent {w event args} { + # Binds an event on a widget to a command. + # w - the widget's path + # event - the event + # args - the command + + if {[string first $args [bind $w $event]]<0} { + bind $w $event [list + {*}$args] + } +} # _________________________ DYNAMIC highlighting ________________________ # @@ -1017,7 +1030,7 @@ proc ::hl_tcl::hl_init {txt args} { hl_readonly $txt $::hl_tcl::my::data(READONLY,$txt) } if {[string first ::hl_tcl:: [bind $txt]]<0} { - bind $txt [list + ::hl_tcl::my::ShowCurrentLine $txt] + my::BindToEvent $txt ::hl_tcl::my::ShowCurrentLine $txt } set ::hl_tcl::my::data(_INSPOS_,$txt) {} my::MemPos $txt @@ -1051,12 +1064,12 @@ proc ::hl_tcl::hl_text {txt} { catch {$txt tag raise hilited; $txt tag raise hilited2} ;# for apave package my::HighlightAll $txt if {![info exists ::hl_tcl::my::data(BIND_TXT,$txt)]} { - bind $txt [list + ::hl_tcl::my::MemPos $txt] - bind $txt [list + ::hl_tcl::my::MemPos1 $txt yes %K %s] - bind $txt [list + ::hl_tcl::my::MemPos $txt] - bind $txt [list + ::hl_tcl::my::MemPos $txt] + my::BindToEvent $txt ::hl_tcl::my::MemPos $txt + my::BindToEvent $txt ::hl_tcl::my::MemPos1 $txt yes %K %s + my::BindToEvent $txt ::hl_tcl::my::MemPos $txt + my::BindToEvent $txt ::hl_tcl::my::MemPos $txt foreach ev {Enter KeyRelease ButtonRelease-1} { - bind $txt <$ev> [list + ::hl_tcl::my::HighlightBrackets $txt] + my::BindToEvent $txt <$ev> ::hl_tcl::my::HighlightBrackets $txt } set ::hl_tcl::my::data(BIND_TXT,$txt) yes } diff --git a/hl_tcl/pkgIndex.tcl b/hl_tcl/pkgIndex.tcl index 8f55810..ef61dd1 100644 --- a/hl_tcl/pkgIndex.tcl +++ b/hl_tcl/pkgIndex.tcl @@ -1,5 +1,5 @@ -package ifneeded hl_tcl 0.9.27 [list source [file join $dir hl_tcl.tcl]] +package ifneeded hl_tcl 0.9.28 [list source [file join $dir hl_tcl.tcl]] # short intro (for Ruff! docs generator) diff --git a/obbit.tcl b/obbit.tcl index 876886f..6aed342 100644 --- a/obbit.tcl +++ b/obbit.tcl @@ -119,7 +119,7 @@ namespace eval ::apave { } } -# _____________________________ Misc procs ________________________________ # +# _____________________________ Common procs ________________________________ # proc ::iswindows {} { @@ -132,8 +132,7 @@ proc ::islinux {} { # Checks if the platform is Linux. return [expr {$::tcl_platform(platform) eq "unix"} ? 1: 0] } - -######################################################################### +#_______________________ proc ::apave::mc {msg} { # Gets a localized version of a message. @@ -143,8 +142,110 @@ proc ::apave::mc {msg} { if {[info exists _MC_($msg)]} {return $_MC_($msg)} return $msg } +#_______________________ + +proc ::apave::getN {sn {defn 0} {min ""} {max ""}} { + + # Gets a number from a string + # sn - string containing a number + # defn - default value when sn is not a number + # min - minimal value allowed + # max - maximal value allowed + + if {$sn eq "" || [catch {set sn [expr {$sn}]}]} {set sn $defn} + if {$max ne ""} { + set sn [expr {min($max,$sn)}] + } + if {$min ne ""} { + set sn [expr {max($min,$sn)}] + } + return $sn +} +#_______________________ + +proc ::apave::openDoc {url} { + + # Opens a document. + # url - document's file name, www link, e-mail etc. + + set commands {xdg-open open start} + foreach opener $commands { + if {$opener eq "start"} { + set command [list {*}[auto_execok start] {}] + } else { + set command [auto_execok $opener] + } + if {[string length $command]} { + break + } + } + if {[string length $command] == 0} { + puts "ERROR: couldn't find any opener" + } + # remove the tailing " &" (as e_menu can set) + set url [string trimright $url] + if {[string match "* &" $url]} {set url [string range $url 0 end-2]} + set url [string trim $url] + if {[catch {exec {*}$command $url &} error]} { + puts "ERROR: couldn't execute '$command':\n$error" + } +} +#_______________________ + +proc ::apave::countChar {str ch} { + # Counts a character in a string. + # str - a string + # ch - a character + # + # Returns a number of non-escaped occurences of character *ch* in + # string *str*. + # + # See also: + # [wiki.tcl-lang.org](https://wiki.tcl-lang.org/page/Reformatting+Tcl+code+indentation) + + set icnt 0 + while {[set idx [string first $ch $str]] >= 0} { + set backslashes 0 + set nidx $idx + while {[string equal [string index $str [incr nidx -1]] \\]} { + incr backslashes + } + if {$backslashes % 2 == 0} { incr icnt } + set str [string range $str [incr idx] end] + } + return $icnt +} +#_______________________ + +proc ::apave::blinkWidget {w {fg #000} {bg #fff} {fg2 {}} {bg2 red} \ + {pause 1000} {count -1} {mode 1}} { + # Makes a widget blink. + # w - the widget's path + # fg - normal foreground color + # bg - normal background color + # fg2 - blinking foreground color (if {}, stops the blinking) + # bg2 - blinking background color + # pause - pause in millisec between blinkings + # count - means how many times do blinking + # mode - for recursive calls + + if {![winfo exists $w]} return + if {$count==0 || $fg2 eq {}} { + $w configure -foreground $fg + $w configure -background $bg + } elseif {$mode==1} { + incr count -1 + $w configure -foreground $fg2 + $w configure -background $bg2 + after $pause ::apave::blinkWidget $w $fg $bg $fg2 $bg2 $pause $count 2 + } elseif {$mode==2} { + $w configure -foreground $fg + $w configure -background $bg + after $pause ::apave::blinkWidget $w $fg $bg $fg2 $bg2 $pause $count 1 + } +} -######################################################################### +## ________________________ Inits _________________________ ## proc ::apave::initPOP {w} { @@ -160,8 +261,7 @@ proc ::apave::initPOP {w} { } } } - -######################################################################### +#_______________________ proc ::apave::initStyles {} { @@ -194,8 +294,7 @@ proc ::apave::initStyles {} { ttk::style map TMenuButtonWest {*}[ttk::style map TMenubutton] ttk::style layout TMenuButtonWest [ttk::style layout TMenubutton] } - -######################################################################### +#_______________________ proc ::apave::initStylesFS {args} { @@ -241,8 +340,7 @@ proc ::apave::initStylesFS {args} { ttk::style map TButtonWestBoldFS {*}[ttk::style map TButton] ttk::style layout TButtonWestBoldFS [ttk::style layout TButton] } - -######################################################################### +#_______________________ proc ::apave::initWM {args} { @@ -295,8 +393,7 @@ proc ::apave::initWM {args} { initStyles return } - -######################################################################### +#_______________________ proc ::apave::cs_Active {{flag ""}} { @@ -308,7 +405,46 @@ proc ::apave::cs_Active {{flag ""}} { return $::apave::_CS_(isActive) } -######################################################################### +## ________________________ Property _________________________ ## + +proc ::apave::setProperty {name args} { + + # Sets a property's value as "application-wide". + # name - name of property + # args - value of property + # + # If *args* is omitted, the method returns a property's value. + # + # If *args* is set, the method sets a property's value as $args. + + variable _AP_Properties + switch [llength $args] { + 0 {return [getProperty $name]} + 1 {return [set _AP_Properties($name) [lindex $args 0]]} + } + puts -nonewline stderr \ + "Wrong # args: should be \"::apave::setProperty propertyname ?value?\"" + return -code error +} +#_______________________ + +proc ::apave::getProperty {name {defvalue ""}} { + # Gets a property's value as "application-wide". + # name - name of property + # defvalue - default value + # + # If the property had been set, the method returns its value. + # + # Otherwise, the method returns the default value (`$defvalue`). + + variable _AP_Properties + if {[info exists _AP_Properties($name)]} { + return $_AP_Properties($name) + } + return $defvalue +} + +## ________________________ Color schemes _________________________ ## proc ::apave::cs_Non {} { @@ -316,8 +452,7 @@ proc ::apave::cs_Non {} { return -3 } - -######################################################################### +#_______________________ proc ::apave::cs_Min {} { @@ -340,27 +475,7 @@ proc ::apave::cs_MaxBasic {} { return $::apave::_CS_(STDCS) } -########################################################################### - -proc ::apave::getN {sn {defn 0} {min ""} {max ""}} { - - # Gets a number from a string - # sn - string containing a number - # defn - default value when sn is not a number - # min - minimal value allowed - # max - maximal value allowed - - if {$sn eq "" || [catch {set sn [expr {$sn}]}]} {set sn $defn} - if {$max ne ""} { - set sn [expr {min($max,$sn)}] - } - if {$min ne ""} { - set sn [expr {max($min,$sn)}] - } - return $sn -} - -########################################################################### +## ________________________ Opfions _________________________ ## proc ::apave::parseOptionsFile {strict inpargs args} { @@ -441,8 +556,7 @@ proc ::apave::parseOptionsFile {strict inpargs args} { } return [list $retlist [string trimright $retfile]] } - -########################################################################### +#_______________________ proc ::apave::parseOptions {opts args} { @@ -462,8 +576,7 @@ proc ::apave::parseOptions {opts args} { } return $retlist } - -########################################################################### +#_______________________ proc ::apave::extractOptions {optsVar args} { @@ -482,8 +595,7 @@ proc ::apave::extractOptions {optsVar args} { } return $retlist } - -########################################################################### +#_______________________ proc ::apave::getOption {optname args} { @@ -498,8 +610,7 @@ proc ::apave::getOption {optname args} { set optvalue [lindex [::apave::parseOptions $args $optname ""] 0] return $optvalue } - -########################################################################### +#_______________________ proc ::apave::putOption {optname optvalue args} { @@ -521,8 +632,7 @@ proc ::apave::putOption {optname optvalue args} { if {$doadd} {lappend optlist $optname $optvalue} return $optlist } - -######################################################################### +#_______________________ proc ::apave::removeOptions {options args} { @@ -553,7 +663,7 @@ proc ::apave::removeOptions {options args} { return $options } -########################################################################### +## ________________________ Text file _________________________ ## proc ::apave::error {{fileName ""}} { # Gets the error's message at reading/writing. @@ -565,8 +675,7 @@ proc ::apave::error {{fileName ""}} { } return "Error of access to\n\"$fileName\"\n\n$_PU_opts(_ERROR_)" } - -########################################################################### +#_______________________ proc ::apave::textsplit {textcont} { # Splits a text's contents by EOLs. Those inventors of EOLs... @@ -574,8 +683,7 @@ proc ::apave::textsplit {textcont} { return [split [string map [list \r\n \n \r \n] $textcont] \n] } - -########################################################################### +#_______________________ proc ::apave::textEOL {{EOL "-"}} { # Gets/sets End-of-Line for text reqding/writing. @@ -609,8 +717,7 @@ proc ::apave::textChanConfigure {channel {coding {}} {eol {}}} { chan configure $channel -translation $eol } } - -########################################################################### +#_______________________ proc ::apave::logName {fname} { # Sets a log file's name. @@ -620,8 +727,7 @@ proc ::apave::logName {fname} { variable _PU_opts; set _PU_opts(_LOGFILE_) [file normalize $fname] } - -########################################################################### +#_______________________ proc ::apave::logMessage {msg} { # Logs messages to a log file. @@ -645,8 +751,7 @@ proc ::apave::logMessage {msg} { close $chan puts "$_PU_opts(_LOGFILE_) - $msg" } - -########################################################################### +#_______________________ proc ::apave::readTextFile {fileName {varName ""} {doErr 0}} { @@ -670,159 +775,75 @@ proc ::apave::readTextFile {fileName {varName ""} {doErr 0}} { } return $fvar } +#_______________________ -########################################################################### - -proc ::apave::writeTextFile {fileName {varName ""} {doErr 0}} { +proc ::apave::writeTextFile {fileName {varName ""} {doErr 0} {doSave 1}} { # Writes to a text file. # fileName - file name # varName - variable name for file content or "" # doErr - if 'true', exit at errors with error message + # doSave - if 'true', saves an empty file, else deletes it # # Returns "yes" if the file was saved successfully. variable _PU_opts - if {$varName ne ""} { + if {$varName ne {}} { upvar $varName contents } else { - set contents "" + set contents {} } - if {[catch {set chan [open $fileName w]} _PU_opts(_ERROR_)]} { - if {$doErr} {error [::apave::error $fileName]} + set res yes + if {!$doSave && [string trim $contents] eq {}} { + if {[catch {file delete $fileName} _PU_opts(_ERROR_)]} { + set res no + } else { + logMessage "delete $fileName" + } + } elseif {[catch {set chan [open $fileName w]} _PU_opts(_ERROR_)]} { set res no } else { ::apave::textChanConfigure $chan puts -nonewline $chan $contents close $chan logMessage "write $fileName" - set res yes } + if {!$res && $doErr} {error [::apave::error $fileName]} return $res } -########################################################################### - -proc ::apave::openDoc {url} { - - # Opens a document. - # url - document's file name, www link, e-mail etc. - - set commands {xdg-open open start} - foreach opener $commands { - if {$opener eq "start"} { - set command [list {*}[auto_execok start] {}] - } else { - set command [auto_execok $opener] - } - if {[string length $command]} { - break - } - } - if {[string length $command] == 0} { - puts "ERROR: couldn't find any opener" - } - # remove the tailing " &" (as e_menu can set) - set url [string trimright $url] - if {[string match "* &" $url]} {set url [string range $url 0 end-2]} - set url [string trim $url] - if {[catch {exec {*}$command $url &} error]} { - puts "ERROR: couldn't execute '$command':\n$error" - } -} - -########################################################################### - -proc ::apave::setProperty {name args} { - - # Sets a property's value as "application-wide". - # name - name of property - # args - value of property - # - # If *args* is omitted, the method returns a property's value. - # - # If *args* is set, the method sets a property's value as $args. +## ________________________ Binds _________________________ ## - variable _AP_Properties - switch [llength $args] { - 0 {return [getProperty $name]} - 1 {return [set _AP_Properties($name) [lindex $args 0]]} - } - puts -nonewline stderr \ - "Wrong # args: should be \"::apave::setProperty propertyname ?value?\"" - return -code error -} +proc ::apave::bindToEvent {w event args} { -proc ::apave::getProperty {name {defvalue ""}} { - # Gets a property's value as "application-wide". - # name - name of property - # defvalue - default value - # - # If the property had been set, the method returns its value. - # - # Otherwise, the method returns the default value (`$defvalue`). + # Binds an event on a widget to a command. + # w - the widget's path + # event - the event + # args - the command - variable _AP_Properties - if {[info exists _AP_Properties($name)]} { - return $_AP_Properties($name) - } - return $defvalue + ::baltip::my::BindToEvent $w $event {*}$args } +#_______________________ -########################################################################### - -proc ::apave::countChar {str ch} { - # Counts a character in a string. - # str - a string - # ch - a character - # - # Returns a number of non-escaped occurences of character *ch* in - # string *str*. - # - # See also: - # [wiki.tcl-lang.org](https://wiki.tcl-lang.org/page/Reformatting+Tcl+code+indentation) +proc ::apave::bindTextagToEvent {w tag event args} { + # Binds an event on a text tag to a command. + # w - the widget's path + # tag - the tag + # event - the event + # args - the command - set icnt 0 - while {[set idx [string first $ch $str]] >= 0} { - set backslashes 0 - set nidx $idx - while {[string equal [string index $str [incr nidx -1]] \\]} { - incr backslashes - } - if {$backslashes % 2 == 0} { incr icnt } - set str [string range $str [incr idx] end] - } - return $icnt + ::baltip::my::BindTextagToEvent $w $tag $event {*}$args } +#_______________________ -########################################################################### - -proc ::apave::blinkWidget {w {fg #000} {bg #fff} {fg2 {}} {bg2 red} \ - {pause 1000} {count -1} {mode 1}} { - # Makes a widget blink. +proc ::apave::bindCantagToEvent {w tag event args} { + # Binds an event on a canvas tag to a command. # w - the widget's path - # fg - normal foreground color - # bg - normal background color - # fg2 - blinking foreground color (if {}, stops the blinking) - # bg2 - blinking background color - # pause - pause in millisec between blinkings - # count - means how many times do blinking - # mode - for recursive calls + # tag - the tag + # event - the event + # args - the command - if {![winfo exists $w]} return - if {$count==0 || $fg2 eq {}} { - $w configure -foreground $fg - $w configure -background $bg - } elseif {$mode==1} { - incr count -1 - $w configure -foreground $fg2 - $w configure -background $bg2 - after $pause ::apave::blinkWidget $w $fg $bg $fg2 $bg2 $pause $count 2 - } elseif {$mode==2} { - $w configure -foreground $fg - $w configure -background $bg - after $pause ::apave::blinkWidget $w $fg $bg $fg2 $bg2 $pause $count 1 - } + ::baltip::my::BindCantagToEvent $w $tag $event {*}$args } # ________________________ ObjectProperty _________________________ # @@ -881,8 +902,7 @@ oo::class create ::apave::ObjectProperty { "Wrong # args: should be \"[namespace current] setProperty propertyname ?value?\"" return -code error } - - ########################################################################### + #_______________________ method getProperty {name {defvalue ""}} { # Gets an property's value as "object-wide". @@ -899,30 +919,30 @@ oo::class create ::apave::ObjectProperty { return $defvalue } - - ## _________________ End of ::apave::ObjectProperty _________________ ## + ## _________________ EONS ObjectProperty _________________ ## } - # ________________________ ObjectTheming _________________________ # -# Another bit - theming manager oo::class create ::apave::ObjectTheming { mixin ::apave::ObjectProperty +## ________________________ Inits _________________________ ## + constructor {args} { + my InitCS # ObjectTheming can play solo or be a mixin if {[llength [self next]]} { next {*}$args } } + #_______________________ destructor { if {[llength [self next]]} next } - - ########################################################################### + #_______________________ method InitCS {} { @@ -938,7 +958,7 @@ oo::class create ::apave::ObjectTheming { return } - ########################################################################### +## ________________________ Fonts _________________________ ## method create_FontsType {type args} { # Creates fonts used in apave, with additional options. @@ -954,8 +974,7 @@ oo::class create ::apave::ObjectTheming { font create $name2 -family $::apave::_CS_(textFont) -size $::apave::_CS_(fs) {*}$args return [list $name1 $name2] } - - ########################################################################### + #_______________________ method create_Fonts {} { # Creates fonts used in apave. @@ -971,58 +990,7 @@ oo::class create ::apave::ObjectTheming { set ::apave::FONTMAIN "[font actual apaveFontDef]" set ::apave::FONTMAINBOLD "[font actual apaveFontDefBold]" } - - ########################################################################### - - method ColorScheme {{ncolor ""}} { - - # Gets a full record of color scheme from a list of available ones - # ncolor - index of color scheme - - if {"$ncolor" eq "" || $ncolor<0} { - # basic color scheme: get colors from a current ttk::style colors - set fW black - set bW #FBFB95 - set bg2 #d8d8d8 - if {[info exists ::apave::_CS_(def_fg)]} { - if {$ncolor == $::apave::_CS_(NONCS)} {set bg2 #e5e5e5} - set fg $::apave::_CS_(def_fg) - set fg2 #2b3f55 - set bg $::apave::_CS_(def_bg) - set fS $::apave::_CS_(def_fS) - set bS $::apave::_CS_(def_bS) - set bA $::apave::_CS_(def_bA) - } else { - set ::apave::_CS_(index) $::apave::_CS_(NONCS) - lassign [::apave::parseOptions [ttk::style configure .] \ - -foreground #000000 -background #d9d9d9 -troughcolor #c3c3c3] fg bg tc - set fS $::apave::_CS_(!FG) - set bS $::apave::_CS_(!BG) - lassign [::apave::parseOptions [ttk::style map . -background] \ - disabled #d9d9d9 active #ececec] bD bA - if {$bA eq {#ececec}} {set bA #ffffff} - lassign [::apave::parseOptions [ttk::style map . -foreground] \ - disabled #a3a3a3] fD - lassign [::apave::parseOptions [ttk::style map . -selectbackground] \ - !focus #9e9a91] bclr - set ::apave::_CS_(def_fg) [set fg2 $fg] - set ::apave::_CS_(def_bg) $bg - set ::apave::_CS_(def_fS) $fS - set ::apave::_CS_(def_bS) $bS - set ::apave::_CS_(def_fD) $fD - set ::apave::_CS_(def_bD) $bD - set ::apave::_CS_(def_bA) $bA - set ::apave::_CS_(def_tc) $tc - set ::apave::_CS_(def_bclr) $bclr - } - return [list default \ - $fg $fg $bA $bg $fg2 $bS $fS #444 grey #4f6379 $fS $bS - $bg $fW $bW $bg2] - # clrtitf clrinaf clrtitb clrinab clrhelp clractb clractf clrcurs clrgrey clrhotk fI bI fM bM fW bW - } - return [lindex $::apave::_CS_(ALL) $ncolor] - } - -# _______________________________________________________________________ # + #_______________________ method basicFontSize {{fs 0} {ds 0}} { @@ -1041,8 +1009,7 @@ oo::class create ::apave::ObjectTheming { return [expr {$::apave::_CS_(fs) + $ds}] } } - - ########################################################################### + #_______________________ method basicDefFont {{deffont ""}} { @@ -1058,20 +1025,7 @@ oo::class create ::apave::ObjectTheming { return $::apave::_CS_(defFont) } } - - ########################################################################### - - method boldDefFont {{fs 0}} { - - # Returns a bold default font. - # fs - font size - - if {$fs == 0} {set fs [my basicFontSize]} - set bf [font actual basicDefFont] - return [dict replace $bf -family [my basicDefFont] -weight bold -size $fs] - } - - ########################################################################### + #_______________________ method basicTextFont {{textfont ""}} { @@ -1087,8 +1041,18 @@ oo::class create ::apave::ObjectTheming { return $::apave::_CS_(textFont) } } + #_______________________ + + method boldDefFont {{fs 0}} { + + # Returns a bold default font. + # fs - font size - ########################################################################### + if {$fs == 0} {set fs [my basicFontSize]} + set bf [font actual basicDefFont] + return [dict replace $bf -family [my basicDefFont] -weight bold -size $fs] + } + #_______________________ method boldTextFont {{fs 0}} { @@ -1100,7 +1064,7 @@ oo::class create ::apave::ObjectTheming { return [dict replace $bf -family [my basicTextFont] -weight bold -size $fs] } - ########################################################################### +## ________________________ Color schemes _________________________ ## method csFont {fontname} { # Returns attributes of CS font. @@ -1120,8 +1084,7 @@ oo::class create ::apave::ObjectTheming { # Returns attributes of CS default font. return [my csFont apaveFontDef] } - - ########################################################################### + #_______________________ method csDarkEdit {{cs -3}} { @@ -1133,8 +1096,7 @@ oo::class create ::apave::ObjectTheming { if {$cs==$cstoned} {set cs $csbasic} return [expr {$cs>22}] } - - ########################################################################### + #_______________________ method csExport {} { @@ -1149,8 +1111,7 @@ oo::class create ::apave::ObjectTheming { } return $theme } - - ########################################################################### + #_______________________ method csCurrent {} { @@ -1158,8 +1119,7 @@ oo::class create ::apave::ObjectTheming { return $::apave::_CS_(index) } - - ########################################################################### + #_______________________ method csGetName {{ncolor 0}} { @@ -1173,8 +1133,7 @@ oo::class create ::apave::ObjectTheming { } return [lindex [my ColorScheme $ncolor] 0] } - - ########################################################################### + #_______________________ method csGet {{ncolor ""}} { @@ -1184,8 +1143,7 @@ oo::class create ::apave::ObjectTheming { if {$ncolor eq ""} {set ncolor [my csCurrent]} return [lrange [my ColorScheme $ncolor] 1 end] } - - ########################################################################### + #_______________________ method csSet {{ncolor 0} {win .} args} { @@ -1257,8 +1215,7 @@ oo::class create ::apave::ObjectTheming { } return [list $fg $bg $fE $bE $fS $bS $hh $grey $cc $ht $tfgI $tbgI $fM $bM $tfgW $tbgW $tHL2 $tbHL $chkHL $res5 $res6 $res7] } - - ########################################################################### + #_______________________ method csAdd {newcs {setnew true}} { @@ -1296,8 +1253,7 @@ oo::class create ::apave::ObjectTheming { if {$setnew} {set ::apave::_CS_(index) [set ::apave::_CS_(old) $found]} return [my csCurrent] } - - ########################################################################### + #_______________________ method csDeleteExternal {} { # Removes all external CS. @@ -1305,8 +1261,7 @@ oo::class create ::apave::ObjectTheming { set ::apave::_CS_(ALL) [lreplace $::apave::_CS_(ALL) 48 end] } - - ########################################################################### + #_______________________ method csToned {cs hue} { # Make an external CS that has tones (hues) of colors for a CS. @@ -1344,6 +1299,99 @@ oo::class create ::apave::ObjectTheming { # _______________________________________________________________________ # + method csMainColors {} { + # Returns a list of main colors' indices of CS. + # See also: csMapTheme + + return [list 0 1 2 3 5 10 11 13 16] + } + #_______________________ + + method csMapTheme {} { + # Returns a map of CS / themeWindow method colors. + # + # The map is a list of indices in CS corresponding to themeWindow's args. + # + # CS record is: + # 0-itemfg 1-mainfg 2-itembg 3-mainbg 4-itemsHL 5-actbg 6-actfg 7-cursor 8-greyed 9-hot \ + 10-emfg 11-embg 12-- 13-menubg 14-winfg 15-winbg 16-itemHL2 ...reserved... + # + # See also: themeWindow + + return [list 1 3 0 2 6 5 8 3 7 9 4 10 11 1 13 14 15 16 17 18 19 20 21] + } + +# ________________________ Theming _________________________ # + +## ________________________ Common procs _________________________ ## + + method ColorScheme {{ncolor ""}} { + # Gets a full record of color scheme from a list of available ones + # ncolor - index of color scheme + + if {"$ncolor" eq "" || $ncolor<0} { + # basic color scheme: get colors from a current ttk::style colors + set fW black + set bW #FBFB95 + set bg2 #d8d8d8 + if {[info exists ::apave::_CS_(def_fg)]} { + if {$ncolor == $::apave::_CS_(NONCS)} {set bg2 #e5e5e5} + set fg $::apave::_CS_(def_fg) + set fg2 #2b3f55 + set bg $::apave::_CS_(def_bg) + set fS $::apave::_CS_(def_fS) + set bS $::apave::_CS_(def_bS) + set bA $::apave::_CS_(def_bA) + } else { + set ::apave::_CS_(index) $::apave::_CS_(NONCS) + lassign [::apave::parseOptions [ttk::style configure .] \ + -foreground #000000 -background #d9d9d9 -troughcolor #c3c3c3] fg bg tc + set fS $::apave::_CS_(!FG) + set bS $::apave::_CS_(!BG) + lassign [::apave::parseOptions [ttk::style map . -background] \ + disabled #d9d9d9 active #ececec] bD bA + if {$bA eq {#ececec}} {set bA #ffffff} + lassign [::apave::parseOptions [ttk::style map . -foreground] \ + disabled #a3a3a3] fD + lassign [::apave::parseOptions [ttk::style map . -selectbackground] \ + !focus #9e9a91] bclr + set ::apave::_CS_(def_fg) [set fg2 $fg] + set ::apave::_CS_(def_bg) $bg + set ::apave::_CS_(def_fS) $fS + set ::apave::_CS_(def_bS) $bS + set ::apave::_CS_(def_fD) $fD + set ::apave::_CS_(def_bD) $bD + set ::apave::_CS_(def_bA) $bA + set ::apave::_CS_(def_tc) $tc + set ::apave::_CS_(def_bclr) $bclr + } + return [list default \ + $fg $fg $bA $bg $fg2 $bS $fS #444 grey #4f6379 $fS $bS - $bg $fW $bW $bg2] + # clrtitf clrinaf clrtitb clrinab clrhelp clractb clractf clrcurs clrgrey clrhotk fI bI fM bM fW bW + } + return [lindex $::apave::_CS_(ALL) $ncolor] + } + +# _______________________________________________________________________ # + + method UpdateSelectAttrs {w} { + + # Updates attributes for selection. + # w - window's name + # Some widgets (e.g. listbox) need a work-around to set + # attributes for selection in run-time, namely at focusing in/out. + + set fD $::apave::_CS_(!FG) + set bD $::apave::_CS_(!BG) + set f -selectforeground + set b -selectbackground + lassign [::apave::parseOptions [ttk::style configure .] $f $fD $b $bD] fS bS + ::apave::bindToEvent $w $w configure $f $fS $b $bS + ::apave::bindToEvent $w $w configure $f $fD $b $bD + return + } + #_______________________ + method Ttk_style {oper ts opt val} { # Sets a new style options. @@ -1370,33 +1418,7 @@ oo::class create ::apave::ObjectTheming { } return } - - ########################################################################### - - method csMainColors {} { - # Returns a list of main colors' indices of CS. - # See also: csMapTheme - - return [list 0 1 2 3 5 10 11 13 16] - } - - ########################################################################### - - method csMapTheme {} { - # Returns a map of CS / themeWindow method colors. - # - # The map is a list of indices in CS corresponding to themeWindow's args. - # - # CS record is: - # 0-itemfg 1-mainfg 2-itembg 3-mainbg 4-itemsHL 5-actbg 6-actfg 7-cursor 8-greyed 9-hot \ - 10-emfg 11-embg 12-- 13-menubg 14-winfg 15-winbg 16-itemHL2 ...reserved... - # - # See also: themeWindow - - return [list 1 3 0 2 6 5 8 3 7 9 4 10 11 1 13 14 15 16 17 18 19 20 21] - } - - ########################################################################### + #_______________________ method apaveTheme {{theme {}}} { # Checks if apave color scheme is used (always for standard ttk themes). @@ -1405,11 +1427,20 @@ oo::class create ::apave::ObjectTheming { if {$theme eq {}} {set theme [ttk::style theme use]} return [expr {$theme in {clam alt classic default awdark awlight}}] } + #_______________________ + + method initTooltip {args} { + # Configurates colors and other attributes of tooltip. + # args - options of ::baltip::configure -# ________________________ theme window _________________________ # + lassign [lrange [my csGet] 14 15] fW bW + ::baltip config -fg $fW -bg $bW -global yes + ::baltip config {*}$args + return + } - ########################################################################### +## ________________________ Theme methods _________________________ ## method Main_Style {tfg1 tbg1 tfg2 tbg2 tfgS tbgS bclr tc fA bA bD} { @@ -1444,8 +1475,7 @@ oo::class create ::apave::ObjectTheming { -background [list disabled $bD active $bA] \ -foreground [list disabled grey active $fA] } - - ########################################################################### + #_______________________ method themeWindow {win {clrs ""} {isCS true} args} { @@ -1705,8 +1735,7 @@ oo::class create ::apave::ObjectTheming { my themeMandatory $win {*}$args return } - - ########################################################################### + #_______________________ method themeMandatory {win args} { @@ -1731,29 +1760,7 @@ oo::class create ::apave::ObjectTheming { my ThemeChoosers return } - - ########################################################################### - - method UpdateSelectAttrs {w} { - - # Updates attributes for selection. - # w - window's name - # Some widgets (e.g. listbox) need a work-around to set - # attributes for selection in run-time, namely at focusing in/out. - - if { [string first "-selectforeground" [bind $w ""]] < 0} { - set com "lassign \[::apave::parseOptions \[ttk::style configure .\] \ - -selectforeground $::apave::_CS_(!FG) \ - -selectbackground $::apave::_CS_(!BG)\] fS bS;" - bind $w "+ $com $w configure \ - -selectforeground \$fS -selectbackground \$bS" - bind $w "+ $w configure -selectforeground \ - $::apave::_CS_(!FG) -selectbackground $::apave::_CS_(!BG)" - } - return - } - - ########################################################################### + #_______________________ method untouchWidgets {args} { @@ -1771,8 +1778,18 @@ oo::class create ::apave::ObjectTheming { } } } + #_______________________ + + method themeExternal {args} { + # Configures an external dialogue so that its colors accord with a current CS. + # args - list of untouched widgets - ########################################################################### + if {[set cs [my csCurrent]] != -2} { + foreach untw $args {my untouchWidgets $untw} + after idle [list [self] csSet $cs . -doit] ;# theme the dialogue to be run + } + } + #_______________________ method themeNonThemed {win {addwid {}}} { @@ -1820,8 +1837,7 @@ oo::class create ::apave::ObjectTheming { } return } - - ########################################################################### + #_______________________ method NonThemedWidgets {selector} { @@ -1841,8 +1857,7 @@ oo::class create ::apave::ObjectTheming { menu menubutton checkbutton radiobutton frame labelframe scale \ scrollbar canvas tablelist tmatchbox] } - - ########################################################################### + #_______________________ method NonTtkTheme {win} { @@ -1874,11 +1889,9 @@ oo::class create ::apave::ObjectTheming { } return } - - ########################################################################### + #_______________________ method NonTtkStyle {typ {dsbl 0}} { - # Makes styling for non-ttk widgets. # typ - widget's type (the same as in "APave::widgetType" method) # dsbl - `1` for disabled; `2` for readonly; otherwise for all widgets @@ -1962,7 +1975,8 @@ oo::class create ::apave::ObjectTheming { return $att } -# _______________________________________________________________________ # + +## ________________________ Popup menus _________________________ ## method ThemePopup {mnu args} { @@ -1985,8 +1999,7 @@ oo::class create ::apave::ObjectTheming { } } } - - ########################################################################### + #_______________________ method themePopup {mnu} { @@ -2004,21 +2017,7 @@ oo::class create ::apave::ObjectTheming { my themeNonThemed $mnu $mnu } - ########################################################################### - - method initTooltip {args} { - - # Configurates colors and other attributes of tooltip. - # args - options of ::baltip::configure - - if {[info commands ::baltip::configure] eq ""} {package require baltip} - lassign [lrange [my csGet] 14 15] fW bW - ::baltip config -fg $fW -bg $bW -global yes - ::baltip config {*}$args - return - } - - ########################################################################### +## ________________________ Tk choosers _________________________ ## method ThemeChoosers {} { @@ -2066,25 +2065,13 @@ oo::class create ::apave::ObjectTheming { } } - ########################################################################### - - method themeExternal {args} { - # Configures an external dialogue so that its colors accord with a current CS. - # args - list of untouched widgets - - if {[set cs [my csCurrent]] != -2} { - foreach untw $args {my untouchWidgets $untw} - after idle [list [self] csSet $cs . -doit] ;# theme the dialogue to be run - } - } - - ## __________________ End of ::apave::ObjectTheming ___________________ ## + ## __________________ EONS ObjectTheming ___________________ ## } -################################# EOF ##################################### -#% DOCTEST SOURCE tests/obbit_1.test +# ___________________________________ EOF _____________________________________ # +#% DOCTEST SOURCE tests/obbit_1.test #RUNF1: ../../../src/alited.tcl LOG=~/TMP/alited-DEBUG.log DEBUG #-RUNF1: ./tests/test2_pave.tcl #RUNF1: ./tests/test2_pave.tcl 10 10 12 "small icons" diff --git a/pickers/klnd/klnd.tcl b/pickers/klnd/klnd.tcl index 344595c..fd18ef1 100755 --- a/pickers/klnd/klnd.tcl +++ b/pickers/klnd/klnd.tcl @@ -249,10 +249,10 @@ proc ::klnd::my::InitCalendar {args} { lassign [::apave::parseOptions $args \ -title {} -value {} -tvar {} -locale {} -parent {} -dateformat %D \ -weekday {} -centerme {} -geometry {} -entry {} -com {} -command {} \ - -currentmonth {} -united no -daylist {-} -hllist {} -popup {}] \ + -currentmonth {} -united no -daylist {-} -hllist {} -popup {} -tip {}] \ title datevalue tvar loc parent p(dformat) \ p(weekday) centerme geo entry com1 com2 \ - p(currentmonth) p(united) p(daylist) p(hllist) p(popup) + p(currentmonth) p(united) p(daylist) p(hllist) p(popup) p(tip) if {$com2 eq {}} {set p(com) $com1} {set p(com) $com2} # get localized week day names lassign [::klnd::weekdays $loc] p(days) p(weekday) @@ -287,6 +287,13 @@ proc ::klnd::my::InitCalendar {args} { proc ::klnd::my::MainWidgets {} { # Forms main widgets of calendar. + variable p + if {$p(tip) eq {}} { + set ::klnd::TMPTIP {} + } else { + set tip [string map [list \{ ( \} )] $p(tip)] ;# for a possible bad list + set ::klnd::TMPTIP "-tip {$tip}" + } return { {fra - - 1 7 {-st new} {}} \ {.fraTool - - 1 7 {-st new} {}} @@ -313,7 +320,7 @@ proc ::klnd::my::MainWidgets {} { if {$i<8} { set lwid "$cur $pw $p 1 1 {-st ew} {-anchor center -foreground $::klnd::my::p(fgh)}" } else { - set lwid "$cur $pw $p 1 1 {-st ew} {-relief flat -overrelief flat -bd 0 -takefocus 0 -padx 8 -pady 4 -font {$::apave::FONTMAIN} -com {::klnd::my::Enter [expr {$i-7}] 1} $att}" + set lwid "$cur $pw $p 1 1 {-st ew} {-relief flat -overrelief flat -bd 0 -takefocus 0 -padx 8 -pady 4 -font {$::apave::FONTMAIN} -com {::klnd::my::Enter [expr {$i-7}] 1} $::klnd::TMPTIP $att}" } %C $lwid set pr $cur @@ -403,7 +410,7 @@ proc ::klnd::clearArgs {args} { # Removes specific options from args. # args - list of options - return [::apave::removeOptions $args -title -value -tvar -locale -parent -dateformat -weekday -com -command -currentmonth -united -daylist -hllist -popup] + return [::apave::removeOptions $args -title -value -tvar -locale -parent -dateformat -weekday -com -command -currentmonth -united -daylist -hllist -popup -tip] } #_______________________ diff --git a/pickers/klnd/klnd2.tcl b/pickers/klnd/klnd2.tcl index d42a8c3..648d167 100755 --- a/pickers/klnd/klnd2.tcl +++ b/pickers/klnd/klnd2.tcl @@ -324,7 +324,7 @@ proc ::klnd::my::MainWidgets2 {obj ownname} { } else { lappend res \ "$ownname.fra.tool - - - - {pack -side top} {-array { \ - IM_KLND_0 {{::klnd::my::SetCurrentDay2 $obj} -tip {$::klnd::my::p(tipF3$obj)\n(F3)@@-under 5}} sev 6 \ + IM_KLND_0 {{::klnd::my::SetCurrentDay2 $obj} -tip {$::klnd::my::p(tipF3$obj)@@-under 5}} sev 6 \ IM_KLND_1 {{::klnd::my::GoYear2 $obj -1} -tip {$::klnd::my::prevY\n(Home)@@-under 5}} h_ 2 \ IM_KLND_2 {{::klnd::my::GoMonth2 $obj -1} -tip {$::klnd::my::prevM\n(PageUp)@@-under 5}} h_ 3 \ LabMonth$obj {{} {-fill x -expand 1} {-anchor center -w 14}} h_ 2 \ @@ -462,7 +462,7 @@ proc ::klnd::calendar2 {pobj w ownname args} { } # save options for current calendar foreach opt {weekday months days loc yvis mvis dvis \ - com tvar dformat united currentmonth daylist popup hllist} { + com tvar dformat united currentmonth daylist popup hllist tip} { set my::p($opt$obj) $my::p($opt) } if {$my::p(daylist) ne {-} && $my::p(united)} { diff --git a/pkgIndex.tcl b/pkgIndex.tcl index bc22382..346d64c 100644 --- a/pkgIndex.tcl +++ b/pkgIndex.tcl @@ -1,4 +1,4 @@ -package ifneeded apave 3.4.6b16 [list source [file join $dir apaveinput.tcl]] +package ifneeded apave 3.4.6b19 [list source [file join $dir apaveinput.tcl]] # A short intro (for Ruff! docs generator:) diff --git a/tests/test2_pave.tcl b/tests/test2_pave.tcl index 76ed96a..b0f6165 100644 --- a/tests/test2_pave.tcl +++ b/tests/test2_pave.tcl @@ -45,7 +45,7 @@ namespace eval t { variable pdlg variable pave variable savedtext; array set savedtext [list] - variable transpopsFile "transpops.txt" + variable transpopsFile "transpops1.txt" # _________________ The code from Tk's demos/ttkpane.tcl ________________ # @@ -277,6 +277,10 @@ namespace eval t { -pause 1500 -fade 1500 -alpha 0.8 -padx 20 -pady 20 } } + if {$tab in {nb4 nb5 nb6 nb7}} { + lassign [pave csGet] - fg - bg + ::apave::blinkWidget .win.fra.fra.$tab.labB $fg $bg $bg $fg 100 7 + } } } @@ -566,7 +570,7 @@ namespace eval t { set ::t::ansSelTab [set ::t::ansSwBta 0] set wbase [pave LfrB] set bar1Opts [list -wbar $wframe -wbase $wbase -lablen 16 -tiplen 20 \ - -csel {::t::selTab %t} -csel2 {::t::selTab2 %t} -bd 1 -expand 1 \ + -csel {::t::selTab %t} -csel2 {::t::selTab2 %t} -bd $::t::btsbd -expand 1 \ -cdel {::t::delTab %t} -redraw $::BTS_REDRAW -popuptip ::t::popupTip \ -menu [list \ sep \ @@ -1508,10 +1512,12 @@ set test2script $::t::ftx1 set ::t::opct clam if {$::argc>=5} { lassign $::argv ::t::opct ::t::newCS ::t::fontsz ::t::ans4 ::t::opcIcon ::t::hue - set ::t::transpopsFile "transpops.txt" + set ::t::transpopsFile "transpops2.txt" + set ::t::btsbd 0 } else { set ::t::newCS 27 ;# ForestDark CS set ::t::opcIcon "small" + set ::t::btsbd 1 } set ::t::opcThemes [list default clam classic alt] if {$::t::newCS!=-2 && ![catch {