# General purpose code for being a tray applet

# Copyright 2016,2020 Ian Jackson
# SPDX-License-Identifier: GPL-3.0-or-later
# There is NO WARRANTY.

package require Tclx
package require tktray

#----- general machinery -----

# Interface:
#
#  tk::tktray widget is called .i
#
# Tooltip:
#
#   Caller may call
#      applet::setup-tooltip ON-VISIBLE ON-INVISIBLE
#   to make applet have a tooltip.
#
#   ON-VISIBLE and ON-INVISIBLE will be globally eval'd
#   when the tooltip becomes visible and invisible.
#
#   Caller should call
#      applet::tooltip-set TEXT-MAYBE-MULTILINE
#   whenever they like.
# 
# Button presses
#
#    Caller may bind .i.i <ButtonPress-$b>
#
#    Alternatively caller may call  applet::setup-button-menu $b
#    which will generate a menu .m$b which the user can configure
#    and which will automatically be posted and unposted etc.
#    In this case the caller should arrange that all of their
#    menus, when an item is selected, call
#      applet::msel
#
# Icon:
#
#  Caller should call:
#      applet::setimage IMAGE
#  as necessary.
#
# Alternatively of icon, it may provide other arrangements for
# using the provided subwindow.  Such a caller should call
#      applet::setup-subwindow ON-DESTROYING ON-READY
#  Then the main code will call ON-DESTROYING just before
#  destroying the inner window and recreating it, and
#  [concat ON-READY [list ORIENTATION]]
#  just after.  The inner window to use is called .i.i.b.
#
#  This uses variables, in the applet namespace,
#      w h border_colour border_width deforient
#  These should be set before setup-subwindow is called and not
#  modified thereafter.
#
#  The user of the subwindow machinery may call
#      applet::subwindow-need-recreate
#  if for any reason the inner window should be destroyed and recreated.
#
# Alternatively, it may request that a subprocess be spawned
# repeatedly with the xid of a suitable window.
#      applet::setup-subproc GET-CMDLINE
#  Then the main code will call [concat GET_CMDLINE [list XID ORIENTATION]]
#  to get the command line to run.
#
#  This also uses the same variables as setup-subwindow.

