# Copyright (c) 2000, Red Hat, Inc.
# 
# This file is part of Source-Navigator.
# 
# Source-Navigator is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 2, or (at your option)
# any later version.
# 
# Source-Navigator is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
# 
# You should have received a copy of the GNU General Public License along
# with Source-Navigator; see the file COPYING.  If not, write to
# the Free Software Foundation, 59 Temple Place - Suite 330, Boston,
# MA 02111-1307, USA.
# 
# toplevel.tcl - A top-level widget.
# Copyright (C) 1998 Cygnus Solutions.

itcl_class Toplevel& {
	constructor args {
		global sn_options

		if {$this == "."} {
			@@rename $this $this-class-
			set twindow $this-class-
			set twindow .
			set twidget .
			@@proc . {args} {
				eval .-class- $args
			}
		} else {
			@@rename $this $this-tmp-
			if {[string index $this 0] == "."} {
				set twindow $this
			} else {
				set twindow [next_window_name]
				incr seq
			}

			set bgc [option get . Background Background]
			if {$bgc != ""} {
				set cmd "-bg $bgc"
			} else {
				set cmd ""
			}

			set off [lsearch -exact $args "-leader"]
			if {$off != -1} {
				set args [lreplace $args $off [expr $off + 1]]
			}

			foreach vars {container colormap menu screen use visual} {
				if {[set $vars] != ""} {
					lappend args -$vars [set $vars]
				}
			}
			
			eval toplevel $twindow $cmd [join $args]

			if {$this == $twindow} {
				@@rename $twindow $this-win-
				set twindow $this-win-
				set twidget $this
			} else {
				set twidget $twindow
			}
			@@rename $this-tmp- $this
		}
		
		if {$width != "" && $height != ""} {
			@@wm geometry $twidget ${width}x$height
		}

		$this iconbitmap $iconbitmap
		$this title "[virtual info class]"
		$this positionfrom user
		
		#close
		on_close "$this delete"
		
		config -leader $leader
		
		#make sure that the tag class "Toplevel" is included
		#in the event tag list, also "all", but Toplevel
		#must be placed before all
		sn_add_tags $twidget {Toplevel all} end
#		sn_add_tags $this {Toplevel all} end
	}

	destructor {
		if {$old_grab != ""} {
			if {[catch {$old_grab set}]} {
				@@grab set $old_grab;	# It might be not a Toplevel& object.
			}
		}
		bind_tk <Unmap> { }

		sn_input_check_in_window $twidget 0

		foreach obj [itcl_info objects "$this*"] {
			if {$obj != $this} {
				catch {$obj delete}
			}
		}

		if {[winfo exists $leader] && [winfo toplevel $leader] == $leader} {
			wm deiconify $leader
		}
		catch {tk_destroy $twidget}
		catch {@@rename $this-win- {}}

		if {[winfo exists $leader]} {
			@@bind $leader <Map> " "
			@@bind $leader <Unmap> " "
			@@bind $leader <Destroy> " "
		}
	}

	method config config {
	}

	method cget args {
		return [eval $twindow cget $args]
	}

	# Widget Tk-methods.
	method aspect args {
		return [eval wm aspect $twidget $args]
	}

	method client args {
		return [eval wm client $twidget $args]
	}

	method colormapwindows args {
		return [eval wm colormapwindows $twidget $args]
	}

	method command args {
		return [eval wm command $twidget $args]
	}

	method config_tk args {
		return [@@eval $twindow config $args]
	}

	method deiconify {} {
		return [wm deiconify $twidget]
	}

	method focusmodel args {
		return [eval wm focusmodel $twidget $args]
	}

	# we cannot used the method name 'frame' because it would
	# overlay the original 'frame' Tk twidget.
	method frame_tk {} {
		return [wm frame $twidget]
	}

	method geometry args {
		return [eval wm geometry $twidget $args]
	}

	method grid args {
		return [eval wm grid $twidget $args]
	}

	method group args {
		return [eval wm group $twidget $args]
	}

	method iconbitmap args {
		return [eval wm iconbitmap $twidget $args]
	}

	method iconify {} {
		return [eval wm iconify $twidget]
	}

	method iconmask args {
		return [eval wm iconmask $twidget $args]
	}

	method iconname args {
		return [eval wm iconname $twidget $args]
	}

	method iconposition args {
		return [eval wm iconposition $twidget $args]
	}

	method icontwindow args {
		return [eval wm icontwindow $twidget $args]
	}

	method maxsize args {
		return [eval wm maxsize $twidget $args]
	}

	method minsize args {
		return [@@eval wm minsize $twidget $args]
	}

	method overrideredirect args {
		return [eval wm overrideredirect $twidget $args]
	}

	method positionfrom args {
		return [eval wm positionfrom $twidget $args]
	}

	method protocol args {
		return [eval wm protocol $twidget $args]
	}

	method resizable args {
		return [eval wm resizable $twidget $args]
	}

	method sizefrom args {
		return [eval wm sizefrom $twidget $args]
	}

	method state {} {
		return [wm state $twidget]
	}

	method title {{args ""} {umlaut_map ""}} {
		set args [join $args]

		if {$umlaut_map == ""} {
			set args [map_umlauts $args]
		}

		if {[string compare $args ""] != 0} {
			return [wm title $twidget $args]
		} else {
			return [wm title $twidget]
		}
	}

	method transient args {
		if {[string compare $args ""] != 0 && [winfo exists $args]} {
			set args [winfo toplevel $args]
		}
		return [eval wm transient $twidget $args]
	}

	method withdraw {} {
		return [wm withdraw $twidget]
	}

	# Widget public properties for Tk methods.
	public background {} {
		if {[winfo exists $twidget]} {
			$twindow config -background $background
		}
	}

	public bd {} {
		if {[winfo exists $twidget]} {
			$twindow config -bd $bd
		}
	}

	public bg {} {
		if {[winfo exists $twidget]} {
			$twindow config -bg $bg
		}
	}

	public borderwidth {} {
		if {[winfo exists $twidget]} {
			$twindow config -borderwidth $borderwidth
		}
	}

	public container {} {
	}

	public colormap {} {
	}

	public cursor {} {
		if {[winfo exists $twidget]} {
			$twindow config -cursor $cursor
		}
	}

	public height "" {
		if {[winfo exists $twidget]} {
			$twindow config -height $height
		}
	}

	public menu {} {
		if {[winfo exists $twidget]} {
			$twindow config -menu $menu
		}
	}

	public relief {} {
		if {[winfo exists $twidget]} {
			$twindow config -relief $relief
		}
	}

	public screen {} {
	}

	public use {} {
	}

	public visual {} {
	}

	public width "" {
		if {[winfo exists $twidget]} {
			$twindow config -width $width
		}
	}
	
	# End of twidget public properties for Tk methods.

	# This function is useful to replace umlauts in window titles, because
	# the window managers (normaly) do not use iso8859-1 fonts.

	proc map_umlauts str {
		regsub -all "\xfc" $str "ue" str
		regsub -all "\xe4" $str "ae" str
		regsub -all "\xf6" $str "oe" str
		regsub -all "\xdc" $str "Ue" str
		regsub -all "\xc4" $str "Ae" str
		regsub -all "\xd6" $str "Oe" str

		return $str
	}

	protected old_grab ""

	method grab args {
		if {$args == "set"} {
			set old_grab [lindex [@@grab current] 0]
			$this bind_tk <1> \
				"if {\"%W\" == \"$twidget\"} {
					$this move_to_mouse 0

					$this raise
					bell -displayof %W
				}
				break
				"
			$this bind_tk <2> [$this bind_tk <1>]
			$this bind_tk <3> [$this bind_tk <1>]
		} elseif {$args == "release"} {
			$this bind_tk <1> { }
			$this bind_tk <2> [$this bind_tk <1>]
			$this bind_tk <3> [$this bind_tk <1>]
		}
		return [@@eval grab $args $twidget]
	}

	method raise args {
		global sn_force_flag tcl_platform
		if {[$this state] != "normal"} {
			set ret [$this deiconify]
		} else {
			#don't steal focus on UNIX
			if {$tcl_platform(platform) == "windows"} {
				set wdg [@@focus -lastfor $twidget]
				eval focus $sn_force_flag $twidget
				focus $wdg
			}
			set ret [@@eval raise $twidget $args]
		}
		return $ret
	}

	method take_focus {{wdg ""}} {
		@@take_focus $twidget $wdg
	}

	#bind Escape and WM-close hint to the window
	method on_close {{cmd ""}} {
		global tcl_platform
		
		if {$cmd == ""} {
			set cmd "$this delete"
		}
		
		@@wm protocol $twidget WM_DELETE_WINDOW $cmd
		@@bind $twidget <Escape> $cmd
		
		#on windows Alt-F4 closes window
		if {$tcl_platform(platform) == "windows"} {
			@@bind $twidget <Alt-F4> $cmd
		}
	}

	method bind_tk args {
		if {[lindex $args 0] == "<Enter>"} {
			@@eval bind_focus_enter $twidget [lrange $args 1 end]
		} else {
			return [@@eval bind $twidget $args]
		}
	}

	method focus_tk {{args ""}} {
		return [@@eval focus $args $twidget]
	}

	proc next_window_name {} {
		set wn "${internal_name}${seq}"
		incr seq
		return $wn
	}

	method window_name {} {
		return $twidget
	}

	method center {{w ""} {h ""} {wdg ""}} {
		global tcl_platform

		#$this withdraw
		update idletasks

		if {$h == "" } {
			set h [winfo height $twidget]
		}
		if {$w == ""} {
			set w [winfo width $twidget]
		}
		if {$h <= 20} {
			set h [winfo reqheight $twidget]
		}
		if {$w <= 10} {
			set w [winfo reqwidth $twidget]
		}
		set sw [winfo screenwidth $twidget]
		set sh [winfo screenheight $twidget]

		set x [expr $sw / 2 - $w / 2]
		set y [expr $sh / 2 - $h / 2]

		set width_height ""

		if {$x < 0 || $y < 0} {
			if {$x < 0} {
				set x 0
				set width_height "=$sw"
			} else {
				set width_height "=$w"
			}

			if {$y < 0} {
				set y 0
				append width_height "x$sh"
			} else {
				append width_height "x$h"
			}
		}
		append width_height "+$x+$y"

		for {set i 0} {$i < 2} {incr i} {
			wm geometry $twidget $width_height
			update idletasks
			if {[winfo x $twidget] == $x} {
				break
			}
		}
	
		wm deiconify $twidget
		take_focus $wdg
	
		return 0
	}

	method move_to_mouse {{swap 1}} {
		#we never move the window to the mouse location
		after idle "$this center; $this deiconify"
	}

	public leader {} {
		global tcl_platform

		if {$tcl_platform(platform) == "windows"} {
			set leader ""
		}
		if {$leader != "" && [winfo exists $leader]} {
			set leader [winfo toplevel $leader]
		}
		if {$leader != "" && [winfo exists $leader] && [winfo exists $twidget]} {
			@@bind $leader <Map> "catch {$this deiconify}"
			@@bind $leader <Unmap> "catch {$this withdraw}"
			@@bind $leader <Destroy> "catch {$this delete}"
		}
	}

	public input_check 1 {
		if {[winfo exists $twidget]} {
			sn_input_check_in_window $twidget $input_check
		}
	}

	protected twindow {}
	protected twidget {}
	method twidget {} {
		return $twidget
	}

	common internal_name .sn_

	global sn_path

        # Currenltly, wm iconbitmap only support xbm. Either we need a b&w
        # version of the ide icon, or we need to add xpm support.

	set iconfile paf.xbm

        common iconbitmap @[file join $sn_path(bitmapdir) $iconfile]

	common seq 0
}

