contentmanager.tcl

来自「Linux下的MSN聊天程序源码」· TCL 代码 · 共 959 行 · 第 1/2 页

package provide contentmanager 0.1
package require snit
package require scalable-bg
package require contentmanager

# o-------------------------------------------------------------------------------+
#  Name: contentmanager                                                           |
#  Description: Manager type                                       	          |
#  Function: Provide an easy-to-use API to groups and elements                    |
# o-------------------------------------------------------------------------------+
snit::type contentmanager {

	pragma -hasinstances no
	pragma -hastypeinfo no
	pragma -hastypedestroy no

	# -------------------------------------------------------------------------------
	#  Methods to create, destroy, configure and use groups and elements
	# -------------------------------------------------------------------------------
	typemethod getpath { args } {
		set path {}
		foreach name $args {
			# strings beginning with - are options, end getting path
			if { [string equal [string index $name 0] "-"] } {
				break
			}
			if { [string equal $path {}] } {
				set path $name
			} else {
				set path $path.$name
			}
		}
		return $path
	}

	typemethod gettree { args } {
		set tree {}
		foreach name $args {
			if { [string equal [string index $name 0] "-"] } {
				break
			} else {
				lappend tree $name
			}
		}
		return $tree
	}

	typemethod getopts { args } {
		set opts {}
		foreach opt $args {
			if { [string equal [string index $opt 0] "-"] } {
				set val [lindex $args [expr {[lsearch $args $opt] + 1}]]
				lappend opts $opt $val
				continue
			} else {
				continue
			}
		}
		return $opts
	}

	typemethod add { _type args } {
		set path [eval $type getpath $args]
		set opts [eval $type getopts $args]
		set tree [eval $type gettree $args]

		# Check item doesn't already exist
		if { [info command $path] != {} } {
			error "$_type '$path' already exists"
			return {}
		}

		switch $_type {
			group {
				eval group $path -tree [list $tree] $opts
				# If this isn't a toplevel group...
				if { [llength $tree] > 1 } {
					# ...set it's state to its parent's state and register with its parent
					set parent [eval $type getpath [lrange $tree 0 end-1]]
					$path configure -state [$parent cget -state]
					set id [lindex $tree end]
					$parent register $id
				} else {
					set id $tree
				}
			}
			element {
				eval element $path -tree [list $tree] $opts
				# If this isn't a toplevel element...
				if { [llength $tree] > 1 } {
					# ...set it's state to its parent's state and register with its parent
					set parent [eval $type getpath [lrange $tree 0 end-1]]
					$path configure -state [$parent cget -state]
					set id [lindex $tree end]
					$parent register $id
				} else {
					set id $tree
				}
			}
			attachment {
				eval element $path -tree [list $tree] $opts
				# Set it's state to its parent's state and attach it to its parent
				set parent [eval $type getpath [lrange $tree 0 end-1]]
				$path configure -state [$parent cget -state]
				set id [lindex $tree end]
				$parent attach $id
			}
			default {
				error "unknown item type '${_type}'"
			}
		}
		return $id
	}

	typemethod insert { index _type args } {
		# Check index is okay
		if { ![string is integer $index] && $index != "end" } {
			error "invalid insert index '$index'"
		}
		
		set path [eval $type getpath $args]
		set opts [eval $type getopts $args]
		set tree [eval $type gettree $args]

		# Check item doesn't already exist
		if { [info command $path] != {} } {
			error "$_type '$path' already exists"
			return {}
		}

		if { [string equal $_type "group"] } {
			set parent [eval $type getpath [lrange $tree 0 end-1]]
			eval group $path -tree [list $tree] $opts
			# If this isn't a toplevel group...
			if { [llength $tree] > 1 } {
				# ...set it's state to its parent's state and register with its parent
				set parent [eval $type getpath [lrange $tree 0 end-1]]
				$path configure -state [$parent cget -state]
				set id [lindex $tree end]
				$parent register $id $index
			} else {
				set id $tree
			}
		} elseif { [string equal $_type "element"] } {
			eval element $path -tree [list $tree] $opts
			# If this isn't a toplevel element...
			if { [llength $tree] > 1 } {
				# ...set it's state to its parent's state and register with its parent
				set parent [eval $type getpath [lrange $tree 0 end-1]]
				$path configure -state [$parent cget -state]
				set id [lindex $tree end]
				$parent register $id $index
			} else {
				set id $tree
			}
		}
		return $id
	}

	typemethod delete { args } {
		set path [eval $type getpath $args]
		set tree [eval $type gettree $args]
		$path destroy
	}

	typemethod configure { args } {
		set path [eval $type getpath $args]
		set opts [eval $type getopts $args]
		$path configurelist $opts
	}

	typemethod cget { args } {
		set tree [lrange $args 0 end-1]
		set opt [lindex $args end]
		set path [eval $type getpath $tree]
		return [$path cget $opt]
	}

	typemethod children { args } {
		set path [eval $type getpath $args]
		return [$path children]
	}

	typemethod coords { args } {
		set tree [lrange $args 0 end-2]
		set coords [lrange $args end-1 end]
		foreach ord $coords {
			if { ![string is integer $ord] } {
				error "cant user non-numeric '$ord' value as ordinate"
			}
		}
		set path [eval $type getpath $tree]
		eval $path coords $coords
	}

	typemethod getcoords { args } {
		set path [eval $type getpath $args]
		return [eval $path coords]
	}

	typemethod width { args } {
		set path [eval $type getpath $args]
		return [eval $path cget -width]
	}

	typemethod height { args } {
		set path [eval $type getpath $args]
		return [eval $path cget -height]
	}

	typemethod move { args } {
		set tree [lrange $args 0 end-2]
		set vector [lrange $args end-1 end]
		set path [eval $type getpath $tree]
		eval $path move $vector
	}

	typemethod bind { args } {
		set tree [lrange $args 0 end-2]
		set path [eval $type getpath $tree]
		set pattern [lindex $args end-1]
		set command [lindex $args end]
		eval $path bind $pattern [list $command]
	}

	typemethod show { args } {
		set path [eval $type getpath $args]
		set opts [eval $type getopts $args]
		eval $path show $opts
	}

	typemethod hide { args } {
		set path [eval $type getpath $args]
		set opts [eval $type getopts $args]
		eval $path hide $opts
	}

	typemethod toggle { args } {
		set path [eval $type getpath $args]
		eval $path toggle
	}

	typemethod sort { args } {
		set lvlopt [lsearch $args -level]
		if { $lvlopt == -1 } {
			set level r
		} else {
			set level [lindex $args [expr {$lvlopt + 1}]]
		}
		set path [eval $type getpath $args]
		eval $path sort $level
	}

	typemethod type { args } {
		set path [eval $type getpath $args]
		return [eval $path type]
	}

	typemethod register { args } {
		set tree [eval $type gettree $args]
		set path [eval $type getpath [lrange $args 0 end-1]]
		set id [lindex $tree end]
		$path register $id
	}

	typemethod unregister { args } {
		set tree [eval $type gettree $args]
		set path [eval $type getpath [lrange $args 0 end-1]]
		set id [lindex $tree end]
		$path unregister $id
	}
}


