path: root/library/systray.tcl

# systray.tcl --

# This file defines the 'tk systray' command for icon display and manipulation
# in the system tray on X11, Windows, and macOS, and the 'tk sysnotify' command
# for system alerts on each platform. It implements an abstraction layer that
# presents a consistent API across the three platforms.

# Copyright © 2020 Kevin Walzer/WordTech Communications LLC.
# Copyright © 2020 Eric Boudaillier.
# Copyright © 2020 Francois Vogel.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# Pure-Tcl system tooltip window for use with system tray icon if native
# implementation not available.

namespace eval ::tk::systray {
    variable _created 0
    variable _options {-image "" -text "" -button1 "" -button3 ""}
    variable _current {}
    variable _ico

    proc _balloon {w help} {
	bind $w <Any-Enter> "after 100 [list [namespace current]::_balloon_show %W [list $help] cursor]"
	bind $w <Any-Leave> "destroy %W._balloon"
    }

    proc _balloon_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 child of the desired widget
	if {([winfo class $w] ne "Menu") && ![string match $w* [eval [list winfo containing] \
								    [winfo pointerxy $w]]]} {
	    return
	}

	set top $w._balloon
	catch {destroy $top}
	toplevel $top -bg black -bd 1
	wm overrideredirect $top 1
	if {[tk windowingsystem] eq "aqua"}  {
	    ::tk::unsupported::MacWindowStyle style $top help none
	}
	pack [message $top._txt -aspect 10000 -text $msg]

	update idletasks
	set screenw [winfo screenwidth $w]
	set screenh [winfo screenheight $w]
	set reqw [winfo reqwidth $top]
	set reqh [winfo reqheight $top]
	# 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 y [expr {[winfo pointery $w]+20}]
	    if {($y < $screenh) && ($y+$reqh) > $screenh} {
		set y [expr {[winfo pointery $w]-$reqh-5}]
	    }
	} elseif {$i ne ""} {
	    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]
	}

	wm geometry $top +$x+$y
	wm deiconify $top
	raise $top

	if {[tk windowingsystem] eq "aqua" && $focus ne ""} {
	    # Aqua's help window steals focus on display
	    after idle [list focus -force $focus]
	}
    }

    proc _win_callback {msg} {
	variable _current
	# The API at the Tk level does not feature bindings to double  clicks. Whatever
	# the speed the user clicks with, he expects the single click binding to fire.
	# Therefore we need to bind to both WM_*BUTTONDOWN and to WM_*BUTTONDBLCLK.
	switch -exact -- $msg {
	    WM_LBUTTONDOWN - WM_LBUTTONDBLCLK {
		uplevel #0 [dict get $_current -button1]
	    }
	    WM_RBUTTONDOWN - WM_RBUTTONDBLCLK {
		uplevel #0 [dict get $_current -button3]
	    }
	}
    }

    namespace export create configure destroy
    namespace ensemble create
}


# Pure-Tcl system notification window for use if native implementation not available.
namespace eval ::tk::sysnotify:: {

    proc _notifywindow {title msg} {
	catch {destroy ._notify}
	set w [toplevel ._notify]
	if {[tk windowingsystem] eq "aqua"} {
	    ::tk::unsupported::MacWindowStyle style $w utility {hud
closeBox resizable}
	    wm title $w "Alert"
	}
	if {[tk windowingsystem] eq "win32"} {
	    wm attributes $w -toolwindow true
	    wm title $w "Alert"
	}
	label $w.l -bg gray30 -fg white -image ::tk::icons::information
	pack $w.l -fill both -expand yes -side left
	message $w.message -aspect 150 -bg gray30 -fg white -aspect 150
-text $title\n\n$msg -width 280
	pack $w.message -side right -fill both -expand yes
	if {[tk windowingsystem] eq "x11"} {
	    wm overrideredirect $w true
	}
	wm attributes $w -alpha 0.0
	set xpos [expr {[winfo screenwidth $w] - 325}]
	wm geometry $w +$xpos+30
	::tk::sysnotify::_fade_in $w
	after 3000 ::tk::sysnotify::_fade_out $w
    }

    #Fade and destroy window.
    proc _fade_out {w} {
	catch {
	    set prev_degree [wm attributes $w -alpha]
	    set new_degree [expr {$prev_degree - 0.05}]
	    set current_degree [wm attributes $w -alpha $new_degree]
	    if {$new_degree > 0.0 && $new_degree != $prev_degree} {
		after 10 [list ::tk::sysnotify::_fade_out $w]
	    } else {
		destroy $w
	    }
	}
    }

    #Fade the window into view.
    proc _fade_in {w} {
	catch {
	    raise $w
	    wm attributes $w -topmost 1
	    set prev_degree [wm attributes $w -alpha]
	    set new_degree [expr {$prev_degree + 0.05}]
	    set current_degree [wm attributes $w -alpha $new_degree]
	    focus -force $w
	    if {$new_degree < 0.9 && $new_degree != $prev_degree} {
		after 10 [list ::tk::sysnotify::_fade_in $w]
	    }
	}
    }
    namespace export *
}


