#
# Copyright (c) 1993 Eric Schenk.
# All rights reserved.
#
# Permission is hereby granted, without written agreement and without
# license or royalty fees, to use, copy, modify, and distribute this
# software and its documentation for any purpose, provided that the
# above copyright notice and the following two paragraphs appear in
# all copies of this software.
# 
# IN NO EVENT SHALL ERIC SCHENK BE LIABLE TO ANY PARTY FOR
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF ERIC
# SCHENK HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# ERIC SCHENK SPECIFICALLY DISCLAIMS ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
# ON AN "AS IS" BASIS, AND ERIC SCHENK HAS NO OBLIGATION TO
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.

# Force all the windows on the screen to be refreshed.
proc refresh {} {
    toplevel .foo -geometry [winfo screenwidth .]x[winfo screenheight .]
    tkwait visibility .foo
    destroy .foo
}

# refresh a toplevel widget with TKWM standard frame format.
proc wrefresh {win} {
    # this may not be a client formatted widget
    catch {
	lower $win.plug
	update
	raise $win.plug
    }
}

proc raise_lower {win} {
    restack $win Opposite None
}

proc restack {win mode sibling} {
    tkwm restack $win $mode $sibling
}

proc client_menu {client} {
    upvar #0 $client data
    if [lindex [$data(decoration) config -titlebar] 4] {
	$data(decoration) invoke
    } else {
	global current_client
	set current_client $client
	set w $current_client.plug
	tkwm_postmenu .client_menu [winfo rootx $w] [winfo rooty $w]
    }
}

proc popup_client_menu {client x y} {
    upvar #0 $client data
    global current_client
    set current_client $client
    set w $current_client.plug
    tkwm_postmenu .client_menu $x $y
}

# Raise a window, waiting for the raise to actually complete on 
# the screen. At the same time, watch for any of a list of events,
# and return 1 if any of them happens.
# This is used in the moving and resizing routines to allow
# a raise to be completed without having to worry that we
# missed the button release corresponding to it.

proc guarded_raise {w event} {
    global tkwm_priv
    
    set tkwm_priv(guard) 0
    bind all $event {global tkwm_priv; set tkwm_priv(guard) 1}
    restack $w Above None
    # force the raise redraws to finish
    update
    update idletasks
    bind all $event {}
    
    return $tkwm_priv(guard)
}

proc internal_zoom {direction win} {
    upvar #0 $win data

    if ![info exists data(zoom)] {set data(zoom) ""}
    if {$data(zoom)==""} {
        # save the original geometry
        # (this is same as [winfo width/height $win.plug]
        # and is in pixels)
        set data(zoom) [wm geometry $win]

        scan $data(zoom) "%dx%d%c%d%c%d" oldw oldh xa x ya y
        set neww $oldw
        set newh $oldh

        if {$direction=="vertical"||$direction=="both"} {
          # start with maximum size
          handleError {
            set newh [tkwm info max_height $win]
            # shrink to screen size less decorations
            set sh [expr {[winfo screenheight $win] - [winfo reqheight $win]}]
            if {$newh > $sh} {
              set newh $sh
            }
	  } {
            set sh [winfo screenheight $win]
	    set newh [winfo screenheight $win]
	    scan [wm maxsize $win] "%d %d" dummy newh
	  }


          # aspect is probably best/easiest handled at this stage.
          # and it might not make too much mess, actually.

          # shrink to grid size
	  catch {
	    # we do no gridding for internal windows yet
            set bh [tkwm info base_height $win]
            set ih [tkwm info height_inc $win]
            set newh [expr {(($newh - $bh)/$ih)*$ih + $bh}]
	  }

          # adjust position
          set y [expr {$y - ($newh - $oldh)/2}]
          if {$y < 0} {
            set y 0
          }
          if {$y + $newh > $sh} {
            set y [expr {$sh - $newh}]
          }
        }

        # parallel code
        if {$direction=="horizontal"||$direction=="both"} {
          handleError {
            set neww [tkwm info max_width $win]
            set sw [expr {[winfo screenwidth $win] - [winfo reqwidth $win]}]
            if {$neww > $sw} {
              set neww $sw
            }
	  } {
	    set sw [winfo screenwidth $win]
	    set neww [winfo screenwidth $win]
	    scan [wm maxsize $win] "%d %d" neww dummy
	  }


	  catch {
   	    # No grid fitting for internal windows.
            set bw [tkwm info base_width $win]
            set iw [tkwm info width_inc $win]
            set neww [expr {(($neww - $bw)/$iw)*$iw + $bw}]
	  }

          set x [expr {$x - ($neww - $oldw)/2}]
          if {$x < 0} {
            set x 0
          }
          if {$x + $neww > $sw} {
            set x [expr {$sw - $neww}]
          }
        }
        wm geometry $win [format "%dx%d%c%d%c%d" $neww $newh $xa $x $ya $y]
    } else {
	wm geometry $win $data(zoom)
	set data(zoom) ""
    }
}

