source: tol/tolbase/lib/byswidget/mdi/mdi.tcl @ c14b554

1941-docker-image-to-testdevel
Last change on this file since c14b554 was 6d7779d, checked in by Jorge Pérez <josp.jorge@…>, 18 years ago

initial import

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@1 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 41.6 KB
Line 
1package require Tk 8.4
2package require snit
3package require fmenu
4
5snit::widget mdidoc {
6  widgetclass Mdidoc
7 
8  typevariable wFocus  ;# topmost window (drawn active)
9  typevariable colors
10  typevariable cursors
11  typevariable offset
12  typevariable icons
13  typevariable noraise 0
14
15  typemethod icon {name} {
16    set icons($name)
17  }
18
19  typeconstructor {
20    set wFocus {}
21    if {$::tcl_platform(platform) == "windows"} {
22      array set colors {
23        gray50 SystemDisabledText
24        white SystemWindow
25        darkblue SystemHighlight
26        gray SystemButtonFace
27      }
28      array set cursors {
29        {} {}
30        nw size_nw_se
31        ne size_ne_sw
32        sw size_ne_sw
33        se size_nw_se
34        n size_ns
35        s size_ns
36        w size_we
37        e size_we   
38      }
39    } else {
40      array set colors {
41        gray50 gray50
42        white white
43        darkblue darkblue
44        gray gray
45      }
46      array set cursors {
47        {} {}
48        nw top_left_corner
49        ne top_right_corner
50        sw bottom_left_corner
51        se bottom_right_corner
52        n sb_v_double_arrow
53        s sb_v_double_arrow
54        w sb_h_double_arrow
55        e sb_h_double_arrow
56      }
57    }
58    set offset 0
59    set icons(minimize) [::image create bitmap -data {
60      #define _width 8
61      #define _height 8
62      static char _bits[] = { 0x00,0x00,0x00,0x00,0x00,0x3e,0x3e,0x00 };
63    }]
64    set icons(maximize) [::image create bitmap -data {
65      #define _width 8
66      #define _height 8
67      static char _bits[] = { 0x7f,0x7f,0x41,0x41,0x41,0x41,0x7f,0x00 };
68    }]
69    set icons(restore) [::image create bitmap -data {
70      #define _width 8
71      #define _height 8
72      static char _bits[] = { 0x7c,0x7c,0x44,0x5f,0x5f,0x71,0x11,0x1f };
73    }]
74    set icons(close) [::image create bitmap -data {
75      #define _width 8
76      #define _height 8
77      static char _bits[] = { 0x00,0x63,0x36,0x1c,0x1c,0x36,0x63,0x00 };
78    }]
79
80    set img_doc_data \
81"R0lGODlhCwANAPcAAAAAAAEBAQICAgMDAwQEBAUFBQYGBgcHBwgICAkJCQoK
82CgsLCwwMDA0NDQ4ODg8PDxAQEBERERISEhMTExQUFBUVFRYWFhcXFxgYGBkZ
83GRoaGhsbGxwcHB0dHR4eHh8fHyAgICEhISIiIiMjIyQkJCUlJSYmJicnJygo
84KCkpKSoqKisrKywsLC0tLS4uLi8vLzAwMDExMTIyMjMzMzQ0NDU1NTY2Njc3
85Nzg4ODk5OTo6Ojs7Ozw8PD09PT4+Pj8/P0BAQEFBQUJCQkNDQ0REREVFRUZG
86RkdHR0hISElJSUpKSktLS0xMTE1NTU5OTk9PT1BQUFFRUVJSUlNTU1RUVFVV
87VVZWVldXV1hYWFlZWVpaWltbW1xcXF1dXV5eXl9fX2BgYGFhYWJiYmNjY2Rk
88ZGVlZWZmZmdnZ2hoaGlpaWpqamtra2xsbG1tbW5ubm9vb3BwcHFxcXJycnNz
89c3R0dHV1dXZ2dnd3d3h4eHl5eXp6ent7e3x8fH19fX5+fn9/f4CAgIGBgYKC
90goODg4SEhIWFhYaGhoeHh4iIiImJiYqKiouLi4yMjI2NjY6Ojo+Pj5CQkJGR
91kZKSkpOTk5SUlJWVlZaWlpeXl5iYmJmZmZqampubm5ycnJ2dnZ6enp+fn6Cg
92oKGhoaKioqOjo6SkpKWlpaampqenp6ioqKmpqaqqqqurq6ysrK2tra6urq+v
93r7CwsLGxsbKysrOzs7S0tLW1tba2tre3t7i4uLm5ubq6uru7u7y8vL29vb6+
94vr+/v8DAwMHBwcLCwsPDw8TExMXFxcbGxsfHx8jIyMnJycrKysvLy8zMzM3N
95zc7Ozs/Pz9DQ0NHR0dLS0tPT09TU1NXV1dbW1tfX19jY2NnZ2dra2tvb29zc
963N3d3d7e3t/f3+Dg4OHh4eLi4uPj4+Tk5OXl5ebm5ufn5+jo6Onp6erq6uvr
976+zs7O3t7e7u7u/v7/Dw8PHx8fLy8vPz8/T09PX19fb29vf39/j4+Pn5+fr6
98+vv7+/z8/P39/f7+/v///yH5BAEAAKoALAAAAAALAA0AAAg5AFUJHEhQIICD
99CA8OBPCvoUOGBh0+VMgw4UNVDCVerHhQIgCMGjf+S5jxY8aQJkdaHAkyJEuS
100JAMCADs="
101
102    set icons(doc) [image create photo -data $img_doc_data]
103
104    event add <<Maximize>> <Shift-Control-M>
105    event add <<Minimize>> <Shift-Control-W>
106    event add <<Restore>>  <Shift-Control-R>
107  }
108
109  option -type
110  option -title
111  option -activeforeground
112  option -activebackground
113  option -lowerforeground
114  option -lowerbackground
115  option -font
116  option -minsize {100 30}
117  option -icontext ""
118  option -state normal
119  option -image ""
120  option -width 250
121  option -height 150
122  option -x 0
123  option -y 0
124  option -closecmd ""
125  option -iniconfig ""
126  option -modal 0
127  option -resizable 1
128  option -helpkey ""
129 
130  variable NormX
131  variable NormY
132  variable IconX -1
133  variable IconY -1
134  variable Xr1
135  variable Xr2
136  variable Yr1
137  variable Yr2
138  variable Xp0
139  variable Yp0
140  variable WMin
141  variable HMin
142  variable XMax
143  variable YMax
144  variable XPos ""
145  variable YPos ""
146  variable constructed 0
147
148  typemethod disableglobalraise {} {
149    set noraise 1
150  }
151 
152  typemethod allowglobalraise {} {
153    set noraise 0
154  }
155
156  proc global_raise { w } {
157    #puts "global_raise for $w"
158    if { $noraise } {
159      set noraise 0
160      return
161    }
162    if {![winfo exists $w] } return
163    while {[set cls [winfo class $w]] ne "Toplevel" && $w ne "."} {
164      if {$cls eq "Mdidoc"} {
165        #puts "voy con un Mdidoc ...."
166        $w raise
167        return
168      }
169      set w [winfo parent $w]
170    }
171  }
172
173  onconfigure -x { x } {
174    set options(-x) $x
175
176    place $win -x $x
177  }
178
179  onconfigure -y { y } {
180    set options(-y) $y
181
182    place $win -y $y
183  }
184 
185  onconfigure -width { d } {
186    set options(-width) $d
187
188    if {$options(-state) eq "normal"} {
189      place $win -width $d
190    }
191  }
192
193  onconfigure -height { d } {
194    set options(-height) $d
195
196    if {$options(-state) eq "normal"} {
197      place $win -height $d
198    }
199  }
200 
201  onconfigure -modal { m } {
202    set options(-modal) $m
203    if { $options(-modal) == 1 } {
204      ::grab set $self
205      bind $self <FocusOut> [list $self raise]
206    } else {
207      ::grab release $self     
208      bind $self <FocusOut> ""
209    }
210  }
211
212  onconfigure -resizable { r } {
213    set options(-resizable) $r
214    if { $options(-resizable) && $options(-state) == "normal" } {
215      bind $win <1>               [mymethod _resize1 %X %Y]
216      bind $win <B1-Motion>       [mymethod _resize2 %X %Y]
217      bind $win <ButtonRelease-1> [mymethod _resize3]
218      bind $win <Motion>          [mymethod _motion %X %Y]
219     
220      grid $win.head.maxb
221      $win.head.icon.m entryconf Maximize -state normal
222    } else {
223      bind $win <1>               {}
224      bind $win <B1-Motion>       {}
225      bind $win <ButtonRelease-1> {}
226      bind $win <Motion>          {}
227      if { $options(-state) == "maximized" } { $self restore }
228      grid remove $win.head.maxb
229      $win.head.icon.m entryconf Maximize -state disabled
230    }
231   
232  }
233
234  # name: -font
235  # args: sFont: font to set
236  # option handler. sets the title font.
237  onconfigure -font { f } {
238    set options(-font) $f
239    #$win.head.text configure -font $f
240    $win.head.title configure -font $f
241  }
242
243  # name: -image
244  # args: sImage: image to set
245  # option handler. sets the image in the title bar.
246  onconfigure -image { img } {
247    if {$img eq ""} {
248      set img $icons(doc)
249    }
250    set options(-image) $img
251    #$win.head.icon configure -image $img
252    $win.head.icon configure -image $img
253  }
254
255  # name: -title
256  # args: sTitle: title to set
257  # option handler. sets title text.
258
259  onconfigure -title { str } {
260    set options(-title) $str
261    #$win.head.text configure -text $str
262    $win.head.title configure -text $str
263  }
264
265  # name: -state
266  # args: sState: new Document state
267  # option handler. sets the state for the document. the variable -state
268  # is set in the respective (private) member functions.
269  onconfigure -state { state } {
270    switch -- [mdi::complete_name $state {normal minimized maximized withdrawn}] {
271      normal    { $self restore }
272      minimized { $self minimize }
273      maximized { $self maximize }
274      withdrawn { $self withdraw }
275    }
276  }
277
278  onconfigure -helpkey { key } {
279      $self bind <F1> "ShowHelp $key"     
280  }
281 
282  method _set_defaults { } {
283    set options(-title) $win
284    set options(-activeforeground) $colors(white)
285    set options(-activebackground) $colors(darkblue)
286    set options(-lowerforeground) $colors(gray)
287    set options(-lowerbackground) $colors(gray50)
288    #set options(-font) [$win.head.text cget -font]
289    set options(-font) [$win.head.title cget -font]
290    set NormX $offset
291    set NormY $offset
292  }
293
294  constructor {args} {
295    # create title bar elements
296    #pack [frame $win.head -border 0] -padx 2 -pady 2 -fill x
297    frame $win.head -border 0
298
299    #pack [label $win.head.icon -border 0] -side left -padx 1
300    set options(-image) $icons(doc)
301    menubutton $win.head.icon -border 0 -image $icons(doc) \
302        -menu $win.head.icon.m
303    # define popup menu
304    puts $win.head.icon
305    menu $win.head.icon.m -tearoff 0
306    $win.head.icon.m add command -label Restore  -command [mymethod restore]
307    $win.head.icon.m add command -label Minimize -command [mymethod minimize]
308    $win.head.icon.m add command -label Maximize -command [mymethod maximize]
309    $win.head.icon.m add separator
310    $win.head.icon.m add command -label Close -command [mymethod kill]
311
312    #pack [label $win.head.clob -border 2 -relief raised \
313    #          -image $icons(close)] -side right -pady 2 -padx 2
314    button $win.head.clob -image $icons(close) -bd 1 -padx 0 -pady 0 \
315        -command [mymethod kill]
316
317    #pack [label $win.head.maxb -border 2 -relief raised \
318    #          -image $icons(maximize)] -side right -pady 2
319    button $win.head.maxb -image $icons(maximize) -bd 1 -padx 0 -pady 0 \
320        -command [mymethod maximize]
321
322    #pack [label $win.head.minb -border 2 -relief raised \
323    #          -image $icons(minimize)] -side right -pady 2
324    button $win.head.minb -image $icons(minimize) -bd 1 -padx 0 -pady 0 \
325        -command [mymethod minimize]
326
327    #pack [label $win.head.text -border 0 -anchor w] -side left \
328    #    -fill x -expand 1
329    label $win.head.title -border 0 -anchor w
330
331    # work area where all inner widgets will be go
332    #pack [frame $win.work -border 0] -fill both -expand 1 -padx 2 -pady 2
333    frame $win.work -border 0
334
335    grid $win.head.icon -row 0 -column 0 -sticky w
336    grid $win.head.title -row 0 -column 1 -sticky "ew"
337    grid $win.head.minb -row 0 -column 2 -pady 2 -sticky e
338    if { $options(-resizable) } {
339      grid $win.head.maxb -row 0 -column 3 -pady 2 -sticky e
340    }
341    grid $win.head.clob -row 0 -column 4 -pady 2 -sticky e
342    grid columnconfigure $win.head 1 -weight 1
343
344    grid $win.head -row 0 -column 0 -sticky "new"
345    grid $win.work -row 1 -column 0 -sticky "snew" -padx 2 -pady 2
346    grid rowconfigure $win 1 -weight 1
347    grid columnconfigure $win 0 -weight 1
348
349    # make sure mouse cursor resets when not over the boarder
350    bind $win.work <Enter> "$hull configure -cursor {}"
351    bind $win.head <Enter> "$hull configure -cursor {}"
352    # default help
353    # bind menu to icon and close button
354    #bind $win.head.icon <1>        [mymethod _show_menu]
355    bind $win.head.icon <Double-1> "[mymethod kill]; break"
356    #bind $win.head.clob <1>        [mymethod kill]
357
358    # increase offset for next window
359    incr offset 16
360    if {[expr {$offset+64}] > [winfo height [winfo parent $win]]} {
361      set offset 0
362    }
363
364    set tmdi [winfo toplevel $win]
365    set script_1 [bind $tmdi <1>]
366    if {[lsearch $script_1 ::mdidoc::global_raise] == -1} {
367      bind $tmdi <1> "+::mdidoc::global_raise %W"
368    }
369    $hull configure -bd 2 -relief raised
370    $self _set_defaults
371    $self configure -helpkey    \
372                      [from args -helpkey $::project::data(defaulthelpkey)]
373    $self configurelist $args
374    puts $args
375    $self restore
376    # .ini
377    $self readIni
378    $self raise
379    #$self _register
380   
381    set constructed 1
382  }
383
384  destructor {
385    #$self _unregister
386  }
387
388  method kill { } {
389    $self writeIni
390    if {$options(-closecmd) ne ""} {
391      set script [string map [list %W $win] $options(-closecmd)]
392          puts $script
393      if {![uplevel 0 $script]} { return }
394    }
395    destroy $win
396  }
397
398  # -type is readonly
399  onconfigure -type {value} {
400    if {!$constructed} {
401      set options(-type) $value
402    }
403  }
404
405  method restore { } {
406    if {$constructed && $options(-state) eq "normal"} return
407    # if we come from iconized state, store the icon position
408    if {$options(-state) == "minimized"} {
409      set IconX $options(-x)
410      set IconY $options(-y)
411    }
412    # morph -x and -y to contain the window position
413    set options(-x) $NormX
414    set options(-y) $NormY
415
416    $self _title_bar on
417    # show the working area and place Document on last known position
418    #pack  $win.work -fill both -expand 1 -padx 2 -pady 2
419    grid $win.work
420    place $win -x $NormX -y $NormY -width $options(-width) \
421      -height $options(-height) -relwidth 0 -relheight 0
422
423    # restore icons and menu entries for all title bar elements
424    $win.head.maxb configure -image $icons(maximize)
425    $win.head.minb configure -image $icons(minimize)
426    #$win.head.text configure -text $options(-title)
427    $win.head.title configure -text $options(-title)
428    $win.head.icon.m entryconf Minimize -state normal
429    $win.head.icon.m entryconf Maximize -state normal
430    $hull configure -border 2
431   
432    if { $options(-resizable) } {
433      grid $win.head.maxb
434      $win.head.icon.m entryconf Maximize -state normal
435    } else {
436      grid remove $win.head.maxb
437      $win.head.icon.m entryconf Maximize -state disabled
438    }
439
440    # restore resize bindings
441    if { $options(-resizable) } {
442      bind $win <1>               [mymethod _resize1 %X %Y]
443      bind $win <B1-Motion>       [mymethod _resize2 %X %Y]
444      bind $win <ButtonRelease-1> [mymethod _resize3]
445    }
446   
447    # restore move bindings
448    bind $win.head.title <1>               [mymethod _move1 %X %Y]
449    bind $win.head.title <B1-Motion>       [mymethod _move2 %X %Y]
450    bind $win.head.title <ButtonRelease-1> [mymethod _move3]
451
452    # restore maximize and minimize bindings
453#     bind $win.head.maxb <1>        [mymethod maximize]
454#     bind $win.head.minb <1>        [mymethod minimize]
455    if { $options(-resizable) } {
456      $win.head.maxb configure -command [mymethod maximize]
457      bind $win.head.title <Double-1> [mymethod maximize]
458    }
459    $win.head.minb configure -command [mymethod minimize]
460   
461    # restore binding for mouse cursor changes over borders
462    if { $options(-resizable) } {
463      bind $win <Motion> [mymethod _motion %X %Y]
464    } else {
465      bind $win <Motion> {}
466    }
467
468    set options(-state) normal
469    $self raise
470    event generate $win <<Restore>> -when now
471 }
472
473  typemethod mdiparent { w } {
474    if {$w eq "." || $w eq ""} {
475      return ""
476    }
477    if {[winfo class $w] eq "Mdidoc"} {
478      return $w
479    }
480    return [mdidoc mdiparent [winfo parent $w]]
481  }
482
483  method Bind { w args } {
484    eval ::bind $w $args
485    foreach _w [winfo children $w] {
486      eval $self Bind $_w $args
487    }
488  }
489
490  method bind { args } {
491    if {[llength $args] < 2} {
492      return [eval ::bind $win $args]
493    }
494    eval $self Bind $win $args
495  }
496
497  method raise { } {
498    #puts "---- method raise para $win [array names options -activeback*]"
499    catch {$wFocus lower}
500    set wFocus $win
501   
502    # esto es lo mas raro, o algo de lo mas raro que he visto en tcl
503    # para reproducir el error cambie el valor de la variable skip_bug_tcl_or_snit a 0
504    set skip_bug_tcl_or_snit 1
505   
506    if {$skip_bug_tcl_or_snit && $::tcl_platform(platform) eq "windows"} {
507      set options(-activebackground) SystemHighlight
508      set options(-activeforeground) SystemWindow
509    }
510    #puts "dime : [array names options -activefore*]"
511    #puts "y ahora : [$win cget -activeforeground]"
512    #puts "dime mas : [array get options -activefore*]"
513   
514   
515    $win.head configure -bg $options(-activebackground)
516    $win.head.icon configure -bg $options(-activebackground)
517    $win.head.title configure -bg $options(-activebackground) \
518        -fg $options(-activeforeground)
519   
520    foreach w [list $win.head.minb $win.head.maxb $win.head.clob] {
521      $w configure -highlightbackground $options(-activebackground)
522    }
523    if {[mdidoc mdiparent [focus]] ne [mdidoc mdiparent $win]} {
524      focus $win
525    }
526    if { $options(-state) eq "maximized" } {
527      set mdi [winfo parent $win]
528      set mdimenu [$mdi cget -mdimenu]
529      $mdimenu set_wcurrent $win
530      set wtop [winfo toplevel $win]
531      set titletop [$mdimenu cget -title]
532      wm title $wtop "$titletop \[[$win cget -title]\]"
533    }
534    raise $win
535  }
536
537  # name: lower
538  # args: -
539  # draws the title bar in grey.
540  method lower {} {
541    $win.head configure -bg $options(-lowerbackground)
542    $win.head.icon configure -bg $options(-lowerbackground)
543    $win.head.title configure -bg $options(-lowerbackground) \
544        -fg $options(-lowerforeground)
545    foreach w [list $win.head.minb $win.head.maxb $win.head.clob] {
546      $w configure -highlightbackground $options(-lowerforeground)
547    }
548  }
549
550  method _show_menu { } {
551    $win.menu post [winfo rootx $win.head.icon] \
552        [expr [winfo height $win.head.icon] + [winfo rooty $win.head.icon]]
553    focus -force $win.menu
554    bind $win.menu <FocusOut> "$win.menu unpost"
555  }
556
557  # args: xp, yp: mouse position
558  # called only when the mouse is over the document's border. returns an area
559  # indicator of the mouse position, e.g. sw for south-west = bottom left.
560  # used to set the mouse cursor and to determine the resize mode.
561  method _get_edge {xp yp} {
562    incr xp [expr {-[winfo rootx $win]}]
563    incr yp [expr {-[winfo rooty $win]}]
564   
565    # allow max. 16 pixel for edge detection
566    set iXEdge [expr ($options(-width) < 16)?$options(-width) >>1:8]
567    set iYEdge [expr ($options(-height) < 16)?$options(-height)>>1:8]
568   
569    # detect if mouse is on one of the edges (x coordinate)
570    if { $xp < $iXEdge } {
571      set sPosH w
572    } elseif { $xp > [expr $options(-width)-$iXEdge] } {
573      set sPosH e
574    } else {
575      set sPosH {}
576    }
577   
578    # detect if mouse is on one of the edges (y coordinate)
579    if { $yp < $iYEdge } {
580      set sPosV n
581    } elseif { $yp > [expr $options(-height)-$iYEdge] } {
582      set sPosV s
583    } else {
584      set sPosV {}
585    }
586   
587    return $sPosV$sPosH
588  }
589 
590  # name: _motion
591  # args: iXp, iYp: mouse position (from the %X and %Y fields of an event)
592  # called by a <Motion> binding over the document frame. Sets the mouse cursor
593  # to show arrows depending on the region of the mouse. _getEdge returns an
594  # area (e.g. ne for north-east = upper right corner), the aCursor array
595  # maps this to a valid cursor name (depending on platform).
596  method _motion { xp yp } {
597    $hull configure -cursor $cursors([$self _get_edge $xp $yp])
598  }
599 
600  # name: _move1
601  # args: iXp, iYp: mouse position (from the %X and %Y fields of an event)
602  # called on a <Button-1> event on the title bar. stores the current mouse
603  # pointer position. raises the document.
604  method _move1 { xp yp } {
605    $self raise
606
607    set wParent [winfo parent $win]
608    set Xr1 [winfo rootx $wParent]
609    set Yr1 [winfo rooty $wParent]
610    set Xr2 [expr $Xr1+[winfo width  $wParent]]
611    set Yr2 [expr $Yr1+[winfo height $wParent]]
612   
613    set Xp0 $xp
614    set Yp0 $yp
615  }
616
617  # name: _move2
618  # args: iXp, iYp: mouse position (from the %X and %Y fields of an event)
619  # called on a <B1-Motion> event on the title bar. calculates the new
620  # window position and places it there.
621  method _move2 { xp yp } {
622    if { $xp < $Xr1 } { set xp $Xr1 }
623    if { $yp < $Yr1 } { set yp $Yr1 }
624    if { $xp > $Xr2 } { set xp $Xr2 }
625    if { $yp > $Yr2 } { set yp $Yr2 }
626   
627    place $win -x [expr $options(-x)-$Xp0+$xp] -y [expr $options(-y)-$Yp0+$yp]
628  }
629
630  # name: _move3
631  # args: -
632  # called on a <ButtonRelease-1> event on the title bar. stores the actual
633  # window position in some private variables.
634  method _move3 {} {
635    set options(-x) [winfo x $win]
636    set options(-y) [winfo y $win]
637  }
638 
639  # name: _resize1
640  # args: iXp, iYp: mouse position (from the %X and %Y fields of an event)
641  # called on a <1> event on one of the borders. stores the current mouse
642  # position. depending on the mouse position (at an edge or not), the
643  # resize mode is determined.
644  method _resize1 { xp yp } {
645    $self raise
646   
647    set WMin [lindex $options(-minsize) 0]
648    set HMin [lindex $options(-minsize) 1]
649   
650    set XMax [expr $options(-x)+$options(-width) -$WMin]
651    set YMax [expr $options(-y)+$options(-height)-$HMin]
652   
653    set Xp0 $xp
654    set Yp0 $yp
655   
656    set sPos [$self _get_edge $xp $yp]
657    set sXPos {}; regexp {[we]} $sPos sXPos; set XPos $sXPos
658    set sYPos {}; regexp {[ns]} $sPos sYPos; set YPos $sYPos
659  }
660 
661  # name: _resize2
662  # args: iXp, iYp: mouse position (from the %X and %Y fields of an event)
663  # called on a <B1-Motion> event on the borders. calculates the new
664  # Document sizes and position and places it depending on the resize mode.
665  method  _resize2 { xp yp } {
666    # sometimes the <1> event and _resize1 didn't precede this one...
667    if { $XPos eq "" && $YPos eq ""} {
668      return
669    }
670   
671    if { $XPos eq "w" } {
672      set X [expr $options(-x)-$Xp0+$xp]
673      if { $X > $XMax } { set X $XMax }
674     
675      set W [expr $options(-width)+$Xp0-$xp]
676      if { $W < $WMin } { set W $WMin }
677     
678      place $win -x $X -width $W
679    } elseif { $XPos eq "e" } {
680      set W [expr $options(-width)-$Xp0+$xp]
681      if { $W < $WMin } { set W $WMin }
682     
683      place $win -width $W
684    }
685   
686    if { $YPos eq "n" } {
687      set Y [expr $options(-y)-$Yp0+$yp]
688      if { $Y > $YMax } { set Y $YMax }
689     
690      set H [expr $options(-height)+$Yp0-$yp]
691      if { $H < $HMin } { set H $HMin }
692     
693      place $win -y $Y -height $H
694    } elseif { $YPos eq "s" } {
695      set H [expr $options(-height)-$Yp0+$yp]
696      if { $H < $HMin } { set H $HMin }
697     
698      place $win -height $H
699    }
700  }
701 
702  # name: _resize3
703  # args: -
704  # called on a <ButtonRelease-1> event on the borders. stores the actual
705  # window size and position in some private variables.
706  method _resize3 {} {
707    set options(-x) [winfo x $win]
708    set options(-y) [winfo y $win]
709    set options(-width)  [winfo width $win]
710    set options(-height) [winfo height $win]
711  }
712 
713  # name: _withdraw
714  # args: -
715  # simply lets the Document disappear.
716  method withdraw {} {
717    place forget $win
718    set options(-state) withdrawn
719  }
720
721  # name: _maximize
722  # args: -
723  # maximizes the document. exchanges the icon for the maximize button.
724  # deletes bindings for resize and move.
725  method maximize {} {
726    if {$constructed && $options(-state) eq "maximized"} return
727    # if it was minimized or withdrawn: set to default
728    # if we come from normal state, store the window position
729    if { $options(-state) eq "normal" } {
730      set NormX $options(-x)
731      set NormY $options(-y)
732    } else {
733      $self restore
734    }
735   
736    # place it to fill entirely its master
737    place $win -x 0 -y 0 -width 0 -height 0 -relwidth 1 -relheight 1
738    $win.head.maxb configure -image $icons(restore)
739    $win.head.icon.m entryconf Maximize -state disabled
740    $hull configure -border 0
741   
742    # delete bindings for resizing
743    bind $win <1> {}
744    bind $win <B1-Motion> {}
745    bind $win <ButtonRelease-1> {}
746   
747    # modify/delete bindings for moving
748    bind $win.head.title <1> [mymethod raise]
749    bind $win.head.title <B1-Motion> {}
750    bind $win.head.title <ButtonRelease-1> {}
751   
752    # delete binding for mouse cursor changes over borders
753    bind $win <Motion> {}
754   
755    # change bindings for maximize button and title bar
756    bind $win.head.title <Double-1> [mymethod restore]
757    #bind $win.head.maxb <1> [mymethod restore]
758    $win.head.maxb configure -command [mymethod restore]
759   
760    set options(-state) maximized
761    event generate $win <<Maximize>> -when now
762  }
763 
764  method _title_bar { {status ""} } {
765    if {$status eq ""} {
766      return [expr {[llength [grid info $win.head]]?on:off}]
767    }
768    if {$status eq "on"} {
769      if {![llength [grid info $win.head]]} {
770        grid $win.head
771      }
772    } elseif {$status eq "off"} {
773      if {[llength [grid info $win.head]]} {
774        grid remove $win.head
775      }
776    } else {
777      error "$self _title_bar, invalid status value '$status': must be 'on' or 'off'"
778    }
779  }
780
781  # name: _minimize
782  # args: -
783  # minimizes the document. exchanges the icon for the minimize button.
784  # deletes bindings for resize.
785  method minimize {} {
786    if {$constructed && $options(-state) eq "minimized"} return
787    # if it was maximized or withdrawn: set to default
788    # if we come from normal state, store the window position
789    if { $options(-state) == "normal" } {
790      set NormX $options(-x)
791      set NormY $options(-y)
792    } else {
793      $self restore
794    }
795   
796    # morph -x and -y to contain the icon position
797    if { $IconX != -1 } {
798      set options(-x) $IconX
799      set options(-y) $IconY
800    } else {
801      set options(-x) $NormX
802      set options(-y) $NormY
803    }
804   
805    # withdraw the document's working area
806    #pack forget $win.work
807    grid remove $win.work
808    $win.head.minb configure -image $icons(restore)
809    $win.head.icon.m entryconf Minimize -state disabled
810   
811    # eventually change title text
812    if { $options(-icontext) ne "" } {
813      $win.head.title configure -text $options(-icontext)
814    }
815   
816    place $win -x $options(-x) -y $options(-y) \
817        -width 128 -height [expr [winfo reqheight $win.head] + 8] -relwidth 0 -relheight 0
818   
819    # delete bindings for resizing
820    bind $win <1> {}
821    bind $win <B1-Motion> {}
822    bind $win <ButtonRelease-1> {}
823   
824    # delete binding for mouse cursor changes over borders
825    bind $win <Motion> {}
826   
827    # change bindings for minimize button and title bar
828    bind $win.head.title <Double-1> [mymethod restore]
829    #bind $win.head.minb <1> [mymethod restore]
830    $win.head.minb configure -command [mymethod restore]
831   
832    set options(-state) minimized
833    event generate $win <<Minimize>> -when now
834  }
835 
836  method client { } {
837    return $win.work
838  }
839
840  #///////////////////////////////////////////////////////////////////////////
841  method writeIni { } {
842  #
843  # PURPOSE: Writes to .ini file information about document properties
844  #
845  # PARAMETERS:
846  #   self: document
847  #
848  #///////////////////////////////////////////////////////////////////////////
849    if {[string length [$self cget -iniconfig]]} {
850      # comprobamos cargado namespace y variable de .ini
851      #&& [info exists idIni]
852      if {[namespace exists ::iniFile]} {
853        set wini ::iniFile::Write
854        set nm [$self cget -iniconfig]
855
856        if { [$self cget -state] ne "minimized" } {
857          $wini $nm mdistate [$self cget -state]
858        }
859        if { $options(-resizable) } {
860          $wini $nm mdiwidth  [$self cget -width]
861          $wini $nm mdiheight [$self cget -height]
862        }
863        $wini $nm mdix [$self cget -x]
864        $wini $nm mdiy [$self cget -y]
865      }
866    }
867  }
868
869  #///////////////////////////////////////////////////////////////////////////
870  method readIni { } {
871  #
872  # PURPOSE: Recovers from .ini file information about document properties
873  #
874  # PARAMETERS:
875  #   self: document
876  #
877  #///////////////////////////////////////////////////////////////////////////
878    if {[string length [$self cget -iniconfig]]} {
879      # comprobamos cargado namespace y variable de .ini
880      #&& [info exists idIni]
881      if {[namespace exists ::iniFile]} {
882        set rini ::iniFile::Read
883        set nm [$self cget -iniconfig]
884        set stt [$rini $nm mdistate normal]
885        $self configure -state $stt
886        if { $stt eq "normal" } {
887          if { $options(-resizable) } {
888            set width [$rini $nm mdiwidth [$self cget -width]]
889            set height [$rini $nm mdiheight [$self cget -height]]
890            if {[string length $width]} { $self configure -width $width }
891            if {[string length $height]} { $self configure -height $height }
892          }
893         
894          set x [$rini $nm mdix [$self cget -x]]
895          set y [$rini $nm mdiy [$self cget -y]]
896          if {[string length $x]} { $self configure -x $x }
897          if {[string length $y]} { $self configure -y $y }
898        }
899      }
900    }
901  }
902
903  #///////////////////////////////////////////////////////////////////////////
904  method getframe { } {
905  #
906  # PURPOSE: returns the document framework
907  #
908  # PARAMETERS:
909  #   self: document
910  #
911  #///////////////////////////////////////////////////////////////////////////
912    return $self.work
913  }
914 
915  #///////////////////////////////////////////////////////////////////////////
916  method setgeometry { geometry } {
917  #
918  # PURPOSE: Set geometry
919  #
920  # PARAMETERS:
921  #   geometry -> geometry specification
922  #///////////////////////////////////////////////////////////////////////////
923    if {[string length $geometry]} {
924      set width    [lindex [split $geometry x] 0]
925      set restgeom [lindex [split $geometry x] 1]
926      set height   [lindex [split $restgeom +] 0]
927      set x        [lindex [split $restgeom +] 1]
928      set y        [lindex [split $restgeom +] 2]
929      $self configure -width $width -height $height -x $x -y $y
930    }
931  }
932}
933
934snit::widgetadaptor mdimenu {
935  # base title to preserve when adding the doc maximized titles
936  option -title
937  # fmenu instance
938  variable menu
939  # current document attached to this fmenu
940  variable wcurrent ""
941  variable wmaster ""
942  variable save_title
943 
944  delegate method * to hull
945  delegate option * to hull
946
947  constructor {args} {
948    installhull using fmenu
949
950    bind MaxDoc <<Minimize>> [mymethod unlink_doc]
951    bind MaxDoc <<Restore>> [mymethod unlink_doc]
952    bind MaxDoc <Destroy> [mymethod unlink_doc 1]
953   
954    $self configurelist $args
955   
956    if { $options(-title) eq "" } {
957      set options(-title) [wm title .]
958    }
959  }
960
961  method create_buttons { } {
962    # create label/buttons
963    menubutton $win.icon -menu $win.icon.menu -relief flat -bd 0
964    # create icon menu
965    menu $win.icon.menu -tearoff 0
966    grid $win.icon -row 0 -column 0 -sticky "w"
967    grid remove $win.icon
968    $win.icon.menu add command -label Restore -command [mymethod restore_doc]
969    $win.icon.menu add command -label Minimize -command [mymethod minimize_doc]
970    $win.icon.menu add command -label Maximize -state disabled
971    $win.icon.menu add separator
972    $win.icon.menu add command -label Close -command [mymethod kill_doc]
973    button $win.minb -image [mdidoc icon minimize] -bd 1 -padx 0 -pady 0 \
974        -command [mymethod minimize_doc]
975    grid $win.minb -row 0 -column 20 -sticky "e"
976    grid remove $win.minb
977    button $win.resb -image [mdidoc icon restore] -bd 1 -padx 0 -pady 0 \
978        -command [mymethod restore_doc]
979    grid $win.resb -row 0 -column 21 -sticky "e"
980    grid remove $win.resb
981    button $win.clob -image [mdidoc icon close] -bd 1 -padx 0 -pady 0 \
982        -command [mymethod kill_doc]
983    grid $win.clob -row 0 -column 22 -sticky "e"
984    grid remove $win.clob   
985  }
986
987  # link_doc --
988  #
989  # link doc to menu interface, this grid the corresponding buttons and
990  # undate commands in those buttons to reference this document.
991
992  method link_doc { wdoc } {
993    if {$wdoc ne ""} {
994      set wcurrent $wdoc
995      set wmaster [winfo parent $wdoc]
996      if {![winfo exists $win.icon]} {
997        $self create_buttons
998      }
999      foreach w [list $win.icon $win.minb $win.resb $win.resb $win.clob] {
1000        if {![llength [grid info $w]]} {
1001          grid $w
1002        }
1003      }
1004      set tags [bindtags $wdoc]
1005      if {[lsearch $tags "MaxDoc"] == -1} {
1006        bindtags $wdoc [lappend tags "MaxDoc"]
1007      }
1008      $win.icon configure -image [$wdoc cget -image]
1009      set wtop [winfo toplevel $win]
1010      #set save_title [wm title $wtop]
1011      #wm title $wtop "$save_title \[[$wdoc cget -title]\]"
1012      wm title $wtop "$options(-title) \[[$wdoc cget -title]\]"
1013    }
1014  }
1015
1016  # unlink_doc --
1017  #
1018  # unlink current doc, unpacking corresponding buttons.
1019
1020  method unlink_doc { {killed 0} } {
1021    grid remove $win.icon
1022    grid remove $win.minb
1023    grid remove $win.resb
1024    grid remove $win.clob
1025    if {!$killed && $wcurrent ne ""} {
1026      set tags [bindtags $wcurrent]
1027      if {[set idx [lsearch $tags "MaxDoc"]]!=-1} {
1028        set tags [lreplace $tags $idx $idx]
1029        bindtags $wcurrent $tags
1030      }
1031      #wm title [winfo toplevel $win] $save_title
1032      wm title [winfo toplevel $win] $options(-title)
1033    }
1034    # check for another maximized in wmaster
1035    set wmax ""
1036    foreach w [winfo children $wmaster] {
1037      if {$w ne $wcurrent && [winfo class $w] eq "Mdidoc"
1038          && [$w cget -state] eq "maximized"} {
1039        set wmax $w
1040      }
1041    }
1042    set wcurrent ""
1043    set wmaster ""
1044    if {$wmax ne ""} {
1045      $self link_doc $wmax
1046    }
1047  }
1048
1049  method restore_doc { } {
1050    if {$wcurrent ne ""} {
1051      $wcurrent restore
1052    }
1053  }
1054
1055  method minimize_doc { } {
1056    if {$wcurrent ne ""} {
1057      $wcurrent minimize
1058    }
1059  }
1060
1061  method kill_doc { } {
1062    if {$wcurrent ne ""} {
1063      $wcurrent kill
1064    }
1065  }
1066 
1067  method set_wcurrent { w } {
1068    set wcurrent $w
1069  }
1070}
1071
1072snit::widget mdi {
1073  widgetclass Mdi
1074
1075  delegate option * to hull
1076
1077  option -mdimenu ""
1078  option -backimg ""
1079
1080  variable counter 0
1081  variable allTypes ;# list of all types registered
1082  variable allDocs  ;# array of all document windows classified by type
1083
1084  constructor { args } {
1085
1086    set allTypes {}
1087    set allDocs() {}
1088    $self configurelist $args
1089    label $win.lback -image $options(-backimg)
1090    pack $win.lback -fill both -expand yes
1091    update
1092  }
1093
1094  onconfigure -backimg {img} {
1095    set options(-backimg) $img
1096    if {[winfo exists $win.lback]} {
1097      $win.lback configure -image $img
1098    }
1099  }
1100
1101  method get_types { } {
1102    set allTypes
1103  }
1104
1105  method get_documents {args} {   
1106    set result {}
1107    if {[llength $args]} {
1108      set type_names $args
1109    } else {
1110      set type_names $allTypes
1111      if {[llength $allDocs()]} {
1112        lappend result "" $allDocs()
1113      }
1114    }
1115    foreach t $type_names {
1116      lappend result $t $allDocs($t)
1117    }
1118    set result
1119  }
1120
1121  method slave { args } {
1122    set wslave [$self _uniquename]
1123    eval ::mdidoc $wslave $args
1124    $self _register $wslave
1125    if { [$wslave cget -state] eq "maximized"} {
1126       # inexplicably the following is required to maximize correctly
1127       update
1128       $wslave configure -state "normal"
1129       $wslave configure -state "maximized"
1130    }
1131    return $wslave
1132  }
1133
1134  method _register { w } {
1135    set t [$w cget -type]
1136    if {$t ne "" && [lsearch $allTypes $t] == -1} {
1137      lappend allTypes $t
1138    }
1139    lappend allDocs($t) $w
1140    bind $w <Destroy> +[mymethod _unregister $w]
1141    bind $w <<Maximize>> [mymethod on_maximize $w]
1142    bind $w <<Minimize>> [mymethod on_minimize $w]
1143    bind $w <<Restore>>  [mymethod on_restore $w]
1144  }
1145
1146  method _unregister { w } {
1147    set t [$w cget -type]
1148    set idx [lsearch $allDocs($t) $w]
1149    if {$idx != -1} {
1150      set allDocs($t) [lreplace $allDocs($t) $idx $idx]
1151      if {$t ne "" && ![llength $allDocs($t)]} {
1152        array unset allDocs $t
1153        set idx [lsearch $allTypes $t]
1154        if {$idx != -1} {
1155          set allTypes [lreplace $allTypes $idx $idx]
1156        }
1157      }
1158    }
1159  }
1160
1161  method on_maximize { w } {
1162    if {$options(-mdimenu) ne ""} {
1163      $w _title_bar off
1164      $options(-mdimenu) link_doc $w
1165    }
1166  }
1167
1168  method on_minimize { w } {
1169  }
1170
1171  method on_restore { w } {
1172  }
1173
1174  # name: arrange
1175  # args: sHow: arrange mode
1176  #       sParent: a valid parent widget of document windows(s).
1177  # static member function. resizes and repositions all Document objects
1178  # in one of several ways. it always arrange iconfied windows before
1179  # it repositions the non-iconfied windows.
1180
1181  method arrange { how } {
1182   
1183    # first check if at least one document window exists
1184    if {[llength [array names allDocs]]==1 && ![llength $allDocs()]} {
1185      return
1186    }
1187   
1188    set how [complete_name $how \
1189                 {horizontally vertically cascade \
1190                      tile icons maximize minimize}]
1191   
1192   
1193    # get a list of all iconified windows and a list of all others
1194    set lDocs {}
1195    set lIcon {}
1196    foreach t [array names allDocs] {
1197      foreach doc $allDocs($t) {
1198        if { [$doc cget -state] != "withdrawn" } {
1199          if { [$doc cget -state] == "minimized" } {
1200            lappend lIcon $doc
1201          } else {
1202            lappend lDocs $doc
1203          }
1204        }
1205      }
1206    }
1207   
1208    # get parent window's dimensions for later calculation
1209    set sParent [winfo parent $doc]
1210    set iW [winfo width  $sParent]
1211    set iH [winfo height $sParent]
1212   
1213    # if there are iconfied windows, arrange them first and reduce iH
1214    set iXd 0
1215    foreach sDoc $lIcon {
1216      set iWd [winfo width $sDoc]
1217      if { [expr $iXd+$iWd] > $iW } {
1218        set iXd 0
1219      }
1220      if { $iXd == 0 } {
1221        incr iH -[winfo height $sDoc]
1222      }
1223      $sDoc configure -x $iXd -y $iH
1224      incr iXd $iWd
1225    }
1226   
1227    # how many non-iconified windows? just exit when none
1228    set iDocs [llength $lDocs]
1229    if { $iDocs == 0 } return
1230   
1231    switch $how {
1232      horizontally {
1233        set iStep [expr $iH/$iDocs]
1234        for { set i 0 } { $i < $iDocs } { incr i } {
1235          set sDoc [lindex $lDocs $i]
1236          $sDoc restore
1237          $sDoc configure -x 0 -y [expr $i*$iStep] -width $iW -height $iStep
1238        }
1239      }
1240     
1241      vertically {
1242        set iStep [expr $iW/$iDocs]
1243        for { set i 0 } { $i < $iDocs } { incr i } {
1244          set sDoc [lindex $lDocs $i]
1245          $sDoc restore
1246          $sDoc configure -x [expr $i*$iStep] -y 0 -width $iStep -height $iH
1247        }
1248      }
1249     
1250      cascade {
1251        set iStep 24
1252        for { set i 0 } { $i < $iDocs } { incr i } {
1253          set sDoc [lindex $lDocs $i]
1254          $sDoc restore
1255          $sDoc configure -x [expr $i*$iStep] -y [expr $i*$iStep] ;#-width [expr $iW*2/3] -height [expr $iH*2/3]
1256          $sDoc raise
1257        }
1258      }
1259     
1260      tile {
1261        for { set i 0 } { $i <= 100 } { incr i } {
1262          set iHor [expr ($i+3)/2]
1263          set iVer [expr ($i+2)/2]
1264          if { [expr $iHor*$iVer] >= $iDocs } break
1265        }
1266       
1267        set iXStep [expr $iW/$iHor]
1268        set iYStep [expr $iH/$iVer]
1269        for { set i 0 } { $i < $iDocs } { incr i } {
1270          set sDoc [lindex $lDocs $i]
1271          $sDoc restore
1272          $sDoc configure -x [expr ($i%$iHor)*$iXStep] -y [expr ($i/$iHor)*$iYStep] -width $iXStep -height $iYStep
1273        }
1274      }
1275     
1276      maximize {
1277        foreach sDoc $lDocs {
1278          $sDoc maximize
1279        }
1280      }
1281     
1282      minimize {
1283        foreach sDoc $lDocs {
1284          $sDoc minimize
1285        }
1286      }
1287    }
1288  }
1289
1290  proc complete_name {short long_values {what option}} {
1291    foreach v $long_values {
1292      set tmp($v) {}
1293    }
1294    if { [info exists tmp($short)] } {
1295      return $short
1296    } else {
1297      set match [array names tmp $short*]
1298
1299      if { [llength $match] == 1 } {
1300        return $match
1301      } elseif { [llength $match] == 0 } {
1302        error "bad $what '$short': must be [join $long_values ,]"
1303      } else {
1304        error "ambiguous $what '$short': must be [join $long_values ,]"
1305      }
1306    }   
1307  }
1308
1309  method _uniquename { } {
1310    while 1 {
1311      incr counter
1312      if {$counter > 2147483647} {
1313        set counter 0
1314      }
1315      set candidate $win.slave$counter
1316      if {![winfo exists $candidate]} {
1317        return $candidate
1318      }
1319    }
1320  }
1321 
1322  #///////////////////////////////////////////////////////////////////////////
1323  method writeDocsIni { } {
1324  #
1325  # PURPOSE: Calls the writeIni method from each mdi document child
1326  #
1327  # PARAMETERS:
1328  #   self: mdi
1329  #
1330  #///////////////////////////////////////////////////////////////////////////
1331    foreach t [array names allDocs] {
1332      foreach doc $allDocs($t) {
1333        $doc writeIni
1334      }
1335    }
1336       
1337  }
1338
1339  #///////////////////////////////////////////////////////////////////////////
1340  method cicle {} {
1341  #
1342  # PURPOSE: cicles the focus between mdi children
1343  #
1344  #///////////////////////////////////////////////////////////////////////////
1345 
1346    set lista ""
1347 
1348    foreach type [array names allDocs] {
1349          foreach doc $allDocs($type) {
1350            if { [$doc cget -state] != "withdrawn" } {
1351              lappend lista $doc
1352            }
1353      }
1354    }
1355
1356    set index 0
1357    foreach doc $lista {
1358          if { $::mdidoc::wFocus eq $doc } { break }
1359          incr index
1360    }
1361        set doc [lindex $lista [expr $index + 1]]
1362        #puts "$lista $doc"
1363        if { $doc ne "" } {
1364          $doc raise
1365        } else {
1366          [lindex $lista 0] raise
1367        }
1368  }
1369}
1370
1371
1372
1373
1374# ------- TEST CODE ----
1375
1376proc SelectDoc { dw } {
1377  if {[$dw cget -state] eq "minimized"} {
1378    $dw restore
1379  } else  {
1380    $dw raise
1381  }
1382}
1383
1384proc FillWindowMenu {mdi m} {
1385  $m delete 0 end
1386  foreach cw [winfo children $m] {
1387    destroy $cw
1388  }
1389  $m add command -label "Tile across" -underline 0 -command "$mdi arrange tile"
1390  $m add command -label "Tile horizontally" -underline 5 \
1391                 -command "$mdi arrange hor"
1392  $m add command -label "Tile vertically" -underline 5 -command "$mdi arrange ver"
1393  $m add command -label "Cascade" -underline 0 -command "$mdi arrange cascade"
1394  $m add separator
1395  $m add command -label "Arrange icons" -underline 0 -command "$mdi arrange icons"
1396  $m add command -label "Minimize all" -underline 0 -command "$mdi arrange min"
1397  foreach t [$mdi get_types] {
1398    $m add cascade -label $t -menu $m.sub$t
1399    menu $m.sub$t -tearoff 0
1400    foreach d [lindex [$mdi get_documents $t] 1] {
1401      $m.sub$t add command -label [$d cget -title] -command "SelectDoc $d "
1402    }
1403  }
1404  foreach d [lindex [$mdi get_documents {}] 1] {
1405    $m add command -label [$d cget -title] -command "SelectDoc $d"
1406  }
1407  if {[$m index end] > 6} {
1408    $m insert 7 separator
1409  }
1410}
1411
1412set test_path [file normalize [file dir [info script]]]
1413
1414proc test_mdi { } {
1415  destroy .tmdi
1416
1417  set md [menudef create %AUTO%]
1418  set id [$md add root cascade -label "&File"]
1419  set cid [$md add $id cascade -label "&New"]
1420  $md add $cid command -label "&Editor" \
1421      -command ".tmdi.master slave -type Editor -resizable 0"
1422  $md add $cid command -label "&Graph" \
1423      -command ".tmdi.master slave -type Graph"
1424  $md add $cid command -label "&Table" \
1425      -command ".tmdi.master slave -type Table"
1426  $md add $cid command -label "&SQL" \
1427      -command ".tmdi.master slave -type SQL"
1428  $md add $id command -label "&Open ..."
1429  $md add $id command -label "&Close"
1430  $md add $id separator
1431  $md add $id command -label "&Exit"
1432  $md add root cascade -label "&Window" \
1433      -postcommand [list FillWindowMenu .tmdi.master %W]
1434  $md add root separator
1435  set id [$md add root cascade -label "&Help"]
1436  $md add $id command -label "&Contents ..."
1437  $md add $id separator
1438  $md add $id command -label "&About ..." 
1439
1440  #$md dump
1441  #return
1442  toplevel .tmdi
1443  mdimenu .tmdi.m -definition $md
1444  update
1445  set bimg [image create photo \
1446                -file [file join $::test_path "../../toltk/images/splash.gif"]]
1447  mdi .tmdi.master -mdimenu .tmdi.m -relief sunken -bd 1 \
1448      -backimg $bimg
1449  grid .tmdi.m -row 0 -column 0 -sticky "new"
1450  grid .tmdi.master -row 1 -column 0 -sticky "snew"
1451  grid columnconfigure .tmdi 0 -weight 1
1452  grid rowconfigure .tmdi 1 -weight 1
1453  $md destroy
1454}
1455
1456
1457package provide mdi 0.1
Note: See TracBrowser for help on using the repository browser.