punkshell/src/modules/punkapp-0.1.tm

#utilities for punk apps to call

package provide punkapp [namespace eval punkapp {
    variable version
    set version 0.1
}]

namespace eval punkapp {
    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
        set toplevels [get_toplevels]
        if {[string length $toplevel]} {
            set wposn [lsearch $toplevels $toplevel]
            if {$wposn > 0} {
                destroy $toplevel
            }
        } else {
            #review 
            if {[info exists ::repl::running] && $::repl::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"} {
                    set waiting "done"
                } else {
                    ::exit
                }
            }
        }
        
        set controllable [get_user_controllable_toplevels]
        if {![llength $controllable]} {
            #review - tight coupling
            if {[info exists ::repl::running] && $::repl::running} {
                show_console
            } else {
                if {$waiting ne "no"} {
                    set waiting "done"
                } else {
                    ::exit
                }
            }
        }
    }
    proc close_window {toplevel} {
        wm withdraw $toplevel
        if {![llength [get_user_controllable_toplevels]]} {
            punkapp::exit $toplevel
        }
        destroy $toplevel
    }
    proc wait {{msg "waiting"}} {
        variable waiting
        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 {[info exists ::repl::running] && $::repl::running} {
            puts stderr "repl eventloop seems to be running - punkapp::wait not required"
        } else {
            if {$waiting eq "no"} {
                set waiting $msg
                vwait ::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 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"
        }
    }
    
}