snit::type group {

	# Parent options
	option -widget -configuremethod SetWidget
	option -parent
	option -id
	option -tree

	# Dimension options
	option -align -default left
	option -orient -default vertical
	option -height -default 0 -configuremethod SetHeight
	option -valign -default top
	option -width -default 0 -configuremethod SetWidth

	# Padding options
	option -padx -default 0
	option -pady -default 0
	option -ipadx -default 0
	option -ipady -default 0

	# State options
	option -omnipresent -default no
	option -state -default normal -configuremethod SetState

	# Position variables
	variable xPos
	variable yPos

	# Children variables
	variable items
	variable hiddenitems
	variable bboxid

	# Attachment variables
	variable attachments

	# Afterid variables
	variable afterid

	# Binding variables
	variable havebinding

	constructor { args } {
		set xPos 0
		set yPos 0
		set items {}
		set bboxid {}
		set attachments {}
		array set afterid {sort {}}
		set havebinding 0
		$self configurelist $args
	}

	destructor {
		catch {
			foreach item $items {
				set tree $options(-tree)
				lappend tree $item
				eval contentmanager delete $tree
			}
		}
		catch { $options(-widget) delete $bboxid }
		catch { eval contentmanager unregister $options(-tree) }
	}

	method type { } {
		return "group"
	}

	method SetWidget { opt val } {
		set options(-widget) $val
		set bboxid [$val create rect 0 0 0 0 -fill "" -outline "" -state hidden]
	}

	method SetWidth { opt val } {
		set options(-width) $val
		if { ![string equal $bboxid ""] } {
			$options(-widget) coords $bboxid $xPos $yPos [expr {$xPos + $val}] [expr {$yPos + $options(-height)}]
		}
	}

	method SetHeight { opt val } {
		set options(-height) $val
		if { [$self GotWidget] } {
			$options(-widget) coords $bboxid $xPos $yPos [expr {$xPos + $options(-width)}] [expr {$yPos + $val}]
		}
	}

	method SetState { opt val } {
		set options(-state) $val
		switch $val {
			"partlyhidden" {
				$self hide
			}
			"hidden" {
				$self hide
			}
			"normal" {
				$self show
			}
		}
	}

	method GotWidget { } {
		if { ![string equal $bboxid ""] } {
			return 1
		} else {
			return 0
		}
	}

	method register { id {idx ""} } {
		if { [string equal $idx ""] } {
			lappend items $id
		} else {
			set items [linsert $items $idx $id]
		}
	}

	method unregister { id } {
		set idx [lsearch $items $id]
		set list1 [lrange $items 0 [expr {$idx - 1}]]
		set list2 [lrange $items [expr {$idx + 1}] end]
		set items [concat $list1 $list2]
	}

	method children { } {
		return $items
	}

	method attach { id } {
		lappend attachments $id
	}

	method bind { pat cmd {mode "bbox"} } {
		if { [string equal $cmd {}] } {
			set havebinding 0
			$options(-widget) itemconfigure $bboxid -state hidden
		} else {
			set havebinding 1
			if { $mode == "bbox" } {
				$options(-widget) itemconfigure $bboxid -state normal
			}
		}
		switch $mode {
			"bbox" {
				$options(-widget) bind $bboxid $pat $cmd
			}
			"components" {
				foreach item $items {
					set tree $options(-tree)
					lappend tree $item
					eval contentmanager bind $tree $pat [list $cmd]
				}
			}
		}
	}

	method coords { {x {}} {y {}} } {
		if { [string equal $x {}] } {
			return "$xPos $yPos"
		} elseif { $x == $xPos && $y == $yPos } {
			return
		}
		set dx [expr {$x - $xPos}]
		set dy [expr {$y - $yPos}]
		$self move $dx $dy
	}

	method move { dx {dy {}} } {
		if { $dx == 0 } {
			if { $dy == 0 || [string equal $dy {}] } {
				return
			}
		}
		incr xPos $dx
		if { [string equal $dy {}] } {
			foreach item $items {
				set tree $options(-tree)
				lappend tree $item
				eval contentmanager move $tree $dx
			}
			if { [$self GotWidget] } {
				$options(-widget) move $bboxid $dx
			}
		} else {
			incr yPos $dy
			foreach item $items {
				set tree $options(-tree)
				lappend tree $item
				eval contentmanager move $tree $dx $dy
			}
			if { [$self GotWidget] } {
				$options(-widget) move $bboxid $dx $dy
			}
		}
		$self PlaceAttachments
	}

	method show { args } {
		if { [string equal $args {}] } {
			set level r
		} else {
			set level [lindex $args 1]
		}