You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
134 lines
4.5 KiB
134 lines
4.5 KiB
2 years ago
|
package provide punkapp [namespace eval punkapp {
|
||
|
variable version
|
||
|
set version 0.1
|
||
|
}]
|
||
|
|
||
|
namespace eval punkapp {
|
||
|
proc hide_dot_window {} {
|
||
|
#alternative to wm withdraw .
|
||
|
#see https://wiki.tcl-lang.org/page/wm+withdraw
|
||
|
wm geometry . 1x1+0+0
|
||
|
wm overrideredirect . 1
|
||
|
wm transient .
|
||
|
}
|
||
|
proc is_toplevel {w} {
|
||
|
if {![llength [info commands winfo]]} {
|
||
|
return 0
|
||
|
}
|
||
|
expr {[winfo toplevel $w] eq $w && ![catch {$w cget -menu}]}
|
||
|
}
|
||
|
proc get_toplevels {{w .}} {
|
||
|
if {![llength [info commands winfo]]} {
|
||
|
return [list]
|
||
|
}
|
||
|
set list {}
|
||
|
if {[is_toplevel $w]} {
|
||
|
lappend list $w
|
||
|
}
|
||
|
foreach w [winfo children $w] {
|
||
|
lappend list {*}[get_toplevels $w]
|
||
|
}
|
||
|
return $list
|
||
|
}
|
||
|
proc exit {{toplevel ""}} {
|
||
|
set toplevels [get_toplevels]
|
||
|
if {[string length $toplevel]} {
|
||
|
set wposn [lsearch $toplevels $toplevel]
|
||
|
if {$wposn > 0} {
|
||
|
destroy $toplevel
|
||
|
}
|
||
|
} else {
|
||
|
#review
|
||
|
puts stderr "punkapp::exit called without toplevel - showing console"
|
||
|
show_console
|
||
|
return 0
|
||
|
}
|
||
|
|
||
|
set controllable [get_user_controllable_toplevels]
|
||
|
if {![llength $controllable]} {
|
||
|
show_console
|
||
|
}
|
||
|
}
|
||
|
|
||
|
proc get_visible_toplevels {{w .}} {
|
||
|
if {![llength [info commands winfo]]} {
|
||
|
return [list]
|
||
|
}
|
||
|
set list [get_toplevels $w]
|
||
|
set mapped [lmap v $list {expr {[winfo ismapped $v] ? $v : {}}}]
|
||
|
set mapped [concat {*}$mapped] ;#ignore {}
|
||
|
set visible [list]
|
||
|
foreach m $mapped {
|
||
|
if {[wm overrideredirect $m] == 0 } {
|
||
|
lappend visible $m
|
||
|
} else {
|
||
|
if {[winfo height $m] >1 && [winfo width $m] > 1} {
|
||
|
#technically even a 1x1 is visible.. but in practice even a 10x10 is hardly likely to be noticeable when overrideredirect == 1
|
||
|
#as a convention - 1x1 with no controls is used to make a window invisible so we'll treat anything larger as visible
|
||
|
lappend visible $m
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
return $visible
|
||
|
}
|
||
|
proc get_user_controllable_toplevels {{w .}} {
|
||
|
set visible [get_visible_toplevels $w]
|
||
|
set controllable [list]
|
||
|
foreach v $visible {
|
||
|
if {[wm overrideredirect $v] == 0} {
|
||
|
append controllable $v
|
||
|
}
|
||
|
}
|
||
|
#only return visible windows with overrideredirect == 0 because there exists some user control.
|
||
|
#todo - review.. consider checking if position is outside screen areas? Technically controllable.. but not easily
|
||
|
return $controllable
|
||
|
}
|
||
|
proc hide_console {args} {
|
||
|
set defaults [dict create -force 0]
|
||
|
if {([llength $args] % 2) != 0} {
|
||
|
error "hide_console expects pairs of arguments. e.g -force 1"
|
||
|
}
|
||
|
set known_opts [dict keys $defaults]
|
||
|
dict for {k v} $args {
|
||
|
if {$k ni $known_opts} {
|
||
|
error "Unrecognised options '$k' known options: $known_opts"
|
||
|
}
|
||
|
}
|
||
|
set opts [dict merge $defaults $args]
|
||
|
set force [dict get $opts -force]
|
||
|
|
||
|
if {!$force} {
|
||
|
if {![llength [get_user_controllable_toplevels]]} {
|
||
|
puts stderr "Cannot hide console while no user-controllable windows available"
|
||
|
return 0
|
||
|
}
|
||
|
}
|
||
|
if {$::tcl_platform(platform) eq "windows"} {
|
||
|
package require twapi
|
||
|
set h [twapi::get_console_window]
|
||
|
twapi::hide_window $h
|
||
|
return 1
|
||
|
} else {
|
||
|
#todo
|
||
|
puts stderr "punkapp::hide_console unimplemented on this platform (todo)"
|
||
|
return 0
|
||
|
}
|
||
|
}
|
||
|
|
||
|
proc show_console {} {
|
||
|
if {$::tcl_platform(platform) eq "windows"} {
|
||
|
package require twapi
|
||
|
if {![catch {set h [twapi::get_console_window]} errM]} {
|
||
|
twapi::show_window $h -activate -normal
|
||
|
} else {
|
||
|
#no console - assume launched from something like wish?
|
||
|
catch {console show}
|
||
|
}
|
||
|
} else {
|
||
|
#todo
|
||
|
puts stderr "punkapp::show_console unimplemented on this platform"
|
||
|
}
|
||
|
}
|
||
|
|
||
|
}
|