proc zoom {win} {
    internal_zoom both $win
}

proc vzoom {win} {
    internal_zoom vertical $win
}

proc hzoom {win} {
    internal_zoom horizontal $win
}

proc set_remove {l i} {
    set num [lsearch [uplevel [list set $l]] $i]
    if {$num != "-1"} {
	set lst [lreplace [uplevel [list set $l]] $num $num]
	uplevel [list set $l $lst]
    }
}

# For window $w:
#    tkwm_registry($w): contains a list of types the window is registered under
#    tkwm_registry($w:$type): contains the key for (w,type)
#
# tkwm_registry($type,$key): A list of windows with the given type and key

proc register {type key win} {
    global tkwm_registry
    
    # Remove old registrations under this type first
    if {[info exists tkwm_registry($win:$type)]} {
	set i $type,$tkwm_registry($win:$type)
	set_remove tkwm_registry($i) $win
    }
    
    if {![info exists tkwm_registry($type,$key)]
	|| [lsearch $tkwm_registry($type,$key) $win] == "-1"} {
	    lappend tkwm_registry($type,$key) $win
	}
    if {![info exists tkwm_registry($win)]
	|| [lsearch $tkwm_registry($win) $type] == "-1"} {
	    lappend tkwm_registry($win) $type
	}
    set tkwm_registry($win:$type) $key
}

proc deregister {win} {
    global tkwm_registry $win
    
    if {[info exists tkwm_registry($win)]} {
	foreach t $tkwm_registry($win) {
	    set i $t,$tkwm_registry($win:$t)
	    set_remove tkwm_registry($i) $win
	    unset tkwm_registry($win:$t)
	}
	unset tkwm_registry($win)
	catch {unset $win}
    }
}

proc registered {type key} {
    global tkwm_registry
    
    if {[info exists tkwm_registry($type,$key)]} {
	return $tkwm_registry($type,$key)
    } else {
	return {}
    }
}

proc registration {win type} {
    global tkwm_registry
    if {[info exists tkwm_registry($win:$type)]} {
	return $tkwm_registry($win:$type)
    } else {
	return {}
    }
}

# find a recursive list of all those windows that are "lead" by a given
# list of windows.
# We have to be careful because the list may be circular!

proc followers_list {wins} {
    if {$wins==""} {return ""}
    foreach i $wins {set Names($i) 1}
    while {[llength $wins]>"0"} {
	set win [lindex $wins 0]
	set wins [lrange $wins 1 end]
	foreach i [concat [registered group $i] [registered transient $i]] {
	    if ![info exists Names($i)] {
	        set Names($i) 1
		lappend wins $i
	     }
        }
    }
    return [array names Names]
}

# NOTE: some windows could be registered in both a group and transient list.
# Note: we must filter for the possibility that a window has registered
# as a follower of itself!

proc immediate_followers_list {win} {
    set list [concat [registered group $win] [registered transient $win]]
    set index [lsearch $list $win]
    if {$index != "-1"} {
	set list [lreplace $list $index $index]
    }
    return $list
}

# withdraw a list of windows and their icons from the screen
# this does nothing to change their states, but it does remove
# them from their respective manager regions.

proc wset_withdraw {state wins} {
    foreach i $wins {
        upvar "#0" $i data
	# this may not be a client formatted widget
        catch {
	    if {[wm state $i]=="normal"} {
		# ask the manager to unmap this window
		$data(res_name) unmap
	    }
            $i.plug configure -state $state
        }
	# this may not be a client formatted widget
        catch {
	    if {[wm state $data(icon)]=="normal"} {
		# ask the manager to unmap this window
		$data(icon) unmap
	    }
        }
	# add on a "withdrawn" tag to the state
        if {![string match w_* $data(state)]} {
            set data(state) "w_[set data(state)]"
        }
    }
}

# restore a list of windows or their icons to the screen
# depending on the state of the client.

proc wset_restore {wins} {
    foreach i $wins {
	upvar "#0" $i data
	if {$data(state) == "w_normal"} {
	   set data(state) "normal"
	   deiconify $i
	}
	if {$data(state) == "w_iconified"} {
	   set data(state) "iconified"
	   iconify $i
	}
    }
}

