1# -*- mode: tcl; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*- 2# 3# $Id: Object.tcl,v 1.3 2006-10-01 23:59:47 villate Exp $ 4# 5# Original Id: object.tcl,v 1.7 1995/02/10 08:32:50 sls Exp sls 6# 7# This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory. 8# 9# Redistribution and use in source and binary forms, with or without 10# modification, are permitted provided that: (1) source code distributions 11# retain the above copyright notice and this paragraph in its entirety, (2) 12# distributions including binary code include the above copyright notice and 13# this paragraph in its entirety in the documentation or other materials 14# provided with the distribution, and (3) all advertising materials mentioning 15# features or use of this software display the following acknowledgement: 16# ``This product includes software developed by the University of California, 17# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of 18# the University nor the names of its contributors may be used to endorse 19# or promote products derived from this software without specific prior 20# written permission. 21# 22# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED 23# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 24# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. 25 26# Prepare for message catalogues 27proc M {str args} { 28 if {$args == ""} {return $str} 29 return [eval [list format $str] $args] 30} 31 32proc object_info {name} { 33 # need an object info function like itcl 34} 35 36set object_priv(currentClass) {} 37set object_priv(objectCounter) 0 38 39proc object_class {name spec} { 40 global object_priv 41 set object_priv(currentClass) $name 42 lappend object_priv(objects) $name 43 upvar #0 ${name}_priv class 44 set class(members) {} 45 set class(params) {} 46 set class(methods) {} 47 proc doc arg "upvar #0 ${name}_priv class; set class(__doc__) \"\$arg\"" 48 eval $spec 49 proc doc arg "" 50 proc $name:config {self args} "uplevel \[concat object_config \$self \$args]" 51 proc $name:configure args "uplevel \[concat object_config \$args]" 52 proc $name:cget {self option} "uplevel \[list object_cget \$self \$option]" 53 proc $name {inst args} "object_new $name \$inst; uplevel \[concat object_config \$inst \$args]" 54} 55 56 57# could do doc as a simple proc that finds if its in a method or a class 58# use uplevel and/or look for self as first of info args 59 60proc method {name args body} { 61 global object_priv 62 set className $object_priv(currentClass) 63 upvar #0 ${className}_priv class 64 lappend class(methods) $name 65 set methodArgs self 66 append methodArgs " " $args 67 set procbody "upvar #0 \$self slot" 68 append procbody "\nproc doc arg \"upvar #0 \$self slot; set slot(${name}.__doc__) \\\$arg\"" 69 append procbody "\n$body" 70 proc $className:$name $methodArgs $procbody 71} 72 73# Pythonic method without the implicit self 74proc def {name args body} { 75 global object_priv 76 set className $object_priv(currentClass) 77 upvar #0 ${className}_priv class 78 lappend class(methods) $name 79 set methodArgs $args 80 set procbody "set self \$[lindex $methodArgs 0]; upvar #0 \$self slot" 81 append procbody "\nproc doc arg \"upvar #0 \$self slot; set slot(${name}.__doc__) \\\$arg\"" 82 append procbody "\n$body" 83 proc $className:$name $methodArgs $procbody 84} 85 86proc member {name {defaultValue {}}} { 87 global object_priv 88 set className $object_priv(currentClass) 89 upvar #0 ${className}_priv class 90 if {![info exists class(member_info/$name)]} { 91 lappend class(members) [list $name $defaultValue] 92 } 93 set class(member_info/$name) {} 94} 95 96proc param {name {defaultValue {}} {resourceClass {}} {configCode {}}} { 97 global object_priv 98 set className $object_priv(currentClass) 99 upvar #0 ${className}_priv class 100 if {$resourceClass == ""} { 101 set resourceClass \ 102 [string toupper [string index $name 0]][string range $name 1 end] 103 } 104 if ![info exists class(param_info/$name)] { 105 lappend class(params) $name 106 } 107 set class(param_info/$name) [list $defaultValue $resourceClass] 108 if {$configCode != {}} { 109 proc $className:config:$name self $configCode 110 } 111} 112 113proc object_include {args} { 114 global object_priv 115 set className $object_priv(currentClass) 116 foreach super_class_name $args { 117 if {[info procs $super_class_name] == ""} {auto_load $super_class_name} 118 upvar #0 ${className}_priv class 119 upvar #0 ${super_class_name}_priv super_class 120 foreach p $super_class(params) { 121 lappend class(params) $p 122 set class(param_info/$p) $super_class(param_info/$p) 123 } 124 set class(members) [concat $super_class(members) $class(members)] 125 foreach m $super_class(methods) { 126 set formals {} 127 set proc $super_class_name:$m 128 foreach arg [info args $proc] { 129 if {[info default $proc $arg def]} { 130 lappend formals [list $arg $def] 131 } else { 132 lappend formals $arg 133 } 134 } 135 proc $className:$m $formals [info body $proc] 136 } 137 } 138} 139 140proc object_new {className {name {}}} { 141 if {$name == {}} { 142 global object_priv 143 set name O_[incr object_priv(objectCounter)] 144 } 145 upvar #0 $name object 146 upvar #0 ${className}_priv class 147 set object(__class__) $className 148 set object(__file__) [info script] 149 foreach var $class(params) { 150 set info $class(param_info/$var) 151 set resourceClass [lindex $info 1] 152 if {$resourceClass != "" && \ 153 ![catch {set val [option get $name $var $resourceClass]}]} { 154 if {$val == ""} { 155 set val [lindex $info 0] 156 } 157 } else { 158 set val [lindex $info 0] 159 } 160 set object($var) $val 161 } 162 foreach var $class(members) { 163 set object([lindex $var 0]) [lindex $var 1] 164 } 165 proc $name {method args} [format { 166 upvar #0 %s object 167 uplevel [concat $object(__class__):$method %s $args] 168 } $name $name] 169 if {[info procs ${className}:__init__] != ""} { 170 $name __init__ 171 } elseif {[info procs ${className}:create] != ""} { 172 $name create 173 } 174 return $name 175} 176 177proc object_define_creator {windowType name spec} { 178 object_class $name $spec 179 if {[info procs $name:create] == {} && [info procs $name:__init__] == {}} { 180 error "widget \"$name\" must define a create method" 181 } 182 if {[info procs $name:reconfig] == {}} { 183 error "widget \"$name\" must define a reconfig method" 184 } 185 proc $name {window args} [format { 186 if {[winfo exists $window]} {destroy $window} 187 # need to transfer option database from Toplevel/Frame if we use -class 188 %s $window -class %s 189 rename $window object_window_of$window 190 upvar #0 $window object 191 set object(__window__) $window 192 object_new %s $window 193 proc %s:frame {self args} \ 194 "uplevel \[concat object_window_of$window \$args]" 195 uplevel [concat $window config $args] 196 # __init__ is a required method 197 if {![catch {$window __init__} err]} { 198 # create is the oldname 199 } elseif {[catch {$window create} err]} { 200 tk_messageBox -icon error -type ok \ 201 -message "Error creating widget \"$window\":\n$err" 202 error "Error creating $window:\n$err" 203 } 204 set object(__created) 1 205 bind $window <Destroy> \ 206 "if !\[string compare %%W $window\] { object_delete $window }" 207 # reconfig is a required method 208 $window reconfig 209 return $window 210 } $windowType \ 211 [string toupper [string index $name 0]][string range $name 1 end] \ 212 $name $name] 213} 214 215# Class creators and their synonyms 216proc object_frame {name spec} { 217 # need to transfer option database from Frame to widget? 218 object_define_creator frame $name $spec 219} 220proc widget {args} { 221 eval object_frame $args 222} 223 224proc object_toplevel {name spec} { 225 # need to transfer option database from Toplevel to widget? 226 object_define_creator toplevel $name $spec 227} 228proc dialog {args} { 229 eval object_toplevel $args 230} 231 232auto_load auto_reset 233set arglist {name args} 234set body { 235 variable index 236 variable scriptFile 237 # Do some fancy reformatting on the "source" call to handle platform 238 # differences with respect to pathnames. Use format just so that the 239 # command is a little easier to read (otherwise it'd be full of 240 # backslashed dollar signs, etc. 241 append index [list set auto_index([fullname $name])] \ 242 [format { [list source [file join $dir %s]]} \ 243 [file split $scriptFile]] "\n" 244} 245foreach elt {widget dialog object_toplevel object_frame} { 246 auto_mkindex_parser::command $elt $arglist $body 247} 248 249auto_mkindex_parser::command object_class {name args} { 250 variable index 251 variable scriptFile 252 # Do some fancy reformatting on the "source" call to handle platform 253 # differences with respect to pathnames. Use format just so that the 254 # command is a little easier to read (otherwise it'd be full of 255 # backslashed dollar signs, etc. 256 append index [list set auto_index([fullname $name])] \ 257 [format { [list source [file join $dir %s]]} \ 258 [file split $scriptFile]] "\n" 259} 260 261 262proc object_config {self args} { 263 upvar #0 $self object 264 set len [llength $args] 265 if {$len == 0} { 266 upvar #0 $object(__class__)_priv class 267 set result {} 268 if {![info exists class(params)]} { 269 return {} 270 } 271 foreach param $class(params) { 272 set info $class(param_info/$param) 273 lappend result \ 274 [list -$param $param [lindex $info 1] [lindex $info 0] \ 275 $object($param)] 276 } 277 if {[info exists object(__window__)]} { 278 set result [concat $result [object_window_of$object(__window__) config]] 279 } 280 return $result 281 } 282 if {$len == 1} { 283 upvar #0 $object(__class__)_priv class 284 if {[string index $args 0] != "-"} { 285 error "param '$args' didn't start with dash" 286 } 287 set param [string range $args 1 end] 288 if {![info exists class(params)]} { 289 error "Attempt to query an undeclared param: $param" 290 } 291 if {[set ndx [lsearch -exact $class(params) $param]] == -1} { 292 if {[info exists object(__window__)]} { 293 return [object_window_of$object(__window__) config -$param] 294 } 295 error "no param '$args'" 296 } 297 set info $class(param_info/$param) 298 return [list -$param $param [lindex $info 1] [lindex $info 0] \ 299 $object($param)] 300 } 301 # accumulate commands and eval them later so that no changes will take 302 # place if we find an error 303 set cmds "" 304 while {$args != ""} { 305 set fieldId [lindex $args 0] 306 if {[string index $fieldId 0] != "-"} { 307 error "param '$fieldId' didn't start with dash" 308 } 309 set fieldId [string range $fieldId 1 end] 310 if ![info exists object($fieldId)] { 311 if {[info exists object(__window__)]} { 312 if {[catch [list object_window_of$object(__window__) config -$fieldId]]} { 313 error "tried to set param '$fieldId' which did not exist." 314 } else { 315 lappend cmds \ 316 [list object_window_of$object(__window__) config -$fieldId [lindex $args 1]] 317 set args [lrange $args 2 end] 318 continue 319 } 320 } 321 322 } 323 if {[llength $args] == 1} { 324 return $object($fieldId) 325 } else { 326 lappend cmds [list set object($fieldId) [lindex $args 1]] 327 if {[info procs $object(__class__):config:$fieldId] != {}} { 328 lappend cmds [list $self config:$fieldId] 329 } 330 set args [lrange $args 2 end] 331 } 332 } 333 foreach cmd $cmds { 334 eval $cmd 335 } 336 if {[info exists object(__created)] && [info procs $object(__class__):reconfig] != {}} { 337 $self reconfig 338 } 339} 340 341proc object_cget {self var} { 342 upvar #0 $self object 343 return [lindex [object_config $self $var] 4] 344} 345 346proc object_delete self { 347 upvar #0 $self object 348 if {[info exists object(__class__)] && [info commands $object(__class__):destroy] != ""} { 349 catch {$object(__class__):destroy $self} 350 } 351 if {[info exists object(__window__)]} { 352 if {[string length [info commands object_window_of$self]]} { 353 catch {rename $self {}} 354 rename object_window_of$self $self 355 } 356 destroy $self 357 } 358 catch {unset object} 359} 360 361proc object_slotname slot { 362 upvar self self 363 return [set self]($slot) 364} 365