tix/library/Primitiv.tcl

   1 # Primitiv.tcl --
   2 #
   3 #       This is the primitive widget. It is just a frame with proper
   4 #       inheritance wrapping. All new Tix widgets will be derived from
   5 #       this widget
   6 #
   7 # Copyright (c) 1996, Expert Interface Technologies
   8 #
   9 # See the file "license.terms" for information on usage and redistribution
  10 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11 #
  12
  13
  14
  15 # No superclass, so the superclass switch is not used
  16 #
  17 #
  18 tixWidgetClass tixPrimitive {
  19     -virtual true
  20     -superclass {}
  21     -classname  TixPrimitive
  22     -method {
  23         cget configure subwidget subwidgets
  24     }
  25     -flag {
  26         -background -borderwidth -cursor
  27         -height -highlightbackground -highlightcolor -highlightthickness
  28         -options -relief -takefocus -width -bd -bg
  29     }
  30     -static {
  31         -options
  32     }
  33     -configspec {
  34         {-background background Background #d9d9d9}
  35         {-borderwidth borderWidth BorderWidth 0}
  36         {-cursor cursor Cursor ""}
  37         {-height height Height 0}
  38         {-highlightbackground highlightBackground HighlightBackground #c3c3c3}
  39         {-highlightcolor highlightColor HighlightColor black}
  40         {-highlightthickness highlightThickness HighlightThickness 0}
  41         {-options options Options ""}
  42         {-relief relief Relief flat}
  43         {-takefocus takeFocus TakeFocus 0 tixVerifyBoolean}
  44         {-width width Width 0}
  45     }
  46     -alias {
  47         {-bd -borderwidth}
  48         {-bg -background}
  49     }
  50 }
  51
  52 #----------------------------------------------------------------------
  53 # ClassInitialization:
  54 #----------------------------------------------------------------------
  55
  56 # not used
  57 # Implemented in C
  58 #
  59 # Override: never
  60 proc tixPrimitive:Constructor {w args} {
  61
  62     upvar #0 $w data
  63     upvar #0 $data(className) classRec
  64
  65     # Set up some minimal items in the class record.
  66     #
  67     set data(w:root)  $w
  68     set data(rootCmd) $w:root
  69
  70     # We need to create the root widget in order to parse the options
  71     # database
  72     tixCallMethod $w CreateRootWidget
  73
  74     # Parse the default options from the options database
  75     #
  76     tixPrimitive:ParseDefaultOptions $w
  77
  78     # Parse the options supplied by the user
  79     #
  80     tixPrimitive:ParseUserOptions $w $args
  81
  82     # Rename the widget command so that it can be use to access
  83     # the methods of this class
  84
  85     tixPrimitive:MkWidgetCmd $w
  86
  87     # Inistalize the Widget Record
  88     #
  89     tixCallMethod $w InitWidgetRec
  90
  91     # Construct the compound widget
  92     #
  93     tixCallMethod $w ConstructWidget
  94
  95     # Do the bindings
  96     #
  97     tixCallMethod $w SetBindings
  98
  99     # Call the configuration methods for all "force call" options
 100     #
 101     foreach option $classRec(forceCall) {
 102         tixInt_ChangeOptions $w $option $data($option)
 103     }
 104 }
 105
 106
 107 # Create only the root widget. We need the root widget to query the option
 108 # database.
 109 #
 110 # Override: seldom. (unless you want to use a toplevel as root widget)
 111 # Chain   : never.
 112
 113 proc tixPrimitive:CreateRootWidget {w args} {
 114     upvar #0 $w data
 115     upvar #0 $data(className) classRec
 116
 117     frame $w -class $data(ClassName)
 118 }
 119
 120 proc tixPrimitive:ParseDefaultOptions {w} {
 121     upvar #0 $w data
 122     upvar #0 $data(className) classRec
 123
 124     # SET UP THE INSTANCE RECORD ACCORDING TO DEFAULT VALUES IN
 125     # THE OPTIONS DATABASE
 126     #
 127     foreach option $classRec(options) {
 128         set spec [tixInt_GetOptionSpec $data(className) $option]
 129
 130         if {[lindex $spec 0] == "="} {
 131             continue
 132         }
 133
 134         set o_name    [lindex $spec 1]
 135         set o_class   [lindex $spec 2]
 136         set o_default [lindex $spec 3]
 137
 138         if {![catch "option get $w $o_name $o_class" db_default]} {
 139             if {$db_default != ""} {
 140                 set data($option) $db_default
 141             } else {
 142                 set data($option) $o_default
 143             }
 144         } else {
 145             set data($option) $o_default
 146         }
 147     }
 148 }
 149
 150 proc tixPrimitive:ParseUserOptions {w arglist} {
 151     upvar #0 $w data
 152     upvar #0 $data(className) classRec
 153
 154     # SET UP THE INSTANCE RECORD ACCORDING TO COMMAND ARGUMENTS FROM
 155     # THE USER OF THE TIX LIBRARY (i.e. Application programmer:)
 156     #
 157     tixForEach {option arg} $arglist {
 158         if {[lsearch $classRec(options) $option] != "-1"} {
 159             set spec [tixInt_GetOptionSpec $data(className) $option]
 160
 161             if {[lindex $spec 0] != "="} {
 162                 set data($option) $arg
 163             } else {
 164                 set realOption [lindex $spec 1]
 165                 set data($realOption) $arg
 166             }
 167         } else {
 168             error "unknown option $option. Should be: [tixInt_ListOptions $w]"
 169         }
 170     }
 171 }
 172
 173 #----------------------------------------------------------------------
 174 # Initialize the widget record
 175 #
 176 #
 177 # Override: always
 178 # Chain   : always, before
 179 proc tixPrimitive:InitWidgetRec {w} {
 180     # default: do nothing
 181 }
 182
 183 #----------------------------------------------------------------------
 184 # SetBindings
 185 #
 186 #
 187 # Override: sometimes
 188 # Chain   : sometimes, before
 189 #
 190 bind TixDestroyHandler <Destroy> {
 191     [tixGetMethod %W [set %W(className)] Destructor] %W
 192 }
 193
 194 proc tixPrimitive:SetBindings {w} {
 195     upvar #0 $w data
 196
 197     if {[winfo toplevel $w] == $w} {
 198         bindtags $w [concat TixDestroyHandler [bindtags $w]]
 199     } else {
 200         bind $data(w:root) <Destroy> \
 201             "[tixGetMethod $w $data(className) Destructor] $w"
 202     }
 203 }
 204
 205 #----------------------------------------------------------------------
 206 # PrivateMethod: ConstructWidget
 207 #
 208 # Construct and set up the compound widget
 209 #
 210 # Override: sometimes
 211 # Chain   : sometimes, before
 212 #
 213 proc tixPrimitive:ConstructWidget {w} {
 214     upvar #0 $w data
 215
 216     $data(rootCmd) config \
 217         -background  $data(-background) \
 218         -borderwidth $data(-borderwidth) \
 219         -cursor      $data(-cursor) \
 220         -relief      $data(-relief)
 221
 222     if {$data(-width) != 0} {
 223         $data(rootCmd) config -width $data(-width)
 224     }
 225     if {$data(-height) != 0} {
 226         $data(rootCmd) config -height $data(-height)
 227     }
 228
 229     set rootname *[string range $w 1 end]
 230
 231     tixForEach {spec value} $data(-options) {
 232         option add $rootname*$spec $value 100
 233     }
 234 }
 235
 236 #----------------------------------------------------------------------
 237 # PrivateMethod: MkWidgetCmd
 238 #
 239 # Construct and set up the compound widget
 240 #
 241 # Override: sometimes
 242 # Chain   : sometimes, before
 243 #
 244 proc tixPrimitive:MkWidgetCmd {w} {
 245     upvar #0 $w data
 246
 247     rename $w $data(rootCmd)
 248     tixInt_MkInstanceCmd $w
 249 }
 250
 251
 252 #----------------------------------------------------------------------
 253 # ConfigOptions:
 254 #----------------------------------------------------------------------
 255
 256 #----------------------------------------------------------------------
 257 # ConfigMethod: config
 258 #
 259 # Configure one option.
 260 #
 261 # Override: always
 262 # Chain   : automatic.
 263 #
 264 # Note the hack of [winfo width] in this procedure
 265 #
 266 # The hack is necessary because of the bad interaction between TK's geometry
 267 # manager (the packer) and the frame widget. The packer determines the size
 268 # of the root widget of the ComboBox (a frame widget) according to the
 269 # requirement of the slaves inside the frame widget, NOT the -width
 270 # option of the frame widget.
 271 #
 272 # However, everytime the frame widget is
 273 # configured, it sends a geometry request to the packer according to its
 274 # -width and -height options and the packer will temporarily resize
 275 # the frame widget according to the requested size! The packer then realizes
 276 # something is wrong and revert to the size determined by the slaves. This
 277 # cause a flash on the screen.
 278 #
 279 foreach opt {-height -width -background -borderwidth -cursor
 280         -highlightbackground -highlightcolor -relief -takefocus -bd -bg} {
 281
 282     set tixPrimOpt($opt) 1
 283 }
 284
 285 proc tixPrimitive:config {w option value} {
 286     global tixPrimOpt
 287     upvar #0 $w data
 288
 289     if [info exists tixPrimOpt($option)] {
 290         $data(rootCmd) config $option $value
 291     }
 292 }
 293
 294 #----------------------------------------------------------------------
 295 # PublicMethods:
 296 #----------------------------------------------------------------------
 297
 298 #----------------------------------------------------------------------
 299 # This method is used to implement the "subwidgets" widget command.
 300 # Will be re-written in C. It can't be used as a public method because
 301 # of the lame substring comparison routines used in tixClass.c
 302 #
 303 #
 304 proc tixPrimitive:subwidgets {w type args} {
 305     upvar #0 $w data
 306
 307     case $type {
 308         -class {
 309             set name [lindex $args 0]
 310             set args [lrange $args 1 end]
 311             # access subwidgets of a particular class
 312             #
 313             # note: if $name=="Frame", will *not return the root widget as well
 314             #
 315             set sub ""
 316             foreach des [tixDescendants $w] {
 317                 if {[winfo class $des] == $name} {
 318                     lappend sub $des
 319                 }
 320             }
 321
 322             # Note: if the there is no subwidget of this class, does not
 323             # cause any error.
 324             #
 325             if {$args == ""} {
 326                 return $sub
 327             } else {
 328                 foreach des $sub {
 329                     eval $des $args
 330                 }
 331                 return ""
 332             }
 333         }
 334         -group {
 335             set name [lindex $args 0]
 336             set args [lrange $args 1 end]
 337             # access subwidgets of a particular group
 338             #
 339             if [info exists data(g:$name)] {
 340                 if {$args == ""} {
 341                     set ret ""
 342                     foreach item $data(g:$name) {
 343                         lappend ret $w.$item
 344                     }
 345                     return $ret
 346                 } else {
 347                     foreach item $data(g:$name) {
 348                         eval $w.$item $args
 349                     }
 350                     return ""
 351                 }
 352             } else {
 353                 error "no such subwidget group $name"
 354             }
 355         }
 356         -all {
 357             set sub [tixDescendants $w]
 358
 359             if {$args == ""} {
 360                 return $sub
 361             } else {
 362                 foreach des $sub {
 363                     eval $des $args
 364                 }
 365                 return ""
 366             }
 367         }
 368         default {
 369             error "unknown flag $type, should be -all, -class or -group"
 370         }
 371     }
 372 }
 373
 374 #----------------------------------------------------------------------
 375 # PublicMethod: subwidget
 376 #
 377 # Access a subwidget withe a particular name
 378 #
 379 # Override: never
 380 # Chain   : never
 381 #
 382 proc tixPrimitive:subwidget {w name args} {
 383     upvar #0 $w data
 384
 385     if [info exists data(w:$name)] {
 386         if {$args == ""} {
 387             return $data(w:$name)
 388         } else {
 389             return [eval $data(w:$name) $args]
 390         }
 391     } else {
 392         error "no such subwidget $name"
 393     }
 394 }
 395
 396
 397 #----------------------------------------------------------------------
 398 # PrivateMethods:
 399 #----------------------------------------------------------------------
 400
 401 # delete the widget record and remove the command
 402 #
 403 proc tixPrimitive:Destructor {w} {
 404     upvar #0 $w data
 405
 406     if {![info exists data(w:root)]} {
 407         return
 408     }
 409
 410     if {[info commands $w] != ""} {
 411         # remove the command
 412         #
 413         rename $w ""
 414     }
 415
 416     if {[info commands $data(rootCmd)] != ""} {
 417         # remove the command of the root widget
 418         #
 419         rename $data(rootCmd) ""
 420     }
 421
 422     # delete the widget record
 423     #
 424     catch {unset data}
 425 }