# deiconify a window. This is trickier than it looks!
# You have to be careful because the followers may form a loop and
# you don't want to go into an infinite regress.
# [for an example client that does this see the openwindows "cm" program.

proc deiconify {win} {
    upvar "#0" $win data

    set data(state) normal
    # unmap this clients icon window
    catch {
	if {[wm state $data(icon)]=="normal"} {
	    # ask the manager to unmap this window
	    $data(icon) unmap
	}
    }
    # map this client window if it is not already mapped
    display_client $win
    # Restore descendants to the correct state. We do this after
    # so descendants are mapped above the main client.
    wset_restore [immediate_followers_list $win]
}

proc iconify {win} {
    upvar "#0" $win data
    wset_withdraw iconic [followers_list [immediate_followers_list $win]]
    # unmap the client window
    catch {
	if {[wm state $win]=="normal"} {
	    # ask the manager to unmap this window
	    $data(res_name) unmap
	}
	$win.plug configure -state iconic
    }
    # map the icon window
    # we only change the leader to an iconified state marker
    # since we want to be able to restore windows correctly on deiconify
    set data(state) iconified
    display_icon $win
    # restack it so the user can see it (suggested by Bill Burdick)
    restack $data(icon) Above None
}

# display a client window

proc display_client {win} {
    global tkwm_priv
    upvar "#0" $win data

    if {[wm state $win]!="normal"} {
	# map the client if it should currently be visible and it's not.
	$data(res_name) map
	# this may not be a client formatted widget
	catch {$win.plug sendconfig}
	update idletasks
    }
    # this may not be a client formatted widget
    catch {$win.plug configure -state normal}
}

# display the icon for the given window

proc display_icon {win} {
    global tkwm_priv
    upvar "#0" $win data

    # create the icon window if we need it
    if ![winfo exists $data(res_name).icon] {create_icon_window $win}

    # map the icon window if it should currently be visible.
    if {[wm state $data(icon)]!="normal"} {
	$data(icon) map
    }

    # this may not be a client formatted widget
    catch {$win.plug configure -state iconic}
}

proc display_room {name} {
    wset_restore [registered room $name]
}

proc withdraw_room {name} {
    wset_withdraw withdrawn [registered room $name]
}

proc tree-bind {win event command} {
    if {[bind $win $event] == ""} {
	bind $win $event $command
	foreach subwin [winfo children $win] {tree-bind $subwin $event $command}
    }
}

proc grabbind {win event command} {
    if {$command != ""} {
        # this may not be a client formatted widget
	catch {tkwm grabevent $win $event}
    } else {
        # this may not be a client formatted widget
	catch {tkwm ungrabevent $win $event}
    }
    bind $win $event $command
}

proc grabevents {win args} {
    foreach i $args {
	catch {tkwm grabevent $win $i}
    }
}

proc ungrabevents {win args} {
    foreach i $args {
	catch {tkwm ungrabevent $win $i}
    }
}


# return the name of the client root variable
proc client_root {path} {
    upvar #0 [winfo toplevel $path] data
    return $data(root)
}

# error and trapping functions

# This function is from a posting by Owen Rees <rtor@ansa.co.uk>
# I should ask permission to use it here.

proc unwindProtect {protectedCmd args} {
  global errorInfo

  set failed [catch "uplevel {$protectedCmd}" result]
  set saveErrInfo $errorInfo

  foreach cmd $args {
    catch "uplevel {$cmd}"
  }

  if { $failed } { error $result $saveErrInfo }
  return $result
}

proc handleError {protectedCmd errorHandler} {
    global errorInfo
    
    set failed [catch "uplevel {$protectedCmd}" result]
    if {$failed == "1"} {set failed [catch "uplevel {$errorHandler}" result]}
    if {$failed} {return $result}
}

proc noisyCatch {protectedCmd} {
  global errorInfo

  set failed [catch "uplevel {$protectedCmd}" result]
  set saveErrInfo $errorInfo
  if { $failed } { tkerror $result }
  set errorInfo $saveErrInfo
  return $result
}

# make sure that grabs are renamed
if {[info command realgrab]==""} {rename grab realgrab}

# substitute a looping version of the grab
proc grab {args} {
    global errorInfo

    set code [catch {eval "realgrab $args"} result]
    # WARNING: This message may have to change if TK changes.
    while {$code=="1"&&$result=="grab failed: another application has grab"} {
    	set code [catch {eval "realgrab $args"} result]
    }
    if {$code!="0"} {
	error $result $errorInfo $code
    }
}

