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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 571 - (hide annotations) (download) (as text)
Tue May 9 00:14:59 2006 UTC (18 years, 1 month ago) by johnpye
File MIME type: text/x-tcl
File size: 29511 byte(s)
Renaming 'tcltk98' to 'tcltk', continued...
1 johnpye 571 # 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