# tk systray --
# This procedure creates an icon display in the platform-specific system tray.
#
# Subcommands:
#
#     create - create systray icon.
#         Arguments:
#             -image - Tk image to display.
#             -text - string to display in tooltip over image.
#             -button1 - Tcl proc to invoke on <Button-1> event.
#             -button3 - Tcl proc to invoke on <Button-3> event.
#
#     configure - change one of the systray properties.
#         Arguments (Any or all can be called):
#             -image - Tk image to update.
#             -text - string to update.
#             -button1 - Tcl proc to change for <Button-1> event.
#             -button3  - Tcl proc to change for <Button-3> event.
#
#     destroy - destroy systray icon.
#         Arguments:
#             none.
proc ::tk::systray::create {args} {
    variable _created
    variable _options
    variable _current
    variable _ico

    if {$_created} {
	return -code error -errorcode {TK SYSTRAY CREATE} "only one system tray icon supported per interpeter"
    }
    _check_options $args 0
    if {![dict exists $args -image]} {
	return -code error -errorcode {TK SYSTRAY CREATE} "missing required option \"-image\""
    }
    set values [dict merge $_options $args]
    try {
	switch -- [tk windowingsystem] {
	    "win32" {
		set _ico [_systray add -image [dict get $values -image] \
			-text [dict get $values -text] \
			-callback [list ::tk::systray::_win_callback %m]]
	    }
	    "x11" {
		_systray ._tray -image [dict get $values -image] -visible true
		_balloon ._tray [dict get $values -text]
		bind ._tray <Button-1> [dict get $values -button1]
		bind ._tray <Button-3> [dict get $values -button3]
	    }
	    "aqua" {
		_systray create [dict get $values -image] [dict get $values -text] \
			[dict get $values -button1] [dict get $values -button3]
	    }
	}
    } on ok {} {
	set _current $values
	set _created 1
	return
    } on error {msg opts} {
	return -code error -errorcode [dict get $opts -errorcode] $msg
    }
}

# Modify the systray icon.
proc ::tk::systray::configure {args} {
    variable _created
    variable _options
    variable _current
    variable _ico

    if {!$_created} {
	return -code error -errorcode {TK SYSTRAY CREATE} "systray not created"
    }
    _check_options $args 1
    if {[llength $args] == 0} {
	return $_current
    } elseif {[llength $args] == 1} {
	return [dict get $_current [lindex $args 0]]
    }
    set values [dict merge $_current $args]
    try {
	switch -- [tk windowingsystem] {
	    "win32" {
		if {[dict exists $args -image]} {
		    _systray modify $_ico -image [dict get $args -image]
		}
		if {[dict exists $args -text]} {
		    _systray modify $_ico -text [dict get $args -text]
		}
	    }
	    "x11" {
		if {[dict exists $args -image]} {
		    ._tray configure -image [dict get $args -image]
		}
		if {[dict exists $args -text]} {
		    _balloon ._tray [dict get $args -text]
		}
		if {[dict exists $args -button1]} {
		    bind ._tray <Button-1> [dict get $args -button1]
		}
		if {[dict exists $args -button3]} {
		    bind ._tray <Button-3> [dict get $args -button3]
		}
	    }
	    "aqua" {
		foreach {key opt} {image -image text \
			-text b1_callback -button1 b3_callback -button3} {
		    if {[dict exists $args $opt]} {
			_systray modify $key [dict get $args $opt]
		    }
		}
	    }
	}
    } on ok {} {
	set _current $values
	return
    } on error {msg opts} {
	return -code error -errorcode [dict get $opts -errorcode] $msg
    }
}


# Remove the systray icon.
proc ::tk::systray::destroy {} {
    variable _created
    variable _current
    variable _ico

    if {!$_created} {
	return -code error -errorcode {TK SYSTRAY DESTROY} "systray not created"
    }
    switch -- [tk windowingsystem] {
	"win32" {
	    _systray delete $_ico
	    set _ico ""
	}
	"x11" {
	    ::destroy ._tray
	}
	"aqua" {
	    _systray destroy
	}
    }
    set _created 0
    set _current {}
    return
}

# Check systray options
proc ::tk::systray::_check_options {argsList singleOk} {
    variable _options

    set len [llength $argsList]
    while {[llength $argsList] > 0} {
        set opt [lindex $argsList 0]
        if {![dict exists $_options $opt]} {
            tailcall return -code error -errorcode {TK SYSTRAY OPTION} \
		"unknown option \"$opt\": must be -image, -text, -button1 or -button3"
        }
        if {[llength $argsList] == 1 && !($len == 1 && $singleOk)} {
            tailcall return -code error -errorcode {TK SYSTRAY OPTION} \
		"missing value for option \"$opt\""
        }
        set argsList [lrange $argsList 2 end]
    }
}

# tk sysnotify --
# This procedure implements a platform-specific system notification alert.
#
#   Arguments:
#       title - main text of alert.
#       message - body text of alert.

proc ::tk::sysnotify::sysnotify {title message} {

    switch -- [tk windowingsystem] {
	"win32" {
	    if {!$::tk::systray::_created} {
		error "must create a system tray icon with the \"tk systray\" command first"
	    }
	    _sysnotify notify $::tk::systray::_ico $title $message
	}
	"x11" {
	    if {[info commands ::tk::sysnotify::_sysnotify] eq ""} {
		_notifywindow $title $message
	    } else {
		_sysnotify $title $message
	    }
	}
	"aqua" {
	    _sysnotify $title $message
	}
    }
    return
}

#Add these commands to the tk command ensemble: tk systray, tk sysnotify
#Thanks to Christian Gollwitzer for the guidance here
namespace ensemble configure tk -map \
    [dict merge [namespace ensemble configure tk -map] \
        {systray ::tk::systray sysnotify ::tk::sysnotify::sysnotify}]