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.
239 lines
9.3 KiB
239 lines
9.3 KiB
#utilities for punk apps to call |
|
|
|
package provide punkapp [namespace eval punkapp { |
|
variable version |
|
set version 0.1 |
|
}] |
|
|
|
namespace eval punkapp { |
|
variable result |
|
variable waiting "no" |
|
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 make_toplevel_next {prefix} { |
|
set top [get_toplevel_next $prefix] |
|
return [toplevel $top] |
|
} |
|
#possible race condition if multiple calls made without actually creating the toplevel, or gap if highest existing closed in the meantime |
|
#todo - reserve_toplevel_next ? keep list of toplevels considered 'allocated' even if never created or already destroyed? what usecase? |
|
#can call wm withdraw to to reserve newly created toplevel. To stop re-use of existing names after destruction would require a list or at least a record of highest created for each prefix |
|
proc get_toplevel_next {prefix} { |
|
set base [string trim $prefix .] ;# .myapp -> myapp .myapp.somewindow -> myapp.somewindow . -> "" |
|
|
|
|
|
|
|
} |
|
proc exit {{toplevel ""}} { |
|
variable waiting |
|
variable result |
|
variable default_result |
|
set toplevels [get_toplevels] |
|
if {[string length $toplevel]} { |
|
set wposn [lsearch $toplevels $toplevel] |
|
if {$wposn > 0} { |
|
destroy $toplevel |
|
} |
|
} else { |
|
#review |
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
|
puts stderr "punkapp::exit called without toplevel - showing console" |
|
show_console |
|
return 0 |
|
} else { |
|
puts stderr "punkapp::exit called without toplevel - exiting" |
|
if {$waiting ne "no"} { |
|
if {[info exists result(shell)]} { |
|
set temp [set result(shell)] |
|
unset result(shell) |
|
set waiting $temp |
|
} else { |
|
set waiting "" |
|
} |
|
} else { |
|
::exit |
|
} |
|
} |
|
} |
|
|
|
set controllable [get_user_controllable_toplevels] |
|
if {![llength $controllable]} { |
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
|
show_console |
|
} else { |
|
if {$waiting ne "no"} { |
|
if {[info exists result(shell)]} { |
|
set temp [set result(shell)] |
|
unset result(shell) |
|
set waiting $temp |
|
} elseif {[info exists result($toplevel)]} { |
|
set temp [set result($toplevel)] |
|
unset result($toplevel) |
|
set waiting $temp |
|
} elseif {[info exists default_result]} { |
|
set temp $default_result |
|
unset default_result |
|
set waiting $temp |
|
} else { |
|
set waiting "" |
|
} |
|
} else { |
|
::exit |
|
} |
|
} |
|
} |
|
} |
|
proc close_window {toplevel} { |
|
wm withdraw $toplevel |
|
if {![llength [get_user_controllable_toplevels]]} { |
|
punkapp::exit $toplevel |
|
} |
|
destroy $toplevel |
|
} |
|
proc wait {args} { |
|
variable waiting |
|
variable default_result |
|
if {[dict exists $args -defaultresult]} { |
|
set default_result [dict get $args -defaultresult] |
|
} |
|
foreach t [punkapp::get_toplevels] { |
|
if {[wm protocol $t WM_DELETE_WINDOW] eq ""} { |
|
wm protocol $t WM_DELETE_WINDOW [list punkapp::close_window $t] |
|
} |
|
} |
|
if {[package provide punk::repl::codethread] ne "" && [punk::repl::codethread::is_running]} { |
|
puts stderr "repl eventloop seems to be running - punkapp::wait not required" |
|
} else { |
|
if {$waiting eq "no"} { |
|
set waiting "waiting" |
|
vwait ::punkapp::waiting |
|
return $::punkapp::waiting |
|
} |
|
} |
|
} |
|
|
|
#A window can be 'visible' according to this - but underneath other windows etc |
|
#REVIEW - change name? |
|
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} { |
|
lappend 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 opts [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] |
|
foreach {k v} $args { |
|
switch -- $k { |
|
-force { |
|
dict set opts $k $v |
|
} |
|
default { |
|
error "Unrecognised options '$k' known options: [dict keys $opts]" |
|
} |
|
} |
|
} |
|
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"} { |
|
#hide won't work for certain consoles cush as conemu,wezterm - and doesn't really make sense for tabbed windows anyway. |
|
#It would be nice if we could tell the console window to hide just the relevant tab - or the whole window if only one tab present - but this is unlikely to be possible in any standard way. |
|
#an ordinary cmd.exe or pwsh.exe or powershell.exe window can be hidden ok though. |
|
#(but with wezterm - process is cmd.exe - but it has style popup and can't be hidden with a twapi::hide_window call) |
|
package require twapi |
|
set h [twapi::get_console_window] |
|
set pid [twapi::get_window_process $h] |
|
set pinfo [twapi::get_process_info $pid -name] |
|
set pname [dict get $pinfo -name] |
|
set wstyle [twapi::get_window_style $h] |
|
#tclkitsh/tclsh? |
|
if {($pname in [list cmd.exe pwsh.exe powershell.exe] || [string match punk*.exe $pname]) && "popup" ni $wstyle} { |
|
twapi::hide_window $h |
|
return 1 |
|
} else { |
|
puts stderr "punkapp::hide_console unable to hide this type of console window" |
|
return 0 |
|
} |
|
} 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" |
|
} |
|
} |
|
|
|
}
|
|
|