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