proc take_focus {win {wdg ""}} {
	global sn_force_flag tcl_platform
	if {![winfo exists $win]} {
		return -1
	}
	if {$tcl_platform(platform) == "windows"} {
		eval focus $sn_force_flag [winfo toplevel $win]
	}
	if {$wdg != "" && [winfo exists $wdg] && [winfo toplevel $wdg] != $wdg} {
		eval focus $sn_force_flag $wdg
	}
	return 0
}

proc window_configure {win {cmd normal} {focus_wdg ""}} {
	if {![winfo exists $win]} {
		return
	}
	switch -- $cmd {
		"normal" -
		"deiconify" {
			global sn_force_flag
			eval focus $sn_force_flag [focus -lastfor $win]
			wm deiconify $win
			eval focus $sn_force_flag [focus -lastfor $win]
			raise $win
			if {$focus_wdg != ""} {
				focus $focus_wdg
			}
		}
		"withdraw" {
			wm withdraw $win
		}
		default {
			error "unrecognized key: $cmd"
		}
	}
}

#bind Escape and WM-close hint to the window
proc on_close {w {cmd ""}} {
	if {$cmd == ""} {
		set cmd "$this delete"
	}
	wm protocol $w WM_DELETE_WINDOW $cmd
	bind $w <Escape> $cmd
}