namespace eval applet {

proc become {} {
    wm withdraw .

    tktray::icon .i -class example
    .i configure -docked 1

    fconfigure stdout -buffering none
    fconfigure stderr -buffering none
}

# used by both menus and tooltips
variable posted 0
variable tooltip_offset {9 9}

#----- menus -----

proc setup-button-menu {b} {
    bind .i.i <ButtonPress> { applet::menubuttonpressed %b %X %Y }
    menu .m$b -tearoff 0
}

proc menubuttonpressed {b x y} {
    variable posted
    tooltip-cancel
    if {$posted == $b} {
	debug::debug "unpost $posted toggle"
     	.m$posted unpost
	set posted 0
    } elseif {[winfo exists .m$b]} {
	if {$posted} {
	    .m$posted unpost
	    debug::debug "unpost $posted other"
	}
	debug::debug "post $b"
	set posted $b
	.m$b post $x $y
    }
}

proc msel {} {
    variable posted
    set posted 0
}

#----- tooltips -----

variable tooltip_on_vis {}
variable tooltip_on_invis {}

proc tooltip-starttimer {state x y} {
    variable tooltip_after
    variable posted
    variable tooltip_inwindow
    if {$state || $posted || !$tooltip_inwindow} { tooltip-cancel; return }
    catch { after cancel $tooltip_after }
    set tooltip_after [after 500 applet::tooltip-show $x $y]
}

proc tooltip-cancel {} {
    variable tooltip_after
    variable tooltip_on_invis
    catch { after cancel $tooltip_after }
    catch { unset $tooltip_after }
    wm withdraw .tt
    uplevel #0 $tooltip_on_invis
}

set tooltip_inwindow 0

proc tooltip-enter {state x y} {
    variable tooltip_inwindow
    set tooltip_inwindow 1
    tooltip-starttimer $state $x $y
}

proc tooltip-leave {} {
    variable tooltip_inwindow
    set tooltip_inwindow 0
    tooltip-cancel
}

proc setup-tooltip {on_vis on_invis} {
    foreach v {vis invis} {
	variable tooltip_on_$v [set on_$v]
    }
    bind .i <Enter> { applet::tooltip-enter %s %X %Y }
    bind .i <Leave> { applet::tooltip-leave }
    bind .i <ButtonRelease> { 
	applet::tooltip-cancel
	applet::tooltip-starttimer %s %X %Y
    }
    bind .i <Motion> { applet::tooltip-starttimer %s %X %Y }
    toplevel .tt -background black
    wm withdraw .tt
    wm overrideredirect .tt 1
    label .tt.t -justify left -background {#EEE1B3}
    pack .tt.t -padx 1 -pady 1
    tooltip-set {}
}

proc tooltip-set {s} {
    .tt.t configure -text $s
}

proc tooltip-show {x y} {
    variable tooltip_on_vis
    variable tooltip_offset
    incr x [lindex $tooltip_offset 0]
    incr y [lindex $tooltip_offset 1]
    wm geometry .tt +$x+$y
    wm deiconify .tt
    raise .tt
    uplevel #0 $tooltip_on_vis
}

#----- simple images -----

proc setimage {image} {
    .i configure -image $image
}

#----- subwindow -----

variable subwindow_on_destroying
variable subwindow_on_ready

variable w 50
variable h 50
variable deforient horizontal
variable border_colour darkblue
variable border_width 1
variable tray_width X
variable tray_height X
variable orientation vertical

proc subwindow-need-recreate {evtype why} {
    variable orientation
    variable innerwindow_after
    variable tray_width
    variable tray_height
    debug::debug "IW-EVENT $evtype $why [winfo reqwidth .i] [winfo reqheight .i] [winfo width .i] [winfo height .i] $orientation"
    switch -exact $orientation {
	horizontal { set szv height }
	vertical { set szv width }
	unknown { return }
    }
    set new_sz [winfo req$szv .i]
    if {![string compare $new_sz [set tray_$szv]]} {
	return
    }
    set tray_$szv $new_sz
#    switch -exact -- $evtype 35 { return }
    if {[info exists innerwindow_after]} return
    set innerwindow_after [after idle applet::innerwindow-resetup]
}

proc innerwindow-resetup {} {
    variable innerwindow_after
    variable subwindow_on_destroying
    variable subwindow_on_ready
    variable border_colour
    variable border_width
    variable deforient
    variable orientation
    unset innerwindow_after

    debug::debug RESETUP

    if {![winfo exists .i.i]} return
    destroy [frame .i.i.make-exist]

    uplevel #0 $subwindow_on_destroying
    catch { destroy .i.i.b }

    set orientation [.i orientation]
    debug::debug "orientation $orientation"
    if {![string compare $orientation unknown]} {
	set orientation $deforient
    }
    .i configure -image applet::innerwindow-ph-$orientation

    frame .i.i.b -background $border_colour -bd $border_width
    pack .i.i.b -fill both -side left -expand 1

    uplevel #0 $subwindow_on_ready [list $orientation]
}

proc setup-subwindow {on_destroying on_ready} {
    variable w
    variable h

    foreach v {on_destroying on_ready} {
	variable subwindow_$v [set $v]
    }

    image create photo applet::innerwindow-ph-horizontal -width $w -height 2
    image create photo applet::innerwindow-ph-vertical -width 2 -height $h
    .i configure -image applet::innerwindow-ph-horizontal

    destroy [frame .i.make-exist]
    #destroy [frame .i.i.make-exist]
    bind .i <<IconConfigure>> { 
	applet::subwindow-need-recreate %T "%T i=%i k=%K N=%N R=%R S=%S k=%k m=%m d=%d s=%s a=%a b=%b c=%c f=%f w,h=%w,%h o=%o p=%p t=%t x,y=%x,%y B=%B D=%D E=%E P=%P W=%W X,Y=%X,%Y"
    }
}

#----- subprocess -----

variable subproc none
variable ratelimit {}

proc setup-subproc {get_cmdline} {
    variable subproc_get_cmdline $get_cmdline
    setup-subwindow applet::subproc-destroying applet::subproc-ready
}

proc subproc-destroying {} {
    variable subproc
    debug::debug "DESTROYING $subproc"

    catch { destroy .i.i.b.c }

    switch -exact $subproc {
	none { }
	old { }
	default { kill $subproc; set subproc old }
    }
}

proc subproc-ready {orientation} {
    variable subproc
    variable subproc_orientation $orientation
    debug::debug "READY $subproc"

    frame .i.i.b.c -container 1 -background orange
    pack .i.i.b.c -fill both -side left -expand 1

    switch -exact $subproc {
	none {
	    run-child
	}
	old {
	    # wait for it to die
	}
	default {
	    error "unexpected state $subproc"
	}
    }
    debug::debug "READY-done $subproc"
}

proc run-child {} {
    variable subproc
    variable ratelimit
    variable subproc_get_cmdline
    variable subproc_orientation

    set id [winfo id .i.i.b.c]
    set cmd [uplevel #0 $subproc_get_cmdline [list $id $subproc_orientation]]

    debug::debug "RUN-CHILD $subproc"
    set now [clock seconds]
    lappend ratelimit $now
    while {[lindex $ratelimit 0] < {$now - 10}} {
	set ratelimit [lrange $ratelimit 1 end]
    }
    if {[llength $ratelimit] > 10} {
	puts stderr "crashing repeatedly, quitting $ratelimit"
	exit 127
    }

    set subproc none
    set subproc [subproc::fork applet::child-died {
	execl [lindex $cmd 0] [lrange $cmd 1 end]
    }]
    debug::debug "FORKED $subproc"
}

proc child-died {how how2} {
    debug::debug "DIED $how $how2"
    variable subproc
    switch -exact $subproc {
	old {
	    set subproc none
	    run-child
	}
	default {
	    set subproc none
	    subwindow-need-recreate child-died child-died
	}
    }
}

}