interfaces/xmaxima/ObjTcl/Object.tcl

   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
  27 proc M {str args} {
  28     if {$args == ""} {return $str}
  29     return [eval [list format $str] $args]
  30 }
  31
  32 proc object_info {name} {
  33     # need an object info function like itcl
  34 }
  35
  36 set object_priv(currentClass) {}
  37 set object_priv(objectCounter) 0
  38
  39 proc 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
  60 proc 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
  74 proc 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
  86 proc 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
  96 proc 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
 113 proc 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
 140 proc 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
 177 proc 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
 216 proc object_frame {name spec} {
 217     # need to transfer option database from Frame to widget?
 218     object_define_creator frame $name $spec
 219 }
 220 proc widget {args} {
 221     eval object_frame $args
 222 }
 223
 224 proc object_toplevel {name spec} {
 225     # need to transfer option database from Toplevel to widget?
 226     object_define_creator toplevel $name $spec
 227 }
 228 proc dialog {args} {
 229     eval object_toplevel $args
 230 }
 231
 232 auto_load auto_reset
 233 set arglist {name args}
 234 set 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 }
 245 foreach elt {widget dialog object_toplevel object_frame} {
 246     auto_mkindex_parser::command $elt $arglist $body
 247 }
 248
 249 auto_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
 262 proc 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
 341 proc object_cget {self var} {
 342     upvar #0 $self object
 343     return [lindex [object_config $self $var] 4]
 344 }
 345
 346 proc 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
 361 proc object_slotname slot {
 362     upvar self self
 363     return [set self]($slot)
 364 }