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 |
|