# a looping version of grabpointer
proc grabpointer {args} {
    global errorInfo

    set code [catch {eval "tkwm grabpointer $args"} result]
    # WARNING: This message may have to change if TKWM changes.
    while {$code=="1"&&$result=="XGrabPointer failed"} {
        set code [catch {eval "tkwm grabpointer $args"} result]
    }
    if {$code!="0"} {
	error $result $errorInfo $code
    }
}

# just for orthoginality.
proc ungrabpointer {} {
    tkwm ungrabpointer
}

# command to restart the whole shebang.

proc tkwm_restart {} {
    global window_list
    global tkwm_libpath

    # delete any existing windows
    if {[info exists window_list]} {
	foreach w $window_list {
	    # just in case the window list is corrupted.
	    noisyCatch { destroy $w }
        }
    }

    # make sure the deletions take effect before we redecorate
    update idletasks
    update

    # clear the old window list
    set window_list {}
    # run the users restarting hook (used by rooms)
    catch {tkwm_restart.hook}
    # make sure that anything the hook did finishes
    update idletasks
    update
    # decorate all the windows
    foreach w [tkwm unmanaged] { map_request startup $w }
}

# cheezy debugging aid from the TCL/TK book.

proc printStack {} {
    puts ""
    set level [info level]
    for {set i 1} {$i < $level} {incr i} {
	puts stdout "Level $i: [info level $i]"
    }
}

# user interface to source code installed in the library directory
proc usePackage {package} {
    global tkwm_libpath
    source $tkwm_libpath/$package
}

#==============================================================================
# User dialog dispatching
#==============================================================================
# The window manager must often interact with the user via some sort
# of DIALOG that requires exclusive access to the pointer and possibly
# to the keyboard, examples of such dialogs are the initial placement of
# a client window or movement of a window. This code here implements
# a queuing system to force exclusive access for such dialogs.
#
# Dialogs must be initiated by a procedure call, and must complete when
# the procedure returns.
#
# Dialogs are queued by a call of the form:
#	dispatch "command ...."
# or
#	exclusive-dispatch "command ...."
#
# Dialogs wishing to call another dialog should use the procedure
#	allow-dispatch "command ...."
# which will run the next dispatch requested command without any
# queuing. Care should be taken that the intended dialog is the
# only one that can be the next requested dispatch. (i.e. updates
# must not occur between the allow-dispatch, and the targeted
# call to a dispatch.)

# The queue, initially empty
set dispatch_queue {}

# Dispatch a command.

proc dispatch {command} {
    global dispatch_queue

    set len [llength $dispatch_queue]
    lappend dispatch_queue $command
    if {$len == 0} {
	noisyCatch {eval $command}
	next-dispatch
    }
}

# Dispatch a command only if the queue is empty.
# This should be used by dialogs that do not want to be invoked
# if some other dialog may be eating events before it gets run.
# Most user dialogs should probably be using this.

proc exclusive-dispatch {command} {
    global dispatch_queue

    set len [llength $dispatch_queue]
    if {$len == 0} {
    	lappend dispatch_queue $command
	noisyCatch {eval $command}
	next-dispatch
    }
}

# allow a dispatched dialog to be run immediately.
# This should only be used within a dialog that is itself dispatched.

proc allow-dispatch {command} {
    rename exclusive-dispatch save-exclusive-dispatch
    rename dispatch save-dispatch
    proc exclusive-dispatch {command} {
	rename dispatch ""
	rename exclusive-dispatch ""
	rename save-dispatch dispatch
	rename save-exclusive-dispatch exclusive-dispatch
	noisyCatch {eval $command}
    }
    proc dispatch {command} {
	rename dispatch ""
	rename exclusive-dispatch ""
	rename save-dispatch dispatch
	rename save-exclusive-dispatch exclusive-dispatch
	noisyCatch {eval $command}
    }
    eval $command
    if {[info procs save-dispatch]!=""} {
	rename dispatch ""
	rename exclusive-dispatch ""
	rename save-dispatch dispatch
	rename save-exclusive-dispatch exclusive-dispatch
    }
}

# do the next thing

proc next-dispatch {} {
    global dispatch_queue

    # this catch is here to avoid checking for an empty queue.
    catch {
	set dispatch_queue [lreplace $dispatch_queue 0 0]
	set command [lindex $dispatch_queue 0]
	noisyCatch {eval $command}
	next-dispatch
    }
}