pixmapmenu.tcl

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

package provide pixmapmenu 0.1
package require contentmanager

snit::widgetadaptor pixmapmenu {

	typevariable arrowdownimg 		;# Arrow image
	typevariable arrowrightimg 		;# Arrow image
	typevariable backgroundimg 		;# Background image
	typevariable backgroundborder 		;# Borders for scalable-bg for background
	typevariable selectimg 			;# Select image
	typevariable selectborder 		;# Borders for scalable-bg for select
	typevariable separatorimg		;# Separator image
	typevariable separatorborder		;# Borders for scalable-bg for separator
	typevariable checkboximg		;# Checkbutton image
	typevariable checktickimg		;# Checkbutton tick image
	typevariable radioboximg		;# Radiobutton image
	typevariable radiotickimg		;# Radiobutton tick image

	typeconstructor {
		::skin::setPixmap menuarrowdown menu_arrow_down.png
		::skin::setPixmap menuarrowright menu_arrow_right.png
		::skin::setPixmap menubackground menu_background.png
		::skin::setPixmap menuselect menu_select.png
		::skin::setPixmap menuseparator menu_separator.png
		::skin::setPixmap checkbox checkbox.png
		::skin::setPixmap checktick checkmark.png
		::skin::setPixmap radiobox radiobox.png
		::skin::setPixmap radiotick radiomark.png
		set checkboximg [::skin::loadPixmap checkbox]
		set checktickimg [::skin::loadPixmap checktick]
		set radioboximg [::skin::loadPixmap radiobox]
		set radiotickimg [::skin::loadPixmap radiotick]
		set arrowdownimg [::skin::loadPixmap menuarrowdown]
		set arrowrightimg [::skin::loadPixmap menuarrowright]
		set backgroundimg [::skin::loadPixmap menubackground]
		set selectimg [::skin::loadPixmap menuselect]
		set separatorimg [::skin::loadPixmap menuseparator]
		set backgroundborder {1 1 1 1}
		set selectborder {1 1 1 1}
		set separatorborder {0 0 0 0}
	}

	option -activeforeground -configuremethod SetForeground -default black
	option -activefg -configuremethod SetForeground -default black
	option -cascadedelay -default 500
	option -disabledforeground -configuremethod SetForeground -default grey
	option -disabledfg -configuremethod SetForeground -default grey
	option -entrypadx -configuremethod SetPadding -default 4
	option -entrypady -configuremethod SetPadding -default 3
	option -foreground -configuremethod SetForeground -default black
	option -fg -configuremethod SetForeground -default black
	option -font -configuremethod SetFont -default "Helvetica 12"
	option -ipadx -configuremethod SetPadding -default 0
	option -ipady -configuremethod SetPadding -default 0
	option -orient -configuremethod SetOrient -default vertical
	option -tearoff -default 0 -readonly yes
	option -type -default normal

	delegate option * to hull except { -highlightthickness -bd -borderwidth }

	variable canvas 	;# Canvas widget
	variable offx 		;# X-ord to create new stuff at so it's hidden
	variable offy 		;# Y-ord to create new stuff at so it's hidden
	variable main 		;# Main contentmanager group
	variable entries 	;# Stores entries
	variable entryid 	;# Unique id for each entry
	variable arrowid 	;# Array to store canvas ids of entries' arrows (cascade entries only)
	variable imageid 	;# Array to store canvas ids of entries' images
	variable textid 	;# Array to store canvas ids of entries' text
	variable checktickid	;# Array to store canvas ids of entries' check marks (checkbutton entries only)
	variable radiotickid	;# Array to store canvas ids of entries' radio marks (radiobutton entries only)
	variable backgroundid	;# Canvas id of background image
	variable background	;# Backgound scalable-bg
	variable select		;# Select scalable-bg
	variable selectid	;# Canvas id of select image
	variable separator	;# Separator scalable-bg
	variable afterid	;# Array to speed up processing of batches of commands
	variable active		;# Active entry
	variable config		;# Array to store names of config objects for entries

	constructor { args } {
		# Initial values
		set entries {}
		set active "none"
		set entryid 0
		set offx -1000
		set offy -1000
		array set afterid {Sort {}}
		array set arrowid {{} {}}
		array set imageid {{} {}}
		array set textid {{} {}}
		array set checktickid {{} {}}
		array set radiotickid {{} {}}
		array set config {{} {}}

		# Create canvas
		installhull using canvas -borderwidth 0 -highlightthickness 0 -relief flat
		set canvas $hull
		# Parse and apply arguments
		$self configurelist $args

		# Create main contentmanager group
		set main [contentmanager add group $self.main \
			-widget $canvas \
			-ipadx $options(-ipadx) \
			-ipady $options(-ipady) \
			-orient $options(-orient)]

		# Create menu background & select
		set background [scalable-bg $self.background \
			-source $backgroundimg	-border $backgroundborder]
		set backgroundid [$canvas create image 0 0 -anchor nw -image [$background name]]
		set select [scalable-bg $self.select \
			-source $selectimg	-border $selectborder \
			-width 	1		-height 1]
		set selectid [$canvas create image 0 0 -anchor nw -image [$select name] -state hidden]
		# Create separator
		set separator [scalable-bg $self.separator -source $separatorimg -border $separatorborder]

		# Bindings
		bindtags $self "Pixmapmenu . all"

		# Update size
		$self UpdateSize
	}

	destructor {
		catch {after cancel $afterid(Sort)}
		catch {contentmanager delete $main}
		catch {$background destroy}
		catch {$select destroy}
		catch {$separator destroy}
		catch {
			foreach { key configobj } [array get config] {
				if { $configobj != "" } {
					$configobj destroy
				}
			}
		}
	}

	method Configure { width height } {
		switch $options(-orient) {
			horizontal {
				$background configure \
					-width	$width	-height	$height
				$separator configure \
					-width 	[image height $separatorimg] \
					-height	[expr {$height - (2 * $options(-ipady)) - (2 * $options(-entrypady))}]
			}
			vertical {
				$background configure \
					-width	$width	-height	$height
				$separator configure \
					-width 	[expr {$width - (2 * $options(-ipadx)) - (2 * $options(-entrypadx))}] \
					-height	[image height $separatorimg]
				$self AlignCascadeArrows
			}
		}
	}

	method UpdateSize { } {
		switch $options(-orient) {
			horizontal {
				set w 0
				set h 0
				foreach entry $entries {
					incr w [contentmanager width $main $entry]
					set entryh [contentmanager height $main $entry]
					if { $entryh > $h } {
						set h $entryh
					}
				}
				if { $options(-type) != "menubar" } {
					incr h [image height $arrowdownimg]
				}
				$hull configure -width [expr {$w + (2 * $options(-ipadx))}] -height [expr {$h + (2 * $options(-ipady))}]
			}
			vertical {
				set w 0
				set h 0
				foreach entry $entries {
					incr h [contentmanager height $main $entry]
					set entryw [contentmanager width $main $entry]
					if { $entryw > $w } {
						set w $entryw
					}
				}
				if { $options(-type) != "menubar" } {
					incr w [image width $arrowrightimg]
				}
				$hull configure -width [expr {$w + (2 * $options(-ipadx))}] -height [expr {$h + (2 * $options(-ipady))}]
				#puts "$self setwidth [expr {$w + (2 * $options(-ipadx))}]"
			}
		}
	}

	method AlignCascadeArrows { } {
		foreach entry $entries {
			if { [info exists arrowid($entry)] } {
				switch $options(-orient) {
					horizontal {
						set x [expr {[$self xposition [lsearch $entries $entry]] + [contentmanager width $main $entry] / 2 - [image width $arrowdownimg] / 2}]
						set y [expr {[$hull cget -height] - $options(-ipady) - [image height $arrowdownimg] - $options(-entrypady)}]
					}
					vertical {
						set x [expr {[$hull cget -width] - $options(-ipadx) - [image width $arrowrightimg] - $options(-entrypadx)}]
						set y [expr {[$self yposition [lsearch $entries $entry]] + [contentmanager height $main $entry] / 2 - [image height $arrowrightimg] / 2}]
					}
				}
				$canvas coords $arrowid($entry) $x $y
			}
		}
	}

	method CreateEntry { index _type args } {
		switch -regexp $_type {
			com.* {
				# Create the canvas items
				set imageid($entryid) [$canvas create image $offx $offy -anchor nw -tags entry$entryid]
				set textid($entryid) [$canvas create text $offx $offy -anchor nw -fill $options(-fg) -font $options(-font) -tags entry$entryid]
				# Create the contentmanager items
				contentmanager insert $index group $main $entryid \
					-widget		$canvas			-orient 	horizontal \
					-ipadx 		$options(-entrypadx) 	-ipady 		$options(-entrypady)
				contentmanager add element $main $entryid icon \
					-widget	$canvas			-tag	$imageid($entryid) \
					-valign center
				contentmanager add element $main $entryid text \
					-widget	$canvas			-tag	$textid($entryid) \
					-padx $options(-entrypadx)	-pady 	$options(-entrypady) \
					-valign center
	
				# Create and configure the entry object
				set config($entryid) [uplevel #0 "$_type $self.$entryid -id $entryid -parent $self"]
				if { [lsearch $args -image] == -1 } {
					lappend args -image {}
				}
				if { [lsearch $args -label] == -1 } {
					lappend args -label {}
				}
				$config($entryid) configurelist $args
			}
			casc.* {
				# Create the canvas items
				set imageid($entryid) [$canvas create image $offx $offy -anchor nw -tags entry$entryid]
				set textid($entryid) [$canvas create text $offx $offy -anchor nw -fill $options(-fg) -font $options(-font) -tags entry$entryid]
				# Create the contentmanager items
				contentmanager insert $index group $main $entryid \
					-widget		$canvas			-orient 	horizontal \
					-ipadx 		$options(-entrypadx) 	-ipady 		$options(-entrypady)
				contentmanager add element $main $entryid icon \
					-widget	$canvas			-tag	$imageid($entryid) \
					-valign center
				contentmanager add element $main $entryid text \
					-widget	$canvas			-tag	$textid($entryid) \
					-padx $options(-entrypadx)	-pady 	$options(-entrypady) \
					-valign center
	
				# Create and configure the entry object
				set config($entryid) [uplevel #0 "$_type $self.$entryid -id $entryid -parent $self"]
				if { [lsearch $args -image] == -1 } {
					lappend args -image {}
				}
				if { [lsearch $args -label] == -1 } {
					lappend args -label {}
				}
				$config($entryid) configurelist $args

				# Add arrow (not on a menubar though)
				if { $options(-type) != "menubar" } {
					switch $options(-orient) {
						horizontal {
							set arrowid($entryid) [$canvas create image $offx $offy -anchor nw -image $arrowdownimg -tags entry$entryid]
						}
						vertical {
							set arrowid($entryid) [$canvas create image $offx $offy -anchor nw -image $arrowrightimg -tags entry$entryid]
						}
					}
					contentmanager add element $main $entryid arrow \
					-widget	$canvas			-tag	$arrowid($entryid) \
					-valign center
				}
			}
			check.* {
				# Create the canvas items
				set imageid($entryid) [$canvas create image $offx $offy -anchor nw -image $checkboximg -tags entry$entryid]
				set checktickid($entryid) [$canvas create image $offx $offy -anchor nw -image $checktickimg -tags entry$entryid]
				set textid($entryid) [$canvas create text $offx $offy -anchor nw -fill $options(-fg) -font $options(-font) -tags entry$entryid]
				# Create the contentmanager items
				contentmanager insert $index group $main $entryid \
					-widget		$canvas			-orient 	horizontal \
					-ipadx 		$options(-entrypadx) 	-ipady 		$options(-entrypady)
				contentmanager add element $main $entryid icon \
					-widget	$canvas			-tag	$imageid($entryid) \
					-padx $options(-entrypadx)	-pady 	$options(-entrypady) \
					-valign center
				contentmanager add attachment $main $entryid icon tick -widget $canvas -tag $checktickid($entryid)
				contentmanager add element $main $entryid text \
					-widget	$canvas			-tag	$textid($entryid) \
					-padx $options(-entrypadx)	-pady 	$options(-entrypady) \
					-valign center
	
				set _type menu_checkbutton
				# Create and configure the entry object
				set config($entryid) [uplevel #0 "$_type $self.$entryid -id $entryid -parent $self -canvas $canvas"]
				if { [lsearch $args -label] == -1 } {
					lappend args -label {}
				}
				$config($entryid) configurelist $args
			}
			radio.* {
				# Create the canvas item
				set imageid($entryid) [$canvas create image $offx $offy -anchor nw -image $radioboximg -tags entry$entryid]
				set radiotickid($entryid) [$canvas create image $offx $offy -anchor nw -image $radiotickimg -tags entry$entryid]
				set textid($entryid) [$canvas create text $offx $offy -anchor nw -fill $options(-fg) -font $options(-font) -tags entry$entryid]
	
				# Create the contentmanager items
				contentmanager insert $index group $main $entryid \
					-widget		$canvas			-orient 	horizontal \
					-ipadx 		$options(-entrypadx) 	-ipady 		$options(-entrypady)
				contentmanager add element $main $entryid icon \
					-widget	$canvas			-tag	$imageid($entryid) \
					-padx $options(-entrypadx)	-pady 	$options(-entrypady) \
					-valign center
				contentmanager add attachment $main $entryid icon tick -widget $canvas -tag $radiotickid($entryid)
				contentmanager add element $main $entryid text \
					-widget	$canvas			-tag	$textid($entryid) \
					-padx $options(-entrypadx)	-pady 	$options(-entrypady) \
					-valign center
				set _type menu_radiobutton
				# Create and configure the entry object
				set config($entryid) [uplevel #0 "$_type $self.$entryid -id $entryid -parent $self -canvas $canvas"]
				if { [lsearch $args -label] == -1 } {
					lappend args -label {}
				}
				$config($entryid) configurelist $args
			}
			sep.* {
				# Create the canvas item
				set id [$canvas create image $offx $offy -anchor nw -image [$separator name] -tags entry$entryid]
				# Create the contentmanager item
				contentmanager insert $index element $main $entryid \
					-widget	$canvas			-tag	$id \
					-ipadx	$options(-entrypadx)	-ipady $options(-entrypady)
				set config($entryid) [uplevel #0 "$_type $self.$entryid -id $entryid -parent $self"]
			}
		}

		incr entryid 1
		return [expr {$entryid - 1}]
	}

	method EntryConfigureImage { id value } {
		$canvas itemconfigure $imageid($id) -image $value
		if { $value == "" } {
			contentmanager hide $main $id icon
		} else {
			contentmanager show $main $id icon
		}
		$self sort
	}

	method EntryConfigureLabel { id value } {
		$canvas itemconfigure $textid($id) -text $value
		if { $value == "" } {
			contentmanager hide $main $id text
		} else {
			contentmanager show $main $id text
		}
		$self sort
	}

	method EntryDeselectCheck { id } {
		# Only works with an after, don't know why :(
		after 0 "$canvas itemconfigure $checktickid($id) -state hidden"
	}

	method EntryDeselectRadio { id } {
		$canvas itemconfigure $radiotickid($id) -state hidden
	}

	method EntrySelectCheck { id } {
		# Only works with an after, don't know why :(
		if { [$config($id) cget -indicatoron] } {
			after 0 "$canvas itemconfigure $checktickid($id) -state normal"
		}
	}

	method EntrySelectRadio { id } {
		if { [$config($id) cget -indicatoron] } {
			$canvas itemconfigure $radiotickid($id) -state normal
		}
	}

	method add { _type args } {
		# Create the entry
		set id [eval $self CreateEntry end $_type $args]
		# Append the entry to the list of entries
		lappend entries $id
	}

	method insert { index _type args } {
		# Create the entry