/[ascend]/trunk/tcltk/TK/generalk.tcl
ViewVC logotype

Contents of /trunk/tcltk/TK/generalk.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 571 - (show annotations) (download) (as text)
Tue May 9 00:14:59 2006 UTC (18 years, 9 months ago) by johnpye
File MIME type: text/x-tcl
File size: 29511 byte(s)
Renaming 'tcltk98' to 'tcltk', continued...
1 # generalk.tcl
2 # by Benjamin A. Allan and Kirk A. Abbott
3 # Created: January 1994
4 # Part of ASCEND
5 # Revision: $Revision: 1.29 $
6 # Last modified on: $Date: 1998/06/18 15:55:25 $
7 # Last modified by: $Author: mthomas $
8 # Revision control file: $RCSfile: generalk.tcl,v $
9 #
10 # This file is part of the ASCEND Tcl/Tk Interface.
11 #
12 # Copyright (C) 1994-1998 Carnegie Mellon University
13 #
14 # The ASCEND Tcl/Tk Interface is free software; you can redistribute
15 # it and/or modify it under the terms of the GNU General Public
16 # License as published by the Free Software Foundation; either
17 # version 2 of the License, or (at your option) any later version.
18 #
19 # The ASCEND Tcl/Tk Interface is distributed in hope that it will be
20 # useful, but WITHOUT ANY WARRANTY; without even the implied warranty
21 # of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 # GNU General Public License for more details.
23 #
24 # You should have received a copy of the GNU General Public License
25 # along with the program; if not, write to the Free Software
26 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the
27 # file named COPYING. COPYING is found in ../compiler.
28
29 # Module: generalk.tcl
30 # Tcl version: 7.1 (Tcl/Tk/XF)
31 # Tk version: 3.4
32 # XF version: 2.2
33 #
34 #
35
36 # module contents
37 global moduleList
38 global autoLoadList
39 #warning: THIS PROCEDURE LIST IS OUT OF DATE. XF MAY FREAK!
40 set moduleList(generalk.tcl) {
41 Alias
42 GetSelection
43 MenuPopupAdd
44 MenuPopupMotion
45 MenuPopupPost
46 MenuPopupRelease
47 NoFunction
48 OptionButtonGet
49 OptionButtonSet
50 SN
51 SymbolicName
52 Unalias
53 }
54 set autoLoadList(generalk.tcl) {0}
55
56
57
58 # User defined procedures
59
60 #
61 # proc listgetgeom {wlist} {
62 #------------------------------------------------------------------------
63 # proc to list the geometries of the windows in wlist
64 # windows not existing are ignored
65 # does not note gridded windows properly
66 #------------------------------------------------------------------------
67 proc listgetgeom {wlist} {
68 set glist ""
69 foreach w $wlist {catch { lappend glist "$w [winfo geometry $w]" } }
70 return $glist
71 }
72
73 #
74 # proc listsetgeom {glist}
75 #------------------------------------------------------------------------
76 # proc to set the geometries of the windows in glist
77 # messed up entries are ignored, probably
78 # doesnot handle gridded windows properly
79 #------------------------------------------------------------------------
80 proc listsetgeom {glist} {
81 foreach g $glist {
82 catch {set win [lindex [split $g] 0]}
83 catch {set geom [lindex [split $g] 1]}
84 catch {wm geometry $win $geom}
85 }
86 }
87
88 proc listbindings {{n ""} {conly ""} {match ""}} {
89 if {$n==""} {
90 puts stderr "listbindings w : bindings on class and widget w"
91 puts stderr "listbindings w -noc : bindings widget w"
92 puts stderr "listbindings c : bindings class c"
93 puts stderr "listbindings c -match pat : c events string matching pat"
94 puts stderr "listbindings c -body pat : c actions string matching pat"
95 return
96 }
97 set class Crapola
98 set p ""
99 if {[winfo exists $n]} {
100 set class [winfo class $n]
101 set p $n
102 } else {
103 set class $n
104 }
105 if {$conly == ""} {
106 puts "Class bindings for $class:"
107 foreach i [bind $class] {
108 puts "bind $class $i \{\n[bind $class $i]\}"
109 }
110 }
111 if { $conly == "-match"} {
112 puts "Class bindings for $class matching event $match:"
113 foreach i [bind $class] {
114 if {[string match $match $i]} {
115 puts "bind $class $i \{\n[bind $class $i]\}"
116 }
117 }
118 }
119 if { $conly == "-body"} {
120 puts "Class bindings for $class matching action $conly:"
121 foreach i [bind $class] {
122 if {[string match $match [bind $class $i]]} {
123 puts "bind $class $i \{\n[bind $class $i]\}"
124 }
125 }
126 }
127 if {$p != ""} {
128 puts "Bindings for widget $p:"
129 foreach i [bind $p] {
130 puts "bind $p $i \{\n[bind $p $i]\}"
131 }
132 }
133 puts "listbindings $n $conly $match"
134 }
135 #
136 # proc attr {w}
137 #------------------------------------------------------------------------
138 # proc to list all attributes of a given widget
139 #------------------------------------------------------------------------
140 proc attr {w} {
141 foreach i [lsort [$w configure]] {
142 puts $i
143 }
144 }
145
146 # proc Table_calc_column_width {table column}
147 #------------------------------------------------------------------------
148 # returns the maximum characters in a column of a table for
149 # a table widget
150 #------------------------------------------------------------------------
151 proc Table_calc_column_width {table column} {
152 if {![winfo exists $table]} {return 0}
153 set ap [$table cget -variable]
154 upvar #0 $ap PA
155 global $ap
156 set maxwidth 0
157 set cindex "*,$column"
158 foreach i [array names PA] {
159 if {[string match $cindex $i]} {
160 set w [string length $PA($i)]
161 if {$w > $maxwidth} {
162 set maxwidth $w
163 }
164 }
165 }
166 return $maxwidth
167 }
168
169 #
170 # proc wich {w}
171 #------------------------------------------------------------------------
172 # proc to list all the children of a given window
173 #------------------------------------------------------------------------
174 proc wich {w} {
175 set children [winfo children $w]
176 foreach child $children {
177 puts $child
178 wich $child
179 }
180 }
181
182 #
183 # proc witchhunt {w}
184 #------------------------------------------------------------------------
185 # proc to list all the children of a given window that export selection.
186 #------------------------------------------------------------------------
187 proc witchhunt {{w .}} {
188 set children [winfo children $w]
189 catch { if {[lindex [$w configure -exportselection] 4]} {
190 puts "[winfo class $w] $w exports selection"
191 }
192 }
193 foreach child $children {
194 witchhunt $child
195 }
196 }
197
198 #----------------------------------------------------------------------------
199 # returns the calling procedure name. This was directly grabbed from the
200 # EDRC SEED project.
201 #----------------------------------------------------------------------------
202 proc procName {} {
203 set depth [expr {[info level]-1}]
204 return [lindex [info level $depth] 0]
205 }
206
207 #
208 # proc menu_disable_all {m}
209 #-------------------------------------------------------------------------
210 # disable all entries on a menu widget of any length
211 #-------------------------------------------------------------------------
212 proc menu_disable_all {m} {
213 set l [$m index last]
214 if {$l=="none"} {return}
215 for {set i 0} {$i <= $l} {incr i} {
216 catch {$m entryconfigure $i -state disabled}
217 }
218 # separators normally cause an error
219 }
220
221
222 #####################
223
224 #
225 # proc ascclearlist {listWidget}
226 #------------------------------------------------------------------------
227 # empty a listbox
228 #------------------------------------------------------------------------
229 proc ascclearlist {listWidget} {
230 if {[$listWidget size] > 0} {
231 $listWidget delete 0 end;
232 }
233 }
234
235 #
236 # proc delete_list_item {list item}
237 #------------------------------------------------------------------------
238 # finds first occurence of item in list, and
239 # returns a new version of the list without that item.
240 # if item is not found, returns original list.
241 #------------------------------------------------------------------------
242 proc delete_list_item {l i} {
243 set p [lsearch -exact $l $i]
244 if {$p == -1} {
245 return $l
246 }
247 return [lreplace $l $p $p]
248 }
249 #
250 # proc updatelist {mlist w}
251 #------------------------------------------------------------------------
252 # stuff each of the items in mlist into list widget in order
253 #------------------------------------------------------------------------
254 proc updatelist {mlist w} {# general list update
255 foreach i $mlist {
256 $w insert end $i;
257 }
258 }
259
260 global tcl_platform tk_version
261 if {$tk_version >= 8.0 && "$tcl_platform(platform)"!="unix"} {
262 #
263 #-----------------------------------------------------------------------
264 # Bare bones ls hack for pcs who are too stupid to know better.
265 #-----------------------------------------------------------------------
266 proc ls {args} {
267 set pattern "__nopattern"
268 set outstyle 0
269 foreach i $args {
270 # parse switches
271 if {"[string index $i 0]" == "-"} {
272 set len [string len $i]
273 for {set c 1} {$c < $len} {incr c} {
274 set opt "[string index $i $c]"
275 if {"$opt" == "l"} {
276 set outstyle 1
277 } else {
278 puts "option $opt ignored"
279 }
280 }
281 } else {
282 if {"$pattern" == "__nopattern"} {
283 set pattern $i
284 } else {
285 append pattern " $i"
286 }
287 }
288 }
289 if {"$pattern" == "__nopattern"} {
290 set pattern "*"
291 }
292 set flist [lsort [glob $pattern]]
293 set maxlen 0
294 set listlen 0
295 foreach i $flist {
296 if {[string length $i] > $maxlen} {
297 set maxlen [string length $i]
298 }
299 incr listlen
300 }
301 set cols [expr 80/($maxlen +4)]
302 set field [expr 80/$cols]
303 if {"$outstyle" != "0"} {
304 foreach i $flist {
305 if {[file isdirectory $i]} {
306 puts stdout "$i/"
307 } else {
308 puts stdout "$i"
309 }
310 }
311 } else {
312 set r 0
313 set c 0
314 foreach i $flist {
315 if {[file isdirectory $i]} {
316 puts -nonewline stdout [format "%-${field}s" "$i/"]
317 } else {
318 puts -nonewline stdout [format "%-${field}s" $i]
319 }
320 incr c
321 if {$c == $cols} {
322 puts stdout ""
323 set c 0
324 }
325 }
326 if {$c} {
327 puts stdout ""
328 }
329 }
330 }
331 }
332 #end if tkversion for ls proc
333
334 #
335 # proc do_raise_lower {w}
336 #------------------------------------------------------------------------
337 # toggle the iconicness of a window
338 #------------------------------------------------------------------------
339 proc do_raise_lower {w} {
340
341 if {[winfo exists $w]} {
342 if {[winfo ismapped $w]} {
343 wm withdraw $w;
344 } else {
345 wm deiconify $w;
346 raise $w
347 }
348 } else {
349 return 1;
350 }
351 }
352
353 #
354 # proc do_raise {w}
355 #------------------------------------------------------------------------
356 # deiconify w if it exists and is iconified
357 #------------------------------------------------------------------------
358 proc do_raise {w} {
359 if {[winfo exists $w]} {
360 if {![winfo ismapped $w]} {
361 wm deiconify $w;
362 }
363 }
364 }
365
366 #
367 # proc d_dumpary {ary}
368 #----------------------------------------------------------------------------
369 # utility routine for dumping an alphabetized array vector . baa 1-94 #
370 #----------------------------------------------------------------------------
371 proc d_dumpary {ary} {
372 parray $ary
373 }
374
375 #
376 # proc d_dumpproclist {lst}
377 #----------------------------------------------------------------------------
378 # utility to dump a list of procedure names and their associated args #
379 # alphabetizes #
380 #----------------------------------------------------------------------------
381 proc d_dumpproclist {lst} {
382 set tmp [lsort $lst]
383 foreach i $tmp {
384 puts "$i {[info args $i]}"
385 }
386 }
387
388 #
389 # proc d_dumplist {lst}
390 #----------------------------------------------------------------------------
391 # utility to dump a list alphabetically #
392 #----------------------------------------------------------------------------
393 proc d_dumplist {lst} {
394 set tmp [lsort $lst]
395 foreach i $tmp {
396 puts "$i"
397 }
398 }
399
400 #
401 # proc d_dumpfile {out filename}
402 #-----------------------------------------------------------------------
403 # dump a text file. out is assumed open and writable
404 # filename is assumed readable.
405 #-----------------------------------------------------------------------
406 proc d_dumpfile {out filename} {
407 set fid [open $filename r]
408 set blob [read $fid]
409 close $fid
410 puts $out "\n$blob"
411 }
412
413 #
414 # ascPopSlide {{name "ascpop"} {geometry "100x50+%X+%Y"} \
415 # {from "0"} {to "10"} {label ""} {okcommand ""} {value "0"}
416 # {setcommand "puts"} {orient "horizontal"}}
417 # by Ben Allan April 25 1994.
418 #------------------------------------------------------------------------
419 # popup slider for a number input. Grabs application.
420 # configs:
421 # AscPopSlide(fg) AscPopSlide(bg) AscPopSlide(font)
422 # AscPopSlide(afg) AscPopSlide(abg)
423 global AscPopSlide
424 set AscPopSlide(fg) black
425 set AscPopSlide(bg) white
426 set AscPopSlide(abg) black
427 set AscPopSlide(afg) white
428 set AscPopSlide(font) -*-*
429 #------------------------------------------------------------------------
430 proc ascPopSlide {{name "ascpop"} {geometry ""} \
431 {from "0"} {to "10"} {label "Value"} {okcommand ""} \
432 {value "0"} {setcommand "puts"} \
433 {orient "horizontal"}} {
434
435 global AscPopSlide
436 if {[winfo exists .$name]} {destroy .$name}
437 toplevel .$name
438 wm geometry .$name $geometry
439 wm title .$name "$label"
440 wm maxsize .$name 400 1000
441 # make slider
442 scale .$name.slide \
443 -command $setcommand \
444 -from $from \
445 -label $label \
446 -orient $orient \
447 -font $AscPopSlide(font) \
448 -to $to
449 .$name.slide set $value
450 button .$name.ok_btn \
451 -text "OK" \
452 -font $AscPopSlide(font) \
453 -width [string length $label] \
454 -command "$okcommand; grab release .$name; destroy .$name"
455
456 # pack widget .$name
457 pack append .$name \
458 .$name.slide {top frame center expand fill} \
459 .$name.ok_btn {top frame center fillx}
460 grab .$name
461 update idletasks
462 }
463
464 proc ascPushText {str} {
465 global ascStackText
466 set ascStackText($ascStackText(len)) $str
467 incr ascStackText(len)
468 }
469 proc ascPopText {} {
470 global ascStackText
471 if {!$ascStackText(len)} { return ""}
472 incr ascStackText(len) -1
473 return $ascStackText($ascStackText(len))
474 }
475
476 global ascStackText
477 set ascStackText(len) 0
478 ascPushText ""
479
480 # proc emacs-bind {textwidgetname}
481 # These bindings rely on the tk8 binding model that widget bindings
482 # get called before class bindings do. With this assumption, we
483 # capture the text to be copied/deleted in a stack.
484 # These do not require widgets to export selection to paste between
485 # text boxes. These are not class bindings, but they assume the standard
486 # class bindings.
487 # ^k kill to eol
488 # ^w kill selection
489 # meta-w copy selection
490 # ^y paste previous copy/kill, but grouping sequences not supported.
491 # meta-y replace last paste with previous kill, and queue 'last paste'
492 # at the back not supported
493 proc emacs-bind {textw} {
494 global tcl_platform
495 if {$tcl_platform(platform) != "unix"} { return }
496 # buffer the delete to eol
497 bind $textw <Control-Key-k> {
498 if !$tk_strictMotif {
499 if [%W compare insert != {insert lineend}] {
500 ascPushText [%W get insert {insert lineend}]
501 }
502 }
503 }
504 # buffer the selection
505 bind $textw <Meta-Key-w> {
506 if !$tk_strictMotif {
507 if {[%W tag nextrange sel 1.0 end] != ""} {
508 ascPushText [%W get sel.first sel.last]
509 }
510 }
511 }
512 # buffer the selection, and delete it. Interaction with multiple selection?
513 bind $textw <Control-Key-w> {
514 if !$tk_strictMotif {
515 if {[%W tag nextrange sel 1.0 end] != ""} {
516 ascPushText [%W get sel.first sel.last]
517 %W delete sel.first sel.last
518 }
519 }
520 }
521 # insert from buffer
522 bind $textw <Control-Key-y> {
523 if !$tk_strictMotif {
524 set old [%W index insert]
525 %W insert insert [ascPopText]
526 %W mark set insert $old
527 }
528 }
529 }
530 #------------------------------------------------------------------------
531
532
533
534 #------------------------------------------------------------------------
535 # PROCEDURES SWIPED WHOLESALE FROM TK/XF
536 #------------------------------------------------------------------------
537 # Procedure: OptionButtonGet
538 proc OptionButtonGet { widget} {
539
540 if {"[winfo class $widget.value]" == "Label"} {
541 return [lindex [$widget.value config -text] 4]
542 } {
543 if {"[winfo class $widget.value]" == "Entry"} {
544 return [$widget.value get]
545 }
546 }
547 }
548
549
550 # Procedure: OptionButtonSet
551 proc OptionButtonSet { widget} {
552
553 if {"[winfo class $widget.value]" == "Label"} {
554 $widget.value config \
555 -text [lindex
556 [$widget.menubutton2.m entryconfig
557 [$widget.menubutton2.m index active] -label] 4]
558 } {
559 if {"[winfo class $widget.value]" == "Entry"} {
560 $widget.value delete 0 end
561 $widget.value insert 0 [lindex
562 [$widget.menubutton2.m entryconfig
563 [$widget.menubutton2.m index active] -label] 4]
564 }
565 }
566 }
567
568
569 # Internal procedures
570
571
572 # Procedure: Alias
573 if {"[info procs Alias]" == ""} {
574 proc Alias { args} {
575 # xf ignore me 7
576 #------------------------------------------------------------------------
577 # Procedure: Alias
578 # Description: establish an alias for a procedure
579 # Arguments: args - no argument means that a list of all aliases
580 # is returned. Otherwise the first parameter is
581 # the alias name, and the second parameter is
582 # the procedure that is aliased.
583 # Returns: nothing, the command that is bound to the alias or a
584 # list of all aliases - command pairs.
585 # Sideeffects: internalAliasList is updated, and the alias
586 # proc is inserted
587 #------------------------------------------------------------------------
588 global internalAliasList
589
590 if {[llength $args] == 0} {
591 return $internalAliasList
592 } {
593 if {[llength $args] == 1} {
594 set xfTmpIndex [lsearch $internalAliasList "[lindex $args 0] *"]
595 if {$xfTmpIndex != -1} {
596 return [lindex [lindex $internalAliasList $xfTmpIndex] 1]
597 }
598 } {
599 if {[llength $args] == 2} {
600 eval "proc [lindex $args 0] {args} {#xf ignore me 4
601 return \[eval \"[lindex $args 1] \$args\"\]}"
602 set xfTmpIndex [lsearch $internalAliasList "[lindex $args 0] *"]
603 if {$xfTmpIndex != -1} {
604 set internalAliasList [lreplace $internalAliasList $xfTmpIndex $xfTmpIndex "[lindex $args 0] [lindex $args 1]"]
605 } {
606 lappend internalAliasList "[lindex $args 0] [lindex $args 1]"
607 }
608 } {
609 error "Alias: wrong number or args: $args"
610 }
611 }
612 }
613 }
614 }
615
616
617 # Procedure: GetSelection
618 if {"[info procs GetSelection]" == ""} {
619 proc GetSelection {} {
620 # xf ignore me 7
621 #------------------------------------------------------------------------
622 # Procedure: GetSelection
623 # Description: get current selection
624 # Arguments: none
625 # Returns: none
626 # Sideeffects: none
627 #------------------------------------------------------------------------
628 set xfSelection ""
629 catch "selection get" xfSelection
630 if {"$xfSelection" == "selection doesn't exist or form \"STRING\" not defined"} {
631 return ""
632 } {
633 return $xfSelection
634 }
635 }
636 }
637
638
639 #------------------------------------------------------------------------
640 # Procedure: MenuPopupAdd
641 if {"[info procs MenuPopupAdd]" == ""} {
642 proc MenuPopupAdd { xfW xfButton xfMenu {xfModifier ""} {xfCanvasTag ""}} {
643
644 # xf ignore me 7
645 # the popup menu handling is from (I already gave up with popup handling :-):
646 #
647 # Copyright 1991,1992 by James Noble.
648 # Everyone is granted permission to copy, modify and redistribute.
649 # This notice must be preserved on all copies or derivates.
650 #
651 ##########
652 # Procedure: MenuPopupAdd
653 # Description: attach a popup menu to widget
654 # Arguments: xfW - the widget
655 # xfButton - the button we use
656 # xfMenu - the menu to attach
657 # {xfModifier} - a optional modifier
658 # {xfCanvasTag} - a canvas tagOrId
659 # Returns: none
660 # Sideeffects: none
661 #------------------------------------------------------------------------
662 ###global tk_popupPriv
663
664 set tk_popupPriv($xfMenu,focus) ""
665 set tk_popupPriv($xfMenu,grab) ""
666 if {"$xfModifier" != ""} {
667 set press "$xfModifier-"
668 set motion "$xfModifier-"
669 set release "Any-"
670 } {
671 set press ""
672 set motion ""
673 set release ""
674 }
675
676 bind $xfMenu "<${motion}B${xfButton}-Motion>" "MenuPopupMotion $xfMenu %W %X %Y"
677 bind $xfMenu "<${release}ButtonRelease-${xfButton}>" "MenuPopupRelease $xfMenu %W"
678 if {"$xfCanvasTag" == ""} {
679 bind $xfW "<${press}ButtonPress-${xfButton}>" "MenuPopupPost $xfMenu %X %Y"
680 bind $xfW "<${release}ButtonRelease-${xfButton}>" "MenuPopupRelease $xfMenu %W"
681 } {
682 $xfW bind $xfCanvasTag "<${press}ButtonPress-${xfButton}>" "MenuPopupPost $xfMenu %X %Y"
683 $xfW bind $xfCanvasTag "<${release}ButtonRelease-${xfButton}>" "MenuPopupRelease $xfMenu %W"
684 }
685 }
686 }
687
688
689 # Procedure: MenuPopupMotion
690 if {"[info procs MenuPopupMotion]" == ""} {
691 proc MenuPopupMotion { xfMenu xfW xfX xfY} {
692 # xf ignore me 7
693 #------------------------------------------------------------------------
694 # Procedure: MenuPopupMotion
695 # Description: handle the popup menu motion
696 # Arguments: xfMenu - the topmost menu
697 # xfW - the menu
698 # xfX - the root x coordinate
699 # xfY - the root x coordinate
700 # Returns: none
701 # Sideeffects: none
702 #------------------------------------------------------------------------
703 global tk_popupPriv
704
705 if {"[info commands $xfW]" != "" && [winfo ismapped $xfW] &&
706 "[winfo class $xfW]" == "Menu" &&
707 [info exists tk_popupPriv($xfMenu,focus)] &&
708 "$tk_popupPriv($xfMenu,focus)" != "" &&
709 [info exists tk_popupPriv($xfMenu,grab)] &&
710 "$tk_popupPriv($xfMenu,grab)" != ""} {
711 set xfPopMinX [winfo rootx $xfW]
712 set xfPopMaxX [expr $xfPopMinX+[winfo width $xfW]]
713 if {$xfX >= $xfPopMinX && $xfX <= $xfPopMaxX} {
714 $xfW activate @[expr $xfY-[winfo rooty $xfW]]
715 if {![catch "$xfW entryconfig @[expr $xfY-[winfo rooty $xfW]] -menu" result]} {
716 if {"[lindex $result 4]" != ""} {
717 foreach binding [bind $xfMenu] {
718 bind [lindex $result 4] $binding [bind $xfMenu $binding]
719 }
720 }
721 }
722 } {
723 $xfW activate none
724 }
725 }
726 }
727 }
728
729
730 #------------------------------------------------------------------------
731 # Procedure: MenuPopupPost
732 if {"[info procs MenuPopupPost]" == ""} {
733 proc MenuPopupPost { xfMenu xfX xfY} {
734 # xf ignore me 7
735 ##########
736 # Procedure: MenuPopupPost
737 # Description: post the popup menu
738 # Arguments: xfMenu - the menu
739 # xfX - the root x coordinate
740 # xfY - the root x coordinate
741 # Returns: none
742 # Sideeffects: none
743 #------------------------------------------------------------------------
744 global tk_popupPriv
745
746 if {"[info commands $xfMenu]" != ""} {
747 if {![info exists tk_popupPriv($xfMenu,focus)]} {
748 set tk_popupPriv($xfMenu,focus) [focus]
749 } {
750 if {"$tk_popupPriv($xfMenu,focus)" == ""} {
751 set tk_popupPriv($xfMenu,focus) [focus]
752 }
753 }
754 set tk_popupPriv($xfMenu,grab) $xfMenu
755
756 catch "$xfMenu activate none"
757 catch "$xfMenu post $xfX $xfY"
758 catch "focus $xfMenu"
759 catch "grab -global $xfMenu"
760 }
761 }
762 }
763
764
765 #------------------------------------------------------------------------
766 # Procedure: MenuPopupRelease
767 if {"[info procs MenuPopupRelease]" == ""} {
768 proc MenuPopupRelease { xfMenu xfW} {
769 # xf ignore me 7
770 ##########
771 # Procedure: MenuPopupRelease
772 # Description: remove the popup menu
773 # Arguments: xfMenu - the topmost menu widget
774 # xfW - the menu widget
775 # Returns: none
776 # Sideeffects: none
777 #------------------------------------------------------------------------
778 global tk_popupPriv
779 global tk_version
780
781 if {"[info commands $xfW]" != "" && [winfo ismapped $xfW] &&
782 "[winfo class $xfW]" == "Menu" &&
783 [info exists tk_popupPriv($xfMenu,focus)] &&
784 "$tk_popupPriv($xfMenu,focus)" != "" &&
785 [info exists tk_popupPriv($xfMenu,grab)] &&
786 "$tk_popupPriv($xfMenu,grab)" != ""} {
787 if {$tk_version >= 3.0} {
788 catch "grab release $tk_popupPriv($xfMenu,grab)"
789 } {
790 catch "grab none"
791 }
792 catch "focus $tk_popupPriv($xfMenu,focus)"
793 set tk_popupPriv($xfMenu,focus) ""
794 set tk_popupPriv($xfMenu,grab) ""
795 if {"[$xfW index active]" != "none"} {
796 $xfW invoke active; catch "$xfMenu unpost"
797 }
798 }
799 catch "$xfMenu unpost"
800 }
801 }
802
803
804 #------------------------------------------------------------------------
805 # Procedure: NoFunction
806 if {"[info procs NoFunction]" == ""} {
807 proc NoFunction { args} {
808 # xf ignore me 7
809 ##########
810 # Procedure: NoFunction
811 # Description: do nothing (especially with scales and scrollbars)
812 # Arguments: args - a number of ignored parameters
813 # Returns: none
814 # Sideeffects: none
815 #------------------------------------------------------------------------
816 }
817 }
818
819
820 #------------------------------------------------------------------------
821 # Procedure: SN
822 if {"[info procs SN]" == ""} {
823 proc SN { {xfName ""}} {
824 # xf ignore me 7
825 ##########
826 # Procedure: SN
827 # Description: map a symbolic name to the widget path
828 # Arguments: xfName
829 # Returns: the symbolic name
830 # Sideeffects: none
831 #------------------------------------------------------------------------
832
833 SymbolicName $xfName
834 }
835 }
836
837
838 #------------------------------------------------------------------------
839 # Procedure: SymbolicName
840 if {"[info procs SymbolicName]" == ""} {
841 proc SymbolicName { {xfName ""}} {
842 # xf ignore me 7
843 ##########
844 # Procedure: SymbolicName
845 # Description: map a symbolic name to the widget path
846 # Arguments: xfName
847 # Returns: the symbolic name
848 # Sideeffects: none
849 #------------------------------------------------------------------------
850
851 global symbolicName
852
853 if {"$xfName" != ""} {
854 set xfArrayName ""
855 append xfArrayName symbolicName ( $xfName )
856 if {![catch "set \"$xfArrayName\"" xfValue]} {
857 return $xfValue
858 } {
859 if {"[info commands XFProcError]" != ""} {
860 XFProcError "Unknown symbolic name:\n$xfName"
861 } {
862 puts stderr "XF error: unknown symbolic name:\n$xfName"
863 }
864 }
865 }
866 return ""
867 }
868 }
869
870
871 #------------------------------------------------------------------------
872 # Procedure: Unalias
873 if {"[info procs Unalias]" == ""} {
874 proc Unalias { aliasName} {
875 # xf ignore me 7
876 ##########
877 # Procedure: Unalias
878 # Description: remove an alias for a procedure
879 # Arguments: aliasName - the alias name to remove
880 # Returns: none
881 # Sideeffects: internalAliasList is updated, and the alias
882 # proc is removed
883 #------------------------------------------------------------------------
884 global internalAliasList
885
886 set xfIndex [lsearch $internalAliasList "$aliasName *"]
887 if {$xfIndex != -1} {
888 rename $aliasName ""
889 set internalAliasList [lreplace $internalAliasList $xfIndex $xfIndex]
890 }
891 }
892 }
893
894 # eof for xf goo
895 #
896
897 # Generic right mouse button popup code
898 # for ascend iv
899 # By Ben Allan
900 # 4/16/98.
901 # Copyright 1998 Carnegie Mellon University
902
903 # the purpose of this is to make the menu go away
904 # while you hold down the button but only after you
905 # move the pointer outside the menu and after a delay
906 # so the slow wristed don't shoot.
907 # tk's MODEL of popups in unix is that they disappear
908 # after any kind of button event in any window (global
909 # focus and grab). This may be motif madness and may not
910 # be TRUE on windoze.
911 global ascPopdata
912 set ascPopdata(delay) 1000
913
914 #
915 #- widget is something largish, typically text or
916 # listbox, possibly frame, rarely a toplevel.
917 #- enabler is a function that returns normal or disabled
918 # as desired. if it returns an error or anything else or is
919 # not provided, the menu item will be disabled.
920 # If no function evaluation is necessary for proper use, "normal" and "disabled"
921 # may also be given for enabler.
922 # enabler functions can be entire scripts in braces.
923 # enabler functions will find %W %x and %y of the button press event
924 # that posted the menu stored in global array ascPopInfo should location
925 # information be needed. These are stored as pW, px, py respectively.
926 # The name of the popup menu is stored in ascPopInfo(menu) and the
927 # index of the entry being checked with the call to enabler is
928 # in ascPopInfo(index)
929 #- kind IS_A menu item type (separator, command, checkbutton, etc)
930 # and args is all the normal arguments to entryconfigure
931 # for a menu item.
932 #
933 # warning: handling cascades with this is messy. See BrowswerProc.tcl
934 # for and example of how to bind the cascade.
935 proc ascRightMouseAddCommand {widget enabler {kind command} args} {
936 global ascPopdata
937 set b $widget.childpop
938 # create if first entry
939 if {![winfo exists $b]} {
940 # build widget $widget.childpop
941 menu $b \
942 -tearoffcommand [string toupper $b] \
943 -tearoff 0
944
945 # make it go away when user leaves it for more than half a second
946 set ascPopdata($b.in) 0
947 bind $b <Leave> "
948 set ascPopdata($b.in) 0
949 set ascPopdata($b.id) \[after \$ascPopdata(delay) \{if \{!\$ascPopdata($b.in)\} \{ tkMenuUnpost $b \} \}\]
950 "
951 bind $b <Any-Enter> "
952 set ascPopdata($b.in) 1
953 catch \{after cancel \$ascPopdata($b.id)\}
954 ascRightMouseUpdateButtons $b %W %x %y
955 "
956 bind $widget <ButtonPress-3> "+
957 ascRightMouseUpdateButtons $b %W %x %y
958 tk_popup $b %X %Y
959 "
960 }
961 # add the entry to the widget
962 set cmd $b
963 append cmd " add $kind "
964 append cmd $args
965 eval $cmd
966 # add the command enabler
967 set n [$b index last]
968 set ascPopdata($b.enabler.$n) $enabler
969 }
970
971 # updates the state of menuentries of b
972 # according to their enablers.
973 # not yet very robust
974 proc ascRightMouseUpdateButtons {b pW px py} {
975 global ascPopdata ascPopInfo
976 set ascPopInfo(pW) $pW
977 set ascPopInfo(px) $px
978 set ascPopInfo(py) $py
979 set ascPopInfo(menu) $b
980 set n [$b index last]
981 for {set e 0} {$e <= $n} {incr e} {
982 set ascPopInfo(index) $e
983 switch $ascPopdata($b.enabler.$e) {
984 normal {
985 catch {$b entryconfigure $e -state normal}
986 }
987 disabled {
988 catch {$b entryconfigure $e -state disabled}
989 }
990 default {
991 set st disabled
992 catch {set st [$ascPopdata($b.enabler.$e)]} err
993 switch $st {
994 normal {
995 catch {$b entryconfigure $e -state normal}
996 }
997 default {
998 catch {$b entryconfigure $e -state disabled}
999 }
1000 }
1001 }
1002 }
1003 }
1004 }
1005

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22