#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" } } }