jpayne@68: #
jpayne@68: # itclWidget.tcl
jpayne@68: # ----------------------------------------------------------------------
jpayne@68: # Invoked automatically upon startup to customize the interpreter
jpayne@68: # for [incr Tcl] when one of ::itcl::widget or ::itcl::widgetadaptor is called.
jpayne@68: # ----------------------------------------------------------------------
jpayne@68: #   AUTHOR:  Arnulf P. Wiedemann
jpayne@68: #
jpayne@68: # ----------------------------------------------------------------------
jpayne@68: #            Copyright (c) 2008  Arnulf P. Wiedemann
jpayne@68: # ======================================================================
jpayne@68: # See the file "license.terms" for information on usage and
jpayne@68: # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
jpayne@68: 
jpayne@68: package require Tk 8.6
jpayne@68: # package require itclwidget [set ::itcl::version]
jpayne@68: 
jpayne@68: namespace eval ::itcl {
jpayne@68: 
jpayne@68: proc widget {name args} {
jpayne@68:     set result [uplevel 1 ::itcl::internal::commands::genericclass widget $name $args]
jpayne@68:     # we handle create by owerselfs !! allow classunknown to handle that
jpayne@68:     oo::objdefine $result unexport create
jpayne@68:     return $result
jpayne@68: }
jpayne@68: 
jpayne@68: proc widgetadaptor {name args} {
jpayne@68:     set result [uplevel 1 ::itcl::internal::commands::genericclass widgetadaptor $name $args]
jpayne@68:     # we handle create by owerselfs !! allow classunknown to handle that
jpayne@68:     oo::objdefine $result unexport create
jpayne@68:     return $result
jpayne@68: }
jpayne@68: 
jpayne@68: } ; # end ::itcl
jpayne@68: 
jpayne@68: 
jpayne@68: namespace eval ::itcl::internal::commands {
jpayne@68: 
jpayne@68: proc initWidgetOptions {varNsName widgetName className} {
jpayne@68:     set myDict [set ::itcl::internal::dicts::classOptions]
jpayne@68:     if {$myDict eq ""} {
jpayne@68:         return
jpayne@68:     }
jpayne@68:     if {![dict exists $myDict $className]} {
jpayne@68:         return
jpayne@68:     }
jpayne@68:     set myDict [dict get $myDict $className]
jpayne@68:     foreach option [dict keys $myDict] {
jpayne@68:         set infos [dict get $myDict $option]
jpayne@68: 	set resource [dict get $infos -resource]
jpayne@68: 	set class [dict get $infos -class]
jpayne@68: 	set value [::option get $widgetName $resource $class]
jpayne@68: 	if {$value eq ""} {
jpayne@68: 	    if {[dict exists $infos -default]} {
jpayne@68: 	        set defaultValue [dict get $infos -default]
jpayne@68: 	        uplevel 1 set ${varNsName}::itcl_options($option) $defaultValue
jpayne@68: 	    }
jpayne@68: 	} else {
jpayne@68: 	    uplevel 1 set ${varNsName}::itcl_options($option) $value
jpayne@68: 	}
jpayne@68:     }
jpayne@68: }
jpayne@68: 
jpayne@68: proc initWidgetDelegatedOptions {varNsName widgetName className args} {
jpayne@68:     set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
jpayne@68:     if {$myDict eq ""} {
jpayne@68:         return
jpayne@68:     }
jpayne@68:     if {![dict exists $myDict $className]} {
jpayne@68:         return
jpayne@68:     }
jpayne@68:     set myDict [dict get $myDict $className]
jpayne@68:     foreach option [dict keys $myDict] {
jpayne@68:         set infos [dict get $myDict $option]
jpayne@68: 	if {![dict exists $infos -resource]} {
jpayne@68: 	    # this is the case when delegating "*"
jpayne@68: 	    continue
jpayne@68: 	}
jpayne@68: 	if {![dict exists $infos -component]} {
jpayne@68: 	    # nothing to do
jpayne@68: 	    continue
jpayne@68: 	}
jpayne@68: 	# check if not in the command line options
jpayne@68: 	# these have higher priority
jpayne@68: 	set myOption $option
jpayne@68: 	if {[dict exists $infos -as]} {
jpayne@68: 	   set myOption [dict get $infos -as]
jpayne@68: 	}
jpayne@68: 	set noOptionSet 0
jpayne@68: 	foreach {optName optVal} $args {
jpayne@68: 	    if {$optName eq $myOption} {
jpayne@68: 	        set noOptionSet 1
jpayne@68: 		break
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68: 	if {$noOptionSet} {
jpayne@68: 	    continue
jpayne@68: 	}
jpayne@68: 	set resource [dict get $infos -resource]
jpayne@68: 	set class [dict get $infos -class]
jpayne@68: 	set component [dict get $infos -component]
jpayne@68: 	set value [::option get $widgetName $resource $class]
jpayne@68: 	if {$component ne ""} {
jpayne@68: 	    if {$value ne ""} {
jpayne@68: 		set compVar [namespace eval ${varNsName}${className} "set $component"]
jpayne@68: 		if {$compVar ne ""} {
jpayne@68: 	            uplevel 1 $compVar configure $myOption $value
jpayne@68: 	        }
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68:     }
jpayne@68: }
jpayne@68: 
jpayne@68: proc widgetinitobjectoptions {varNsName widgetName className} {
jpayne@68: #puts stderr "initWidgetObjectOptions!$varNsName!$widgetName!$className!"
jpayne@68: }
jpayne@68: 
jpayne@68: proc deletehull {newName oldName what} {
jpayne@68:     if {$what eq "delete"} {
jpayne@68:         set name [namespace tail $newName]
jpayne@68:         regsub {hull[0-9]+} $name {} name
jpayne@68:         rename $name {}
jpayne@68:     }
jpayne@68:     if {$what eq "rename"} {
jpayne@68:         set name [namespace tail $newName]
jpayne@68:         regsub {hull[0-9]+} $name {} name
jpayne@68:         rename $name {}
jpayne@68:     }
jpayne@68: }
jpayne@68: 
jpayne@68: proc hullandoptionsinstall {objectName className widgetClass hulltype args} {
jpayne@68:     if {$hulltype eq ""} {
jpayne@68:         set hulltype frame
jpayne@68:     }
jpayne@68:     set idx 0
jpayne@68:     set found 0
jpayne@68:     foreach {optName optValue} $args {
jpayne@68: 	if {$optName eq "-class"} {
jpayne@68: 	    set found 1
jpayne@68: 	    set widgetClass $optValue
jpayne@68: 	    break
jpayne@68: 	}
jpayne@68:         incr idx
jpayne@68:     }
jpayne@68:     if {$found} {
jpayne@68:         set args [lreplace $args $idx [expr {$idx + 1}]]
jpayne@68:     }
jpayne@68:     if {$widgetClass eq ""} {
jpayne@68:         set widgetClass $className
jpayne@68: 	set widgetClass [string totitle $widgetClass]
jpayne@68:     }
jpayne@68:     set cmd "set win $objectName; ::itcl::builtin::installhull using $hulltype -class $widgetClass $args"
jpayne@68:     uplevel 2 $cmd
jpayne@68: }
jpayne@68: 
jpayne@68: } ; # end ::itcl::internal::commands
jpayne@68: 
jpayne@68: namespace eval ::itcl::builtin {
jpayne@68: 
jpayne@68: proc installhull {args} {
jpayne@68:     set cmdPath ::itcl::internal::commands
jpayne@68:     set className [uplevel 1 info class]
jpayne@68: 
jpayne@68:     set replace 0
jpayne@68:     switch -- [llength $args] {
jpayne@68: 	0	{
jpayne@68: 		return -code error\
jpayne@68: 		"wrong # args: should be \"[lindex [info level 0] 0]\
jpayne@68: 		name|using <widgetType> ?arg ...?\""
jpayne@68: 	}
jpayne@68: 	1	{
jpayne@68: 		set widgetName [lindex $args 0]
jpayne@68: 		set varNsName $::itcl::internal::varNsName($widgetName)
jpayne@68: 	}
jpayne@68: 	default	{
jpayne@68: 		upvar win win
jpayne@68: 		set widgetName $win
jpayne@68: 
jpayne@68: 		set varNsName $::itcl::internal::varNsName($widgetName)
jpayne@68: 	        set widgetType [lindex $args 1]
jpayne@68: 		incr replace
jpayne@68: 		if {[llength $args] > 3 && [lindex $args 2] eq "-class"} {
jpayne@68: 		    set classNam [lindex $args 3]
jpayne@68: 		    incr replace 2
jpayne@68: 		} else {
jpayne@68: 		    set classNam [string totitle $widgetType]
jpayne@68: 		}
jpayne@68: 		uplevel 1 [lreplace $args 0 $replace $widgetType $widgetName -class $classNam]
jpayne@68: 		uplevel 1 [list ${cmdPath}::initWidgetOptions $varNsName $widgetName $className]
jpayne@68: 	}
jpayne@68:     }
jpayne@68: 
jpayne@68:     # initialize the itcl_hull variable
jpayne@68:     set i 0
jpayne@68:     set nam ::itcl::internal::widgets::hull
jpayne@68:     while {1} {
jpayne@68:          incr i
jpayne@68: 	 set hullNam ${nam}${i}$widgetName
jpayne@68: 	 if {[::info command $hullNam] eq ""} {
jpayne@68: 	     break
jpayne@68: 	}
jpayne@68:     }
jpayne@68:     uplevel 1 [list ${cmdPath}::sethullwindowname $widgetName]
jpayne@68:     uplevel 1 [list ::rename $widgetName $hullNam]
jpayne@68:     uplevel 1 [list ::trace add command $hullNam {delete rename} ::itcl::internal::commands::deletehull]
jpayne@68:     catch {${cmdPath}::checksetitclhull [list] 0}
jpayne@68:     namespace eval ${varNsName}${className} "set itcl_hull $hullNam"
jpayne@68:     catch {${cmdPath}::checksetitclhull [list] 2}
jpayne@68:     uplevel 1 [lreplace $args 0 $replace ${cmdPath}::initWidgetDelegatedOptions $varNsName $widgetName $className]
jpayne@68: }
jpayne@68: 
jpayne@68: proc installcomponent {args} {
jpayne@68:     upvar win win
jpayne@68: 
jpayne@68:     set className [uplevel 1 info class]
jpayne@68:     set myType [${className}::info types [namespace tail $className]]
jpayne@68:     set isType 0
jpayne@68:     if {$myType ne ""} {
jpayne@68:         set isType 1
jpayne@68:     }
jpayne@68:     set numArgs [llength $args]
jpayne@68:     set usage "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?"
jpayne@68:     if {$numArgs < 4} {
jpayne@68:         error $usage
jpayne@68:     }
jpayne@68:     foreach {componentName using widgetType widgetPath} $args break
jpayne@68:     set opts [lrange $args 4 end]
jpayne@68:     if {$using ne "using"} {
jpayne@68:         error $usage
jpayne@68:     }
jpayne@68:     if {!$isType} {
jpayne@68:         set hullExists [uplevel 1 ::info exists itcl_hull]
jpayne@68:         if {!$hullExists} {
jpayne@68:             error "cannot install \"$componentName\" before \"itcl_hull\" exists"
jpayne@68:         }
jpayne@68:         set hullVal [uplevel 1 set itcl_hull]
jpayne@68:         if {$hullVal eq ""} {
jpayne@68:             error "cannot install \"$componentName\" before \"itcl_hull\" exists"
jpayne@68:         }
jpayne@68:     }
jpayne@68:     # check for delegated option and ask the option database for the values
jpayne@68:     # first check for number of delegated options
jpayne@68:     set numOpts 0
jpayne@68:     set starOption 0
jpayne@68:     set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
jpayne@68:     if {[dict exists $myDict $className]} {
jpayne@68:         set myDict [dict get $myDict $className]
jpayne@68: 	foreach option [dict keys $myDict] {
jpayne@68: 	    if {$option eq "*"} {
jpayne@68: 	        set starOption 1
jpayne@68: 	    }
jpayne@68: 	    incr numOpts
jpayne@68: 	}
jpayne@68:     }
jpayne@68:     set myOptionDict [set ::itcl::internal::dicts::classOptions]
jpayne@68:     if {[dict exists $myOptionDict $className]} {
jpayne@68:         set myOptionDict [dict get $myOptionDict $className]
jpayne@68:     }
jpayne@68:     set cmd [list $widgetPath configure]
jpayne@68:     set cmd1 "set $componentName \[$widgetType $widgetPath\]"
jpayne@68:     uplevel 1 $cmd1
jpayne@68:     if {$starOption} {
jpayne@68: 	upvar $componentName compName
jpayne@68: 	set cmd1 [list $compName configure]
jpayne@68:         set configInfos [uplevel 1 $cmd1]
jpayne@68: 	foreach entry $configInfos {
jpayne@68: 	    if {[llength $entry] > 2} {
jpayne@68: 	        foreach {optName resource class defaultValue} $entry break
jpayne@68: 		set val ""
jpayne@68: 		catch {
jpayne@68: 		    set val [::option get $win $resource $class]
jpayne@68: 		}
jpayne@68: 		if {$val ne ""} {
jpayne@68: 		    set addOpt 1
jpayne@68: 		    if {[dict exists $myDict $$optName]} {
jpayne@68: 		        set addOpt 0
jpayne@68: 		    } else {
jpayne@68: 		        set starDict [dict get $myDict "*"]
jpayne@68: 			if {[dict exists $starDict -except]} {
jpayne@68: 			    set exceptions [dict get $starDict -except]
jpayne@68: 			    if {[lsearch $exceptions $optName] >= 0} {
jpayne@68: 			        set addOpt 0
jpayne@68: 			    }
jpayne@68: 
jpayne@68: 			}
jpayne@68: 			if {[dict exists $myOptionDict $optName]} {
jpayne@68: 			    set addOpt 0
jpayne@68: 			}
jpayne@68:                     }
jpayne@68: 		    if {$addOpt} {
jpayne@68: 		        lappend cmd $optName $val
jpayne@68: 		    }
jpayne@68: 
jpayne@68: 		}
jpayne@68: 
jpayne@68: 	    }
jpayne@68:         }
jpayne@68:     } else {
jpayne@68:         foreach optName [dict keys $myDict] {
jpayne@68: 	    set optInfos [dict get $myDict $optName]
jpayne@68: 	    set resource [dict get $optInfos -resource]
jpayne@68: 	    set class [namespace tail $className]
jpayne@68: 	    set class [string totitle $class]
jpayne@68: 	    set val ""
jpayne@68: 	    catch {
jpayne@68: 	        set val [::option get $win $resource $class]
jpayne@68:             }
jpayne@68: 	    if {$val ne ""} {
jpayne@68: 		if {[dict exists $optInfos -as] } {
jpayne@68: 	            set optName [dict get $optInfos -as]
jpayne@68: 		}
jpayne@68: 		lappend cmd $optName $val
jpayne@68: 	    }
jpayne@68: 	}
jpayne@68:     }
jpayne@68:     lappend cmd {*}$opts
jpayne@68:     uplevel 1 $cmd
jpayne@68: }
jpayne@68: 
jpayne@68: } ; # end ::itcl::builtin
jpayne@68: 
jpayne@68: set ::itcl::internal::dicts::hullTypes [list \
jpayne@68:        frame \
jpayne@68:        toplevel \
jpayne@68:        labelframe \
jpayne@68:        ttk:frame \
jpayne@68:        ttk:toplevel \
jpayne@68:        ttk:labelframe \
jpayne@68:     ]
jpayne@68: 
jpayne@68: namespace eval ::itcl::builtin::Info {
jpayne@68: 
jpayne@68: proc hulltypes {args} {
jpayne@68:     namespace upvar ::itcl::internal::dicts hullTypes hullTypes
jpayne@68: 
jpayne@68:     set numArgs [llength $args]
jpayne@68:     if {$numArgs > 1} {
jpayne@68:         error "wrong # args should be: info hulltypes ?<pattern>?"
jpayne@68:     }
jpayne@68:     set pattern ""
jpayne@68:     if {$numArgs > 0} {
jpayne@68:         set pattern [lindex $args 0]
jpayne@68:     }
jpayne@68:     if {$pattern ne ""} {
jpayne@68:         return [lsearch -all -inline -glob $hullTypes $pattern]
jpayne@68:     }
jpayne@68:     return $hullTypes
jpayne@68: 
jpayne@68: }
jpayne@68: 
jpayne@68: proc widgetclasses {args} {
jpayne@68:     set numArgs [llength $args]
jpayne@68:     if {$numArgs > 1} {
jpayne@68:         error "wrong # args should be: info widgetclasses ?<pattern>?"
jpayne@68:     }
jpayne@68:     set pattern ""
jpayne@68:     if {$numArgs > 0} {
jpayne@68:         set pattern [lindex $args 0]
jpayne@68:     }
jpayne@68:     set myDict [set ::itcl::internal::dicts::classes]
jpayne@68:     if {![dict exists $myDict widget]} {
jpayne@68:         return [list]
jpayne@68:     }
jpayne@68:     set myDict [dict get $myDict widget]
jpayne@68:     set result [list]
jpayne@68:     if {$pattern ne ""} {
jpayne@68:         foreach key [dict keys $myDict] {
jpayne@68: 	    set myInfo [dict get $myDict $key]
jpayne@68: 	    set value [dict get $myInfo -widget]
jpayne@68: 	    if {[string match $pattern $value]} {
jpayne@68: 	        lappend result $value
jpayne@68:             }
jpayne@68:         }
jpayne@68:     } else {
jpayne@68:         foreach key [dict keys $myDict] {
jpayne@68: 	    set myInfo [dict get $myDict $key]
jpayne@68: 	    lappend result [dict get $myInfo -widget]
jpayne@68: 	}
jpayne@68:     }
jpayne@68:     return $result
jpayne@68: }
jpayne@68: 
jpayne@68: proc widgets {args} {
jpayne@68:     set numArgs [llength $args]
jpayne@68:     if {$numArgs > 1} {
jpayne@68:         error "wrong # args should be: info widgets ?<pattern>?"
jpayne@68:     }
jpayne@68:     set pattern ""
jpayne@68:     if {$numArgs > 0} {
jpayne@68:         set pattern [lindex $args 0]
jpayne@68:     }
jpayne@68:     set myDict [set ::itcl::internal::dicts::classes]
jpayne@68:     if {![dict exists $myDict widget]} {
jpayne@68:         return [list]
jpayne@68:     }
jpayne@68:     set myDict [dict get $myDict widget]
jpayne@68:     set result [list]
jpayne@68:     if {$pattern ne ""} {
jpayne@68:         foreach key [dict keys $myDict] {
jpayne@68: 	    set myInfo [dict get $myDict $key]
jpayne@68: 	    set value [dict get $myInfo -name]
jpayne@68: 	    if {[string match $pattern $value]} {
jpayne@68: 	        lappend result $value
jpayne@68:             }
jpayne@68:         }
jpayne@68:     } else {
jpayne@68:         foreach key [dict keys $myDict] {
jpayne@68: 	    set myInfo [dict get $myDict $key]
jpayne@68: 	    lappend result [dict get $myInfo -name]
jpayne@68: 	}
jpayne@68:     }
jpayne@68:     return $result
jpayne@68: }
jpayne@68: 
jpayne@68: proc widgetadaptors {args} {
jpayne@68:     set numArgs [llength $args]
jpayne@68:     if {$numArgs > 1} {
jpayne@68:         error "wrong # args should be: info widgetadaptors ?<pattern>?"
jpayne@68:     }
jpayne@68:     set pattern ""
jpayne@68:     if {$numArgs > 0} {
jpayne@68:         set pattern [lindex $args 0]
jpayne@68:     }
jpayne@68:     set myDict [set ::itcl::internal::dicts::classes]
jpayne@68:     if {![dict exists $myDict widgetadaptor]} {
jpayne@68:         return [list]
jpayne@68:     }
jpayne@68:     set myDict [dict get $myDict widgetadaptor]
jpayne@68:     set result [list]
jpayne@68:     if {$pattern ne ""} {
jpayne@68:         foreach key [dict keys $myDict] {
jpayne@68: 	    set myInfo [dict get $myDict $key]
jpayne@68: 	    set value [dict get $myInfo -name]
jpayne@68: 	    if {[string match $pattern $value]} {
jpayne@68: 	        lappend result $value
jpayne@68:             }
jpayne@68:         }
jpayne@68:     } else {
jpayne@68:         foreach key [dict keys $myDict] {
jpayne@68: 	    set myInfo [dict get $myDict $key]
jpayne@68: 	    lappend result [dict get $myInfo -name]
jpayne@68: 	}
jpayne@68:     }
jpayne@68:     return $result
jpayne@68: }
jpayne@68: 
jpayne@68: } ; # end ::itcl::builtin::Info