ET 2023-12-27 cooltip 1.6
This is an upgrade to tooltip 1.6 found in the Tklib. It supports tips with 7 configurable color text tags and 3 styles. Another 9 extra tags can be configured by program control for advanced use. A separate GUI editor is included to build cool tips with style. Unicode up to \uFFFF is supported.
It is upwards compatible with existing tooltip code, as it uses the same namespace, tooltip:: and the same commands, including the configuration options from the latest tooltip version 1.6. The Tooltip 1.6 options for -index, -items, -tag, and -tab can be added as specified in the tooltip 1.6 manual.
Quick test drive:
See here for the documentation on tooltip 1.6: https://core.tcl-lang.org/tklib/doc/trunk/embedded/md/tklib/files/modules/tooltip/tooltip.md
Cooltip is bundled with a GUI tip builder to build more stylish tips. The tip builder also demonstrates the kinds of tips that can be built using the tool. The cooltip 1.6 package is assumed to be a Tcl module and should therefore be placed in a file named:
cooltip-1.6.tm
The GUI builder assumes that it and the cooltip module are in the same directory and is run with a wish file.tcl command. It uses [info script] to know where it and the cooltip module reside. It can have any name, but must be able to find the cooltip module.
Cooltip works with 2 types of tips, but uses the same command. The options are those from tooltip 1.6 used to designate such things as menu index, text widget tags, listbox items, and ttk::notebook tabs.
tooltip::tooltip <widget> ?options? <tip>
If <tip> is a regular text string, then it should work the same as with tooltip 1.6. One builds a styled tip using the GUI builder, and when ready for use clicks the copy button. This will create the tip text as a text widget dump assigned to a variable with a
set tooltipN {##<widget dump>} statement and places it onto the clipboard. Then <tip> would be $tooltipN rather than a litteral text string. N can be any text. A styled tip text is prefixed with ## to differentiate it from a non-styled tip.
This can then be pasted from the clipboard into the user program, possibly replacing an earlier version. To re-edit one copies this set statement and pastes it back into the GUI builder. This eliminates any need for intermediate files. However, the GUI is also able to save to and load from a pair of fixed filenames (in the [pwd] directory) for quick backups of text and configuration settings.
If the user does any advanced configuration of the text tags, these are saved in the 2nd file of the pair as a single tcl source-able statement; this can be simply added to the user program if they were changed in the GUI console. The Config settings apply to all tips, so the config is not saved with each individual tip.
All unicode chars inserted by the builder, are reverted back to their \uXXXX escapes before copied to the clipboard for pasting into the program.
When pasted back into the GUI builder it will parse the set statement extracting the text dump re-creating the tip in its text window. The GUI builder uses the Tk text widget, and so supports all the standard shortcuts. It also handles undo (control-z) but only the text, not the attributes. On windows, redo is control-y and shift-control-z on linux. In addition, a control-wheel will increase or decrease the config value for the font.
Note: the GUI program's copy/paste buttons (on the menubar) are not raw copy/paste, but specialized to work only on the set statements exclusively. Regular copy/paste is supported by the text widget shortcuts (control-c/control-v).
ET 1/13/2024 - recent changes - mirror changes in the tooltip widget config (when entering config changes via the console window) into the editor widget and added the control-mousewheel for font size zooming. Load and Save should also remember any config changes too. New is the configure option with a dialog to configure most attributes of each color 1/14/2024. Reworked the clear command, added awdark if available 1/15. And fixed console on linux code for 9.0. Font chooser in configure. Bug fix, performance fix. 1/18, border dialog 1/27
The user program would either find the cooltip module in a known module directory with a simple package require cooltip, or similar to auto_path, use the module command tcl::tm::path add <path> to let the package command find the module in the <path> folder specified.
A user program could also just source the module or even simply embed it into the program (it's relatively small at ~800 lines). The GUI builder is not needed at runtime in the target user program.
Below in the discussion is the cooltip module, which as mentioned, should be named cooltip-1.6.tm and placed in either a known module directory, or in the same directory with the GUI builder that follows.
In most cases, the built in 7 colors and 3 styles with a single font should be sufficient for most tool tips. However, using the config option one can create very elaborate tips using multiple fonts, colors, and other attributes. For example, superscripts can be created using a smaller font with the -offset option.
Cooltip also includes 2 config options, -extraw and -extrah to increase the width and height of all tooltips and defaults to 0. In addition to the 7 colors, which can be configured if desired (e.g. to change the actual color) there are 9 extra tags grey51..grey59 which are available for full configuration using any option for a text widget tag. These are not used by the GUI program so changing them won't interfere with its own tips. When text is changed to one of those colors, it will have a grey background and when hovering over with the mouse pointer, a tooltip will identify the color assigned.
When using a tooltip::tooltip config with no options, it will output all the current values. The color options can also include other attributes, such as -font as well as modifications to the color itself (e.g. note how -grey is actually set to grey80). Each option value is a list of text widget tag options. To remove a tag option, set to {}.
The GUI builder also includes an enhanced console for windows and linux. When it starts up, it pre-loads the history with a few sample configuration commands that can be retrieved and edited using the up arrow key. This provides a way to test config's of say the 9 grey5n tags with a quick feedback using the GUI's ->test widget.
In the below sample commands entered into the GUI's console, one can see all the config settings and change of grey51's font and relief settings. One could then select text and assign it to color grey51 which would also modify the other attributes.
% tooltip::tooltip config
-foreground black -background lightyellow -font {FixedSys 10} -red {-foreground red} -green {-foreground green} -blue {-foreground lightblue}
-orange {-foreground orange} -violet {-foreground violet} -black {-foreground black} -grey {-foreground grey80} -grey51 {-background grey90
-foreground black -selectbackground lightblue} -grey52 {-background grey90 -foreground black -selectbackground lightblue} -grey53 {-background
grey90 -foreground black -selectbackground lightblue} -grey54 {-background grey90 -foreground black -selectbackground lightblue} -grey55
{-background grey90 -foreground black -selectbackground lightblue} -grey56 {-background grey90 -foreground black -selectbackground lightblue}
-grey57 {-background grey90 -foreground black -selectbackground lightblue} -grey58 {-background grey90 -foreground black -selectbackground
lightblue} -grey59 {-background grey90 -foreground black -selectbackground lightblue} -extraw 0 -extrah 0
% tooltip::tooltip config -grey51
-background grey90 -foreground black -selectbackground lightblue
% tooltip::tooltip config -grey51 {-font {courier 12} -relief ridge -borderwidth 4}
% tooltip::tooltip config -grey51
-background grey90 -borderwidth 4 -font {courier 12} -foreground black -relief ridge -selectbackground lightblue
Note that with multiple fonts one will likely need to pad lines on the right with spaces so the geometry is accurate. Similarly, one may need extra blank lines at the bottom. The -extraw and -extrah are global options and effect all tips and could be used as well.
# #
# cooltip-1.6.tm
#
#
# tooltips with colors
#
# Copyright (c) 1996-2007 Jeffrey Hobbs
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tooltip.tcl,v 1.16 2008/12/01 23:37:16 hobbs Exp $
#
# Initiated: 28 October 1996
# As modified by ET 25 dec 2023
package require Tk 8.5-
package require msgcat
#------------------------------------------------------------------------
# PROCEDURE
# tooltip::tooltip
#
# DESCRIPTION
# Implements a tooltip (balloon help) system
#
# ARGUMENTS
# tooltip <option> ?arg?
#
# clear ?pattern?
# Stops the specified widgets (defaults to all) from showing tooltips.
#
# configure ?opt ?val opt val ...?? if configureall returns even {} items on introspection
# Configure foreground, background and font.
# and 7+9 color replacements + wrap, extrah, extraw
#
# delay ?millisecs?
# Query or set the delay. The delay is in milliseconds and must
# be at least 50. Returns the delay.
#
# fade ?boolean?
# Enables or disables fading of the tooltip.
#
# disable OR off
# Disables all tooltips.
#
# enable OR on
# Enables tooltips for defined widgets.
#
# <widget> ?-index index? ?-item(s) items? ?-tab tabId" ?-tag tag? ?message?
# * If -index is specified, then <widget> is assumed to be a menu and
# index represents what index into the menu (either the numerical index
# or the label) to associate the tooltip message with.
# Tooltips do not appear for disabled menu items.
# * If -item(s) is specified, then <widget> is assumed to be a listbox,
# ttk::treeview or canvas and items specifies one or more items.
# * If -tab is specified, then <widget> is assumed to be a ttk::notebook
# and tabId specifies a tab identifier.
# * If -tag is specified, then <widget> is assumed to be a text and tag
# specifies a tag name.
# If message is {}, then the tooltip for that widget is removed.
# The widget must exist prior to calling tooltip. The current
# tooltip message for <widget> is returned, if any.
#
# RETURNS: varies (see methods above)
#
# NAMESPACE & STATE
# The namespace tooltip is used.
# Control toplevel name via ::tooltip::wname.
#
# EXAMPLE USAGE:
# tooltip .button "A Button"
# tooltip .menu -index 5 "Loads a file" - index must be a number
# tooltip::G(alwayson) is a list of regular widgets (i.e. ones with no -index, etc.) that are always on
# These apply only to buttons, checkboxes, entry, etc.
#------------------------------------------------------------------------
namespace eval ::tooltip {
namespace export -clear tooltip
variable tooltip
variable G
if {![info exists G]} {
# config_done is set whenever the configure changes anything, so we can trace it in the gui program
array set G {
config_done 1
enabled 1
fade 1
extraw 0
extrah 0
background lightyellow
font {FixedSys 10}
FADESTEP 0.2
FADEID {}
DELAY 500
AFTERID {}
alwayson {}
LAST -1
TOPLEVEL .__tooltip__
}
if {[tk windowingsystem] eq "x11"} {
set G(fade) 0 ; # don't fade by default on X11
}
}
# functional options
option add *Tooltip.Label.highlightThickness 0
option add *Tooltip.Label.relief solid
option add *Tooltip.Label.borderWidth 1
option add *Tooltip.Label.padX 5
option add *Tooltip.Label.padY 5
# configurable options
option add *Tooltip.Label.background lightyellow
option add *Tooltip.Label.foreground black
option add *Tooltip.Label.font $G(font) ;# was TkTooltipFont
# The extra ::hide call in <Enter> is necessary to catch moving to
# child widgets where the <Leave> event won't be generated
bind Tooltip <Enter> [namespace code {
#tooltip::hide
variable tooltip
variable G
set G(LAST) -1
if {($G(enabled) || ("%W" in $G(alwayson))) && [info exists tooltip(%W)]} {
set G(AFTERID) \
[after $G(DELAY) [namespace code [list show %W $tooltip(%W) cursor]]]
}
}]
bind Menu <<MenuSelect>> [namespace code { menuMotion %W }]
bind Tooltip <Leave> [namespace code [list hide 1]] ; # fade ok
bind Tooltip <Any-KeyPress> [namespace code hide]
bind Tooltip <Any-Button> [namespace code hide]
}
proc ::tooltip::tooltip {w args} {
variable tooltip
variable G
switch -glob -- $w {
clear {
if {[llength $args]==0} { set args .* }
clear [lindex $args 0]
}
delay {
if {[llength $args]} {
set millisecs [lindex $args 0]
if {![string is integer -strict $millisecs] || $millisecs<50} {
return -code error "tooltip delay must be an integer\
greater than or equal to 50 (delay is in millisecs)"
}
return [set G(DELAY) $millisecs]
} else {
return $G(DELAY)
}
}
fade {
if {[llength $args]} {
set G(fade) [string is true -strict [lindex $args 0]]
}
return $G(fade)
}
off - disable {
set G(enabled) 0
hide
}
on - enable {
set G(enabled) 1
}
con* {
return [::tooltip::configure $w {*}$args]
}
default {
set i $w
if {[llength $args]} {
set i [uplevel 1 [namespace code [list register $w {*}$args]]]
}
set b $G(TOPLEVEL)
if {[info exists tooltip($i)]} { return $tooltip($i) }
}
}
}
proc ::tooltip::register {w args} {
variable tooltip
set key [lindex $args 0]
while {[string match -* $key]} {
switch -- $key {
-- {
set args [lreplace $args 0 0]
set key [lindex $args 0]
break
}
-index {
if {[catch {$w entrycget 1 -label}]} {
return -code error "widget \"$w\" does not seem to be a\
menu, which is required for the -index switch"
}
set index [lindex $args 1]
set args [lreplace $args 0 1]
}
-item - -items {
if {[winfo class $w] in {Listbox Treeview}} {
set items [lindex $args 1]
} else {
set namedItem [lindex $args 1]
if {[catch {$w find withtag $namedItem} items]} {
return -code error "widget \"$w\" is not a canvas, or\
item \"$namedItem\" does not exist in the canvas"
}
}
set args [lreplace $args 0 1]
}
-tab {
if {[winfo class $w] ne "TNotebook"} {
return -code error "widget \"$w\" is not a ttk::notebook\
widget"
}
set tabId [lindex $args 1]
if {[catch {$w index $tabId} tabIndex]} {
return -code error $tabIndex
} elseif {$tabIndex < 0 || $tabIndex >= [$w index end]} {
return -code error "tab index $tabId out of bounds"
}
set tabWin [lindex [$w tabs] $tabIndex]
set args [lreplace $args 0 1]
}
-tag {
set tag [lindex $args 1]
set r [catch {lsearch -exact [$w tag names] $tag} ndx]
if {$r || $ndx == -1} {
return -code error "widget \"$w\" is not a text widget or\
\"$tag\" is not a text tag"
}
set args [lreplace $args 0 1]
}
default {
return -code error "unknown option \"$key\":\
should be -index, -item(s), -tab, -tag or --"
}
}
set key [lindex $args 0]
}
if {[llength $args] != 1} {
return -code error "wrong # args: should be \"tooltip widget\
?-index index? ?-item(s) items? ?-tab tabId? ?-tag tag? ?--?\
message\""
}
if {$key eq ""} {
clear $w
} else {
if {![winfo exists $w]} {
return -code error "bad window path name \"$w\""
}
if {[info exists index]} {
set tooltip($w,$index) $key
return $w,$index
} elseif {[info exists items]} {
foreach item $items {
set tooltip($w,$item) $key
set class [winfo class $w]
if { $class eq "Listbox" || $class eq "Treeview"} {
enableListbox $w $item
} else {
enableCanvas $w $item
}
}
# Only need to return the first item for the purposes of
# how this is called
return $w,[lindex $items 0]
} elseif {[info exists tabWin]} {
set tooltip($w,$tabWin) $key
enableNotebook $w $tabWin
return $w,$tabWin
} elseif {[info exists tag]} {
set tooltip($w,t_$tag) $key
enableTag $w $tag
return $w,$tag
} else {
set tooltip($w) $key
# Note: Add the necessary bindings only once.
set tags [bindtags $w]
if {[lsearch -exact $tags "Tooltip"] == -1} {
bindtags $w [linsert $tags end "Tooltip"]
}
return $w
}
}
}
proc ::tooltip::createToplevel {} {
variable G
variable labelOpts
set b $G(TOPLEVEL)
toplevel $b -class Tooltip -borderwidth 0
if {[tk windowingsystem] eq "aqua"} {
::tk::unsupported::MacWindowStyle style $b help none
} else {
wm overrideredirect $b 1
}
catch {wm attributes $b -topmost 1}
# avoid the blink issue with 1 to <1 alpha on Windows
catch {wm attributes $b -alpha 0.99}
wm positionfrom $b program
wm withdraw $b
label $b.label {*}[expr {[info exists labelOpts] ? $labelOpts : ""}]
# cputs green "label create [linsert $labelOpts 0 label $b.label]\n"
text $b.text -background yellow -relief raised -bd 2 -wrap none -font $G(font)
pack $b.text -ipadx 1 -expand 1 -fill both ;#create our text widget instead of the label, leave label alone though, just don't pack it
set_tags $b.text ;# setup our style and color tags
# pack $b.text $b.label -ipadx 1
}
proc ::tooltip::configure {config args} { ;# config is the entire word, if it's configureall, it's special returns even {} items
set len [llength $args]
if {$len >= 2 && ($len % 2) != 0} {
return -level 2 -code error "wrong # args. Should be\
\"tooltip configure ?opt ?val opt val ...??\""
}
variable G
set b $G(TOPLEVEL)
if {![winfo exists $b]} {
createToplevel
}
set opts1 {-foreground -background -font}
set opts2 {-red -green -blue -orange -violet -black -grey -grey51 -grey52 -grey53 -grey54 -grey55 -grey56 -grey57 -grey58 -grey59 -extraw -extrah -wrap}
if { $len == 0 } {
set keys {}
foreach item $opts1 {
lappend keys $item [::tooltip::configure $config $item]
}
foreach item $opts2 {
lappend keys $item [::tooltip::configure $config $item]
}
return $keys
}
foreach {key value} $args {
if { $key eq "-fg" } {
set key -foreground
} elseif { $key eq "-bg" } {
set key -background
}
if { $key in $opts1 } { ;# compatibility
set keys {}
foreach opt {-foreground -background -font} {
set val [$b.label configure $opt]
set opts($opt) [lindex $val 4]
set defs($opt) [lindex $val 1]
lappend keys $opt
}
if { $len == 1 } {
set key [lindex $args 0]
if { $key eq "-fg" } {
set key -foreground
} elseif { $key eq "-bg" } {
set key -background
}
if {$key ni $keys} {
return -level 2 -code error "unknown option \"$key\""
} else {
return $opts($key)
}
} else {
# allow -fg and -bg as aliases
lappend keys -fg -bg
set defs(-fg) $defs(-foreground)
set defs(-bg) $defs(-background)
if {$key ni $keys} {
return -level 2 -code error "unknown option \"$key\""
}
if [catch {
$b.label configure $key $value
option add *Tooltip.Label.$defs($key) $value
# puts "option add *Tooltip.Label.$defs($key) $value"
if { $key eq "-font" } {
$b.text tag configure label -font $value
set G(font) $value
set_tags $b.text no
$b.text configure -font $value
}
if { $key eq "-background" } {
set G(background) $value
}
} err] {
return -level 2 -code error $err
}
}
} elseif { $key in $opts2 } {
# puts "in opt2 keyx= |$key| opts2= |$opts2| "
if { $len == 1 } {
if { $key eq "-extraw" } {
return $G(extraw)
} elseif { $key eq "-wrap" } {
return [$G(TOPLEVEL).text cget -wrap]
} elseif { $key eq "-extrah" } {
return $G(extrah)
}
set cfig [$b.text tag configure [string range $key 1 end]]
set cfig2 [list]
foreach item $cfig {
if { [lindex $item end] ne "" || $config eq "configureall"} {
lappend cfig2 [lindex $item 0] [lindex $item end]
}
}
return $cfig2
} else {
if { $key eq "-extraw" } {
set G(extraw) $value
} elseif { $key eq "-extrah" } {
set G(extrah) $value
} elseif { $key eq "-wrap" } {
$G(TOPLEVEL).text config -wrap $value
} else {
$b.text tag configure [string range $key 1 end] {*}$value
}
}
} else {
return -level 2 -code error "unknown option $key"
}
}
incr G(config_done) 1 ;# write to this so config change can be traced
return
}
proc ::tooltip::clear {{pattern .*}} {
variable tooltip
# cache the current widget at pointer
set ptrw [winfo containing {*}[winfo pointerxy .]]
foreach w [array names tooltip $pattern] {
unset tooltip($w)
if {[winfo exists $w]} {
set tags [bindtags $w]
if {[set i [lsearch -exact $tags "Tooltip"]] != -1} {
bindtags $w [lreplace $tags $i $i]
}
## We don't remove TooltipMenu because there
## might be other indices that use it
# Withdraw the tooltip if we clear the current contained item
if {$ptrw eq $w} { hide }
}
}
}
proc ::tooltip::show {w msg {i {}}} {
if {![winfo exists $w]} { return }
# Use string match to allow that the help will be shown when
# the pointer is in any descendant of the desired widget
if {([winfo class $w] ne "Menu")
&& ![string match $w* [winfo containing {*}[winfo pointerxy $w]]]} {
return
}
variable G
after cancel $G(FADEID)
set b $G(TOPLEVEL)
if {![winfo exists $b]} {
createToplevel
}
# Use late-binding msgcat (lazy translation) to support programs
# that allow on-the-fly l10n changes
$b.label configure -text [::msgcat::mc $msg] -justify left
if { [string range $msg 0 1] eq "##" } {
set msg [string range $msg 2 end]
# puts "\n---\nfound a complex one\n$msg\n---"
$b.text delete 1.0 end
tooltip::restore $b.text $msg
lassign [w-h $b.text] wid ht
# puts "Wid= |$wid| Ht= |$ht| complex one"
$b.text config -width [expr { $wid+$G(extraw) }] -height [expr { $ht-2+$G(extrah) }] -background $G(background)
} else {
wm geom $b {}
$b.text delete 1.0 end
$b.text insert 1.0 $msg label
lassign [w-h-l $msg] wid ht
# puts "wid= |$wid| ht= |$ht| "
set bg [$b.label cget -background]
set fg [$b.label cget -foreground]
set ft [$b.label cget -font]
# $b.text config -width [expr { $wid+$G(extraw) }] -height [expr { $ht-1+$G(extrah) }] -background $bg -foreground $fg -font $ft
$b.text config -width [expr { $wid }] -height [expr { $ht-1 }] -background $bg -foreground $fg -font $ft
}
update idletasks
set screenw [winfo screenwidth $w]
set screenh [winfo screenheight $w]
set reqw [winfo reqwidth $b]
set reqh [winfo reqheight $b]
# When adjusting for being on the screen boundary, check that we are
# near the "edge" already, as Tk handles multiple monitors oddly
if {$i eq "cursor"} {
set py [winfo pointery $w]
set y [expr {$py + 20}]
# this is a wrong calculation?
# if {($y < $screenh) && ($y+$reqh) > $screenh} {}
if { ($y + $reqh) > $screenh } {
set y [expr {$py - $reqh - 5}]
}
} elseif {$i ne ""} {
# menu entry
set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[$w yposition $i]+25}]
if {($y < $screenh) && ($y+$reqh) > $screenh} {
# show above if we would be offscreen
set y [expr {[winfo rooty $w]+[$w yposition $i]-$reqh-5}]
}
} else {
set y [expr {[winfo rooty $w]+[winfo vrooty $w]+[winfo height $w]+5}]
if {($y < $screenh) && ($y+$reqh) > $screenh} {
# show above if we would be offscreen
set y [expr {[winfo rooty $w]-$reqh-5}]
}
}
if {$i eq "cursor"} {
set x [winfo pointerx $w]
} else {
set x [expr {[winfo rootx $w]+[winfo vrootx $w]+
([winfo width $w]-$reqw)/2}]
}
# only readjust when we would appear right on the screen edge
if {$x<0 && ($x+$reqw)>0} {
set x 0
} elseif {($x < $screenw) && ($x+$reqw) > $screenw} {
set x [expr {$screenw-$reqw}]
}
if {[tk windowingsystem] eq "aqua"} {
set focus [focus]
}
# avoid the blink issue with 1 to <1 alpha on Windows, watch half-fading
catch {wm attributes $b -alpha 0.99}
wm geometry $b +$x+$y
wm deiconify $b
raise $b
if {[tk windowingsystem] eq "aqua" && $focus ne ""} {
# Aqua's help window steals focus on display
after idle [list focus -force $focus]
}
}
proc ::tooltip::w-h {w} {
set max 0
for {set item 0} {$item < 100} {incr item} {
set ind [$w index ${item}.end]
set wid [lindex [split $ind .] 1]
if { $wid > $max } {
set max $wid
}
}
set h [lindex [split [$w index end] .] 0 ]
return [list $max $h]
}
proc ::tooltip::w-h-l {l} {
set max 0
set lines [split $l \n]
foreach line $lines {
set wid [string length $line]
if { $wid > $max } {
set max $wid
}
}
return [list $max [llength $lines]]
}
proc ::tooltip::menuMotion {w} {
variable G
if {$G(enabled)} {
variable tooltip
# Menu events come from a funny path, map to the real path.
set m [string map {"#" "."} [winfo name $w]]
set cur [$w index active]
# The next two lines (all uses of LAST) are necessary until the
# <<MenuSelect>> event is properly coded for Unix/(Windows)?
# puts "cur= |$cur| G(LAST)= |$G(LAST)| returning = [expr { $cur == $G(LAST) }]" ;# this is broken on 9.0b1 (if only 1 item)
# if {$cur == $G(LAST)} return ;# I don't grok this, but it breaks the code in 9.0b1, and w/o it, it works in 8.6 and 9.0 ughhhh
set G(LAST) $cur
# a little inlining - this is :hide
after cancel $G(AFTERID)
catch {wm withdraw $G(TOPLEVEL)}
# puts "[info exists tooltip($m,$cur)] $m,$cur"
if { ! [info exists tooltip($m,$cur)]} {
if { [info exists tooltip($w,$cur)] } {
set m $w
}
}
# puts "[info exists tooltip($m,$cur)] $m,$cur [catch {$w entrycget $cur -label} cur] [info exists tooltip($m,$cur)]"
if {[info exists tooltip($m,$cur)] || \
(![catch {$w entrycget $cur -label} cur] && \
[info exists tooltip($m,$cur)])} {
set G(AFTERID) [after $G(DELAY) \
[namespace code [list show $w $tooltip($m,$cur) cursor]]]
}
}
}
proc ::tooltip::hide {{fadeOk 0}} {
variable G
after cancel $G(AFTERID)
after cancel $G(FADEID)
if {$fadeOk && $G(fade)} {
fade $G(TOPLEVEL) $G(FADESTEP)
} else {
catch {wm withdraw $G(TOPLEVEL)}
}
}
proc ::tooltip::fade {w step} {
if {[catch {wm attributes $w -alpha} alpha] || $alpha <= 0.0} {
catch { wm withdraw $w }
catch { wm attributes $w -alpha 0.99 }
} else {
variable G
wm attributes $w -alpha [expr {$alpha-$step}]
set G(FADEID) [after 50 [namespace code [list fade $w $step]]]
}
}
proc ::tooltip::wname {{w {}}} {
variable G
if {[llength [info level 0]] > 1} {
# $w specified
if {$w ne $G(TOPLEVEL)} {
hide
destroy $G(TOPLEVEL)
set G(TOPLEVEL) $w
}
}
return $G(TOPLEVEL)
}
proc ::tooltip::listitemTip {w x y} {
variable tooltip
variable G
set G(LAST) -1
if {[winfo class $w] eq "Listbox"} {
set item [$w index @$x,$y]
} else {
set item [$w identify item $x $y]
}
if {$G(enabled) && [info exists tooltip($w,$item)]} {
set G(AFTERID) [after $G(DELAY) \
[namespace code [list show $w $tooltip($w,$item) cursor]]]
}
}
# Handle the lack of <Enter>/<Leave> between listbox/treeview items using
# <Motion>
proc ::tooltip::listitemMotion {w x y} {
variable tooltip
variable G
if {$G(enabled)} {
if {[winfo class $w] eq "Listbox"} {
set item [$w index @$x,$y]
} else {
set item {}
set region [$w identify region $x $y]
if {$region eq "tree" || $region eq "cell"} {
set item [$w identify item $x $y]
}
}
if {$item ne $G(LAST)} {
set G(LAST) $item
after cancel $G(AFTERID)
catch {wm withdraw $G(TOPLEVEL)}
if {[info exists tooltip($w,$item)]} {
set G(AFTERID) [after $G(DELAY) \
[namespace code [list show $w $tooltip($w,$item) cursor]]]
}
}
}
}
# Initialize tooltip events for listbox/treeview widgets
proc ::tooltip::enableListbox {w args} {
if {[string match *listitemTip* [bind $w <Enter>]]} { return }
bind $w <Enter> +[namespace code [list listitemTip %W %x %y]]
bind $w <Motion> +[namespace code [list listitemMotion %W %x %y]]
bind $w <Leave> +[namespace code [list hide 1]] ; # fade ok
bind $w <Any-KeyPress> +[namespace code hide]
bind $w <Any-Button> +[namespace code hide]
}
proc ::tooltip::canvasitemTip {w args} {
variable tooltip
variable G
set G(LAST) -1
set item [$w find withtag current]
if {$G(enabled) && [info exists tooltip($w,$item)]} {
set G(AFTERID) [after $G(DELAY) \
[namespace code [list show $w $tooltip($w,$item) cursor]]]
}
}
proc ::tooltip::enableCanvas {w args} {
if {[string match *canvasitemTip* [$w bind all <Enter>]]} { return }
$w bind all <Enter> +[namespace code [list canvasitemTip $w]]
$w bind all <Leave> +[namespace code [list hide 1]] ; # fade ok
$w bind all <Any-KeyPress> +[namespace code hide]
$w bind all <Any-Button> +[namespace code hide]
}
proc ::tooltip::notebooktabTip {w x y} {
variable tooltip
variable G
set G(LAST) -1
set tabIndex [$w index @$x,$y]
set tabWin [lindex [$w tabs] $tabIndex]
if {$G(enabled) && [info exists tooltip($w,$tabWin)]} {
set G(AFTERID) [after $G(DELAY) \
[namespace code [list show $w $tooltip($w,$tabWin) cursor]]]
}
}
# Handle the lack of <Enter>/<Leave> between ttk::notebook items using <Motion>
proc ::tooltip::notebooktabMotion {w x y} {
variable tooltip
variable G
if {$G(enabled)} {
set tabIndex [$w index @$x,$y]
set tabWin [lindex [$w tabs] $tabIndex]
if {$tabWin ne $G(LAST)} {
set G(LAST) $tabWin
after cancel $G(AFTERID)
catch {wm withdraw $G(TOPLEVEL)}
if {[info exists tooltip($w,$tabWin)]} {
set G(AFTERID) [after $G(DELAY) \
[namespace code [list show $w $tooltip($w,$tabWin) cursor]]]
}
}
}
}
# Initialize tooltip events for ttk::notebook widgets
proc ::tooltip::enableNotebook {w args} {
if {[string match *notebooktabTip* [bind $w <Enter>]]} { return }
bind $w <Enter> +[namespace code [list notebooktabTip %W %x %y]]
bind $w <Motion> +[namespace code [list notebooktabMotion %W %x %y]]
bind $w <Leave> +[namespace code [list hide 1]] ; # fade ok
bind $w <Any-KeyPress> +[namespace code hide]
bind $w <Any-Button> +[namespace code hide]
}
proc ::tooltip::tagTip {w tag} {
variable tooltip
variable G
set G(LAST) -1
if {$G(enabled) && [info exists tooltip($w,t_$tag)]} {
if {[info exists G(AFTERID)]} { after cancel $G(AFTERID) }
set G(AFTERID) [after $G(DELAY) \
[namespace code [list show $w $tooltip($w,t_$tag) cursor]]]
}
}
proc ::tooltip::enableTag {w tag} {
if {[string match *tagTip* [$w tag bind $tag]]} { return }
$w tag bind $tag <Enter> +[namespace code [list tagTip $w $tag]]
$w tag bind $tag <Leave> +[namespace code [list hide 1]] ; # fade ok
$w tag bind $tag <Any-KeyPress> +[namespace code hide]
$w tag bind $tag <Any-Button> +[namespace code hide]
}
proc ::tooltip::set_tags {w {colors yes}} {
variable G
set font $G(font)
$w tag configure bolditalicunder -font "$font bold italic underline"
$w tag configure boldunder -font "$font bold underline"
$w tag configure italicunder -font "$font italic underline"
$w tag configure bolditalic -font "$font bold italic"
$w tag configure bold -font "$font bold"
$w tag configure italic -font "$font italic"
$w tag configure under -font "$font underline"
$w tag configure normal -font "$font"
$w tag configure label -font "$font"
if { $colors } {
$w tag configure red -foreground red
$w tag configure green -foreground green
$w tag configure blue -foreground lightblue
$w tag configure orange -foreground orange
$w tag configure violet -foreground violet
$w tag configure grey -foreground grey80
$w tag configure black -foreground black
foreach gr {1 2 3 4 5 6 7 8 9} {
$w tag configure grey5$gr -foreground black -background grey90 -selectbackground lightblue
}
}
$w tag add normal insert
}
proc ::tooltip::restore {w savex} {
set save [subst -nocommands -novariables $savex]
# create items, restoring their attributes
foreach {key value index} $save \
{
switch $key \
{
exec { eval [string replace $value 0 [string first " " $value]-1 $w] }
image { $w image create $index -name $value }
text { $w insert $index $value }
mark {
switch $value {
current { set currentIndex $index }
insert { set insertIndex $index}
default { $w mark set $value $index }
}
}
tagon { set tag($value) $index }
tagoff { $w tag add $value $tag($value) $index }
window { $w window create $index -window $value }
}
}
$w mark set current $currentIndex
$w mark set insert $insertIndex
}
package provide tooltip 1.6 ;# - not needed for cooltip, but keeps this from causing conflicts if user tries a package require tooltip also
Below in the discussion is the cooltip gui builder program. Copy it to a file in the same directory as cooltip-1.6.tm and run with wish. If the module is in one of the known directories, the module system will find it and this same directory requirement would not be needed.
# The cooltip gui editor from Arjen's little wp, by ET 12/25/2023
#
# wordp.tcl --
# A very basic word processor original by Arjen
#
# mainWindow --
# Set up the window with some buttons
#
lappend auto_path [pwd]
set wtitle [wm title .]
wm title . "$wtitle tooltip"
set ::cooltip [file dirname [info script]]
tcl::tm::path add [file dirname [info script]]
set ::ver [package require cooltip 1.6]
set ::myfont $::tooltip::G(font)
set ::nowcolor black
# add your own picks here
set picks {\u261B \u2611 \u2190 \u2191 \u2192 \u2193 \u2194
\u2195 \u2196 \u2197 \u2198
\u2726 \u2727 \u2729 \u272A \u2022 \u00A9 \u2023 "\u231A \u231B"
\u277D \u25B2 "\u007B \uFFFC \u007D \u3010 \uFFFC \u3011"
"\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500"
"-setup choices-" "-in variable-" "-picks-"
} ;# set some favorites here, the 10 char line makes the tearoff wider as well
#0x2190 LEFTWARDS ARROW
#0x2191 UPWARDS ARROW
#0x2192 RIGHTWARDS ARROW
#0x2193 DOWNWARDS ARROW
#0x2194 LEFT RIGHT ARROW
#0x2195 UP DOWN ARROW
#0x2196 NORTH WEST ARROW
#0x2197 NORTH EAST ARROW
#0x2198 SOUTH EAST ARROW
#0x2726 BLACK FOUR POINTED STAR
#0x2727 WHITE FOUR POINTED STAR
#0x2729 STRESS OUTLINED WHITE STAR
#0x272A CIRCLED WHITE STAR
#0x277D DINGBAT NEGATIVE CIRCLED DIGIT EIGHT
#0x25B2 BLACK UP-POINTING TRIANGLE
namespace eval popup {
set VERSION 0.1
}
set tears {} ;# list of tearoff menus, so we can gang move them
set lastgeom {}
proc mainWindow {} {
catch {console show}
global bold
global italic
global under
global red
global tootip_varname tipsonoff
global colorlab
global picks
global texttag
set ::atoz "--"
set ::clipboard {}
dosetsave ""
puts "Dir= |$::cooltip| ver=$::ver saveto= |$::savefile| font= |$::myfont| "
set ::themex 0
set ::darkonoff 0
set ::curtheme [ttk::style theme use]
puts "::argv= |$::argv| curtheme= |$::curtheme| "
# on linux, menus will be made darkmode by awthemes using option database, not ttk styles, simply by doing the package require awdark
# so we can only suppress it by not doing the package require, hence the user command line option
# On windows, this is suppressed for some reason, comment said it had bad side effects so not done
if { "-nodark" ni $::argv } { ;
if [catch {
package require awdark
set ::themex 1
ttk::style theme use awdark
set ::darkonoff 1
} err_code] {
puts stderr $err_code
}
}
set tootip_varname "tooltip"
#
# Create the toolbar
#
global t
set t [frame .toolbar]
text .text -font $::myfont -width 100 -height 50 -wrap none -undo true -insertbackground red -background grey85 ;# need to see the cursor, red seems to work
ttk::button $t.load -text "Load" -style Toolbutton -command [list loadf .text $t.testbut]
ttk::button $t.save -text "Save" -style Toolbutton -command {storeText 1}
ttk::combobox $t.atoz -text "A-Z" -style Toolbutton -width 2 -height 27 -textvariable ::atoz -values {"--" A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
bind $t.atoz <<ComboboxSelected>> [list doatoz]
$t.atoz set "--"
ttk::button $t.next -text "+" -style Toolbutton -command {loadnextone}
ttk::button $t.copy -text "Copy" -style Toolbutton -command {storeText 0}
ttk::button $t.paste -text "Paste" -style Toolbutton -command [list clip .text $t.testbut]
ttk::button $t.clear -text "Clear" -style Toolbutton
ttk::checkbutton $t.bold -text "Bold" -style Toolbutton -variable bold -command {toggleFont}
ttk::checkbutton $t.italic -text "Italic" -style Toolbutton -variable italic -command {toggleFont}
ttk::checkbutton $t.under -text "Underline" -style Toolbutton -variable under -command {toggleFont}
ttk::label $t.pick -text "Pick" -style Toolbutton
ttk::label $t.color -text "Color" -style Toolbutton -background black -foreground white
ttk::button $t.test -text "Notes" -style Toolbutton -command [list testit $t.testbut]
ttk::button $t.testbut -text "\u2192Test" -style Toolbutton -command [list testit $t.testbut]
ttk::checkbutton $t.tip -text "Tips On" -variable tipsonoff -command {onoff}
set tooltip::G(alwayson) [list $t.testbut]
ttk::separator .sep
ttk::separator $t.sep1 -orient vertical
ttk::separator $t.sep2 -orient vertical
ttk::separator $t.sep3 -orient vertical
ttk::separator $t.sep4 -orient vertical
ttk::separator $t.sep5 -orient vertical
set colorlab $t.color ;# so we can change it to the current color
bind $t.testbut <Enter> [list testit $t.testbut]
bind $t.clear <1> {clear text}
bind $t.clear <Control-1> {clear all}
bind $t.clear <Shift-1> {clear config}
# our 2 tearoff menus
set ::fnt {ariel 10}
set ::popup::menu(color) {
{radiobutton -label "red " -value red -variable nowcolor -background "PaleVioletRed1" -foreground black -font $::fnt -command colorset}
{radiobutton -label "green " -value green -variable nowcolor -background "lightgreen" -foreground black -font $::fnt -command colorset}
{radiobutton -label "blue " -value blue -variable nowcolor -background "lightblue" -foreground black -font $::fnt -command colorset}
{radiobutton -label "orange " -value orange -variable nowcolor -background "orange" -foreground black -font $::fnt -command colorset}
{radiobutton -label "violet " -value violet -variable nowcolor -background "violet" -foreground black -font $::fnt -command colorset}
{radiobutton -label "grey " -value grey -variable nowcolor -background "grey80" -foreground white -font $::fnt -command colorset}
{radiobutton -label "black " -value black -variable nowcolor -background "black" -foreground white -font $::fnt -command colorset -selectcolor white}
{separator}
{separator}
{radiobutton -label "grey51 " -value grey51 -variable nowcolor -background "grey80" -foreground white -font $::fnt -command colorset -selectcolor white}
{radiobutton -label "grey52 " -value grey52 -variable nowcolor -background "grey70" -foreground white -font $::fnt -command colorset -selectcolor white}
{radiobutton -label "grey53 " -value grey53 -variable nowcolor -background "grey80" -foreground white -font $::fnt -command colorset -selectcolor white}
{radiobutton -label "grey54 " -value grey54 -variable nowcolor -background "grey70" -foreground white -font $::fnt -command colorset -selectcolor white}
{radiobutton -label "grey55 " -value grey55 -variable nowcolor -background "grey80" -foreground white -font $::fnt -command colorset -selectcolor white}
{radiobutton -label "grey56 " -value grey56 -variable nowcolor -background "grey70" -foreground white -font $::fnt -command colorset -selectcolor white}
{radiobutton -label "grey57 " -value grey57 -variable nowcolor -background "grey80" -foreground white -font $::fnt -command colorset -selectcolor white}
{radiobutton -label "grey58 " -value grey58 -variable nowcolor -background "grey70" -foreground white -font $::fnt -command colorset -selectcolor white}
{radiobutton -label "grey59 " -value grey59 -variable nowcolor -background "grey80" -foreground white -font $::fnt -command colorset -selectcolor white}
{separator}
{separator}
{checkbutton -label "DarkMode " -variable darkonoff -onvalue 1 -offvalue 0 -command {dodark} -font $::fnt}
{checkbutton -label "Wrapping " -variable wraponoff -onvalue 1 -offvalue 0 -command {dowrapping} -font $::fnt}
{separator}
{command -label "Configure " -command {con_dlog $::nowcolor} -font $::fnt}
{command -label "Change Folder" -command {newpwd} -font $::fnt}
{separator}
{command -label "Create Catalog" -command {createcatalog} -font $::fnt}
{command -label "Expand Catalog" -command {expandcatalog} -font $::fnt}
{cascade -label "Borders" -menu .borders -font $::fnt }
{separator}
{command -label "Console" -command {console show} -font $::fnt}
{separator}
{separator}
{command -label "Exit" -command exit -foreground red -font $::fnt}
}
set ::popup::menu(borders) {
{command -label "Configure Borders ..." -command {main_dlog} -font $::fnt }
{command -label "Output Border Code " -command {dump_main_config} -font $::fnt }
{nop command -label "Add Borders3 " -command {do_addborders 3} -font $::fnt }
}
set ::wraponoff 0
set ::popup::menu(picks) {}
foreach pick $picks {
append ::popup::menu(picks) \n \{ [list command -label $pick -font {arial 12} -command "pick1 $pick"] \}
}
::popup::create color 1 {-tearoffcommand {tearoffcmd 0 0 } }
::popup::create picks 1 {-tearoffcommand {tearoffcmd 140 0} }
::popup::create borders 1 {-tearoffcommand {tearoffcmd -37 -50} }
bind $t.color <Button-1> {::popup::show %W color}
bind $t.pick <Button-1> {::popup::show %W picks}
# ok, now grid them or pack em, I prefer packing
set widgets [list $t.load $t.save $t.atoz $t.next $t.clear $t.sep1 $t.copy $t.paste $t.sep2 $t.test $t.testbut $t.sep3 $t.bold $t.italic $t.under $t.sep4 $t.color $t.pick $t.sep5 $t.tip]
if { 0 } {
grid {*}$widgets -padx 2 -sticky ns
grid $t -sticky w
grid .sep -sticky we
grid .text
} else {
pack {*}$widgets -side left -fill both -expand true -anchor w
pack $t .sep .text -fill x -side top
}
#
# Tags for the various fonts
#
tooltip::set_tags .text
.text tag add normal insert
set texttag normal
set italic 0
set bold 0
set under 0
set red 0
set tipsonoff 1
clear text;# if we don't do this, the first load is messed up
colorset
focus -force .text
set tooltip_bold {##mark current 1.0 tagon normal 1.0 tagon black 1.0 text Styles 1.0 tagoff black 1.6 text { } 1.6 tagoff normal 1.7 tagon red 1.7 tagon bold 1.7 text \u2196 1.7 tagoff bold 1.8 tagoff red 1.8 tagon normal 1.8 text { } 1.8 tagon black 1.9 text {and colors} 1.9 tagoff black 1.19 text { } 1.19 tagoff normal 1.20 tagon red 1.20 tagon bold 1.20 text \u2197 1.20 tagoff bold 1.21 tagoff red 1.21 tagon normal 1.21 text { } 1.21 tagon black 1.22 text {are sticky. Once they are
} 1.22 text {set, text typed or pasted will use that style. You can
} 2.0 text {use all 3 together with any of the colors. So be
} 3.0 text { \u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500
} 4.0 tagoff black 5.0 text { } 5.0 tagon black 5.1 text \u2726 5.1 tagoff black 5.2 text { } 5.2 tagon black 5.15 text { } 5.15 tagoff black 5.18 text { } 5.18 tagoff normal 5.19 tagon bolditalicunder 5.19 tagon red 5.19 text {B } 5.19 tagoff red 5.21 tagon orange 5.21 text O 5.21 tagoff orange 5.22 tagon red 5.22 text { } 5.22 tagoff red 5.23 tagon green 5.23 text L 5.23 tagoff green 5.24 tagon red 5.24 text { } 5.24 tagoff red 5.25 tagon green 5.25 text D 5.25 tagoff bolditalicunder 5.26 tagoff green 5.26 tagon black 5.26 tagon normal 5.26 text { \u2726} 5.26 tagoff normal 5.45 tagon under 5.45 text {
} 5.45 tagoff under 6.0 tagon normal 6.0 text { \u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500\u2500
} 6.0 text {To modify an attribute of existing text, select the
} 7.0 text {text and then set the attribues/colors} 8.0 mark tk::anchor1 8.38 mark insert 8.38 text { you want.
} 8.38 tagoff normal 9.0 tagoff black 9.0}
set tooltip_copy {##mark current 1.0 tagon normal 1.0 tagon black 1.0 text The 1.0 tagoff black 1.3 text { } 1.3 tagon red 1.4 text Copy 1.4 tagoff red 1.8 text { } 1.8 tagon black 1.9 text {command copies} 1.9 mark tk::anchor1 1.23 mark insert 1.23 text { all the text in the
} 1.23 text {window below } 2.0 tagoff normal 2.13 tagoff black 2.13 tagon violet 2.13 tagon bold 2.13 text \u2193 2.13 tagoff bold 2.14 tagoff violet 2.14 tagon normal 2.14 tagon black 2.14 text { into the clipboard with all its
} 2.14 text {attributes formatted as a tcl} 3.0 tagoff black 3.29 text { } 3.29 tagon red 3.30 text set 3.30 tagoff red 3.33 text { } 3.33 tagon black 3.34 text {command.
} 3.34 text {
} 4.0 text {It can then be pasted into the user program where
} 5.0 text {it can be used in a tooltip command. The variable
} 6.0 text {defaults to tooltip. The user should change that,
} 7.0 text {for example, } 8.0 tagoff black 8.13 tagon red 8.13 text tooltip3 8.13 tagoff red 8.21 tagon black 8.21 text {. To use it, one would
} 8.21 text {write the followng tcl code:
} 9.0 text {
} 10.0 text { tooltip::tooltip } 11.0 tagoff black 11.21 tagon orange 11.21 text <widget3> 11.21 tagoff orange 11.30 tagon black 11.30 text { } 11.30 tagoff black 11.31 tagon red 11.31 text {$tooltip3} 11.31 tagoff red 11.40 tagon black 11.40 text {
} 11.40 text {
} 12.0 tagoff black 13.0 tagon red 13.0 text Copy 13.0 tagoff red 13.4 tagon black 13.4 text { writes a formatted pretty print \u261b stdout
} 13.4 text {or \u261b console of the text widget dump command.} 14.0 tagoff black 14.45 text {
} 14.45 text {
} 15.0 tagon red 16.0 text Copy 16.0 tagoff red 16.4 text { } 16.4 tagon black 16.5 text {ignores any currently} 16.5 tagoff black 16.26 text { } 16.26 tagoff normal 16.27 tagon violet 16.27 tagon bold 16.27 text selected 16.27 tagoff bold 16.35 tagoff violet 16.35 tagon normal 16.35 text { } 16.35 tagon black 16.36 text {text, as it
} 16.36 text {always uploads the entire window to the clipboard.
} 17.0 tagoff normal 18.0 tagoff black 18.0}
set tooltip_paste {##mark current 1.0 tagon normal 1.0 tagon black 1.0 text {Select and copy your code from} 1.0 tagoff black 1.30 text { } 1.30 tagon red 1.31 text {set tooltipN {...}} 1.31 tagoff red 1.49 text { } 1.49 tagon black 1.50 text {in your
} 1.50 text {text editor and use the} 2.0 tagoff black 2.23 text { } 2.23 tagon red 2.24 text Paste 2.24 tagoff red 2.29 text { } 2.29 tagon black 2.30 text {command to reload it here for
} 2.30 text {editing. After it's edited, use the } 3.0 tagoff black 3.36 tagon red 3.36 text Copy 3.36 tagoff red 3.40 tagon black 3.40 text { command to
} 3.40 text {place the new contents into the clipboard for pasting
} 4.0 text {back into your source program.
} 5.0 text {
} 6.0 text The 7.0 tagoff black 7.3 text { } 7.3 tagon red 7.4 text Copy 7.4 tagoff red 7.8 text { } 7.8 tagon black 7.9 text {command will use the variable name from the
} 7.9 text {last paste operation or use the variable name} 8.0 tagoff black 8.45 text { } 8.45 tagon red 8.46 text tooltip. 8.46 tagoff red 8.54 text {
} 8.54 text {
} 9.0 tagon black 10.0 text {Be sure to select the entire statement. If you don't
} 10.0 text {begin with } 11.0 tagoff black 11.11 tagon violet 11.11 text set 11.11 tagoff violet 11.14 tagon black 11.14 text { an error will be posted
} 11.14 tagoff normal 12.0 tagoff black 12.0 mark tk::anchor1 12.0 mark insert 12.0}
set tooltip_test {##tagon normal 1.0 tagon black 1.0 text \u2500\u2500\u2500\u2500 1.0 tagoff black 1.4 tagon red 1.4 text { } 1.4 tagoff red 1.6 tagon black 1.6 text { } 1.6 tagoff normal 1.7 tagon bold 1.7 text {Notes on the \u2192Test button} 1.7 tagoff bold 1.32 tagoff black 1.32 tagon normal 1.32 tagon red 1.32 text { } 1.32 tagoff red 1.33 tagon black 1.33 text {\u2500\u2500\u2500\u2500\u2500
} 1.33 text {
} 2.0 text {\u2727 This will render with tooltip config settings} 3.0 tagoff black 3.47 tagon orange 3.47 text { } 3.47 tagoff orange 3.48 tagon black 3.48 text {as noted.
} 3.48 text {
} 4.0 mark current 5.0 text {\u2727 If the last line's not showing, you need
} 5.0 text { a newline after the last line.
} 6.0 text {
} 7.0 text {\u2727 If it's cutting off on the right side, add some
} 8.0 text { spaces at the end of the longest line.
} 9.0 text { This can happen with unicode.
} 10.0 text {
} 11.0 text {\u2727 Click this button to force an update in the test
} 12.0 text { button.} 13.0 tagoff black 13.10 tagon orange 13.10 text {
} 13.10 text {
} 14.0 tagoff orange 15.0 tagon black 15.0 text {\u2727 Cannot use braces, use unicode instead\u3010 \u3011
} 15.0 text {
} 16.0 text {tooltip::tooltip configure ?-option value?} 17.0 tagoff black 17.42 tagon red 17.42 text { } 17.42 tagoff red 17.43 tagon orange 17.43 text {\u261b defaults} 17.43 tagoff orange 17.53 tagon red 17.53 text {
} 17.53 tagoff red 18.0 tagon black 18.0 text {
} 18.0 text {-fg -foreground } 19.0 tagoff black 19.16 tagon orange 19.16 text black 19.16 tagoff orange 19.21 tagon red 19.21 text { } 19.21 tagoff red 19.29 tagon black 19.29 text {
} 19.29 text {-bg -background } 20.0 tagoff black 20.16 tagon orange 20.16 text lightyellow 20.16 tagoff orange 20.27 tagon red 20.27 text { } 20.27 tagoff red 20.31 tagon black 20.31 text {
} 20.31 text -font\u3010 21.0 tagoff black 21.6 tagon orange 21.6 text {FixedSys 10} 21.6 tagoff orange 21.17 tagon black 21.17 text {\u3011
} 21.17 text {
} 22.0 text {The above affect both regular and styled tips. Can also
} 23.0 text {replace the 7 colors, e.g. } 24.0 tagoff black 24.27 tagon red 24.27 text -red 24.27 tagoff red 24.31 tagon black 24.31 text { } 24.31 tagoff black 24.32 tagon red 24.32 text purple 24.32 tagoff red 24.38 tagon black 24.38 mark tk::anchor1 24.38 mark insert 24.38 text {
} 24.38 text {
} 25.0 text {-black } 26.0 tagoff black 26.7 tagon grey 26.7 text -grey 26.7 tagoff grey 26.12 tagon black 26.12 text { } 26.12 tagoff black 26.13 tagon violet 26.13 text -violet 26.13 tagoff violet 26.20 tagon black 26.20 text { } 26.20 tagoff black 26.21 tagon orange 26.21 text -orange 26.21 tagoff orange 26.28 tagon black 26.28 text { } 26.28 tagoff black 26.29 tagon blue 26.29 text -blue 26.29 tagoff blue 26.34 tagon black 26.34 text { } 26.34 tagoff black 26.35 tagon green 26.35 text -green 26.35 tagoff green 26.41 tagon black 26.41 text { } 26.41 tagoff black 26.42 tagon red 26.42 text -red 26.42 tagoff red 26.46 tagon black 26.46 text {
} 26.46 text {
} 27.0 tagoff normal 28.0 tagoff black 28.0}
# styled tips
tooltip::tooltip $t.bold $tooltip_bold
tooltip::tooltip $t.copy $tooltip_copy
tooltip::tooltip $t.paste $tooltip_paste
tooltip::tooltip $t.test $tooltip_test
# regular tips
atoztips
tooltip::tooltip $t.tip "Turns on/off cooltip tips. The test\nbutton \u2192Test is always on\n"
tooltip::tooltip $t.next "Load next one in directory"
tooltip::tooltip $t.atoz "Save file name extra A-Z, or -none-"
tooltip::tooltip $t.pick "A menu of favorites, including unicode\nedit to add or replace with your own."
tooltip::tooltip $t.color "A menu of colors with a tearoff.\nThe tearoff menu also has tooltips\nexplaining the menu items.\n"
tooltip::tooltip $t.clear "Clear text in edit window\nShift-click Clear Configurations\nControl-click Clear Both\n"
foreach tag {51 52 53 54 55 56 57 58 59} {
tooltip::tooltip .text -tag grey$tag "grey$tag"
}
# namespace import tooltip::tooltip
history add "::tooltip::tooltip config -grey51 {-font {courier 12} -relief ridge -borderwidth 4}"
history add "::tooltip::tooltip config -grey51"
history add "::tooltip::tooltip config -font {courier 14}"
history add "::tooltip::tooltip config -background grey80"
history add "::tooltip::tooltip config"
history add "$::tooltip::G(TOPLEVEL).text "
history add "::tooltip::tooltip delay 50"
history add "main_dlog"
# history add "ttk::themes"
# history add "package require "
# history add ".con config -bg black"
# history add "ttk::style theme use default ;#smaller"
puts [history info]
puts "\nTo access the above pre-loaded history, use up-arrow\nthis version: 1/22/2024\nWhat's new? control-mousewheel zoom; text configure dialog with more attributes"
puts "awdark if available and more ttk widgets\; experimental wrap mode; to suppress awdark\nby command line: wish [file tail [info script]] -nodark; new current directory chooser dialog"
puts "Load/Save can have a-z with a menu and a load next; New cataloging, so one can put a series of\ntips into a single file or on the wiki; configure functionally ordered rather than alphabetical"
puts "Fancy borders using tabs, such as in the screen shot on the wiki; will soon upload some configurations"
console eval {wm geom . 109x24+10+10}
wm geom . 1004x517+181+209
trace add variable ::tooltip::G(font) write {catch {.text configure -font $::tooltip::G(font) ; ::tooltip::set_tags .text} ;#}
trace add variable ::tooltip::G(config_done) write {catch {config2text; #puts "config change: $::tooltip::G(config_done) "} ;# }
trace add variable ::nowcolor write {catch {colchange; #puts "color change: $::nowcolor "} ;# }
bind .text <Control-MouseWheel> {mwheel %D} ;# windows
bind .text <Control-4> {mwheel 1} ;# linux
bind .text <Control-5> {mwheel -1}
bind . <Configure> {gangmove}
set ::lastfound -1
}
proc gangmove {} {
if { $::lastgeom eq "" } {
set ::lastgeom [wm geom .]
return
}
if { ([incr ::movecount] % 4) != 0} {
return
}
set geom $::lastgeom
regexp {^([0-9]+)x([0-9]+)([+-])([+-]?[0-9]+)([+-])([+-]?[0-9]+)} $geom -> dx dy xs xpos ys ypos
if { [llength $::tears] > 0 } {
# update
set geomnow [wm geom .] ;# get the leader's current position
regexp {^([0-9]+)x([0-9]+)([+-])([+-]?[0-9]+)([+-])([+-]?[0-9]+)} $geomnow -> dx dy xs xx ys yy ;# only need the xx and yy
} else {
set ::lastgeom [wm geom .]
return
}
if { $xpos == $xx && $ypos == $yy } {
} else {
set dx [expr { $xx - $xpos }]
set dy [expr { $yy - $ypos }]
set ::lastgeom $geomnow
foreach w $::tears {
if { ![winfo exists $w] } {
continue
}
set geom [wm geom $w]
regexp {^([0-9]+)x([0-9]+)([+-])([+-]?[0-9]+)([+-])([+-]?[0-9]+)} $geom -> sxx syy xs xpos ys ypos
set newx [expr { $xpos + $dx }]
set newy [expr { $ypos + $dy }]
set newgeom ${sxx}x${syy}+$newx+$newy
wm geom $w $newgeom
# wait 1000
update
update idletasks
}
}
return
}
proc loadnextone {{getletters 0}} {
set files [glob -nocomplain save*2.tcl]
if { [llength $files] <= 0 } {
puts "no files found"
return {}
}
# set f $::atoz
set letters {}
foreach file $files {
if { [regexp -nocase -linestop -lineanchor {save([a-zA-Z])?2.tcl} $file -> firstone] } {
lappend letters $firstone
}
}
set letters [lsort $letters]
if { $getletters } {
return $letters ;# just want the letters, don't skip
}
puts "letters= |$letters| "
incr ::lastfound
if { $::lastfound >= [llength $files]} {
set ::lastfound 0
}
set f [lindex $letters $::lastfound]
if { $f eq "" } {
set f "--"
}
$::t.atoz set [string toupper $f ]
doatoz [string tolower $f ]
loadf .text $::t.testbut
}
proc getfile {file {nonl 1}} {
set io [open $file r]
if { $nonl } {
set data [read -nonewline $io]
} else {
set data [read $io]
}
close $io
return $data
}
proc createcatalog {args} {
set letters [loadnextone 1]
if { [llength $letters] <= 0 } {
return 0
}
set out {}
set out2 {}
foreach letter $letters {
set letter [string tolower $letter]
lappend out [list $letter [getfile save${letter}.tcl]]
lappend out2 [list $letter [getfile save${letter}2.tcl]]
}
set io [open catalog.tcl w]
foreach item $out { ;# write out all the text data with delimiter markers
lassign $item letter data
puts $io "# Begin text \{${letter}\}"
puts $io "set tooltip_${letter} \{##\\"
puts $io $data
puts $io "\}\n# End text \{${letter}\}"
}
set letter [lindex $letters 0]
set letter [string tolower $letter]
set last [lrange $letters 1 end]
set first [getfile save${letter}2.tcl] ;# compare all to the first one
set same 1
foreach letter $last {
set letter [string tolower $letter]
if { [getfile save${letter}2.tcl] ne $first } { ;# if all configs the same, output only once
puts "Not the same at $letter"
set same 0
break
}
}
# puts "same= |$same| "
if { $same } {
foreach item $out2 { ;# still need to process as a list, but just done the first one
lassign $item letter data
puts $io "# Begin config ${letters}"
puts $io $data
puts $io "# End config ${letters}"
break
}
} else {
foreach item $out2 { ;# do all of them since not all the same
lassign $item letter data
puts $io "# Begin config \{${letter}\}"
puts $io $data
puts $io "# End config \{${letter}\}"
}
}
close $io
set comment ""
if { $same && [llength $letters] > 1} {
set comment " - All with the same config"
}
puts "created catalog with [llength $letters] item(s) = $letters $comment"
return [llength $letters]
}
proc expandcatalog {} {
if [catch {
set data [getfile catalog.tcl]
puts "ok"
} err_code] {
puts stderr $err_code
return
}
set lines [split $data \n]
set n -1
set toc [list]
foreach line $lines {
incr n
if { [string range $line 0 11] eq "# Begin text" } {
# puts "t n= |[expr { $n +1 }]| line= |$line| "
lappend toc [list b t [expr { $n+1 }] [lrange $line 3 end]]
} elseif { [string range $line 0 13] eq "# Begin config" } {
# puts "c n= |[expr { $n +1 }]| line= |$line| "
lappend toc [list b c [expr { $n+1 }] [lrange $line 3 end]]
} elseif { [string range $line 0 9] eq "# End text" } {
# puts "c n= |[expr { $n +1 }]| line= |$line| "
lappend toc [list e t [expr { $n-1 }] [lrange $line 3 end]]
} elseif { [string range $line 0 11] eq "# End config" } {
# puts "c n= |[expr { $n +1 }]| line= |$line| "
lappend toc [list e c [expr { $n-1 }] [lrange $line 3 end]]
} else {
# dothis
}
}
puts ""
foreach {odd even} $toc { ;# check pass
lassign $odd check1 kind1 n1 letters1
lassign $even check2 kind2 n2 letters2
incr n1; incr n2 ;# only for testing not when done
if { $check1 ne "b" || $check2 ne "e" || $kind1 ne $kind2} {
puts "Bad catalog for lines $n1 to $n2"
puts "n1= |$n1| n2= |$n2| |$check1 $check2 $kind1 $kind2| letters1= |$letters1| "
return
}
# puts "n1= |$n1| n2= |$n2| |$check1 $check2 $kind1 $kind2| letters1= |$letters1| "
}
update
puts stderr "Expand Catalog.tcl in directory [pwd]"
foreach {odd even} $toc { ;# do it pass
lassign $odd check1 kind1 n1 letters1
lassign $even check2 kind2 n2 letters2
if { $kind1 eq "t" } {
lassign $letters1 letter
set letter [string tolower $letter]
set file "save$letter.tcl"
write2file $lines [expr { $n1+1 }] [expr { $n2-1 }] $file
} else {
foreach letter $letters1 {
set letter [string tolower $letter]
set file "save${letter}2.tcl"
write2file $lines $n1 $n2 $file
}
}
}
}
proc write2file {lines from to file} {
puts "Lines [format %5s [expr { $from+1 }] ] .. [format %5s [expr { $to+1 }] ] $file"
set io [open $file w]
for {set m $from} {$m <= $to} {incr m} {
puts $io [lindex $lines $m]
}
close $io
}
proc dosetsave {arg} {
set arg [string tolower $arg]
set ::savefile [file join [pwd] "save${arg}.tcl"] ;# save writes here
set ::savefile2 [file join [pwd] "save${arg}2.tcl"] ;# save writes here
}
proc doatoz {args} {
if { $::atoz eq "--" } {
dosetsave ""
} else {
dosetsave $::atoz
}
atoztips
puts "Save file name: $::savefile"
}
proc atoztips {} {
global t
tooltip::tooltip $t.save "Quick save text to $::savefile\nSave the config to $::savefile2\n"
tooltip::tooltip $t.load "The load/save commands use 2 fixed file names\n $::savefile is the text dump\n $::savefile2 is the config dump\nBoth are saved into the current directory\n\nNote copy/paste does not save the config settings\nUse save then include [file tail $::savefile2 ] contents in the user\nprogram if you have configured color options\n"
}
proc mwheel {direction} {
lassign $::tooltip::G(font) name size
if { [string is integer -strict $size] } { ;# must be an int, like courier 12
if { $direction > 0 } {
incr size
} else {
incr size -1
}
if { $size > 30 || $size < 6 } {
return
}
tooltip::tooltip configure -font [list $name $size]
}
}
proc dowrapping {args} {
if { $::wraponoff } {
tooltip::tooltip config -wrap word
} else {
tooltip::tooltip config -wrap none
}
}
proc dodark {args} {
#puts "::themex= |$::themex| ::darkonoff= |$::darkonoff| "
set con 0
if { [info command .con] eq ".con" } {
set con 1 ;# there's a dialog open
}
if { $::themex } { ;# cannot switch themes if no dark was available
destroy .con
if { $::darkonoff } {
# puts "go to dark"
ttk::style theme use awdark
} else {
# puts "go to light $::curtheme"
ttk::style theme use $::curtheme
}
} else {
set ::darkonoff 0
puts stderr "Cannot go to dark mode"
}
if { $con } {
con_dlog $::nowcolor
}
}
proc newpwd {args} {
set dir [tk_chooseDirectory -initialdir [pwd] -mustexist yes -title "Choose a directory"]
if {$dir eq ""} {
puts stderr "No new directory chosen"
} else {
puts stderr "New directory is: $dir" ; update
cd $dir
doatoz $::atoz
atoztips
set ::lastfound -1
}
}
proc tearoffcmd {xx yy menu thetear } { ;# so tearoffs don't open at 0,0 - this is really ugly code I found somewhere !
# puts "menu= |$menu| thetear= |$thetear| "
if { $menu eq ".color" } {
tooltip::tooltip $thetear -index 1 "These 7 colors can be configured as desired,\nbut if changed, will also affect this editors tips.\n\nClicking a color sets a selection to that color\neven if this is the current color unlike\nstyles where clicking one that is set will\nunset that style of the selection. Can click a style \ntwice to set a selection to the current setting.\n\nStyles are on/off, Colors are mutually exclusive \nradio buttons.\n"
tooltip::tooltip $thetear -index 10 "The 9 greys 51-59 are available for advanced\ntag usage. This editor doesn't use them\n\nNote: Settings such as tabs only apply if the first\ntext on a line is tagged with its color\n"
tooltip::tooltip $thetear -index 22 "Experimental, not working, just turns on the option\n"
tooltip::tooltip $thetear -index 24 "Opens a configure dialog for all the colors. Can \nchoose a different color while open.\n\nClick Apply before changing or changes will not be\nsaved except for checkboxes, listboxes, fonts, and\ncolors selected by the color picker.\n \nTo enter a named color type in the box and type Enter.\n\nTo revert to defaults clear an item and type Enter.\n"
tooltip::tooltip $thetear -index 25 "Select a directory of save files that\nall load, save, and catalog operations\nwill work in.\n"
tooltip::tooltip $thetear -index 27 "Create Catalog creates a single file\ncatalog.tcl with all the save files\n"
tooltip::tooltip $thetear -index 28 "Expand Catalog that recreates all the save\nfiles from a single catalog.tcl\n"
}
set geom [wm geom .]
set re {^([0-9]+)x([0-9]+)([+-])([+-]?[0-9]+)([+-])([+-]?[0-9]+)}
regexp $re $geom -> dx0 dy0 xs xpos ys ypos
set geomt [wm geom $thetear]
regexp $re $geomt -> dx dy xs xpost ys ypost
set newx [expr { $xpos + $dx0 +5 + $xx }] ;# place to the right of main window
set newy [expr { $ypos - 1 +$yy }]
wm geom $thetear ${dx}x$dy+${newx}+${newy}
if { $thetear ni $::tears } {
lappend ::tears $thetear
}
}
proc ::popup::create {m {tear 0} {tearoffcmd {}}} {
#----------------
# create menu (m) with from list of supplied items (a)
#---------------
set c $m
set m ".[string tolower $m]"
# destroy any pre-exising menu with the same name
destroy $m
# create new menus
menu $m -tearoff $tear {*}$tearoffcmd
foreach i $::popup::menu($c) {
#~~~puts "popup create $c $m $i"
if { [lindex $i 0] != "nop" } {
eval $m add $i
}
}
}
proc ::popup::show {w m} {
#---------------
# display the popup menu adjacent to the current pointer location
#---------------
set m ".[string tolower $m]"
foreach {x y} [winfo pointerxy $w] {}
set ::active(tag) $m
tk_popup $m $x $y
return
}
proc timems {args} {
set result [uplevel 1 time $args]
set number [format %.3f [expr {( [lindex $result 0] / 1000. )}]]
set number [regsub -all {\d(?=(\d{3})+($|\.))} $number {\0,}]
return "[format %12s $number ] milliseconds [lrange $result 2 end]"
}
proc testit {w} {
set tip [storeText 2]
# puts "w= |$w| tip= |$tip| "
tooltip::tooltip $w $tip
}
proc onoff {args} {
global tipsonoff
if { $tipsonoff } {
tooltip::tooltip on
} else {
tooltip::tooltip off
}
}
proc pick1 {args} {
.text insert insert "$args" $::texttag ;# put in here
focus -force .text
}
proc bt {args} { ;# debugging aid
if { $args eq "" } {
puts [join [lsort [bind Text]] \n]
puts ""
return
}
puts [bind Text $args]
}
proc clip {w test} {
# puts "w= |$w| test= |$test| "
clear text ;# don't clear the config settings, user can use clear to do that
set data [clipboard get]
global s name dump dump2
lassign $data s name dump
if { $s ne "set" } {
error "does not begin with a set command"
}
set ::tootip_varname $name
# puts stderr $data
puts "Command= |$s| name= |$name| list length= [llength $dump]"
wm title . "$::wtitle $name"
set dump2 [string range $dump 2 end ]
restore $w $dump2
testit $test
}
proc clear {what} {
puts stderr "Clear $what"
if { $what eq "text" } {
.text delete 1.0 end
after 0 {focus -force .text}
return
} elseif { $what eq "all" } {
.text delete 1.0 end
} elseif { $what eq "config" } {
} else {
error "bad clear $what"
}
if { [info command $::tooltip::G(TOPLEVEL).text] eq ""} {
# puts "not created yet"
return
}
# delete all tags and then restore them all, clears any set attributes
# puts stderr "clear configurations"
catch {destroy .con}
if [catch {
.text tag delete {*}[.text tag names]
$::tooltip::G(TOPLEVEL).text tag delete {*}[$::tooltip::G(TOPLEVEL).text tag names]
tooltip::set_tags $::tooltip::G(TOPLEVEL).text
tooltip::set_tags .text
foreach tag {51 52 53 54 55 56 57 58 59} { ;# recreate these, we lost them from above
tooltip::tooltip .text -tag grey$tag "grey$tag"
}
} err_code] {
puts "clear: $err_code"
}
after 0 {focus -force .text}
}
# overide these two actions that the text widget uses for
# its default bindings, so we can add the tags to pastes and insert
proc tk_textPaste {w} {
if {![catch {::tk::GetSelection $w CLIPBOARD} sel]} {
set oldSeparator [$w cget -autoseparators]
if {$oldSeparator} {
$w configure -autoseparators 0
$w edit separator
}
if {[tk windowingsystem] ne "x11"} {
catch { $w delete sel.first sel.last }
}
$w insert insert $sel $::texttag ;# modify here
if {$oldSeparator} {
$w edit separator
$w configure -autoseparators 1
}
}
}
proc ::tk::TextInsert {w s} {
if {$s eq "" || [$w cget -state] eq "disabled"} {
return
}
set compound 0
if {[TextCursorInSelection $w]} {
set oldSeparator [$w cget -autoseparators]
if {$oldSeparator} {
$w configure -autoseparators 0
$w edit separator
set compound 1
}
$w delete sel.first sel.last
}
$w insert insert $s $::texttag ;# modify here
$w see insert
if {$compound && $oldSeparator} {
$w edit separator
$w configure -autoseparators 1
}
}
proc make_border {lines pixels {grey 59}} { ;# if lines are 0 or less, place border around text
set surround 0
if { $lines <= 0 } {
set surround 1
}
if { $surround == 0} {
clear text
} else {
set last [.text index end]
set lines [lindex [split $last .] 0 ]
}
tooltip::tooltip configure -grey$grey {\
-background grey90 -bgstipple {} -borderwidth {} -elide {} -fgstipple {} -font {} -foreground black \
-justify {} -lmargin1 {} -lmargin2 {} -lmargincolor {} -offset {} -overstrike {} -overstrikefg {} \
-relief {} -rmargin {} -rmargincolor {} -selectbackground lightblue -selectforeground {} -spacing1 {} \
-spacing2 {} -spacing3 {} -tabs {} -tabstyle {} -underline {} -underlinefg {} -wrap {} \
}
tooltip::tooltip configure -grey$grey "-background \#969696 -borderwidth 5 -elide 0 \
-foreground black -lmargin1 3 -offset 0 -overstrike 0 \
-relief raised -selectbackground lightblue -spacing1 0 -spacing3 0 \
-tabs $pixels -tabstyle wordprocessor -underline 0"
if { $surround == 0} {
.text insert 1.0 [string repeat "\n" $lines] "normal black"
.text insert 1.end "\t " "normal grey$grey"
.text insert $lines.end "\t " "normal grey$grey"
} else {
.text insert 1.0 "\n" "normal black"
.text insert 1.end "\t " "normal grey$grey"
}
for {set m 2} {$m <= $lines -1} {incr m} {
.text insert $m.0 " " "normal grey$grey"
.text insert $m.end "\t" "normal black"
.text insert $m.end " " "normal grey$grey"
}
if { $surround == 1} {
.text insert end " \t " "normal grey$grey"
}
after 100 {console eval {focus -force .console}}
return
}
proc insert_clip {{indent 1}} {
set data [clipboard get]
set lines [split $data \n]
set n 1
foreach line $lines {
.text insert [incr n].1 "[string repeat " " $indent]$line" "normal black"
if { $n == [llength $lines] } { ;# skip last null entry that split makes
break
}
}
after 100 {console eval {focus -force .console}}
return
}
# toggleFont --
# Make the text appear in bold, italic, underline font or normal
# also current color
# Arguments:
# None
#
# Returns:
# Nothing
#
# Side effects:
# Next letters typed or pasted in the text widget have the selected font and color
#
proc toggleFont {} {
global bold
global italic
global under
global red
global texttag
global nowcolor
set type ""
if { $bold } {
append type "bold"
}
if { $italic } {
append type "italic"
}
if { $under } {
append type "under"
}
if { $type eq "" } {
set type "normal"
}
append type " $nowcolor"
set texttag [string trim $type ]
# puts "texttag= |$texttag| "
Apply2Selection
focus -force .text
}
proc colorset {} {
global texttag nowcolor colorlab
lassign $texttag style
set texttag "$style $nowcolor"
# puts $texttag
set fg black
if { $nowcolor in {black green red violet grey} } {
set fg white
}
set bg $nowcolor
if { $nowcolor eq "blue" } {
set bg lightblue
}
$colorlab configure -background $bg -foreground $fg
Apply2Selection
focus -force .text
}
proc Apply2Selection {} {
set s [.text tag ranges sel]
# puts "s= |$s| "
if { $s eq "" } { ;# isn't one
return
}
lassign $s from to
set chars [.text get {*}$s]
.text delete {*}$s
# puts "newattr= $from $chars $::texttag "
.text insert $from $chars $::texttag
.text tag add sel $from $to
}
proc config2text {args} { ;# copy all the config args for colors into our text edit widget
set opts2 {-red -green -blue -orange -violet -black -grey -grey51 -grey52 -grey53 -grey54 -grey55 -grey56 -grey57 -grey58 -grey59}
set gt ${::tooltip::G(TOPLEVEL)}.text
foreach c $opts2 {
set tag [string range $c 1 end]
set all [$gt tag config $tag] ;# get all attr's even those that are null
foreach item $all {
lassign $item key x2 x3 x4 val
set err_code ""
if [catch {
.text tag configure $tag {*}[list $key $val] ;# if null there, we will reset it to null in .text also
} err_code] {
# puts "tried to copy tag: |$tag| key/val: |$key| |$val| got error: $err_code"
catch {.text tag configure $tag {*}[list $key {}]} ;# if this gets a bad value, our tag becomes useless
}
}
}
.text configure -foreground [tooltip::tooltip configure -foreground]
# .text configure -background [tooltip::tooltip configure -background]
.text configure -wrap [tooltip::tooltip configure -wrap]
if { [tooltip::tooltip config -wrap] eq "word" } {
set ::wraponoff 1
} else {
set ::wraponoff 0
}
}
proc colchange {args} {;# someone changed the current color
global nowcolor
if { [info command .con] eq ".con"} { ;# if there's a configure dialog open,
con_dlog $nowcolor ;# start it up again with the new color
}
}
proc main_dlog {{color Borders}} { ;# configure dialog
set savegeom ""
if { [info command .win] eq ".win"} {
set savegeom [wm geom .win]
}
destroy .win
global configs
if [catch {
foreach ii [array names configs 1??,*] {unset ::configs($ii)}
} err_code] {
puts $err_code
}
if { [info command .win] eq ".win" } {
return ;# already or still exists
}
toplevel .win
if { $::themex && $::darkonoff} {
.win config -bg grey20
}
ttk::label .win.label1 -text "--Configuration--"
label .win.label2 -text $color -background white -foreground black -relief ridge
ttk::button .win.apply -text "Apply" -command [list doapplyx main]
grid .win.label1 .win.label2 .win.apply
set fields [list \
{background color {value1 value2} "To reset, erase and apply (or Enter)"}\
{-foreground color {value1 value2}}\
{-highlightbackground color {value1 value2}}\
{-highlightcolor color {value1 value2}}\
{relief combobox {flat groove raised ridge solid sunken} "Works together with borderwidth"}\
{{} separator {0 50 1 0}}\
{borderwidth spinbox {0 30 1 0} "All spinboxes and comboboxes can be adjusted\nusing the mousewheel\n"}\
{highlightthickness spinbox {0 50 1 0} "Tips cannot be highlighted, but this\nwill create an extra border around\nthe tip.\n"}\
{{} separator {0 50 1 0}}\
{padx spinbox {0 50 1 0} "Extra horizontal spacing on both sides"}\
{pady spinbox {0 50 1 0} "Extra vertical spacing, top and bottom"}\
{{} separator {0 50 1 0}}\
{spacing1 spinbox {0 50 1 0} "Vertical spacing between lines"}\
{-spacing2 spinbox {0 50 1 0}}\
{spacing3 spinbox {0 50 1 0}}\
{{} separator {value1 value2}}\
]
set i 100
foreach field $fields {
lassign $field name type values tips
if { [string index $name 0] eq "-" } {
continue
}
set ddd {} ;# assume no dialog needed
if { $type ne "separator" } {
set vnow [.text cget -$name]
}
incr i
set l [ttk::label .win.l$i -text "$name" ]
if { $tips ne "" } {
tooltip::tooltip .win.l$i $tips
}
set ::configs($i,type) $type
if { $type eq "combobox" } {
set w [ttk::combobox .win.w$i -textvariable ::configs($i,value) -values $values ]
bind .win.w$i <<ComboboxSelected>> [list setcombox $i $color]
set ::configs($i,value) $vnow
set ::configs($i,legal) $values
} elseif { $type eq "spinbox" } {
lassign $values from to by initial
set w [ttk::spinbox .win.w$i -textvariable ::configs($i,value) -from $from -to $to -increment $by -command [list setspinx $i $color]]
set ::configs($i,value) $vnow
bind .win.w$i <Key-Return> [list setspinx $i main]
if { $vnow eq "" } {
.win.w$i set $initial
} else {
.win.w$i set $vnow
}
} elseif { $type eq "separator" } {
set w [ttk::separator .win.w$i]
} elseif { $type eq "color" } {
set w [ttk::entry .win.w$i -textvariable ::configs($i,value)]
set ::configs($i,value) $vnow
set ddd [ttk::button .win.cw$i -command [list setcolorx $i $color] -text Color...]
bind .win.w$i <Key-Return> [list doapplyx main]
} elseif { $type eq "type" } {
} else { ;# no default
error "bad configure type $type"
}
grid $l $w {*}$ddd -sticky w -padx 10
set configs($i,name) $name
}
tooltip::tooltip .win.apply "Apply values for typed in values\n"
# button .win.ok -text "Ok" -command {}
# ttk::button .win.done -text "Done" -command {destroy .win}
# grid .win.apply .win.done
if { $savegeom ne "" } {
wm geom .win $savegeom
} else {
wm geom .win +9+3
}
}
proc main2tips {} {
if {![winfo exists $::tooltip::G(TOPLEVEL)]} {
::tooltip::createToplevel
}
foreach fig {background relief borderwidth highlightthickness padx pady spacing1 spacing3} {
$::tooltip::G(TOPLEVEL).text config -$fig [.text cget -$fig]
}
}
proc dump_main_config {} {
puts "\n\n#---------------------\n# Copy this to the user program:\n"
puts "if \{!\[winfo exists \$::tooltip::G(TOPLEVEL)\]\} \{"
puts " ::tooltip::createToplevel"
puts "\}"
set figs {$::tooltip::G(TOPLEVEL).text configure }
foreach fig {background relief borderwidth highlightthickness padx pady spacing1 spacing3} {
append figs " " -$fig " " [.text cget -$fig]
}
puts $figs
if { [info exist ::bgchange] } {
set bg [tooltip::tooltip config -bg]
puts "tooltip::tooltip config -background $bg"
}
puts "#---------------------\n"
}
proc con_dlog {{color grey51}} { ;# configure dialog
set savegeom ""
if { [info command .con] eq ".con"} {
set savegeom [wm geom .con]
}
destroy .con
global configs
if [catch {
foreach ii [array names configs 2??,*] {unset ::configs($ii)}
} err_code] {
puts $err_code
}
if { [info command .con] eq ".con" } {
return ;# already or still exists
}
toplevel .con
if { $::themex && $::darkonoff} {
.con config -bg grey20
}
ttk::label .con.label1 -text "--Configuration--"
label .con.label2 -text $color -background white -foreground black -relief ridge
ttk::button .con.apply -text "Apply" -command [list doapply $color]
grid .con.label1 .con.label2 .con.apply
set fields [list \
{background color {value1 value2}}\
{foreground color {value1 value2}}\
{-bgstipple entry {value1 value2}}\
{-fgstipple type {value1 value2}}\
{font font {value1 value2}}\
{justify combobox {left center right}}\
{offset spinbox {-25 25 1 0} "Raises or lowers the text"}\
{borderwidth spinbox {0 30 1 0}}\
{relief combobox {flat groove raised ridge solid sunken} "Works together with borderwidth"}\
{lmargin1 spinbox {0 100 1 0} "Only effective if text of this color\nbegins on a line\n"}\
{lmargin2 spinbox {0 100 1 0}}\
{lmargincolor color {value1 value2}}\
{rmargin spinbox {0 100 1 0}}\
{rmargincolor color {value1 value2}}\
{elide checkbutton {value1 value2} "Hides all text of this color"}\
{overstrike checkbutton {value1 value2}}\
{underline checkbutton {value1 value2}}\
{overstrikefg color {value1 value2}}\
{underlinefg color {value1 value2}}\
{-selectbackground color {value1 value2}}\
{-selectforeground color {value1 value2}}\
{- separator {0 50 1 0}}\
{spacing1 spinbox {0 50 1 0}}\
{spacing2 spinbox {0 50 1 0}}\
{spacing3 spinbox {0 50 1 0}}\
{tabs entry {value1 value2} "If tabs is a single integer, it can be\nadjusted by 1 unit with the mousewheel\nshift-wheel adjusts by 10\n"}\
{tabstyle combobox {tabular wordprocessor}}\
{wrap combobox {none char word} "Still experimental"}\
{{} separator {value1 value2}}\
]
set i 200
foreach field $fields {
lassign $field name type values tips
if { [string index $name 0] eq "-" } {
continue
}
set ddd {} ;# assume no dialog needed
if { $type ne "separator" } {
set vnow [lindex [.text tag config $color -$name] end ]
}
incr i
set l [ttk::label .con.l$i -text "$name" ]
if { $tips ne "" } {
tooltip::tooltip .con.l$i $tips
}
set ::configs($i,type) $type
if { $type eq "combobox" } {
set w [ttk::combobox .con.w$i -textvariable ::configs($i,value) -values $values ]
bind .con.w$i <<ComboboxSelected>> [list setcombo $i $color]
set ::configs($i,value) $vnow
set ::configs($i,legal) $values
} elseif { $type eq "spinbox" } {
lassign $values from to by initial
set w [ttk::spinbox .con.w$i -textvariable ::configs($i,value) -from $from -to $to -increment $by -command [list setspin $i $color]]
set ::configs($i,value) $vnow
bind .con.w$i <Key-Return> [list setspin $i $color]
if { $vnow eq "" } {
.con.w$i set $initial
} else {
.con.w$i set $vnow
}
} elseif { $type eq "separator" } {
set w [ttk::separator .con.w$i]
} elseif { $type eq "checkbutton" } {
set w [ttk::checkbutton .con.w$i -variable ::configs($i,value) -command [list setcheck $i $color]]
set ::configs($i,value) $vnow
} elseif { $type eq "font" } {
set w [ttk::entry .con.w$i -textvariable ::configs($i,value)]
set ::configs($i,value) $vnow
set ::configs($i,legal) "-font"
set ddd [ttk::button .con.cw$i -command [list setfont $i $color] -text Font...]
bind .con.w$i <Key-Return> [list doapply $color]
} elseif { $type eq "color" } {
set w [ttk::entry .con.w$i -textvariable ::configs($i,value)]
set ::configs($i,value) $vnow
set ddd [ttk::button .con.cw$i -command [list setcolor $i $color] -text Color...]
bind .con.w$i <Key-Return> [list doapply $color]
} elseif { $type eq "entry" } {
set w [ttk::entry .con.w$i -textvariable ::configs($i,value)]
set ::configs($i,value) $vnow
bind .con.w$i <Key-Return> [list doapply $color]
bind .con.w$i <MouseWheel> [list entrywheel %D 1 $i $color 1 2000]
bind .con.w$i <Shift-MouseWheel> [list entrywheel %D 10 $i $color 1 2000]
} elseif { $type eq "type" } {
} else { ;# no default
error "bad configure type $type"
}
grid $l $w {*}$ddd -sticky w -padx 10
# puts "$w / name= |$name| type= |$type| values= |$values| "
set configs($i,name) $name
}
tooltip::tooltip .con.apply "Apply static values from text entries\nFor example font, named colors, or tabs\nNote: relief needs a borderwidth\nspinboxes should support mousewheel\nCan also type Return in any entry to apply\nMany attributes only apply if first used on a\nline e.g. spacing123, margins or tabs\n"
# button .con.ok -text "Ok" -command {}
# ttk::button .con.done -text "Done" -command {destroy .con}
# grid .con.apply .con.done
if { $savegeom ne "" } {
wm geom .con $savegeom
} else {
wm geom .con +9+3
}
}
proc between {a b c} {
if { $b < $a } {
return $a
} elseif { $b > $c } {
return $c
} else {
return $b
}
}
proc copyg {from to} {
if { ![string is integer $from ] || ![string is integer $to ] } {
error "$from and $to are not both integers"
}
if {!( [between 1 $from 9] == $from) || ! ( [between 1 $to 9] == $to)} {
error "$from or $to out of range (1..9)"
}
tooltip::tooltip configure -grey5$to [tooltip::tooltip configureall -grey5$from]
if { [info command .con] eq ".con" } {
set geom [wm geom .con]
con_dlog grey5$to
set ::nowcolor grey5$to
wm geom .con $geom
}
}
proc tomain {grey} { ;# text
set zoo [dict create {*}[tooltip::tooltip configureall -grey5$grey]]
dict for {a b} $zoo {
if [catch {
$::tooltip::G(TOPLEVEL).text config {*}[list $a $b]
foo $::tooltip::G(TOPLEVEL).text config {*}[list $a $b]
} err_code] {
puts stderr " {*}[list $a $b] - $err_code"
}
}
}
proc entrywheel {dir mult i color from to} {
set v $::configs($i,value)
if {! [string is integer $v] || $v eq ""} {
set set ::configs($i,value) ""
return ;# if not a simple integer, we just punt
}
if { $dir > 0} {
incr v $mult
} else {
incr v -$mult
}
set ::configs($i,value) [between $from $v $to]
doapply $color
}
proc doapply {color} {
global configs
for {set i 1} {$i < 100} {incr i} {
if {! [info exist ::configs($i,name)] } {
# puts "done doapply $i"
return
}
if { $::configs($i,type) in {font color entry spinbox}} {
# puts "apply to $color [format %10s $i ] with [format %15s |$::configs($i,name)| ] type= [format %10s |$::configs($i,type)| ] value = |$::configs($i,value)|"
if [catch {
tooltip::tooltip config -$color [list -$::configs($i,name) $::configs($i,value)]
} err_code] {
puts stderr "$err_code will try to set to null"
if [catch {
tooltip::tooltip config -$color [list -$::configs($i,name) {}]
} err_code] {
puts stderr "couldn't set to null: $err_code"
}
}
}
}
}
proc doapplyx {args} {
global configs
for {set i 101} {$i < 200} {incr i} {
if {! [info exist ::configs($i,name)] } {
return
}
if { $::configs($i,type) in {font color entry spinbox}} {
if [catch {
set name $::configs($i,name)
set value $::configs($i,value)
if { $name eq "background" } {
if { $value eq ""} {
tooltip::tooltip config -background lightyellow
.text config -background grey85
unset -nocomplain ::bgchange
set ::configs($i,value) grey85
} else {
tooltip::tooltip config -background $value
set ::bgchange 1
}
} elseif { $name eq "foreground" } {
if { $value eq ""} {
tooltip::tooltip config -background black
.text config -background black
unset -nocomplain ::fgchange
set ::configs($i,value) black
} else {
tooltip::tooltip config -foreground $value
set ::fgchange 1
}
} else {
.text config {*}[list -$name $value]
}
} err_code] {
puts stderr "doapplyx: $err_code"
}
}
}
wm geom . [wm geom .] ; main2tips
}
proc foo {args} { ;# for debug only
puts "foo: args= |$args|"
}
proc setcombo {i color} {
# puts "combo: i= |$i| color= |$color| "
if { $::configs($i,value) in $::configs($i,legal)} {
tooltip::tooltip config -$color "-$::configs($i,name) $::configs($i,value)"
} else {
puts stderr "invalid $::configs($i,name) not one of $::configs($i,legal)"
}
}
proc setcombox {i color} {
if { $::configs($i,value) in $::configs($i,legal)} {
.text config {*}"-$::configs($i,name) $::configs($i,value)"
} else {
puts stderr "invalid $::configs($i,name) not one of $::configs($i,legal)"
}
wm geom . [wm geom .] ; main2tips
}
proc setcheck {i color} {
# puts "check: i= |$i| color= |$color| "
tooltip::tooltip config -$color "-$::configs($i,name) $::configs($i,value)"
}
proc setspin {i color} {
# puts "spin: i= |$i| color= |$color| "
tooltip::tooltip config -$color "-$::configs($i,name) $::configs($i,value)"
}
proc setspinx {i color} {
.text config {*}"-$::configs($i,name) $::configs($i,value)"
wm geom . [wm geom .] ; main2tips
}
proc setcolor {i color} {
set ncolor [tk_chooseColor -initialcolor $color -title "Choose color"]
# puts "col: i= |$i| ncolor= |$ncolor| color= |$color| "
if { $color ne "" } {
set ::configs($i,value) $ncolor
tooltip::tooltip config -$color "-$::configs($i,name) $ncolor"
doapply $color
}
}
proc setcolorx {i color} {
set color [.text cget -bg]
set ncolor [tk_chooseColor -initialcolor $color -title "Choose color"]
if { $color ne "" } {
set ::configs($i,value) $ncolor
.text config -$::configs($i,name) $ncolor
doapplyx main
}
}
proc setfont {i color} {
tk fontchooser configure -command [list gotfont $i $color]
tk fontchooser show
# puts "col: i= |$i| ncolor= |$ncolor| color= |$color| "
}
proc gotfont {i color args} {
# puts "gotfont i= |$i| color= |$color| args= |$args| "
lassign $args nfont
if { $color ne "" } {
set ::configs($i,value) $nfont
tooltip::tooltip config -$color "-$::configs($i,name) [list $nfont]"
}
}
catch {unset conv} ;# we generate this once only, takes time to build it
proc tocode {str} { ;# revert back to unicode \uFFFF so can be placed in source code
global conv
if { ![info exist conv] } {
set conv [list "\t" "\\t" " " " "] ;# space to space for speedup, same as letter/symbols below
set c {e i a n s o r t l c u d p m h g y b f v k w z x j q E I A N S O R T L C U D P M H G Y B F V K W Z X J Q 0 1 2 3 4 5 6 7 8 9 0}
set d {! @ # $ % ^ & * ( ) _ + - = \{ \} [ ] ; ' : \" < > , . / ?}
foreach letter [concat {{ }} $c $d] {
lappend conv $letter $letter
}
# most chars are not unicode, so the above is found quickly worst case is no hit at all
for {set m 0x100} {$m < 0xffff} {incr m} {
if { $m == 0x2424 || $m == 0x2409} {
continue ;# except for our nl char or horizontal tab
}
set h [format %04x $m ]
set y "set x \\u$h"
eval $y
lappend conv $x "\\u$h"
}
}
return [string map $conv $str]
}
# storeText --
# Dump the contents
#
# Arguments:
# action 1=save 2=return text dump, with unicode back to \uxxxx form so we can use in a program
#
# Returns:
# Nothing
#
# Side effects:
# Prints the contents of the text widget in a console
# and saves it based on action
#
proc storeText {action} {
# console show
global tags
set ender "end"
set textdump [.text dump 1.0 $ender]
if { [.text get end-1c end] eq "\n" } {
# puts "trimming last newline"
set textdump [lrange $textdump 0 end-3]
}
if { $action == 1} {
set ::save $textdump
set io [open $::savefile w]
fconfigure $io -encoding utf-8
puts $io [tocode $::save]
close $io
set io [open $::savefile2 w]
set out [tooltip::tooltip configureall]
regsub -nocase -linestop -lineanchor -all {(-grey5[1-9]|-blue|-violet|-red|-green|-orange|-black|-grey )} $out "\\\n\\1" out2
puts $io "tooltip::tooltip configure $out2"
close $io
}
if { $action == 2} {
set ans "##[tocode $textdump]" ;# so we can time this easier
return $ans
}
set tcode "\nset $::tootip_varname \{##[tocode $textdump]\}\n\n" ;# code we can copy into our program
clipboard clear ; clipboard append "$tcode" ;# the 2 #'s tell tooltip it's a complex tip
set ::clipboard $tcode
catch {unset ::tags}
set cnt 0
foreach {key value index} $textdump { ;# fancy dump
set color normal
if { $key eq "text" } {
set color red
set value [string map {"\n" "\u2424" "\t" "\u2409" } $value]
}
if { $key eq "tagon" } {
set color normal
set ::tags($value) {}
foreach item [.text tag configure $value] {
set value2 [lindex $item 4]
if {[string length $value2] > 0} {
set option [lindex $item 0]
lappend ::tags($value) $option $value2
}
}
}
cputs $color "key= |[format %10s $key]| index= |[format %10s $index ]| value= [format %-30s |[tocode $value]|] \n"
if { [incr cnt] % 100 == 0 } {
update
}
}
puts \n-----------------\n
if [catch {
parray ::tags
} err_code] {
puts $err_code
}
puts \n-----------------\n
}
proc loadf {w test} {
set con 0
if { [info command .con] eq ".con" } {
set con 1 ;# there's a dialog open
set geom [wm geom .con]
}
clear all
set io [open $::savefile r]
fconfigure $io -encoding utf-8 ;# for our unicode characters
set ::save [read -nonewline $io]
close $io
if { [lindex $::save end-2] eq "text" && [lindex $::save end-1] eq "\n"} {
# puts "trimming last newline on load"
set ::save [lrange $::save 0 end-3]
}
restore $w $::save
if { [file exist $::savefile2] } {
source $::savefile2
}
testit $test
if { [tooltip::tooltip config -wrap] eq "word" } {
set ::wraponoff 1
} else {
set ::wraponoff 0
}
if { $con } {
con_dlog $::nowcolor
wm geom .con $geom
}
}
proc restore {w savex} {
set save [subst -nocommands -novariables $savex]
# create items, restoring their attributes
foreach {key value index} $save \
{
switch $key \
{
exec { eval [string replace $value 0 [string first " " $value]-1 $w] }
image { $w image create $index -name $value }
text { $w insert $index $value }
mark {
switch $value {
current { set currentIndex $index }
insert { set insertIndex $index}
default { $w mark set $value $index }
}
}
tagon { set tag($value) $index }
tagoff { $w tag add $value $tag($value) $index }
window { $w window create $index -window $value }
}
}
$w mark set current $currentIndex
$w mark set insert $insertIndex
}
proc cputs { color args} { ;# this (re-)defines my color puts
if { $::tcl_platform(platform) eq "windows" || 1} {
if { $color eq "red" } {
puts -nonewline stderr {*}$args
} else {
puts -nonewline {*}$args
}
} else {
puts -nonewline {*}$args
}
}
#proc
# main --
# Run the thing
#
# Include a console for non-windows and modify it
#puts "before console "
package require Tk
if { $::tcl_platform(platform) ne "windows" } {
if {[catch {console show}]} { ;# if already done, bypass
puts "enable console"
######################## linux console
########################################################################
# Check Tcl/Tk support
########################################################################
if {[catch {package require Tcl 8-}]} {
package require Tcl 7.5-
}
if {[catch {package require Tk 8-}]} {
if {[catch {package require Tk 4.1}]} {
return -code error "Tk required but not loaded."
}
}
########################################################################
# Provide the support which the Tk library script console.tcl assumes
########################################################################
# 1. Create an interpreter for the console window widget and load Tk
set consoleInterp [interp create]
$consoleInterp eval [list set tk_library $tk_library]
$consoleInterp alias exit exit
load "" Tk $consoleInterp
# 2. A command 'console' in the application interpreter
;proc console {sub {optarg {}}} [subst -nocommands {
switch -exact -- \$sub {
title {
$consoleInterp eval wm title . [list \$optarg]
}
hide {
$consoleInterp eval wm withdraw .
}
show {
$consoleInterp eval wm deiconify .
}
eval {
$consoleInterp eval \$optarg
}
default {
error "bad option \\\"\$sub\\\": should be hide, show, or title"
}
}
}]
# 3. Alias a command 'consoleinterp' in the console window interpreter
# to cause evaluation of the command 'consoleinterp' in the
# application interpreter.
;proc consoleinterp {sub cmd} {
switch -exact -- $sub {
eval {
uplevel #0 $cmd
}
record {
history add $cmd
catch {uplevel #0 $cmd} retval
return $retval
}
default {
error "bad option \"$sub\": should be eval or record"
}
}
}
if {[package vsatisfies [package provide Tk] 4]} {
$consoleInterp alias interp consoleinterp
} else {
$consoleInterp alias consoleinterp consoleinterp
}
# 4. Bind the <Destroy> event of the application interpreter's main
# window to kill the console (via tkConsoleExit)
bind . <Destroy> [list +if {[string match . %W]} [list catch \
[list $consoleInterp eval ::tk::ConsoleExit]]]
# 5. Redirect stdout/stderr messages to the console
if { 0 } { ;#no, don't use this, it doesn't work (unicode fail)
# 5a. we can use TIP#230 channel transforms to achieve this simply:
} else {
# 5b. Pre-8.6 needs to redefine 'puts' in order to redirect stdout
# and stderr messages to the console
rename puts tcl_puts
;proc puts {args} [subst -nocommands {
switch -exact -- [llength \$args] {
1 {
if {[string match -nonewline \$args]} {
if {[catch {uplevel 1 [linsert \$args 0 tcl_puts]} msg]} {
regsub -all tcl_puts \$msg puts msg
return -code error \$msg
}
} else {
$consoleInterp eval [list ::tk::ConsoleOutput stdout \
"[lindex \$args 0]\n"]
}
}
2 {
if {[string match -nonewline [lindex \$args 0]]} {
$consoleInterp eval [list ::tk::ConsoleOutput stdout \
[lindex \$args 1]]
} elseif {[string match stdout [lindex \$args 0]]} {
$consoleInterp eval [list ::tk::ConsoleOutput stdout \
"[lindex \$args 1]\n"]
} elseif {[string match stderr [lindex \$args 0]]} {
$consoleInterp eval [list ::tk::ConsoleOutput stderr \
"[lindex \$args 1]\n"]
} else {
if {[catch {uplevel 1 [linsert \$args 0 tcl_puts]} msg]} {
regsub -all tcl_puts \$msg puts msg
return -code error \$msg
}
}
}
3 {
if {![string match -nonewline [lindex \$args 0]]} {
if {[catch {uplevel 1 [linsert \$args 0 tcl_puts]} msg]} {
regsub -all tcl_puts \$msg puts msg
return -code error \$msg
}
} elseif {[string match stdout [lindex \$args 1]]} {
$consoleInterp eval [list ::tk::ConsoleOutput stdout \
[lindex \$args 2]]
} elseif {[string match stderr [lindex \$args 1]]} {
$consoleInterp eval [list ::tk::ConsoleOutput stderr \
[lindex \$args 2]]
} else {
if {[catch {uplevel 1 [linsert \$args 0 tcl_puts]} msg]} {
regsub -all tcl_puts \$msg puts msg
return -code error \$msg
}
}
}
default {
if {[catch {uplevel 1 [linsert \$args 0 tcl_puts]} msg]} {
regsub -all tcl_puts \$msg puts msg
return -code error \$msg
}
}
}
}]
$consoleInterp alias puts puts
# Restore normal [puts] if console widget goes away...
proc Oc_RestorePuts {slave} {
rename puts {}
rename tcl_puts puts
interp delete $slave
}
}
# 6. No matter what Tk_Main says, insist that this is an interactive shell
set tcl_interactive 1
########################################################################
# Evaluate the Tk library script console.tcl in the console interpreter
########################################################################
$consoleInterp eval source [list [file join $tk_library console.tcl]]
if {[string match 8.3.4 $tk_patchLevel]} {
# Workaround bug in first draft of the tkcon enhancments
$consoleInterp eval {
bind Console <Control-Key-v> {}
}
}
$consoleInterp alias Oc_RestorePuts Oc_RestorePuts $consoleInterp
$consoleInterp eval {
bind Console <Destroy> +Oc_RestorePuts
}
unset consoleInterp
console title "[wm title .] Console"
######################## end linux console
} else { ;# already done
puts "console already done"
}
} ;# if not windows
if [catch { ;# add our enhancements if not allready there (in the tclkit)
console eval {
if { ![info exist ::tk::do_scroll] } {
# proc console stuff
set vers [split [info patch] .]
# was: $::tcl_platform(platform) eq "windows" && [package vcompare [info patch] 8.6.9]
if { [.menubar.edit entrycget 5 -label] eq "Font..."} { ;# test for font... menu item, if there, +1 to find incr/decr font size
set menuincr 1
puts "incr menu, there's a Font... item"
} else {
set menuincr 0
puts "no incr menu, there's no Font... item"
}
if [catch {
.console config -inactiveselectbackground SystemInactiveBorder
} err_code] {
puts stderr "inactive border setup: $err_code "
}
.console config -tabs {32 left} -tabstyle wordprocessor -width 30
# wm geom . 110x30+446+9
bind all <Button-3> {.menubar.edit invoke 2}
bind all <Control-Button-3> {.menubar.edit invoke 1;.menubar.edit invoke 2}
pack forget .console .sb .consoleframe
pack [frame .frame -bg black] -side left -fill y -ipady 10 -pady 10
#pack [button .frame.eval -text Cev -command {clipboard clear; clipboard append "console eval \{\}"; .menubar.edit invoke 2}] -side top -fill x
pack [button .frame.clear -bg white -fg black -text Clear -command {.menubar.file invoke 2}] -side top -fill x
pack [button .frame.smaller -bg white -text {font -} -command {.menubar.edit invoke [expr ( $menuincr+6 )];after 100 {.frame.repos invoke}}] -side top -fill x
pack [button .frame.bigger -bg white -text {font +} -command {.menubar.edit invoke [expr ( $menuincr+5 )];after 100 {.frame.repos invoke}}] -side top -fill x
pack [button .frame.exit -bg pink -text Exit -command {exit}] -side top -fill x
pack [button .frame.repos -bg white -text BottOM -command {.console see end; .console mark set insert end}] -side top -fill x
pack [frame .frame.frame -bg black] -side top -fill x
pack [button .frame.frame.pm20 -bg gray -text -x -command {wm geom . [expr [lindex [split [wm geom .] x] 0]-10]x[lindex [split [wm geom .] x] 1]}] -side left -fill x -expand 1
pack [button .frame.frame.pp20 -bg gray -text +x -command {wm geom . [expr [lindex [split [wm geom .] x] 0]+10]x[lindex [split [wm geom .] x] 1]}] -side left -fill x -expand 1
.frame.bigger invoke;.frame.bigger invoke;.frame.bigger invoke;.frame.bigger invoke
pack [checkbutton .frame.scroll -bg white -fg black -text scroll -variable ::tk::do_scroll] -side top -fill x
pack .consoleframe -in . -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 -side left
pack .console -in .consoleframe -anchor center -expand 1 -fill both -ipadx 0 -ipady 0 -padx 1 -pady 1 -side left
pack .sb -in .consoleframe -anchor center -expand 0 -fill both -ipadx 0 -ipady 0 -padx 1 -pady 1 -side right
set ::tk::console::maxLines 10000
.menubar add casc -label Extra2 -menu [menu .menubar.extra -tearoff 0]
proc menu+ {head label cmd} {
set cmd2 [list consoleinterp eval $cmd]
.menubar.$head add command -label $label -command $cmd2
}
# menu+ extra {Widget Tree} {wtree}
proc ::tk::ConsoleOutput {dest string} {
set w .console
$w insert output $string $dest
::tk::console::ConstrainBuffer $w $::tk::console::maxLines
if {$::tk::do_scroll} {$w see insert}
}
set ::tk::do_scroll 1
}
}
} errstr ] {
puts stderr "console error = $errstr"
}
mainWindow
The easiest way to include borders around tooltips is to configure the text widget that cooltip creates:
(The latest GUI code has a border menu that can do this interactively, and output the code to the console window).
# First, the toplevel must be createad, if not already done.
# Paste this into the gui editor's console (cntrl-v not the paste button)
# to apply it there and see results in the editor's own tips as well as any
# being created
#
if {![winfo exists $::tooltip::G(TOPLEVEL)]} {
::tooltip::createToplevel
}
$::tooltip::G(TOPLEVEL).text config -bd 8 -relief ridge -pady 4 -padx 4