Staging
v0.5.1
v0.5.1
https://github.com/python/cpython
Tip revision: c26ef13d23bab6328b4f9164b4eb3619c754c45f authored by cvs2svn on 30 September 2003, 07:10:26 UTC
This commit was manufactured by cvs2svn to create tag 'r232c1'.
This commit was manufactured by cvs2svn to create tag 'r232c1'.
Tip revision: c26ef13
tkpython.rsrc
> > ½· ½õ ²u ±u BÚyo `.;å <åÑå 4©Bg <£åµ]
tkpython.rsrc.crcpoolertAD MErl rsrcRSED ²ct© °0»~=G
. N^ _TONÐNV >(o.MgpB°Glàxü BïÏü B`\~B`XáP Zà_VáP
B2 xÁï)o áP
B0 å@VáP Z2 >Þ@`áP
BàÁßVáP ! ! ¨ », P ð
File Type: ò ` p&H&JMIh @ ð?ø?ú ÿ ÿoÿÿÿÿþþ?þ?ü üøøø H H Ò À Í
}uÀ
}uÌ]u÷]u×<ÕU××ÕUWÕÕU\5UU\
UU\
UUpUUp ÕUÀ 5UÀ 5UÀ ÿÿÿÿÿÿ ÿÿÌÌ ò `
°L
° ü þþ þ?þ?þ?ü üøøø H H Ò óÏ ]uðUUÜ ÕU\ÕU\
UU\
UU\
UUpUUp ÕUÀ 5UÀ 5UÀ ÿÿÿÿÿÿ ÿÿÌÌ Z ` À`ÿÿ @ÿÀ ÀàÿÿÿøÿàÿÀÿÀ H H ÿÿ ð 2%ð oÿÿÿÿÿÿÿ""""" ð """"!ð 3333O ÿÿÿÿÿ ÿÿÿÿÿÿ »»»»»» îîîîîî ÝÝÝÝÝÝ ÌÌÌÌÌÌ DDDDDD Z ` ø3ÌdfIOD"cÆ?ü)))+Ôix þþ ø?üþþþþþ?ü?ü?ü?ü?üþþþþ H H ÿÿÿÿð öÿÿPo `_ Võð ð!ó ð öñ ð _ õ ð`ÿÿPð ÿÿÿÿÿÿ ðð ðð ðð! ðð ñ ðð!ðôõ _Oðÿÿÿÿÿÿðÿÿÿÿÿÿð ÿÿÿÿÿÿ DDDDDD ªªªªªª îîîîîî UUUUUU ÝÝÝÝÝÝ wwwwww R ` ø 3ùpÐ
ÚUzU6í¡üøþ ÿ ÿ?ÿÿÿÿÿÿÿÿÿÿÿ?ÿ ÿ ÿþü H H ÿÿÿð ÿB""Oð B!"O ÿ ÿ ÿ$ÿÿÿô/_"""""/õ/"""""/ô"""""/ôOò"$ÿ/õ/òò////_òòS_// ÿOòóôÿ/ ""òò"/ B""""O ô"""$ð ÿÿÿÿ ÿÿÿÿÿÿ ÌÌff ÌÌÌÌÿÿ 3333ff ÿÿ ffffÌÌ R ` x p@6O°ð~0|008 ðà ü üàÿÿÿÿÿÿøÿøÿøÿüü?ø ð H H " aa D DDQ DDD DDQQ ## ÿÿÿÿÿÿ ÌÌff ÝÝ ÿÿff33 ÌÌÌÌÌÌ ÿÿÌÌ J ` ? ÀÈ ê È Ë ø88>&& . & !>ø? ÀÏàïàÏàÏàÿø?þææîæà ð?ø>ø H H ÿÿÿ ÿ ÿ ñ11ð ÿðóóóð ÿ ñ11ð ÿ òÿòð Oÿñ!!ÿð ÿòÿÿ@ ñ!!ðð òðð ñ/!ðÿð ò ðð ñ/!ð ñ!/!!ð ÿÿðÿÿð ÿÿÿÿÿÿ »» ÌÌÌÌÌÌ ªªªªªª DDDDDD ú ` >øcÁÀ` 00 `À >øüÿþÿþÿþÿþÿþÿþü?ø ðàÀ H H Ò üÿÀ:«ªpéæe¦\éæff\éÖff\5p
feÀY Ö\ 5p À ÿÿÿÿÿÿ ÝÝ ÿÿffÌÌ z ` ¾ ðè((èðþ ð ø ø ø ø ø ø ø ø ø ø øð H H yJð ð ÿÿÿÿ !ð 6UUcð 5Qð 533Qð 6UUað 3ð 3333ð 3333ð """"ð ð xð ÿÿÿÿ ÿÿÿÿÿÿ îîîîîî ÌÌÌÌÌÌ ÝÝÝÝÝÝ DDDDDD """""" UUUUUU ªªªªªª »»»»»» wwwwww
R ` ð p @@ ð øøððàÀÀ H H ÿÿ ôð @Bð ô/ õ?ÿ óRð 5 S/ õ2ð óð 5/ ÿð ÿ ð ÿÿÿÿÿÿ ÌÌÌÌÌÌ ÿÿÿÿ ÝÝ ÿÿff33 R ` p øÞÞ ÞÞÞÞÞ1ÞqÞýÞ x 0 p øþþþ þ þ þ þ?þþÿþø x 0
H H ð ? óCð 4?ð O4?ð õ_4?ð P_4?ð _4?ð _4?ð _4?ð ó _4?ð3P_4?ðÿó?O4?ð ð " ÿÿÿÿÿÿ ÿÿff33 ÝÝ DDDDDD ÝÝÝÝÝÝ z ` @
@? ! 9 ) 9 ) 9 9 ! ! ? ? ? ? ? ? ? ? ? ? ? ? H H ` ÿ ` 3ð` ð ÿÿÿ ø õ÷ ú÷ ù÷ ú÷ ù÷ õ÷ ø ø ÿÿÿ ÿÿÿÿÿÿ ªªªªªª wwwwww UUUUUU """""" DDDDDD »»»»»» ÝÝÝÝÝÝ îîîîîî ffffÌÌ
ÌÌÌÌÿÿ ò ` @@@98À88 $H((0 ÀÀÀ?øÿþ?øà ð<x880 H H Ò
À
À
À 5p 5p 5p ×_ÀõUU|Õ_À ×\ \×
p5À
À
À À À ÿÿÿÿÿÿ ÿÿÿÿ R ` ÀàààÀ
` Àà ð ð ðàÀ ð ð ð p p H H ÿð 1? ó"#ð ñð óð 1? ÿð ðÿðð ÿð @ @ @ @ @ @ ÿÿÿÿÿÿ îîîîîî ÿÿ ÝÝÝÝÝÝ 3333ff ÝÝ B ` ààààààààààààð ø ø ø ø ø øðàààà
H H ÿÿð ÿÿð ÿÿð ÿÿð ð / "ò!ð ""ñ#ð "ñ!ÿ "ÿñ#ÿ ""!ð """ð ñ11? ÿÿð ÿÿð ÿÿð ÿÿð ÿÿÿÿÿÿ ÌÌÌÌÌÌ îîîîîî »»»»»» Dp&H&JMIh @ ð?ø?ú ÿ ÿoÿÿÿÿþþ?þ?ü üøøø D @ 0
!,L À ðøü ü?ì Ì
D 1J@J@?
?J@JF1 1{ÀÿàÿàÀ?Àÿæÿï{Ï1 Dÿÿ¿¡¡ù¡¡¿
ýýÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ D ÿ ~ ¸(@ " D H ° @ ÿ ~ øøèÀ > | x ð @ D ÿ ~ ¸(À > | x ð @ ÿ ~ øøèÀ > | x ð @ D`'XhP( ¯Ô¯Ô P(Xh'| à?ðxxp8à ïÜïÜà p8xx?ø ü D`'XhS(£¯Ô¯Ô£S(Xh'| à?ðxxs8ã ïÜïÜã s8xx?ø ü Dàðø |>>| øðààð ø>||>ø ðà `p8 8pàÀÀàp 88 p` D |üø øð° 8 p þþ üüøøð p>`|`ø@p@ D à à @ à à?ð àÀ D @ à à À à?ð à à D À`ÿÿ @ÿÀ ÀàÿÿÿøÿàÿÀÿÀ D q üQQQQüq üüüüüü D À À È@ÈÉ Ê Ì ÏÀÀ À ÿðÿð @
À D S 3ó ÿÿ P 0ð D @ üü @ D þþ Dÿþ ¿þ ¯ú¨
«êª*ªª«ª¨*¯ê
¿úÿþ D ÀÀ à à30# ÀÀ à à?ð?ðøw¸g D Àð ø<<8 pppp8 << øðÀ Àð ø?üþ|>ø ø ø ø |>þ?ü øðÀ D ø3ÌdfIOD"cÆ?ü)))+Ôix þþ ø?üþþþþþ?ü?ü?ü?ü?üþþþþ Dø 3ùpÐ
ÚUzU6í¡üøþ ÿ ÿ?ÿÿÿÿÿÿÿÿÿÿÿ?ÿ ÿ ÿþü Dþþ þþ ÿþÿþÿþ DB¢R*¨Ð
ý~ý~
Ð*¨R¢B Cãs;¸ ðàÿþÿþÿþà ð;¸sãC D þþ DÀ
"Bþþ þþB"
À Àà ð>ø~üþþ þþ~ü>ø ðàÀ D à à?ð?ð?ð?ð à à à?ð?ðøøøø?ð?ð à D ?ü !! ?ü ?ü?ü0 0 13Ì3Ì10 0 ?ü?ü D Àà
°
°àÀ Ààð ø?ü;ÜÀÀ;Ü?ü øðàÀ D < øøð ð``@@ @ > þüü?øÿøððà à8ÀpÀà@ D < øø p ° @ > þüü?øøðp` `8@p@à @ D ?ü"D&d,48 !!8 ,4&d"D?ü ?ü>|>|<<9#Ä#Ä9<<>|>|?ü D GÀoà|0HL ~ ü d$|ìÄ ÇÀïàÿðÿøü8þÿ ÿþþþ8~?þ þîÆ D Àà1þþ1àÀ Ààðè;Üþÿÿÿÿþ;ÜèðàÀ D x p@6O°ð~0|008 ðà ü üàÿÿÿÿÿÿøÿøÿøÿüü?ø ð D? ÀÈ ê È Ë ø88>&& . & !>ø? ÀÏàïàÏàÏàÿø?þææîæà ð?ø>ø D < ðàÀàð/àð_ðàÀJ b 4 < ðàÀàð/àððàÀ~ ~ <
D ?À@ ?"A$ P ?Àà?ðøøøüþÿþü ø p D >øcÁÀ` 00 `À >øüÿþÿþÿþÿþÿþÿþü?ø ðàÀ DÿÿÕUª«ÕU РРРЪ«ÕUª«ÿÿÿÿÿÿÿÿÿÿððððððððÿÿÿÿÿÿÿÿ D ?ü øOògæsÎyþþysÎgæOò ø?ü þþÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿþþ D Ààð
À À ` ` À à ð ø ü À ààð ð p D ` ` `a b d oüd b a `` ` ü D øø DüüDDETETETETDDüüüüüüÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþ D øø D 0 0 0 0 0 0 0 ð ð D ð C$K p@@@ Px<ø? ð C'Ë ðÀÀÀà ð px<ø? DüüDDTTTTTTTTDDüüüüüüÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþ D ðè((èð ð ø ø ø ø ø ø ø ø ø ø øð D ð p @@ ð øøððàÀÀ DÀàððàÀCÂCÃ! 8Àñx @àð ø?ü?ü øðGâççççÿ?ü ùÿÿÿø
D ø ø DÀà p0 0 p àÀàÀ ?ø ðàÀ D 0 p ðððððð° 8 x øøøøø ø?øø¸ D F &?ö & F @ ?ð @ D 0 0 0 0 0 0 ð ð 0 0 0 0 0 0
DüüDDUDUDUDUDDDüüüüüüÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþÿþ D þ@"@"@"âD"D"D"D"GþDDDþ þþ`vöö|6l6l6l>oþoþnþþ D @ @```pppxx x |>8 @ ààðððøøø ü ü?ü?þ|~8 DàÀ ðàÀ D ?üx ?ü 8 þÿÿþ8 D ?ÿx ?ÿ 8 ÿÿÿÿ8 D ÿü ÿü ÿþÿÿÿþ D Ààð@@@@@@@@@@@ ÀàðøÀÀÀÀÀÀÀÀÀÀÀ D ÀààÀ Àà ð ðàÀ D p øÞÞ ÞÞÞÞÞ1ÞqÞýÞ x 0 p øþþþ þ þ þ þ?þþÿþø x 0
D @ @ @ GàD D"D""â
þ ÿÀÿÀÿÀà ïðïðì7ì7ì7ì7÷ÿ ÿÿÿ D @@g à àg@@ p88p8p àçïßÿÿøøÿÿïßç à8p8pp8 D @
@? ! 9 ) 9 ) 9 9 ! ! ? ? ? ? ? ? ? ? ? ? ? ? D @@@98À88 $H((0 ÀÀÀ?øÿþ?øà ð<x880 D à p0` ÁÂÁ` 0 pà à ð<xp ãããp <x ðà D ÿþ D ` x > ? à
@ à ø þ à?ø?þ Ààp8 DÿðÿðÀ À ÏÀÌ Ê É ÈÈ@À À À
@ Dÿÿ ó 3 S ð 0 P D üü @ @ D þþ D ÀàààÀ
` Àà ð ð ðàÀ ð ð ð p p D øø D (I¦'È0a @@ ð øþüÿþû¾ãÀààÀ D ð ð 0 0 0 0 0 0 0 Dààààààààààààð ø ø ü ü ø øðàààà
D ` ` ® ü LOpen h ü |LCancel ë Q ü 4LEject < ü PLDesktop æ æ [ û \MÀ ¨ », U k (
ÃX Î`
MDEFO Nú NuHç0Oïÿî8/ 6$o &&|MDEFYO.¸ T.UO>¸
?_ UO>¸
?_ xÿÿ \f x \ P/h /h
D f6?// 4// 4// 4/
Ho N/!ß T?/ 1ß
?/ 1ß
D f*¶Rg& xÿÿ \g x \ P!o !o
!ï ú!ï þOï Lß Nt ÿÿ ¤¤ d D ÿ ÿþ H H d D
d D D d D H H Ø ZZ ÿ76ÿ ÿ ÿ 55ÿ ÿ Ì 44ÿ ÿ 33ÿ ÿ f 76ÿ ÿ 3 55ÿ ÿ 44ÿ Ì ÿ 33ÿ Ì Ì 76ÿ Ì 55ÿ Ì f úúÿ Ì 3 33ÿ Ì 10ÿ ÿ //ÿ Ì úúÿ ùùÿ f 10ÿ 3 //ÿ ..ÿ f ÿ ùùÿ f Ì 10ÿ f //ÿ f f ..ÿ f 3 --ÿ f 10ÿ 3 ÿ //ÿ 3 Ì ..ÿ 3 --ÿ 3 f 10ÿ 3 3 //ÿ 3 ..ÿ ÿ --ÿ Ì 10ÿ //ÿ f ..ÿ 3 -øÿ +*Ì ÿ ÿ ))Ì ÿ Ì ((Ì ÿ 'øÌ ÿ f +*Ì ÿ 3 ))Ì ÿ ((Ì Ì ÿ ''Ì Ì Ì +*Ì Ì ))Ì Ì f ((Ì Ì 3 ''Ì Ì +*Ì ÿ ))Ì Ì ((Ì ''Ì f ÛÛÌ 3 GGÌ FFÌ f ÿ EEÌ f Ì ÛÛÌ f GGÌ f f FFÌ f 3 EEÌ f ÛÛÌ 3 ÿ GGÌ 3 Ì FFÌ 3 EEÌ 3 f ÛÛÌ 3 3 AAÌ 3 @@Ì ÿ ??Ì Ì CBÌ AAÌ f @@Ì 3 ??Ì CB ÿ ÿ AA ÿ Ì @@ ÿ ?? ÿ f CB ÿ 3 AA ÿ @@ Ì ÿ ?? Ì Ì CB Ì AA Ì f @@ Ì 3 ?? Ì CB ÿ AA Ì @@ ?? f =< 3 ;; :: f ÿ 99 f Ì =< f ;; f f :: f 3 99 f =< 3 ÿ ;; 3 Ì :: 3 99 3 f =< 3 3 ;; 3 :: ÿ 99 Ì =< ;; f :: 3 99 =<f ÿ ÿ ;;f ÿ Ì ::f ÿ 99f ÿ f =<f ÿ 3 ;;f ÿ ::f Ì ÿ 99f Ì Ì 76f Ì 55f Ì f 44f Ì 3 33f Ì 76f ÿ 55f Ì 44f 33f f 76f 3 55f 44f f ÿ 33f f Ì 76f f 55f f f 44f f 3 33f f 76f 3 ÿ 55f 3 Ì 44f 3 33f 3 f 76f 3 3 55f 3 44f ÿ 33f Ì 10f //f f ..f 3 ùùf 103 ÿ ÿ //3 ÿ Ì ..3 ÿ ùù3 ÿ f 103 ÿ 3 //3 ÿ ..3 Ì ÿ --3 Ì Ì 103 Ì //3 Ì f ..3 Ì 3 --3 Ì 103 ÿ //3 Ì ..3 --3 f 103 3 //3 ..3 f ÿ -ø3 f Ì +*3 f ))3 f f ((3 f 3 'ø3 f +*3 3 ÿ ))3 3 Ì ((3 3 ''3 3 f +*3 3 3 ))3 3 ((3 ÿ ''3 Ì +*3 ))3 f ((3 3 ''3 IH ÿ ÿ GG ÿ Ì FF ÿ EE ÿ f IH ÿ 3 GG ÿ FF Ì ÿ EE Ì Ì IH Ì GG Ì f FF Ì 3 EE Ì CB ÿ AA Ì @@ ?? f CB 3 AA @@ f ÿ ?? f Ì CB f AA f f @@ f 3 ?? f CB 3 ÿ AA 3 Ì @@ 3 ?? 3 f CB 3 3 AA 3 @@ ÿ ?? Ì CB AA f @@ 3 ??î =<Ý ;;» ::ª 99 =<w ;;U ::D 99" =< ;; î :: Ý 99 » =< ª ;; :: w 99 U =< D ;; " :: 99 î =< Ý ;; » :: ª 99 =< w ;; U :: D 99 " 76 55î î î 44Ý Ý Ý 33» » » 76ª ª ª 55 44w w w 33U U U 76D D D 55" " " 44 33 d D d D
d D½ è õöþþ223ý9 æ ü õõþ þ223þ9 :ü@òA@3é ü@ÜA9õõ õõöþ 2ÕA@923ý9 :ü@üA2 ÁA ÁA ÁA ÁA ÂA@õ èAGGÝA@ ðA GúA;;ÝA@ ñA G; ;GAAG;GßA: öðA þAG;;ÞA9 õ@óA G;;GAGA ;GGÞA9 õ@óAG þAGAGÜA3 @óAGGþA5G÷AýGéA2 @òA;GAG5 ÷AGA9@GêA ! @òA;GAA 5GùAG@þ ö@GëA # @óAG5AAG;AGúA G:ö õOUõGëA " :óAG;þA ùAG:õ UÈþÎV@ëA 9ðAGA;GûAG@õõ¤üÎÈ]ëAö 9ðAG;AGüAG@öÈúÎ dìA@õ 9ðAG úAG*ÈúÎdØìA @þ % 9ïA ;GüAGõ¤ûÎÈØüAþGüA GùA :þ ( 9ïA ;GýAG9 ¤úÎ «úA ;;AAG; ;GúA 9þ $ 3ñAGA úAyùÎ dúA5 ýA ùA 9þ ( 2ñAG; üAG9öùÎØûAGA þAG ùA 9þ , 2ñAG;ûAyúΪ@AAGGþA
GAGAAG5GúA 2þ / ñAG;GþAG@öÈúÎdØA@99þAG;;GþA5AGúA þ ' ñAG;;GþAGyúÎ A@2õ :GAG;òA þ ' ñAG;;GýA¤úΫªþÈy 9GAG GóA þ êA@+ÈõÎ 3GAA ;GóA þ ëAG:UôÎ] 9GGA ñA öþ ëAG9yôÎ9 9GG5GóA@õþ ëAG9¤õΫ @GAAGóA @ý ëAG9¤õÎAGAGòA @ý ëAG9ÈõÎcõ2GG;;GòA :ý ö@ìAG9ÈõÎ9õ@GA;ðA 9ý õ@ëA@ÈýÎȤüΫGíA 9ý þ @ëA @üΤÈüÎú@GíA 2ý þ @êA ªþÎùÈüÎVGìA 2ý þ @êA «þÎdVÈýÎÈ2êA ý þ @íA@GþÎ@UüÎú@êA ý þ :íA@ûÎΫ9yýÎ «èA ý þ :íA ö¤ÎÎ3yýÎAGGêA ý þ 9íA*¤ÈÎÎþÎd 99ëA@õý þ 9íAOýÎd÷¤þΫöëA @ü þ 9íAyþΫ@+¤üÎ÷GìA @ü þ 9íAyþΫ@öÈüÎöGìA @ü þ :îAGyþΫ@õÈýΤõ:GìA @ü þ :îAGVþÎû:öÈýÎõ@ëA@õý þ @îA GVÎÎÈ9öÈýÎV@ëA@õý þ @îA G92ÎÎÈ9*ÈýÎVéA öý þ @îAG:2ÎÎÈd*üÎ2éA ý þ @íA@2«ÎÈd9NüÎ:éA ý õ@íA@«ÎÎdNýΫ@@êA ý õ@ìAÎÎd3NýΫ@éA ý öìAGúÎÎd3NýÎGêA ý ìAGùÎÈd3NýÎc@GêA ý ëA@ùÎÈd9NýÎ9@GéA 2ý êA9ÎÎ9öþΫAA9@êA 2ý ëAG:ÈÎ9öÈÎÎdöõ@êA 3ý êA @¤Î9*ÈΫA@øöéA 9ý ëA
GA«È9õÈΫ«Î¤éA 9ý íA G99GÈ«@õÈýΤéA 9ý íA G: Ϋ@õÈýÎUGêA 9ý ëAyÈÎÎ@ö¤ýÎ+9GêA :ý ìAG9yþÎd¤þΤ@éA @ý 2êA2¤ÎÎyþÎùGéA @ý 2ëAG@÷ÈÎyþÎ2@èA @ý 3êA G@øÈ«UÎÎGèA @ý 3éAG@ù¤9OÎÎ]æA@õþ 9èAGdû9+È«äA öþ 9åA@ödäA þ 9ëA:ýA@GöA@9GôA þ ' 9ûAGGòA @þA9GüAGGüA9 9GôA þ ) 9ûA@9óA Gõ@AAG3GüA9:ýAG9 9GôA þ 6 :üAG @üAGA@üA Gõ@AAG3GþAG@ GþAG9 9Aþ@÷A þ : :ýAG@ @GAAG99@þAGõ@AAG9üA 9þAG9 9@9÷A þ 5 @ûA @þA
G@ 9A 2GAAGõ@þA@üA: ýAG9 993õA þ 9 @üAG @þAG2 @A9@þAGõ@ýA@þAG@ GþAG9 õ@GöA 2þ : @üA G @GAAG @GGýAGõ@þA
G9GAAG@ GþAG9 AG÷A 2þ 8 @üAG ýAG9 :G@9þAGõýA
G33GAAG@ GþAG9 99 öA 3þ : õ@üAG2 9ýA @3:GAA:õ9þAG:ýA@õ3@AA@ @ @øA 9þ ) õ@úA99ûA::@ýAý@ýA@@ýA@9@ýAú@÷A 9þ * öùAGGûAGGûAGGûA9@ýAGGûA GþA GöA 9þ
áA @äA :þ ÃA :þ ÃA @þ ÃA @þ ÃA @þ
ÃA@õ ÂAö ÂA ÂA íAþ@ :ù@âA + 2ùAþ@þ92öõø õõöûû2233û9::û@
992öõÈ ½ ÿ à À à ð ø ü ø ð à À " A ã" " " > øðÄðòp p0 ð äàÎ` 1 c c ?ø ðàÀ Àà ð?ø
XÀ ,## tk.tcl --
#
# Initialization script normally executed in the interpreter for each
# Tk-based application. Arranges class bindings for widgets.
#
# RCS: @(#) $Id: tk.tcl,v 1.20.2.2 2001/10/19 17:33:00 hobbs Exp $
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Insist on running with compatible versions of Tcl and Tk.
package require -exact Tk 8.3
package require -exact Tcl 8.3
# Add Tk's directory to the end of the auto-load search path, if it
# isn't already on the path:
if {[info exists auto_path] && [string compare {} $tk_library] && \
[lsearch -exact $auto_path $tk_library] < 0} {
lappend auto_path $tk_library
}
# Turn off strict Motif look and feel as a default.
set tk_strictMotif 0
# Turn on useinputmethods (X Input Methods) by default.
# We catch this because safe interpreters may not allow the call.
catch {tk useinputmethods 1}
# Create a ::tk namespace
namespace eval ::tk {
}
# ::tk::PlaceWindow --
# place a toplevel at a particular position
# Arguments:
# toplevel name of toplevel window
# ?placement? pointer ?center? ; places $w centered on the pointer
# widget widgetPath ; centers $w over widget_name
# defaults to placing toplevel in the middle of the screen
# ?anchor? center or widgetPath
# Results:
# Returns nothing
#
proc ::tk::PlaceWindow {w {place ""} {anchor ""}} {
wm withdraw $w
update idletasks
set checkBounds 1
if {[string equal -len [string length $place] $place "pointer"]} {
## place at POINTER (centered if $anchor == center)
if {[string equal -len [string length $anchor] $anchor "center"]} {
set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]
set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]
} else {
set x [winfo pointerx $w]
set y [winfo pointery $w]
}
} elseif {[string equal -len [string length $place] $place "widget"] && \
[winfo exists $anchor] && [winfo ismapped $anchor]} {
## center about WIDGET $anchor, widget must be mapped
set x [expr {[winfo rootx $anchor] + \
([winfo width $anchor]-[winfo reqwidth $w])/2}]
set y [expr {[winfo rooty $anchor] + \
([winfo height $anchor]-[winfo reqheight $w])/2}]
} else {
set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
set checkBounds 0
}
if {$checkBounds} {
if {$x < 0} {
set x 0
} elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} {
set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}]
}
if {$y < 0} {
set y 0
} elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} {
set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}]
}
}
wm geometry $w +$x+$y
wm deiconify $w
}
# ::tk::SetFocusGrab --
# swap out current focus and grab temporarily (for dialogs)
# Arguments:
# grab new window to grab
# focus window to give focus to
# Results:
# Returns nothing
#
proc ::tk::SetFocusGrab {grab {focus {}}} {
set index "$grab,$focus"
upvar ::tk::FocusGrab($index) data
lappend data [focus]
set oldGrab [grab current $grab]
lappend data $oldGrab
if {[winfo exists $oldGrab]} {
lappend data [grab status $oldGrab]
}
# The "grab" command will fail if another application
# already holds the grab. So catch it.
catch {grab $grab}
if {[winfo exists $focus]} {
focus $focus
}
}
# ::tk::RestoreFocusGrab --
# restore old focus and grab (for dialogs)
# Arguments:
# grab window that had taken grab
# focus window that had taken focus
# destroy destroy|withdraw - how to handle the old grabbed window
# Results:
# Returns nothing
#
proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {
set index "$grab,$focus"
foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break }
unset ::tk::FocusGrab($index)
catch {focus $oldFocus}
grab release $grab
if {[string equal $destroy "withdraw"]} {
wm withdraw $grab
} else {
destroy $grab
}
if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
if {[string equal $oldStatus "global"]} {
grab -global $oldGrab
} else {
grab $oldGrab
}
}
}
# ::tk::GetSelection --
# This tries to obtain the default selection.
# This shadows the 8.4 version which handles UTF8_STRING as well.
# Arguments:
# w The widget for which the selection will be retrieved.
# Important for the -displayof property.
# sel The source of the selection (PRIMARY or CLIPBOARD)
# Results:
# Returns the selection, or an error if none could be found
#
proc ::tk::GetSelection {w {sel PRIMARY}} {
if {[catch {selection get -displayof $w -selection $sel} txt]} {
return -code error "could not find default selection"
} else {
return $txt
}
}
# tkScreenChanged --
# This procedure is invoked by the binding mechanism whenever the
# "current" screen is changing. The procedure does two things.
# First, it uses "upvar" to make global variable "tkPriv" point at an
# array variable that holds state for the current display. Second,
# it initializes the array if it didn't already exist.
#
# Arguments:
# screen - The name of the new screen.
proc tkScreenChanged screen {
set x [string last . $screen]
if {$x > 0} {
set disp [string range $screen 0 [expr {$x - 1}]]
} else {
set disp $screen
}
uplevel #0 upvar #0 tkPriv.$disp tkPriv
global tkPriv
global tcl_platform
if {[info exists tkPriv]} {
set tkPriv(screen) $screen
return
}
array set tkPriv {
activeMenu {}
activeItem {}
afterId {}
buttons 0
buttonWindow {}
dragging 0
focus {}
grab {}
initPos {}
inMenubutton {}
listboxPrev {}
menuBar {}
mouseMoved 0
oldGrab {}
popup {}
postedMb {}
pressX 0
pressY 0
prevPos 0
selectMode char
}
set tkPriv(screen) $screen
set tkPriv(tearoff) [string equal $tcl_platform(platform) "unix"]
set tkPriv(window) {}
}
# Do initial setup for tkPriv, so that it is always bound to something
# (otherwise, if someone references it, it may get set to a non-upvar-ed
# value, which will cause trouble later).
tkScreenChanged [winfo screen .]
# tkEventMotifBindings --
# This procedure is invoked as a trace whenever tk_strictMotif is
# changed. It is used to turn on or turn off the motif virtual
# bindings.
#
# Arguments:
# n1 - the name of the variable being changed ("tk_strictMotif").
proc tkEventMotifBindings {n1 dummy dummy} {
upvar $n1 name
if {$name} {
set op delete
} else {
set op add
}
event $op <<Cut>> <Control-Key-w>
event $op <<Copy>> <Meta-Key-w>
event $op <<Paste>> <Control-Key-y>
}
#----------------------------------------------------------------------
# Define common dialogs on platforms where they are not implemented
# using compiled code.
#----------------------------------------------------------------------
if {[string equal [info commands tk_chooseColor] ""]} {
proc tk_chooseColor {args} {
return [eval tkColorDialog $args]
}
}
if {[string equal [info commands tk_getOpenFile] ""]} {
proc tk_getOpenFile {args} {
if {$::tk_strictMotif} {
return [eval tkMotifFDialog open $args]
} else {
return [eval ::tk::dialog::file::tkFDialog open $args]
}
}
}
if {[string equal [info commands tk_getSaveFile] ""]} {
proc tk_getSaveFile {args} {
if {$::tk_strictMotif} {
return [eval tkMotifFDialog save $args]
} else {
return [eval ::tk::dialog::file::tkFDialog save $args]
}
}
}
if {[string equal [info commands tk_messageBox] ""]} {
proc tk_messageBox {args} {
return [eval tkMessageBox $args]
}
}
if {[string equal [info command tk_chooseDirectory] ""]} {
proc tk_chooseDirectory {args} {
return [eval ::tk::dialog::file::chooseDir::tkChooseDirectory $args]
}
}
#----------------------------------------------------------------------
# Define the set of common virtual events.
#----------------------------------------------------------------------
switch $tcl_platform(platform) {
"unix" {
event add <<Cut>> <Control-Key-x> <Key-F20>
event add <<Copy>> <Control-Key-c> <Key-F16>
event add <<Paste>> <Control-Key-v> <Key-F18>
event add <<PasteSelection>> <ButtonRelease-2>
# Some OS's define a goofy (as in, not <Shift-Tab>) keysym
# that is returned when the user presses <Shift-Tab>. In order for
# tab traversal to work, we have to add these keysyms to the
# PrevWindow event.
# The info exists is necessary, because tcl_platform(os) doesn't
# exist in safe interpreters.
if {[info exists tcl_platform(os)]} {
switch $tcl_platform(os) {
"IRIX" -
"Linux" { event add <<PrevWindow>> <ISO_Left_Tab> }
"HP-UX" {
# This seems to be correct on *some* HP systems.
catch { event add <<PrevWindow>> <hpBackTab> }
}
}
}
trace variable tk_strictMotif w tkEventMotifBindings
set tk_strictMotif $tk_strictMotif
}
"windows" {
event add <<Cut>> <Control-Key-x> <Shift-Key-Delete>
event add <<Copy>> <Control-Key-c> <Control-Key-Insert>
event add <<Paste>> <Control-Key-v> <Shift-Key-Insert>
event add <<PasteSelection>> <ButtonRelease-2>
}
"macintosh" {
event add <<Cut>> <Control-Key-x> <Key-F2>
event add <<Copy>> <Control-Key-c> <Key-F3>
event add <<Paste>> <Control-Key-v> <Key-F4>
event add <<PasteSelection>> <ButtonRelease-2>
event add <<Clear>> <Clear>
}
}
# ----------------------------------------------------------------------
# Read in files that define all of the class bindings.
# ----------------------------------------------------------------------
if {[string compare $tcl_platform(platform) "macintosh"] && \
[string compare {} $tk_library]} {
source [file join $tk_library button.tcl]
source [file join $tk_library entry.tcl]
source [file join $tk_library listbox.tcl]
source [file join $tk_library menu.tcl]
source [file join $tk_library scale.tcl]
source [file join $tk_library scrlbar.tcl]
source [file join $tk_library text.tcl]
}
# ----------------------------------------------------------------------
# Default bindings for keyboard traversal.
# ----------------------------------------------------------------------
event add <<PrevWindow>> <Shift-Tab>
bind all <Tab> {tkTabToWindow [tk_focusNext %W]}
bind all <<PrevWindow>> {tkTabToWindow [tk_focusPrev %W]}
# tkCancelRepeat --
# This procedure is invoked to cancel an auto-repeat action described
# by tkPriv(afterId). It's used by several widgets to auto-scroll
# the widget when the mouse is dragged out of the widget with a
# button pressed.
#
# Arguments:
# None.
proc tkCancelRepeat {} {
global tkPriv
after cancel $tkPriv(afterId)
set tkPriv(afterId) {}
}
# tkTabToWindow --
# This procedure moves the focus to the given widget. If the widget
# is an entry, it selects the entire contents of the widget.
#
# Arguments:
# w - Window to which focus should be set.
proc tkTabToWindow {w} {
if {[string equal [winfo class $w] Entry]} {
$w selection range 0 end
$w icursor end
}
focus $w
}
,ÿ# button.tcl --
#
# This file defines the default bindings for Tk label, button,
# checkbutton, and radiobutton widgets and provides procedures
# that help in implementing those bindings.
#
# RCS: @(#) $Id: button.tcl,v 1.6 1999/09/02 17:02:52 hobbs Exp $
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#-------------------------------------------------------------------------
# The code below creates the default class bindings for buttons.
#-------------------------------------------------------------------------
if {[string match "macintosh" $tcl_platform(platform)]} {
bind Radiobutton <Enter> {
tkButtonEnter %W
}
bind Radiobutton <1> {
tkButtonDown %W
}
bind Radiobutton <ButtonRelease-1> {
tkButtonUp %W
}
bind Checkbutton <Enter> {
tkButtonEnter %W
}
bind Checkbutton <1> {
tkButtonDown %W
}
bind Checkbutton <ButtonRelease-1> {
tkButtonUp %W
}
}
if {[string match "windows" $tcl_platform(platform)]} {
bind Checkbutton <equal> {
tkCheckRadioInvoke %W select
}
bind Checkbutton <plus> {
tkCheckRadioInvoke %W select
}
bind Checkbutton <minus> {
tkCheckRadioInvoke %W deselect
}
bind Checkbutton <1> {
tkCheckRadioDown %W
}
bind Checkbutton <ButtonRelease-1> {
tkButtonUp %W
}
bind Checkbutton <Enter> {
tkCheckRadioEnter %W
}
bind Radiobutton <1> {
tkCheckRadioDown %W
}
bind Radiobutton <ButtonRelease-1> {
tkButtonUp %W
}
bind Radiobutton <Enter> {
tkCheckRadioEnter %W
}
}
if {[string match "unix" $tcl_platform(platform)]} {
bind Checkbutton <Return> {
if {!$tk_strictMotif} {
tkCheckRadioInvoke %W
}
}
bind Radiobutton <Return> {
if {!$tk_strictMotif} {
tkCheckRadioInvoke %W
}
}
bind Checkbutton <1> {
tkCheckRadioInvoke %W
}
bind Radiobutton <1> {
tkCheckRadioInvoke %W
}
bind Checkbutton <Enter> {
tkButtonEnter %W
}
bind Radiobutton <Enter> {
tkButtonEnter %W
}
}
bind Button <space> {
tkButtonInvoke %W
}
bind Checkbutton <space> {
tkCheckRadioInvoke %W
}
bind Radiobutton <space> {
tkCheckRadioInvoke %W
}
bind Button <FocusIn> {}
bind Button <Enter> {
tkButtonEnter %W
}
bind Button <Leave> {
tkButtonLeave %W
}
bind Button <1> {
tkButtonDown %W
}
bind Button <ButtonRelease-1> {
tkButtonUp %W
}
bind Checkbutton <FocusIn> {}
bind Checkbutton <Leave> {
tkButtonLeave %W
}
bind Radiobutton <FocusIn> {}
bind Radiobutton <Leave> {
tkButtonLeave %W
}
if {[string match "windows" $tcl_platform(platform)]} {
#########################
# Windows implementation
#########################
# tkButtonEnter --
# The procedure below is invoked when the mouse pointer enters a
# button widget. It records the button we're in and changes the
# state of the button to active unless the button is disabled.
#
# Arguments:
# w - The name of the widget.
proc tkButtonEnter w {
global tkPriv
if {[string compare [$w cget -state] "disabled"] \
&& [string equal $tkPriv(buttonWindow) $w]} {
$w configure -state active -relief sunken
}
set tkPriv(window) $w
}
# tkButtonLeave --
# The procedure below is invoked when the mouse pointer leaves a
# button widget. It changes the state of the button back to
# inactive. If we're leaving the button window with a mouse button
# pressed (tkPriv(buttonWindow) == $w), restore the relief of the
# button too.
#
# Arguments:
# w - The name of the widget.
proc tkButtonLeave w {
global tkPriv
if {[string compare [$w cget -state] "disabled"]} {
$w configure -state normal
}
if {[string equal $tkPriv(buttonWindow) $w]} {
$w configure -relief $tkPriv(relief)
}
set tkPriv(window) ""
}
# tkCheckRadioEnter --
# The procedure below is invoked when the mouse pointer enters a
# checkbutton or radiobutton widget. It records the button we're in
# and changes the state of the button to active unless the button is
# disabled.
#
# Arguments:
# w - The name of the widget.
proc tkCheckRadioEnter w {
global tkPriv
if {[string compare [$w cget -state] "disabled"] \
&& [string equal $tkPriv(buttonWindow) $w]} {
$w configure -state active
}
set tkPriv(window) $w
}
# tkButtonDown --
# The procedure below is invoked when the mouse button is pressed in
# a button widget. It records the fact that the mouse is in the button,
# saves the button's relief so it can be restored later, and changes
# the relief to sunken.
#
# Arguments:
# w - The name of the widget.
proc tkButtonDown w {
global tkPriv
set tkPriv(relief) [$w cget -relief]
if {[string compare [$w cget -state] "disabled"]} {
set tkPriv(buttonWindow) $w
$w configure -relief sunken -state active
}
}
# tkCheckRadioDown --
# The procedure below is invoked when the mouse button is pressed in
# a button widget. It records the fact that the mouse is in the button,
# saves the button's relief so it can be restored later, and changes
# the relief to sunken.
#
# Arguments:
# w - The name of the widget.
proc tkCheckRadioDown w {
global tkPriv
set tkPriv(relief) [$w cget -relief]
if {[string compare [$w cget -state] "disabled"]} {
set tkPriv(buttonWindow) $w
$w configure -state active
}
}
# tkButtonUp --
# The procedure below is invoked when the mouse button is released
# in a button widget. It restores the button's relief and invokes
# the command as long as the mouse hasn't left the button.
#
# Arguments:
# w - The name of the widget.
proc tkButtonUp w {
global tkPriv
if {[string equal $tkPriv(buttonWindow) $w]} {
set tkPriv(buttonWindow) ""
$w configure -relief $tkPriv(relief)
if {[string equal $tkPriv(window) $w]
&& [string compare [$w cget -state] "disabled"]} {
$w configure -state normal
uplevel #0 [list $w invoke]
}
}
}
}
if {[string match "unix" $tcl_platform(platform)]} {
#####################
# Unix implementation
#####################
# tkButtonEnter --
# The procedure below is invoked when the mouse pointer enters a
# button widget. It records the button we're in and changes the
# state of the button to active unless the button is disabled.
#
# Arguments:
# w - The name of the widget.
proc tkButtonEnter {w} {
global tkPriv
if {[string compare [$w cget -state] "disabled"]} {
$w configure -state active
if {[string equal $tkPriv(buttonWindow) $w]} {
$w configure -state active -relief sunken
}
}
set tkPriv(window) $w
}
# tkButtonLeave --
# The procedure below is invoked when the mouse pointer leaves a
# button widget. It changes the state of the button back to
# inactive. If we're leaving the button window with a mouse button
# pressed (tkPriv(buttonWindow) == $w), restore the relief of the
# button too.
#
# Arguments:
# w - The name of the widget.
proc tkButtonLeave w {
global tkPriv
if {[string compare [$w cget -state] "disabled"]} {
$w configure -state normal
}
if {[string equal $tkPriv(buttonWindow) $w]} {
$w configure -relief $tkPriv(relief)
}
set tkPriv(window) ""
}
# tkButtonDown --
# The procedure below is invoked when the mouse button is pressed in
# a button widget. It records the fact that the mouse is in the button,
# saves the button's relief so it can be restored later, and changes
# the relief to sunken.
#
# Arguments:
# w - The name of the widget.
proc tkButtonDown w {
global tkPriv
set tkPriv(relief) [$w cget -relief]
if {[string compare [$w cget -state] "disabled"]} {
set tkPriv(buttonWindow) $w
$w configure -relief sunken
}
}
# tkButtonUp --
# The procedure below is invoked when the mouse button is released
# in a button widget. It restores the button's relief and invokes
# the command as long as the mouse hasn't left the button.
#
# Arguments:
# w - The name of the widget.
proc tkButtonUp w {
global tkPriv
if {[string equal $w $tkPriv(buttonWindow)]} {
set tkPriv(buttonWindow) ""
$w configure -relief $tkPriv(relief)
if {[string equal $w $tkPriv(window)] \
&& [string compare [$w cget -state] "disabled"]} {
uplevel #0 [list $w invoke]
}
}
}
}
if {[string match "macintosh" $tcl_platform(platform)]} {
####################
# Mac implementation
####################
# tkButtonEnter --
# The procedure below is invoked when the mouse pointer enters a
# button widget. It records the button we're in and changes the
# state of the button to active unless the button is disabled.
#
# Arguments:
# w - The name of the widget.
proc tkButtonEnter {w} {
global tkPriv
if {[string compare [$w cget -state] "disabled"]} {
if {[string equal $w $tkPriv(buttonWindow)]} {
$w configure -state active
}
}
set tkPriv(window) $w
}
# tkButtonLeave --
# The procedure below is invoked when the mouse pointer leaves a
# button widget. It changes the state of the button back to
# inactive. If we're leaving the button window with a mouse button
# pressed (tkPriv(buttonWindow) == $w), restore the relief of the
# button too.
#
# Arguments:
# w - The name of the widget.
proc tkButtonLeave w {
global tkPriv
if {[string equal $w $tkPriv(buttonWindow)]} {
$w configure -state normal
}
set tkPriv(window) ""
}
# tkButtonDown --
# The procedure below is invoked when the mouse button is pressed in
# a button widget. It records the fact that the mouse is in the button,
# saves the button's relief so it can be restored later, and changes
# the relief to sunken.
#
# Arguments:
# w - The name of the widget.
proc tkButtonDown w {
global tkPriv
if {[string compare [$w cget -state] "disabled"]} {
set tkPriv(buttonWindow) $w
$w configure -state active
}
}
# tkButtonUp --
# The procedure below is invoked when the mouse button is released
# in a button widget. It restores the button's relief and invokes
# the command as long as the mouse hasn't left the button.
#
# Arguments:
# w - The name of the widget.
proc tkButtonUp w {
global tkPriv
if {[string equal $w $tkPriv(buttonWindow)]} {
$w configure -state normal
set tkPriv(buttonWindow) ""
if {[string equal $w $tkPriv(window)]
&& [string compare [$w cget -state] "disabled"]} {
uplevel #0 [list $w invoke]
}
}
}
}
##################
# Shared routines
##################
# tkButtonInvoke --
# The procedure below is called when a button is invoked through
# the keyboard. It simulate a press of the button via the mouse.
#
# Arguments:
# w - The name of the widget.
proc tkButtonInvoke w {
if {[string compare [$w cget -state] "disabled"]} {
set oldRelief [$w cget -relief]
set oldState [$w cget -state]
$w configure -state active -relief sunken
update idletasks
after 100
$w configure -state $oldState -relief $oldRelief
uplevel #0 [list $w invoke]
}
}
# tkCheckRadioInvoke --
# The procedure below is invoked when the mouse button is pressed in
# a checkbutton or radiobutton widget, or when the widget is invoked
# through the keyboard. It invokes the widget if it
# isn't disabled.
#
# Arguments:
# w - The name of the widget.
# cmd - The subcommand to invoke (one of invoke, select, or deselect).
proc tkCheckRadioInvoke {w {cmd invoke}} {
if {[string compare [$w cget -state] "disabled"]} {
uplevel #0 [list $w $cmd]
}
}
J# dialog.tcl --
#
# This file defines the procedure tk_dialog, which creates a dialog
# box containing a bitmap, a message, and one or more buttons.
#
# RCS: @(#) $Id: dialog.tcl,v 1.8 2000/04/18 02:18:33 ericm Exp $
#
# Copyright (c) 1992-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
# tk_dialog:
#
# This procedure displays a dialog box, waits for a button in the dialog
# to be invoked, then returns the index of the selected button. If the
# dialog somehow gets destroyed, -1 is returned.
#
# Arguments:
# w - Window to use for dialog top-level.
# title - Title to display in dialog's decorative frame.
# text - Message to display in dialog.
# bitmap - Bitmap to display in dialog (empty string means none).
# default - Index of button that is to display the default ring
# (-1 means none).
# args - One or more strings to display in buttons across the
# bottom of the dialog box.
proc tk_dialog {w title text bitmap default args} {
global tkPriv tcl_platform
# Check that $default was properly given
if {[string is int $default]} {
if {$default >= [llength $args]} {
return -code error "default button index greater than number of\
buttons specified for tk_dialog"
}
} elseif {[string equal {} $default]} {
set default -1
} else {
set default [lsearch -exact $args $default]
}
# 1. Create the top-level window and divide it into top
# and bottom parts.
catch {destroy $w}
toplevel $w -class Dialog
wm title $w $title
wm iconname $w Dialog
wm protocol $w WM_DELETE_WINDOW { }
# Dialog boxes should be transient with respect to their parent,
# so that they will always stay on top of their parent window. However,
# some window managers will create the window as withdrawn if the parent
# window is withdrawn or iconified. Combined with the grab we put on the
# window, this can hang the entire application. Therefore we only make
# the dialog transient if the parent is viewable.
#
if { [winfo viewable [winfo toplevel [winfo parent $w]]] } {
wm transient $w [winfo toplevel [winfo parent $w]]
}
if {[string equal $tcl_platform(platform) "macintosh"]} {
unsupported1 style $w dBoxProc
}
frame $w.bot
frame $w.top
if {[string equal $tcl_platform(platform) "unix"]} {
$w.bot configure -relief raised -bd 1
$w.top configure -relief raised -bd 1
}
pack $w.bot -side bottom -fill both
pack $w.top -side top -fill both -expand 1
# 2. Fill the top part with bitmap and message (use the option
# database for -wraplength and -font so that they can be
# overridden by the caller).
option add *Dialog.msg.wrapLength 3i widgetDefault
if {[string equal $tcl_platform(platform) "macintosh"]} {
option add *Dialog.msg.font system widgetDefault
} else {
option add *Dialog.msg.font {Times 12} widgetDefault
}
label $w.msg -justify left -text $text
pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
if {[string compare $bitmap ""]} {
if {[string equal $tcl_platform(platform) "macintosh"] && \
[string equal $bitmap "error"]} {
set bitmap "stop"
}
label $w.bitmap -bitmap $bitmap
pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
}
# 3. Create a row of buttons at the bottom of the dialog.
set i 0
foreach but $args {
button $w.button$i -text $but -command [list set tkPriv(button) $i]
if {$i == $default} {
$w.button$i configure -default active
} else {
$w.button$i configure -default normal
}
grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew -padx 10
grid columnconfigure $w.bot $i
# We boost the size of some Mac buttons for l&f
if {[string equal $tcl_platform(platform) "macintosh"]} {
set tmp [string tolower $but]
if {[string equal $tmp "ok"] || [string equal $tmp "cancel"]} {
grid columnconfigure $w.bot $i -minsize [expr {59 + 20}]
}
}
incr i
}
# 4. Create a binding for <Return> on the dialog if there is a
# default button.
if {$default >= 0} {
bind $w <Return> "
[list $w.button$default] configure -state active -relief sunken
update idletasks
after 100
set tkPriv(button) $default
"
}
# 5. Create a <Destroy> binding for the window that sets the
# button variable to -1; this is needed in case something happens
# that destroys the window, such as its parent window being destroyed.
bind $w <Destroy> {set tkPriv(button) -1}
# 6. Withdraw the window, then update all the geometry information
# so we know how big it wants to be, then center the window in the
# display and de-iconify it.
wm withdraw $w
update idletasks
set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
- [winfo vrootx [winfo parent $w]]}]
set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
- [winfo vrooty [winfo parent $w]]}]
wm geom $w +$x+$y
wm deiconify $w
# 7. Set a grab and claim the focus too.
set oldFocus [focus]
set oldGrab [grab current $w]
if {[string compare $oldGrab ""]} {
set grabStatus [grab status $oldGrab]
}
grab $w
if {$default >= 0} {
focus $w.button$default
} else {
focus $w
}
# 8. Wait for the user to respond, then restore the focus and
# return the index of the selected button. Restore the focus
# before deleting the window, since otherwise the window manager
# may take the focus away so we can't redirect it. Finally,
# restore any grab that was in effect.
tkwait variable tkPriv(button)
catch {focus $oldFocus}
catch {
# It's possible that the window has already been destroyed,
# hence this "catch". Delete the Destroy handler so that
# tkPriv(button) doesn't get reset by it.
bind $w <Destroy> {}
destroy $w
}
if {[string compare $oldGrab ""]} {
if {[string compare $grabStatus "global"]} {
grab $oldGrab
} else {
grab -global $oldGrab
}
}
return $tkPriv(button)
}
>C# entry.tcl --
#
# This file defines the default bindings for Tk entry widgets and provides
# procedures that help in implementing those bindings.
#
# RCS: @(#) $Id: entry.tcl,v 1.11.2.1 2001/04/04 07:57:17 hobbs Exp $
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#-------------------------------------------------------------------------
# Elements of tkPriv that are used in this file:
#
# afterId - If non-null, it means that auto-scanning is underway
# and it gives the "after" id for the next auto-scan
# command to be executed.
# mouseMoved - Non-zero means the mouse has moved a significant
# amount since the button went down (so, for example,
# start dragging out a selection).
# pressX - X-coordinate at which the mouse button was pressed.
# selectMode - The style of selection currently underway:
# char, word, or line.
# x, y - Last known mouse coordinates for scanning
# and auto-scanning.
# data - Used for Cut and Copy
#-------------------------------------------------------------------------
#-------------------------------------------------------------------------
# The code below creates the default class bindings for entries.
#-------------------------------------------------------------------------
bind Entry <<Cut>> {
if {![catch {tkEntryGetSelection %W} tkPriv(data)]} {
clipboard clear -displayof %W
clipboard append -displayof %W $tkPriv(data)
%W delete sel.first sel.last
unset tkPriv(data)
}
}
bind Entry <<Copy>> {
if {![catch {tkEntryGetSelection %W} tkPriv(data)]} {
clipboard clear -displayof %W
clipboard append -displayof %W $tkPriv(data)
unset tkPriv(data)
}
}
bind Entry <<Paste>> {
global tcl_platform
catch {
if {[string compare $tcl_platform(platform) "unix"]} {
catch {
%W delete sel.first sel.last
}
}
%W insert insert [selection get -displayof %W -selection CLIPBOARD]
tkEntrySeeInsert %W
}
}
bind Entry <<Clear>> {
%W delete sel.first sel.last
}
bind Entry <<PasteSelection>> {
if {!$tkPriv(mouseMoved) || $tk_strictMotif} {
tkEntryPaste %W %x
}
}
# Standard Motif bindings:
bind Entry <1> {
tkEntryButton1 %W %x
%W selection clear
}
bind Entry <B1-Motion> {
set tkPriv(x) %x
tkEntryMouseSelect %W %x
}
bind Entry <Double-1> {
set tkPriv(selectMode) word
tkEntryMouseSelect %W %x
catch {%W icursor sel.first}
}
bind Entry <Triple-1> {
set tkPriv(selectMode) line
tkEntryMouseSelect %W %x
%W icursor 0
}
bind Entry <Shift-1> {
set tkPriv(selectMode) char
%W selection adjust @%x
}
bind Entry <Double-Shift-1> {
set tkPriv(selectMode) word
tkEntryMouseSelect %W %x
}
bind Entry <Triple-Shift-1> {
set tkPriv(selectMode) line
tkEntryMouseSelect %W %x
}
bind Entry <B1-Leave> {
set tkPriv(x) %x
tkEntryAutoScan %W
}
bind Entry <B1-Enter> {
tkCancelRepeat
}
bind Entry <ButtonRelease-1> {
tkCancelRepeat
}
bind Entry <Control-1> {
%W icursor @%x
}
bind Entry <Left> {
tkEntrySetCursor %W [expr {[%W index insert] - 1}]
}
bind Entry <Right> {
tkEntrySetCursor %W [expr {[%W index insert] + 1}]
}
bind Entry <Shift-Left> {
tkEntryKeySelect %W [expr {[%W index insert] - 1}]
tkEntrySeeInsert %W
}
bind Entry <Shift-Right> {
tkEntryKeySelect %W [expr {[%W index insert] + 1}]
tkEntrySeeInsert %W
}
bind Entry <Control-Left> {
tkEntrySetCursor %W [tkEntryPreviousWord %W insert]
}
bind Entry <Control-Right> {
tkEntrySetCursor %W [tkEntryNextWord %W insert]
}
bind Entry <Shift-Control-Left> {
tkEntryKeySelect %W [tkEntryPreviousWord %W insert]
tkEntrySeeInsert %W
}
bind Entry <Shift-Control-Right> {
tkEntryKeySelect %W [tkEntryNextWord %W insert]
tkEntrySeeInsert %W
}
bind Entry <Home> {
tkEntrySetCursor %W 0
}
bind Entry <Shift-Home> {
tkEntryKeySelect %W 0
tkEntrySeeInsert %W
}
bind Entry <End> {
tkEntrySetCursor %W end
}
bind Entry <Shift-End> {
tkEntryKeySelect %W end
tkEntrySeeInsert %W
}
bind Entry <Delete> {
if {[%W selection present]} {
%W delete sel.first sel.last
} else {
%W delete insert
}
}
bind Entry <BackSpace> {
tkEntryBackspace %W
}
bind Entry <Control-space> {
%W selection from insert
}
bind Entry <Select> {
%W selection from insert
}
bind Entry <Control-Shift-space> {
%W selection adjust insert
}
bind Entry <Shift-Select> {
%W selection adjust insert
}
bind Entry <Control-slash> {
%W selection range 0 end
}
bind Entry <Control-backslash> {
%W selection clear
}
bind Entry <KeyPress> {
tkEntryInsert %W %A
}
# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
# Otherwise, if a widget binding for one of these is defined, the
# <KeyPress> class binding will also fire and insert the character,
# which is wrong. Ditto for Escape, Return, and Tab.
bind Entry <Alt-KeyPress> {# nothing}
bind Entry <Meta-KeyPress> {# nothing}
bind Entry <Control-KeyPress> {# nothing}
bind Entry <Escape> {# nothing}
bind Entry <Return> {# nothing}
bind Entry <KP_Enter> {# nothing}
bind Entry <Tab> {# nothing}
if {[string equal $tcl_platform(platform) "macintosh"]} {
bind Entry <Command-KeyPress> {# nothing}
}
# On Windows, paste is done using Shift-Insert. Shift-Insert already
# generates the <<Paste>> event, so we don't need to do anything here.
if {[string compare $tcl_platform(platform) "windows"]} {
bind Entry <Insert> {
catch {tkEntryInsert %W [selection get -displayof %W]}
}
}
# Additional emacs-like bindings:
bind Entry <Control-a> {
if {!$tk_strictMotif} {
tkEntrySetCursor %W 0
}
}
bind Entry <Control-b> {
if {!$tk_strictMotif} {
tkEntrySetCursor %W [expr {[%W index insert] - 1}]
}
}
bind Entry <Control-d> {
if {!$tk_strictMotif} {
%W delete insert
}
}
bind Entry <Control-e> {
if {!$tk_strictMotif} {
tkEntrySetCursor %W end
}
}
bind Entry <Control-f> {
if {!$tk_strictMotif} {
tkEntrySetCursor %W [expr {[%W index insert] + 1}]
}
}
bind Entry <Control-h> {
if {!$tk_strictMotif} {
tkEntryBackspace %W
}
}
bind Entry <Control-k> {
if {!$tk_strictMotif} {
%W delete insert end
}
}
bind Entry <Control-t> {
if {!$tk_strictMotif} {
tkEntryTranspose %W
}
}
bind Entry <Meta-b> {
if {!$tk_strictMotif} {
tkEntrySetCursor %W [tkEntryPreviousWord %W insert]
}
}
bind Entry <Meta-d> {
if {!$tk_strictMotif} {
%W delete insert [tkEntryNextWord %W insert]
}
}
bind Entry <Meta-f> {
if {!$tk_strictMotif} {
tkEntrySetCursor %W [tkEntryNextWord %W insert]
}
}
bind Entry <Meta-BackSpace> {
if {!$tk_strictMotif} {
%W delete [tkEntryPreviousWord %W insert] insert
}
}
bind Entry <Meta-Delete> {
if {!$tk_strictMotif} {
%W delete [tkEntryPreviousWord %W insert] insert
}
}
# A few additional bindings of my own.
bind Entry <2> {
if {!$tk_strictMotif} {
%W scan mark %x
set tkPriv(x) %x
set tkPriv(y) %y
set tkPriv(mouseMoved) 0
}
}
bind Entry <B2-Motion> {
if {!$tk_strictMotif} {
if {abs(%x-$tkPriv(x)) > 2} {
set tkPriv(mouseMoved) 1
}
%W scan dragto %x
}
}
# tkEntryClosestGap --
# Given x and y coordinates, this procedure finds the closest boundary
# between characters to the given coordinates and returns the index
# of the character just after the boundary.
#
# Arguments:
# w - The entry window.
# x - X-coordinate within the window.
proc tkEntryClosestGap {w x} {
set pos [$w index @$x]
set bbox [$w bbox $pos]
if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {
return $pos
}
incr pos
}
# tkEntryButton1 --
# This procedure is invoked to handle button-1 presses in entry
# widgets. It moves the insertion cursor, sets the selection anchor,
# and claims the input focus.
#
# Arguments:
# w - The entry window in which the button was pressed.
# x - The x-coordinate of the button press.
proc tkEntryButton1 {w x} {
global tkPriv
set tkPriv(selectMode) char
set tkPriv(mouseMoved) 0
set tkPriv(pressX) $x
$w icursor [tkEntryClosestGap $w $x]
$w selection from insert
if {[string compare "disabled" [$w cget -state]]} {focus $w}
}
# tkEntryMouseSelect --
# This procedure is invoked when dragging out a selection with
# the mouse. Depending on the selection mode (character, word,
# line) it selects in different-sized units. This procedure
# ignores mouse motions initially until the mouse has moved from
# one character to another or until there have been multiple clicks.
#
# Arguments:
# w - The entry window in which the button was pressed.
# x - The x-coordinate of the mouse.
proc tkEntryMouseSelect {w x} {
global tkPriv
set cur [tkEntryClosestGap $w $x]
set anchor [$w index anchor]
if {($cur != $anchor) || (abs($tkPriv(pressX) - $x) >= 3)} {
set tkPriv(mouseMoved) 1
}
switch $tkPriv(selectMode) {
char {
if {$tkPriv(mouseMoved)} {
if {$cur < $anchor} {
$w selection range $cur $anchor
} elseif {$cur > $anchor} {
$w selection range $anchor $cur
} else {
$w selection clear
}
}
}
word {
if {$cur < [$w index anchor]} {
set before [tcl_wordBreakBefore [$w get] $cur]
set after [tcl_wordBreakAfter [$w get] [expr {$anchor-1}]]
} else {
set before [tcl_wordBreakBefore [$w get] $anchor]
set after [tcl_wordBreakAfter [$w get] [expr {$cur - 1}]]
}
if {$before < 0} {
set before 0
}
if {$after < 0} {
set after end
}
$w selection range $before $after
}
line {
$w selection range 0 end
}
}
if {$tkPriv(mouseMoved)} {
$w icursor $cur
}
update idletasks
}
# tkEntryPaste --
# This procedure sets the insertion cursor to the current mouse position,
# pastes the selection there, and sets the focus to the window.
#
# Arguments:
# w - The entry window.
# x - X position of the mouse.
proc tkEntryPaste {w x} {
global tkPriv
$w icursor [tkEntryClosestGap $w $x]
catch {$w insert insert [selection get -displayof $w]}
if {[string compare "disabled" [$w cget -state]]} {focus $w}
}
# tkEntryAutoScan --
# This procedure is invoked when the mouse leaves an entry window
# with button 1 down. It scrolls the window left or right,
# depending on where the mouse is, and reschedules itself as an
# "after" command so that the window continues to scroll until the
# mouse moves back into the window or the mouse button is released.
#
# Arguments:
# w - The entry window.
proc tkEntryAutoScan {w} {
global tkPriv
set x $tkPriv(x)
if {![winfo exists $w]} return
if {$x >= [winfo width $w]} {
$w xview scroll 2 units
tkEntryMouseSelect $w $x
} elseif {$x < 0} {
$w xview scroll -2 units
tkEntryMouseSelect $w $x
}
set tkPriv(afterId) [after 50 [list tkEntryAutoScan $w]]
}
# tkEntryKeySelect --
# This procedure is invoked when stroking out selections using the
# keyboard. It moves the cursor to a new position, then extends
# the selection to that position.
#
# Arguments:
# w - The entry window.
# new - A new position for the insertion cursor (the cursor hasn't
# actually been moved to this position yet).
proc tkEntryKeySelect {w new} {
if {![$w selection present]} {
$w selection from insert
$w selection to $new
} else {
$w selection adjust $new
}
$w icursor $new
}
# tkEntryInsert --
# Insert a string into an entry at the point of the insertion cursor.
# If there is a selection in the entry, and it covers the point of the
# insertion cursor, then delete the selection before inserting.
#
# Arguments:
# w - The entry window in which to insert the string
# s - The string to insert (usually just a single character)
proc tkEntryInsert {w s} {
if {[string equal $s ""]} {
return
}
catch {
set insert [$w index insert]
if {([$w index sel.first] <= $insert)
&& ([$w index sel.last] >= $insert)} {
$w delete sel.first sel.last
}
}
$w insert insert $s
tkEntrySeeInsert $w
}
# tkEntryBackspace --
# Backspace over the character just before the insertion cursor.
# If backspacing would move the cursor off the left edge of the
# window, reposition the cursor at about the middle of the window.
#
# Arguments:
# w - The entry window in which to backspace.
proc tkEntryBackspace w {
if {[$w selection present]} {
$w delete sel.first sel.last
} else {
set x [expr {[$w index insert] - 1}]
if {$x >= 0} {$w delete $x}
if {[$w index @0] >= [$w index insert]} {
set range [$w xview]
set left [lindex $range 0]
set right [lindex $range 1]
$w xview moveto [expr {$left - ($right - $left)/2.0}]
}
}
}
# tkEntrySeeInsert --
# Make sure that the insertion cursor is visible in the entry window.
# If not, adjust the view so that it is.
#
# Arguments:
# w - The entry window.
proc tkEntrySeeInsert w {
set c [$w index insert]
if {($c < [$w index @0]) || ($c > [$w index @[winfo width $w]])} {
$w xview $c
}
}
# tkEntrySetCursor -
# Move the insertion cursor to a given position in an entry. Also
# clears the selection, if there is one in the entry, and makes sure
# that the insertion cursor is visible.
#
# Arguments:
# w - The entry window.
# pos - The desired new position for the cursor in the window.
proc tkEntrySetCursor {w pos} {
$w icursor $pos
$w selection clear
tkEntrySeeInsert $w
}
# tkEntryTranspose -
# This procedure implements the "transpose" function for entry widgets.
# It tranposes the characters on either side of the insertion cursor,
# unless the cursor is at the end of the line. In this case it
# transposes the two characters to the left of the cursor. In either
# case, the cursor ends up to the right of the transposed characters.
#
# Arguments:
# w - The entry window.
proc tkEntryTranspose w {
set i [$w index insert]
if {$i < [$w index end]} {
incr i
}
set first [expr {$i-2}]
if {$first < 0} {
return
}
set new [string index [$w get] [expr {$i-1}]][string index [$w get] $first]
$w delete $first $i
$w insert insert $new
tkEntrySeeInsert $w
}
# tkEntryNextWord --
# Returns the index of the next word position after a given position in the
# entry. The next word is platform dependent and may be either the next
# end-of-word position or the next start-of-word position after the next
# end-of-word position.
#
# Arguments:
# w - The entry window in which the cursor is to move.
# start - Position at which to start search.
if {[string equal $tcl_platform(platform) "windows"]} {
proc tkEntryNextWord {w start} {
set pos [tcl_endOfWord [$w get] [$w index $start]]
if {$pos >= 0} {
set pos [tcl_startOfNextWord [$w get] $pos]
}
if {$pos < 0} {
return end
}
return $pos
}
} else {
proc tkEntryNextWord {w start} {
set pos [tcl_endOfWord [$w get] [$w index $start]]
if {$pos < 0} {
return end
}
return $pos
}
}
# tkEntryPreviousWord --
#
# Returns the index of the previous word position before a given
# position in the entry.
#
# Arguments:
# w - The entry window in which the cursor is to move.
# start - Position at which to start search.
proc tkEntryPreviousWord {w start} {
set pos [tcl_startOfPreviousWord [$w get] [$w index $start]]
if {$pos < 0} {
return 0
}
return $pos
}
# tkEntryGetSelection --
#
# Returns the selected text of the entry with respect to the -show option.
#
# Arguments:
# w - The entry window from which the text to get
proc tkEntryGetSelection {w} {
set entryString [string range [$w get] [$w index sel.first] \
[expr {[$w index sel.last] - 1}]]
if {[string compare [$w cget -show] ""]} {
regsub -all . $entryString [string index [$w cget -show] 0] entryString
}
return $entryString
}
¼# focus.tcl --
#
# This file defines several procedures for managing the input
# focus.
#
# RCS: @(#) $Id: focus.tcl,v 1.7.2.1 2000/08/05 23:53:13 hobbs Exp $
#
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# tk_focusNext --
# This procedure returns the name of the next window after "w" in
# "focus order" (the window that should receive the focus next if
# Tab is typed in w). "Next" is defined by a pre-order search
# of a top-level and its non-top-level descendants, with the stacking
# order determining the order of siblings. The "-takefocus" options
# on windows determine whether or not they should be skipped.
#
# Arguments:
# w - Name of a window.
proc tk_focusNext w {
set cur $w
while {1} {
# Descend to just before the first child of the current widget.
set parent $cur
set children [winfo children $cur]
set i -1
# Look for the next sibling that isn't a top-level.
while {1} {
incr i
if {$i < [llength $children]} {
set cur [lindex $children $i]
if {[string equal [winfo toplevel $cur] $cur]} {
continue
} else {
break
}
}
# No more siblings, so go to the current widget's parent.
# If it's a top-level, break out of the loop, otherwise
# look for its next sibling.
set cur $parent
if {[string equal [winfo toplevel $cur] $cur]} {
break
}
set parent [winfo parent $parent]
set children [winfo children $parent]
set i [lsearch -exact $children $cur]
}
if {[string equal $w $cur] || [tkFocusOK $cur]} {
return $cur
}
}
}
# tk_focusPrev --
# This procedure returns the name of the previous window before "w" in
# "focus order" (the window that should receive the focus next if
# Shift-Tab is typed in w). "Next" is defined by a pre-order search
# of a top-level and its non-top-level descendants, with the stacking
# order determining the order of siblings. The "-takefocus" options
# on windows determine whether or not they should be skipped.
#
# Arguments:
# w - Name of a window.
proc tk_focusPrev w {
set cur $w
while {1} {
# Collect information about the current window's position
# among its siblings. Also, if the window is a top-level,
# then reposition to just after the last child of the window.
if {[string equal [winfo toplevel $cur] $cur]} {
set parent $cur
set children [winfo children $cur]
set i [llength $children]
} else {
set parent [winfo parent $cur]
set children [winfo children $parent]
set i [lsearch -exact $children $cur]
}
# Go to the previous sibling, then descend to its last descendant
# (highest in stacking order. While doing this, ignore top-levels
# and their descendants. When we run out of descendants, go up
# one level to the parent.
while {$i > 0} {
incr i -1
set cur [lindex $children $i]
if {[string equal [winfo toplevel $cur] $cur]} {
continue
}
set parent $cur
set children [winfo children $parent]
set i [llength $children]
}
set cur $parent
if {[string equal $w $cur] || [tkFocusOK $cur]} {
return $cur
}
}
}
# tkFocusOK --
#
# This procedure is invoked to decide whether or not to focus on
# a given window. It returns 1 if it's OK to focus on the window,
# 0 if it's not OK. The code first checks whether the window is
# viewable. If not, then it never focuses on the window. Then it
# checks the -takefocus option for the window and uses it if it's
# set. If there's no -takefocus option, the procedure checks to
# see if (a) the widget isn't disabled, and (b) it has some key
# bindings. If all of these are true, then 1 is returned.
#
# Arguments:
# w - Name of a window.
proc tkFocusOK w {
set code [catch {$w cget -takefocus} value]
if {($code == 0) && ($value != "")} {
if {$value == 0} {
return 0
} elseif {$value == 1} {
return [winfo viewable $w]
} else {
set value [uplevel #0 $value [list $w]]
if {$value != ""} {
return $value
}
}
}
if {![winfo viewable $w]} {
return 0
}
set code [catch {$w cget -state} value]
if {($code == 0) && [string equal $value "disabled"]} {
return 0
}
regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
}
# tk_focusFollowsMouse --
#
# If this procedure is invoked, Tk will enter "focus-follows-mouse"
# mode, where the focus is always on whatever window contains the
# mouse. If this procedure isn't invoked, then the user typically
# has to click on a window to give it the focus.
#
# Arguments:
# None.
proc tk_focusFollowsMouse {} {
set old [bind all <Enter>]
set script {
if {[string equal "%d" "NotifyAncestor"] \
|| [string equal "%d" "NotifyNonlinear"] \
|| [string equal "%d" "NotifyInferior"]} {
if {[tkFocusOK %W]} {
focus %W
}
}
}
if {[string compare $old ""]} {
bind all <Enter> "$old; $script"
} else {
bind all <Enter> $script
}
}
4Ã# listbox.tcl --
#
# This file defines the default bindings for Tk listbox widgets
# and provides procedures that help in implementing those bindings.
#
# RCS: @(#) $Id: listbox.tcl,v 1.11 2000/03/24 19:38:57 ericm Exp $
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
# Copyright (c) 1998 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#--------------------------------------------------------------------------
# tkPriv elements used in this file:
#
# afterId - Token returned by "after" for autoscanning.
# listboxPrev - The last element to be selected or deselected
# during a selection operation.
# listboxSelection - All of the items that were selected before the
# current selection operation (such as a mouse
# drag) started; used to cancel an operation.
#--------------------------------------------------------------------------
#-------------------------------------------------------------------------
# The code below creates the default class bindings for listboxes.
#-------------------------------------------------------------------------
# Note: the check for existence of %W below is because this binding
# is sometimes invoked after a window has been deleted (e.g. because
# there is a double-click binding on the widget that deletes it). Users
# can put "break"s in their bindings to avoid the error, but this check
# makes that unnecessary.
bind Listbox <1> {
if {[winfo exists %W]} {
tkListboxBeginSelect %W [%W index @%x,%y]
}
}
# Ignore double clicks so that users can define their own behaviors.
# Among other things, this prevents errors if the user deletes the
# listbox on a double click.
bind Listbox <Double-1> {
# Empty script
}
bind Listbox <B1-Motion> {
set tkPriv(x) %x
set tkPriv(y) %y
tkListboxMotion %W [%W index @%x,%y]
}
bind Listbox <ButtonRelease-1> {
tkCancelRepeat
%W activate @%x,%y
}
bind Listbox <Shift-1> {
tkListboxBeginExtend %W [%W index @%x,%y]
}
bind Listbox <Control-1> {
tkListboxBeginToggle %W [%W index @%x,%y]
}
bind Listbox <B1-Leave> {
set tkPriv(x) %x
set tkPriv(y) %y
tkListboxAutoScan %W
}
bind Listbox <B1-Enter> {
tkCancelRepeat
}
bind Listbox <Up> {
tkListboxUpDown %W -1
}
bind Listbox <Shift-Up> {
tkListboxExtendUpDown %W -1
}
bind Listbox <Down> {
tkListboxUpDown %W 1
}
bind Listbox <Shift-Down> {
tkListboxExtendUpDown %W 1
}
bind Listbox <Left> {
%W xview scroll -1 units
}
bind Listbox <Control-Left> {
%W xview scroll -1 pages
}
bind Listbox <Right> {
%W xview scroll 1 units
}
bind Listbox <Control-Right> {
%W xview scroll 1 pages
}
bind Listbox <Prior> {
%W yview scroll -1 pages
%W activate @0,0
}
bind Listbox <Next> {
%W yview scroll 1 pages
%W activate @0,0
}
bind Listbox <Control-Prior> {
%W xview scroll -1 pages
}
bind Listbox <Control-Next> {
%W xview scroll 1 pages
}
bind Listbox <Home> {
%W xview moveto 0
}
bind Listbox <End> {
%W xview moveto 1
}
bind Listbox <Control-Home> {
%W activate 0
%W see 0
%W selection clear 0 end
%W selection set 0
event generate %W <<ListboxSelect>>
}
bind Listbox <Shift-Control-Home> {
tkListboxDataExtend %W 0
}
bind Listbox <Control-End> {
%W activate end
%W see end
%W selection clear 0 end
%W selection set end
event generate %W <<ListboxSelect>>
}
bind Listbox <Shift-Control-End> {
tkListboxDataExtend %W [%W index end]
}
bind Listbox <<Copy>> {
if {[string equal [selection own -displayof %W] "%W"]} {
clipboard clear -displayof %W
clipboard append -displayof %W [selection get -displayof %W]
}
}
bind Listbox <space> {
tkListboxBeginSelect %W [%W index active]
}
bind Listbox <Select> {
tkListboxBeginSelect %W [%W index active]
}
bind Listbox <Control-Shift-space> {
tkListboxBeginExtend %W [%W index active]
}
bind Listbox <Shift-Select> {
tkListboxBeginExtend %W [%W index active]
}
bind Listbox <Escape> {
tkListboxCancel %W
}
bind Listbox <Control-slash> {
tkListboxSelectAll %W
}
bind Listbox <Control-backslash> {
if {[string compare [%W cget -selectmode] "browse"]} {
%W selection clear 0 end
event generate %W <<ListboxSelect>>
}
}
# Additional Tk bindings that aren't part of the Motif look and feel:
bind Listbox <2> {
%W scan mark %x %y
}
bind Listbox <B2-Motion> {
%W scan dragto %x %y
}
# The MouseWheel will typically only fire on Windows. However,
# someone could use the "event generate" command to produce one
# on other platforms.
bind Listbox <MouseWheel> {
%W yview scroll [expr {- (%D / 120) * 4}] units
}
if {[string equal "unix" $tcl_platform(platform)]} {
# Support for mousewheels on Linux/Unix commonly comes through mapping
# the wheel to the extended buttons. If you have a mousewheel, find
# Linux configuration info at:
# http://www.inria.fr/koala/colas/mouse-wheel-scroll/
bind Listbox <4> {
if {!$tk_strictMotif} {
%W yview scroll -5 units
}
}
bind Listbox <5> {
if {!$tk_strictMotif} {
%W yview scroll 5 units
}
}
}
# tkListboxBeginSelect --
#
# This procedure is typically invoked on button-1 presses. It begins
# the process of making a selection in the listbox. Its exact behavior
# depends on the selection mode currently in effect for the listbox;
# see the Motif documentation for details.
#
# Arguments:
# w - The listbox widget.
# el - The element for the selection operation (typically the
# one under the pointer). Must be in numerical form.
proc tkListboxBeginSelect {w el} {
global tkPriv
if {[string equal [$w cget -selectmode] "multiple"]} {
if {[$w selection includes $el]} {
$w selection clear $el
} else {
$w selection set $el
}
} else {
$w selection clear 0 end
$w selection set $el
$w selection anchor $el
set tkPriv(listboxSelection) {}
set tkPriv(listboxPrev) $el
}
event generate $w <<ListboxSelect>>
}
# tkListboxMotion --
#
# This procedure is called to process mouse motion events while
# button 1 is down. It may move or extend the selection, depending
# on the listbox's selection mode.
#
# Arguments:
# w - The listbox widget.
# el - The element under the pointer (must be a number).
proc tkListboxMotion {w el} {
global tkPriv
if {$el == $tkPriv(listboxPrev)} {
return
}
set anchor [$w index anchor]
switch [$w cget -selectmode] {
browse {
$w selection clear 0 end
$w selection set $el
set tkPriv(listboxPrev) $el
event generate $w <<ListboxSelect>>
}
extended {
set i $tkPriv(listboxPrev)
if {[string equal {} $i]} {
set i $el
$w selection set $el
}
if {[$w selection includes anchor]} {
$w selection clear $i $el
$w selection set anchor $el
} else {
$w selection clear $i $el
$w selection clear anchor $el
}
if {![info exists tkPriv(listboxSelection)]} {
set tkPriv(listboxSelection) [$w curselection]
}
while {($i < $el) && ($i < $anchor)} {
if {[lsearch $tkPriv(listboxSelection) $i] >= 0} {
$w selection set $i
}
incr i
}
while {($i > $el) && ($i > $anchor)} {
if {[lsearch $tkPriv(listboxSelection) $i] >= 0} {
$w selection set $i
}
incr i -1
}
set tkPriv(listboxPrev) $el
event generate $w <<ListboxSelect>>
}
}
}
# tkListboxBeginExtend --
#
# This procedure is typically invoked on shift-button-1 presses. It
# begins the process of extending a selection in the listbox. Its
# exact behavior depends on the selection mode currently in effect
# for the listbox; see the Motif documentation for details.
#
# Arguments:
# w - The listbox widget.
# el - The element for the selection operation (typically the
# one under the pointer). Must be in numerical form.
proc tkListboxBeginExtend {w el} {
if {[string equal [$w cget -selectmode] "extended"]} {
if {[$w selection includes anchor]} {
tkListboxMotion $w $el
} else {
# No selection yet; simulate the begin-select operation.
tkListboxBeginSelect $w $el
}
}
}
# tkListboxBeginToggle --
#
# This procedure is typically invoked on control-button-1 presses. It
# begins the process of toggling a selection in the listbox. Its
# exact behavior depends on the selection mode currently in effect
# for the listbox; see the Motif documentation for details.
#
# Arguments:
# w - The listbox widget.
# el - The element for the selection operation (typically the
# one under the pointer). Must be in numerical form.
proc tkListboxBeginToggle {w el} {
global tkPriv
if {[string equal [$w cget -selectmode] "extended"]} {
set tkPriv(listboxSelection) [$w curselection]
set tkPriv(listboxPrev) $el
$w selection anchor $el
if {[$w selection includes $el]} {
$w selection clear $el
} else {
$w selection set $el
}
event generate $w <<ListboxSelect>>
}
}
# tkListboxAutoScan --
# This procedure is invoked when the mouse leaves an entry window
# with button 1 down. It scrolls the window up, down, left, or
# right, depending on where the mouse left the window, and reschedules
# itself as an "after" command so that the window continues to scroll until
# the mouse moves back into the window or the mouse button is released.
#
# Arguments:
# w - The entry window.
proc tkListboxAutoScan {w} {
global tkPriv
if {![winfo exists $w]} return
set x $tkPriv(x)
set y $tkPriv(y)
if {$y >= [winfo height $w]} {
$w yview scroll 1 units
} elseif {$y < 0} {
$w yview scroll -1 units
} elseif {$x >= [winfo width $w]} {
$w xview scroll 2 units
} elseif {$x < 0} {
$w xview scroll -2 units
} else {
return
}
tkListboxMotion $w [$w index @$x,$y]
set tkPriv(afterId) [after 50 [list tkListboxAutoScan $w]]
}
# tkListboxUpDown --
#
# Moves the location cursor (active element) up or down by one element,
# and changes the selection if we're in browse or extended selection
# mode.
#
# Arguments:
# w - The listbox widget.
# amount - +1 to move down one item, -1 to move back one item.
proc tkListboxUpDown {w amount} {
global tkPriv
$w activate [expr {[$w index active] + $amount}]
$w see active
switch [$w cget -selectmode] {
browse {
$w selection clear 0 end
$w selection set active
event generate $w <<ListboxSelect>>
}
extended {
$w selection clear 0 end
$w selection set active
$w selection anchor active
set tkPriv(listboxPrev) [$w index active]
set tkPriv(listboxSelection) {}
event generate $w <<ListboxSelect>>
}
}
}
# tkListboxExtendUpDown --
#
# Does nothing unless we're in extended selection mode; in this
# case it moves the location cursor (active element) up or down by
# one element, and extends the selection to that point.
#
# Arguments:
# w - The listbox widget.
# amount - +1 to move down one item, -1 to move back one item.
proc tkListboxExtendUpDown {w amount} {
if {[string compare [$w cget -selectmode] "extended"]} {
return
}
set active [$w index active]
if {![info exists tkPriv(listboxSelection)]} {
global tkPriv
$w selection set $active
set tkPriv(listboxSelection) [$w curselection]
}
$w activate [expr {$active + $amount}]
$w see active
tkListboxMotion $w [$w index active]
}
# tkListboxDataExtend
#
# This procedure is called for key-presses such as Shift-KEndData.
# If the selection mode isn't multiple or extend then it does nothing.
# Otherwise it moves the active element to el and, if we're in
# extended mode, extends the selection to that point.
#
# Arguments:
# w - The listbox widget.
# el - An integer element number.
proc tkListboxDataExtend {w el} {
set mode [$w cget -selectmode]
if {[string equal $mode "extended"]} {
$w activate $el
$w see $el
if {[$w selection includes anchor]} {
tkListboxMotion $w $el
}
} elseif {[string equal $mode "multiple"]} {
$w activate $el
$w see $el
}
}
# tkListboxCancel
#
# This procedure is invoked to cancel an extended selection in
# progress. If there is an extended selection in progress, it
# restores all of the items between the active one and the anchor
# to their previous selection state.
#
# Arguments:
# w - The listbox widget.
proc tkListboxCancel w {
global tkPriv
if {[string compare [$w cget -selectmode] "extended"]} {
return
}
set first [$w index anchor]
set last $tkPriv(listboxPrev)
if { [string equal $last ""] } {
# Not actually doing any selection right now
return
}
if {$first > $last} {
set tmp $first
set first $last
set last $tmp
}
$w selection clear $first $last
while {$first <= $last} {
if {[lsearch $tkPriv(listboxSelection) $first] >= 0} {
$w selection set $first
}
incr first
}
event generate $w <<ListboxSelect>>
}
# tkListboxSelectAll
#
# This procedure is invoked to handle the "select all" operation.
# For single and browse mode, it just selects the active element.
# Otherwise it selects everything in the widget.
#
# Arguments:
# w - The listbox widget.
proc tkListboxSelectAll w {
set mode [$w cget -selectmode]
if {[string equal $mode "single"] || [string equal $mode "browse"]} {
$w selection clear 0 end
$w selection set active
} else {
$w selection set 0 end
}
event generate $w <<ListboxSelect>>
}
# menu.tcl --
#
# This file defines the default bindings for Tk menus and menubuttons.
# It also implements keyboard traversal of menus and implements a few
# other utility procedures related to menus.
#
# RCS: @(#) $Id: menu.tcl,v 1.12 2000/04/17 19:32:00 ericm Exp $
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#-------------------------------------------------------------------------
# Elements of tkPriv that are used in this file:
#
# cursor - Saves the -cursor option for the posted menubutton.
# focus - Saves the focus during a menu selection operation.
# Focus gets restored here when the menu is unposted.
# grabGlobal - Used in conjunction with tkPriv(oldGrab): if
# tkPriv(oldGrab) is non-empty, then tkPriv(grabGlobal)
# contains either an empty string or "-global" to
# indicate whether the old grab was a local one or
# a global one.
# inMenubutton - The name of the menubutton widget containing
# the mouse, or an empty string if the mouse is
# not over any menubutton.
# menuBar - The name of the menubar that is the root
# of the cascade hierarchy which is currently
# posted. This is null when there is no menu currently
# being pulled down from a menu bar.
# oldGrab - Window that had the grab before a menu was posted.
# Used to restore the grab state after the menu
# is unposted. Empty string means there was no
# grab previously set.
# popup - If a menu has been popped up via tk_popup, this
# gives the name of the menu. Otherwise this
# value is empty.
# postedMb - Name of the menubutton whose menu is currently
# posted, or an empty string if nothing is posted
# A grab is set on this widget.
# relief - Used to save the original relief of the current
# menubutton.
# window - When the mouse is over a menu, this holds the
# name of the menu; it's cleared when the mouse
# leaves the menu.
# tearoff - Whether the last menu posted was a tearoff or not.
# This is true always for unix, for tearoffs for Mac
# and Windows.
# activeMenu - This is the last active menu for use
# with the <<MenuSelect>> virtual event.
# activeItem - This is the last active menu item for
# use with the <<MenuSelect>> virtual event.
#-------------------------------------------------------------------------
#-------------------------------------------------------------------------
# Overall note:
# This file is tricky because there are five different ways that menus
# can be used:
#
# 1. As a pulldown from a menubutton. In this style, the variable
# tkPriv(postedMb) identifies the posted menubutton.
# 2. As a torn-off menu copied from some other menu. In this style
# tkPriv(postedMb) is empty, and menu's type is "tearoff".
# 3. As an option menu, triggered from an option menubutton. In this
# style tkPriv(postedMb) identifies the posted menubutton.
# 4. As a popup menu. In this style tkPriv(postedMb) is empty and
# the top-level menu's type is "normal".
# 5. As a pulldown from a menubar. The variable tkPriv(menubar) has
# the owning menubar, and the menu itself is of type "normal".
#
# The various binding procedures use the state described above to
# distinguish the various cases and take different actions in each
# case.
#-------------------------------------------------------------------------
#-------------------------------------------------------------------------
# The code below creates the default class bindings for menus
# and menubuttons.
#-------------------------------------------------------------------------
bind Menubutton <FocusIn> {}
bind Menubutton <Enter> {
tkMbEnter %W
}
bind Menubutton <Leave> {
tkMbLeave %W
}
bind Menubutton <1> {
if {[string compare $tkPriv(inMenubutton) ""]} {
tkMbPost $tkPriv(inMenubutton) %X %Y
}
}
bind Menubutton <Motion> {
tkMbMotion %W up %X %Y
}
bind Menubutton <B1-Motion> {
tkMbMotion %W down %X %Y
}
bind Menubutton <ButtonRelease-1> {
tkMbButtonUp %W
}
bind Menubutton <space> {
tkMbPost %W
tkMenuFirstEntry [%W cget -menu]
}
# Must set focus when mouse enters a menu, in order to allow
# mixed-mode processing using both the mouse and the keyboard.
# Don't set the focus if the event comes from a grab release,
# though: such an event can happen after as part of unposting
# a cascaded chain of menus, after the focus has already been
# restored to wherever it was before menu selection started.
bind Menu <FocusIn> {}
bind Menu <Enter> {
set tkPriv(window) %W
if {[string equal [%W cget -type] "tearoff"]} {
if {[string compare "%m" "NotifyUngrab"]} {
if {[string equal $tcl_platform(platform) "unix"]} {
tk_menuSetFocus %W
}
}
}
tkMenuMotion %W %x %y %s
}
bind Menu <Leave> {
tkMenuLeave %W %X %Y %s
}
bind Menu <Motion> {
tkMenuMotion %W %x %y %s
}
bind Menu <ButtonPress> {
tkMenuButtonDown %W
}
bind Menu <ButtonRelease> {
tkMenuInvoke %W 1
}
bind Menu <space> {
tkMenuInvoke %W 0
}
bind Menu <Return> {
tkMenuInvoke %W 0
}
bind Menu <Escape> {
tkMenuEscape %W
}
bind Menu <Left> {
tkMenuLeftArrow %W
}
bind Menu <Right> {
tkMenuRightArrow %W
}
bind Menu <Up> {
tkMenuUpArrow %W
}
bind Menu <Down> {
tkMenuDownArrow %W
}
bind Menu <KeyPress> {
tkTraverseWithinMenu %W %A
}
# The following bindings apply to all windows, and are used to
# implement keyboard menu traversal.
if {[string equal $tcl_platform(platform) "unix"]} {
bind all <Alt-KeyPress> {
tkTraverseToMenu %W %A
}
bind all <F10> {
tkFirstMenu %W
}
} else {
bind Menubutton <Alt-KeyPress> {
tkTraverseToMenu %W %A
}
bind Menubutton <F10> {
tkFirstMenu %W
}
}
# tkMbEnter --
# This procedure is invoked when the mouse enters a menubutton
# widget. It activates the widget unless it is disabled. Note:
# this procedure is only invoked when mouse button 1 is *not* down.
# The procedure tkMbB1Enter is invoked if the button is down.
#
# Arguments:
# w - The name of the widget.
proc tkMbEnter w {
global tkPriv
if {[string compare $tkPriv(inMenubutton) ""]} {
tkMbLeave $tkPriv(inMenubutton)
}
set tkPriv(inMenubutton) $w
if {[string compare [$w cget -state] "disabled"]} {
$w configure -state active
}
}
# tkMbLeave --
# This procedure is invoked when the mouse leaves a menubutton widget.
# It de-activates the widget, if the widget still exists.
#
# Arguments:
# w - The name of the widget.
proc tkMbLeave w {
global tkPriv
set tkPriv(inMenubutton) {}
if {![winfo exists $w]} {
return
}
if {[string equal [$w cget -state] "active"]} {
$w configure -state normal
}
}
# tkMbPost --
# Given a menubutton, this procedure does all the work of posting
# its associated menu and unposting any other menu that is currently
# posted.
#
# Arguments:
# w - The name of the menubutton widget whose menu
# is to be posted.
# x, y - Root coordinates of cursor, used for positioning
# option menus. If not specified, then the center
# of the menubutton is used for an option menu.
proc tkMbPost {w {x {}} {y {}}} {
global tkPriv errorInfo
global tcl_platform
if {[string equal [$w cget -state] "disabled"] || \
[string equal $w $tkPriv(postedMb)]} {
return
}
set menu [$w cget -menu]
if {[string equal $menu ""]} {
return
}
set tearoff [expr {[string equal $tcl_platform(platform) "unix"] \
|| [string equal [$menu cget -type] "tearoff"]}]
if {[string first $w $menu] != 0} {
error "can't post $menu: it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
}
set cur $tkPriv(postedMb)
if {[string compare $cur ""]} {
tkMenuUnpost {}
}
set tkPriv(cursor) [$w cget -cursor]
set tkPriv(relief) [$w cget -relief]
$w configure -cursor arrow
$w configure -relief raised
set tkPriv(postedMb) $w
set tkPriv(focus) [focus]
$menu activate none
tkGenerateMenuSelect $menu
# If this looks like an option menubutton then post the menu so
# that the current entry is on top of the mouse. Otherwise post
# the menu just below the menubutton, as for a pull-down.
update idletasks
if {[catch {
switch [$w cget -direction] {
above {
set x [winfo rootx $w]
set y [expr {[winfo rooty $w] - [winfo reqheight $menu]}]
$menu post $x $y
}
below {
set x [winfo rootx $w]
set y [expr {[winfo rooty $w] + [winfo height $w]}]
$menu post $x $y
}
left {
set x [expr {[winfo rootx $w] - [winfo reqwidth $menu]}]
set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
set entry [tkMenuFindName $menu [$w cget -text]]
if {[$w cget -indicatoron]} {
if {$entry == [$menu index last]} {
incr y [expr {-([$menu yposition $entry] \
+ [winfo reqheight $menu])/2}]
} else {
incr y [expr {-([$menu yposition $entry] \
+ [$menu yposition [expr {$entry+1}]])/2}]
}
}
$menu post $x $y
if {[string compare $entry {}] && [string compare [$menu entrycget $entry -state] "disabled"]} {
$menu activate $entry
tkGenerateMenuSelect $menu
}
}
right {
set x [expr {[winfo rootx $w] + [winfo width $w]}]
set y [expr {(2 * [winfo rooty $w] + [winfo height $w]) / 2}]
set entry [tkMenuFindName $menu [$w cget -text]]
if {[$w cget -indicatoron]} {
if {$entry == [$menu index last]} {
incr y [expr {-([$menu yposition $entry] \
+ [winfo reqheight $menu])/2}]
} else {
incr y [expr {-([$menu yposition $entry] \
+ [$menu yposition [expr {$entry+1}]])/2}]
}
}
$menu post $x $y
if {[string compare $entry {}] && [string compare [$menu entrycget $entry -state] "disabled"]} {
$menu activate $entry
tkGenerateMenuSelect $menu
}
}
default {
if {[$w cget -indicatoron]} {
if {[string equal $y {}]} {
set x [expr {[winfo rootx $w] + [winfo width $w]/2}]
set y [expr {[winfo rooty $w] + [winfo height $w]/2}]
}
tkPostOverPoint $menu $x $y [tkMenuFindName $menu [$w cget -text]]
} else {
$menu post [winfo rootx $w] [expr {[winfo rooty $w]+[winfo height $w]}]
}
}
}
} msg]} {
# Error posting menu (e.g. bogus -postcommand). Unpost it and
# reflect the error.
set savedInfo $errorInfo
tkMenuUnpost {}
error $msg $savedInfo
}
set tkPriv(tearoff) $tearoff
if {$tearoff != 0} {
focus $menu
if {[winfo viewable $w]} {
tkSaveGrabInfo $w
grab -global $w
}
}
}
# tkMenuUnpost --
# This procedure unposts a given menu, plus all of its ancestors up
# to (and including) a menubutton, if any. It also restores various
# values to what they were before the menu was posted, and releases
# a grab if there's a menubutton involved. Special notes:
# 1. It's important to unpost all menus before releasing the grab, so
# that any Enter-Leave events (e.g. from menu back to main
# application) have mode NotifyGrab.
# 2. Be sure to enclose various groups of commands in "catch" so that
# the procedure will complete even if the menubutton or the menu
# or the grab window has been deleted.
#
# Arguments:
# menu - Name of a menu to unpost. Ignored if there
# is a posted menubutton.
proc tkMenuUnpost menu {
global tcl_platform
global tkPriv
set mb $tkPriv(postedMb)
# Restore focus right away (otherwise X will take focus away when
# the menu is unmapped and under some window managers (e.g. olvwm)
# we'll lose the focus completely).
catch {focus $tkPriv(focus)}
set tkPriv(focus) ""
# Unpost menu(s) and restore some stuff that's dependent on
# what was posted.
catch {
if {[string compare $mb ""]} {
set menu [$mb cget -menu]
$menu unpost
set tkPriv(postedMb) {}
$mb configure -cursor $tkPriv(cursor)
$mb configure -relief $tkPriv(relief)
} elseif {[string compare $tkPriv(popup) ""]} {
$tkPriv(popup) unpost
set tkPriv(popup) {}
} elseif {[string compare [$menu cget -type] "menubar"] \
&& [string compare [$menu cget -type] "tearoff"]} {
# We're in a cascaded sub-menu from a torn-off menu or popup.
# Unpost all the menus up to the toplevel one (but not
# including the top-level torn-off one) and deactivate the
# top-level torn off menu if there is one.
while {1} {
set parent [winfo parent $menu]
if {[string compare [winfo class $parent] "Menu"] \
|| ![winfo ismapped $parent]} {
break
}
$parent activate none
$parent postcascade none
tkGenerateMenuSelect $parent
set type [$parent cget -type]
if {[string equal $type "menubar"] || \
[string equal $type "tearoff"]} {
break
}
set menu $parent
}
if {[string compare [$menu cget -type] "menubar"]} {
$menu unpost
}
}
}
if {($tkPriv(tearoff) != 0) || [string compare $tkPriv(menuBar) ""]} {
# Release grab, if any, and restore the previous grab, if there
# was one.
if {[string compare $menu ""]} {
set grab [grab current $menu]
if {[string compare $grab ""]} {
grab release $grab
}
}
tkRestoreOldGrab
if {[string compare $tkPriv(menuBar) ""]} {
$tkPriv(menuBar) configure -cursor $tkPriv(cursor)
set tkPriv(menuBar) {}
}
if {[string compare $tcl_platform(platform) "unix"]} {
set tkPriv(tearoff) 0
}
}
}
# tkMbMotion --
# This procedure handles mouse motion events inside menubuttons, and
# also outside menubuttons when a menubutton has a grab (e.g. when a
# menu selection operation is in progress).
#
# Arguments:
# w - The name of the menubutton widget.
# upDown - "down" means button 1 is pressed, "up" means
# it isn't.
# rootx, rooty - Coordinates of mouse, in (virtual?) root window.
proc tkMbMotion {w upDown rootx rooty} {
global tkPriv
if {[string equal $tkPriv(inMenubutton) $w]} {
return
}
set new [winfo containing $rootx $rooty]
if {[string compare $new $tkPriv(inMenubutton)] \
&& ([string equal $new ""] \
|| [string equal [winfo toplevel $new] [winfo toplevel $w]])} {
if {[string compare $tkPriv(inMenubutton) ""]} {
tkMbLeave $tkPriv(inMenubutton)
}
if {[string compare $new ""] \
&& [string equal [winfo class $new] "Menubutton"] \
&& ([$new cget -indicatoron] == 0) \
&& ([$w cget -indicatoron] == 0)} {
if {[string equal $upDown "down"]} {
tkMbPost $new $rootx $rooty
} else {
tkMbEnter $new
}
}
}
}
# tkMbButtonUp --
# This procedure is invoked to handle button 1 releases for menubuttons.
# If the release happens inside the menubutton then leave its menu
# posted with element 0 activated. Otherwise, unpost the menu.
#
# Arguments:
# w - The name of the menubutton widget.
proc tkMbButtonUp w {
global tkPriv
global tcl_platform
set menu [$w cget -menu]
set tearoff [expr {[string equal $tcl_platform(platform) "unix"] || \
([string compare $menu {}] && \
[string equal [$menu cget -type] "tearoff"])}]
if {($tearoff != 0) && [string equal $tkPriv(postedMb) $w] \
&& [string equal $tkPriv(inMenubutton) $w]} {
tkMenuFirstEntry [$tkPriv(postedMb) cget -menu]
} else {
tkMenuUnpost {}
}
}
# tkMenuMotion --
# This procedure is called to handle mouse motion events for menus.
# It does two things. First, it resets the active element in the
# menu, if the mouse is over the menu. Second, if a mouse button
# is down, it posts and unposts cascade entries to match the mouse
# position.
#
# Arguments:
# menu - The menu window.
# x - The x position of the mouse.
# y - The y position of the mouse.
# state - Modifier state (tells whether buttons are down).
proc tkMenuMotion {menu x y state} {
global tkPriv
if {[string equal $menu $tkPriv(window)]} {
if {[string equal [$menu cget -type] "menubar"]} {
if {[info exists tkPriv(focus)] && \
[string compare $menu $tkPriv(focus)]} {
$menu activate @$x,$y
tkGenerateMenuSelect $menu
}
} else {
$menu activate @$x,$y
tkGenerateMenuSelect $menu
}
}
if {($state & 0x1f00) != 0} {
$menu postcascade active
}
}
# tkMenuButtonDown --
# Handles button presses in menus. There are a couple of tricky things
# here:
# 1. Change the posted cascade entry (if any) to match the mouse position.
# 2. If there is a posted menubutton, must grab to the menubutton; this
# overrrides the implicit grab on button press, so that the menu
# button can track mouse motions over other menubuttons and change
# the posted menu.
# 3. If there's no posted menubutton (e.g. because we're a torn-off menu
# or one of its descendants) must grab to the top-level menu so that
# we can track mouse motions across the entire menu hierarchy.
#
# Arguments:
# menu - The menu window.
proc tkMenuButtonDown menu {
global tkPriv
global tcl_platform
if {![winfo viewable $menu]} {
return
}
$menu postcascade active
if {[string compare $tkPriv(postedMb) ""] && \
[winfo viewable $tkPriv(postedMb)]} {
grab -global $tkPriv(postedMb)
} else {
while {[string equal [$menu cget -type] "normal"] \
&& [string equal [winfo class [winfo parent $menu]] "Menu"] \
&& [winfo ismapped [winfo parent $menu]]} {
set menu [winfo parent $menu]
}
if {[string equal $tkPriv(menuBar) {}]} {
set tkPriv(menuBar) $menu
set tkPriv(cursor) [$menu cget -cursor]
$menu configure -cursor arrow
}
# Don't update grab information if the grab window isn't changing.
# Otherwise, we'll get an error when we unpost the menus and
# restore the grab, since the old grab window will not be viewable
# anymore.
if {[string compare $menu [grab current $menu]]} {
tkSaveGrabInfo $menu
}
# Must re-grab even if the grab window hasn't changed, in order
# to release the implicit grab from the button press.
if {[string equal $tcl_platform(platform) "unix"]} {
grab -global $menu
}
}
}
# tkMenuLeave --
# This procedure is invoked to handle Leave events for a menu. It
# deactivates everything unless the active element is a cascade element
# and the mouse is now over the submenu.
#
# Arguments:
# menu - The menu window.
# rootx, rooty - Root coordinates of mouse.
# state - Modifier state.
proc tkMenuLeave {menu rootx rooty state} {
global tkPriv
set tkPriv(window) {}
if {[string equal [$menu index active] "none"]} {
return
}
if {[string equal [$menu type active] "cascade"]
&& [string equal [winfo containing $rootx $rooty] \
[$menu entrycget active -menu]]} {
return
}
$menu activate none
tkGenerateMenuSelect $menu
}
# tkMenuInvoke --
# This procedure is invoked when button 1 is released over a menu.
# It invokes the appropriate menu action and unposts the menu if
# it came from a menubutton.
#
# Arguments:
# w - Name of the menu widget.
# buttonRelease - 1 means this procedure is called because of
# a button release; 0 means because of keystroke.
proc tkMenuInvoke {w buttonRelease} {
global tkPriv
if {$buttonRelease && [string equal $tkPriv(window) {}]} {
# Mouse was pressed over a menu without a menu button, then
# dragged off the menu (possibly with a cascade posted) and
# released. Unpost everything and quit.
$w postcascade none
$w activate none
event generate $w <<MenuSelect>>
tkMenuUnpost $w
return
}
if {[string equal [$w type active] "cascade"]} {
$w postcascade active
set menu [$w entrycget active -menu]
tkMenuFirstEntry $menu
} elseif {[string equal [$w type active] "tearoff"]} {
tkTearOffMenu $w
tkMenuUnpost $w
} elseif {[string equal [$w cget -type] "menubar"]} {
$w postcascade none
set active [$w index active]
set isCascade [string equal [$w type $active] "cascade"]
# Only de-activate the active item if it's a cascade; this prevents
# the annoying "activation flicker" you otherwise get with
# checkbuttons/commands/etc. on menubars
if { $isCascade } {
$w activate none
event generate $w <<MenuSelect>>
}
tkMenuUnpost $w
# If the active item is not a cascade, invoke it. This enables
# the use of checkbuttons/commands/etc. on menubars (which is legal,
# but not recommended)
if { !$isCascade } {
uplevel #0 [list $w invoke $active]
}
} else {
tkMenuUnpost $w
uplevel #0 [list $w invoke active]
}
}
# tkMenuEscape --
# This procedure is invoked for the Cancel (or Escape) key. It unposts
# the given menu and, if it is the top-level menu for a menu button,
# unposts the menu button as well.
#
# Arguments:
# menu - Name of the menu window.
proc tkMenuEscape menu {
set parent [winfo parent $menu]
if {[string compare [winfo class $parent] "Menu"]} {
tkMenuUnpost $menu
} elseif {[string equal [$parent cget -type] "menubar"]} {
tkMenuUnpost $menu
tkRestoreOldGrab
} else {
tkMenuNextMenu $menu left
}
}
# The following routines handle arrow keys. Arrow keys behave
# differently depending on whether the menu is a menu bar or not.
proc tkMenuUpArrow {menu} {
if {[string equal [$menu cget -type] "menubar"]} {
tkMenuNextMenu $menu left
} else {
tkMenuNextEntry $menu -1
}
}
proc tkMenuDownArrow {menu} {
if {[string equal [$menu cget -type] "menubar"]} {
tkMenuNextMenu $menu right
} else {
tkMenuNextEntry $menu 1
}
}
proc tkMenuLeftArrow {menu} {
if {[string equal [$menu cget -type] "menubar"]} {
tkMenuNextEntry $menu -1
} else {
tkMenuNextMenu $menu left
}
}
proc tkMenuRightArrow {menu} {
if {[string equal [$menu cget -type] "menubar"]} {
tkMenuNextEntry $menu 1
} else {
tkMenuNextMenu $menu right
}
}
# tkMenuNextMenu --
# This procedure is invoked to handle "left" and "right" traversal
# motions in menus. It traverses to the next menu in a menu bar,
# or into or out of a cascaded menu.
#
# Arguments:
# menu - The menu that received the keyboard
# event.
# direction - Direction in which to move: "left" or "right"
proc tkMenuNextMenu {menu direction} {
global tkPriv
# First handle traversals into and out of cascaded menus.
if {[string equal $direction "right"]} {
set count 1
set parent [winfo parent $menu]
set class [winfo class $parent]
if {[string equal [$menu type active] "cascade"]} {
$menu postcascade active
set m2 [$menu entrycget active -menu]
if {[string compare $m2 ""]} {
tkMenuFirstEntry $m2
}
return
} else {
set parent [winfo parent $menu]
while {[string compare $parent "."]} {
if {[string equal [winfo class $parent] "Menu"] \
&& [string equal [$parent cget -type] "menubar"]} {
tk_menuSetFocus $parent
tkMenuNextEntry $parent 1
return
}
set parent [winfo parent $parent]
}
}
} else {
set count -1
set m2 [winfo parent $menu]
if {[string equal [winfo class $m2] "Menu"]} {
if {[string compare [$m2 cget -type] "menubar"]} {
$menu activate none
tkGenerateMenuSelect $menu
tk_menuSetFocus $m2
# This code unposts any posted submenu in the parent.
set tmp [$m2 index active]
$m2 activate none
$m2 activate $tmp
return
}
}
}
# Can't traverse into or out of a cascaded menu. Go to the next
# or previous menubutton, if that makes sense.
set m2 [winfo parent $menu]
if {[string equal [winfo class $m2] "Menu"]} {
if {[string equal [$m2 cget -type] "menubar"]} {
tk_menuSetFocus $m2
tkMenuNextEntry $m2 -1
return
}
}
set w $tkPriv(postedMb)
if {[string equal $w ""]} {
return
}
set buttons [winfo children [winfo parent $w]]
set length [llength $buttons]
set i [expr {[lsearch -exact $buttons $w] + $count}]
while {1} {
while {$i < 0} {
incr i $length
}
while {$i >= $length} {
incr i -$length
}
set mb [lindex $buttons $i]
if {[string equal [winfo class $mb] "Menubutton"] \
&& [string compare [$mb cget -state] "disabled"] \
&& [string compare [$mb cget -menu] ""] \
&& [string compare [[$mb cget -menu] index last] "none"]} {
break
}
if {[string equal $mb $w]} {
return
}
incr i $count
}
tkMbPost $mb
tkMenuFirstEntry [$mb cget -menu]
}
# tkMenuNextEntry --
# Activate the next higher or lower entry in the posted menu,
# wrapping around at the ends. Disabled entries are skipped.
#
# Arguments:
# menu - Menu window that received the keystroke.
# count - 1 means go to the next lower entry,
# -1 means go to the next higher entry.
proc tkMenuNextEntry {menu count} {
global tkPriv
if {[string equal [$menu index last] "none"]} {
return
}
set length [expr {[$menu index last]+1}]
set quitAfter $length
set active [$menu index active]
if {[string equal $active "none"]} {
set i 0
} else {
set i [expr {$active + $count}]
}
while {1} {
if {$quitAfter <= 0} {
# We've tried every entry in the menu. Either there are
# none, or they're all disabled. Just give up.
return
}
while {$i < 0} {
incr i $length
}
while {$i >= $length} {
incr i -$length
}
if {[catch {$menu entrycget $i -state} state] == 0} {
if {[string compare $state "disabled"]} {
break
}
}
if {$i == $active} {
return
}
incr i $count
incr quitAfter -1
}
$menu activate $i
tkGenerateMenuSelect $menu
if {[string equal [$menu type $i] "cascade"]} {
set cascade [$menu entrycget $i -menu]
if {[string compare $cascade ""]} {
# Here we auto-post a cascade. This is necessary when
# we traverse left/right in the menubar, but undesirable when
# we traverse up/down in a menu.
$menu postcascade $i
tkMenuFirstEntry $cascade
}
}
}
# tkMenuFind --
# This procedure searches the entire window hierarchy under w for
# a menubutton that isn't disabled and whose underlined character
# is "char" or an entry in a menubar that isn't disabled and whose
# underlined character is "char".
# It returns the name of that window, if found, or an
# empty string if no matching window was found. If "char" is an
# empty string then the procedure returns the name of the first
# menubutton found that isn't disabled.
#
# Arguments:
# w - Name of window where key was typed.
# char - Underlined character to search for;
# may be either upper or lower case, and
# will match either upper or lower case.
proc tkMenuFind {w char} {
global tkPriv
set char [string tolower $char]
set windowlist [winfo child $w]
foreach child $windowlist {
# Don't descend into other toplevels.
if {[string compare [winfo toplevel [focus]] \
[winfo toplevel $child]]} {
continue
}
if {[string equal [winfo class $child] "Menu"] && \
[string equal [$child cget -type] "menubar"]} {
if {[string equal $char ""]} {
return $child
}
set last [$child index last]
for {set i [$child cget -tearoff]} {$i <= $last} {incr i} {
if {[string equal [$child type $i] "separator"]} {
continue
}
set char2 [string index [$child entrycget $i -label] \
[$child entrycget $i -underline]]
if {[string equal $char [string tolower $char2]] \
|| [string equal $char ""]} {
if {[string compare [$child entrycget $i -state] "disabled"]} {
return $child
}
}
}
}
}
foreach child $windowlist {
# Don't descend into other toplevels.
if {[string compare [winfo toplevel [focus]] \
[winfo toplevel $child]]} {
continue
}
switch [winfo class $child] {
Menubutton {
set char2 [string index [$child cget -text] \
[$child cget -underline]]
if {[string equal $char [string tolower $char2]] \
|| [string equal $char ""]} {
if {[string compare [$child cget -state] "disabled"]} {
return $child
}
}
}
default {
set match [tkMenuFind $child $char]
if {[string compare $match ""]} {
return $match
}
}
}
}
return {}
}
# tkTraverseToMenu --
# This procedure implements keyboard traversal of menus. Given an
# ASCII character "char", it looks for a menubutton with that character
# underlined. If one is found, it posts the menubutton's menu
#
# Arguments:
# w - Window in which the key was typed (selects
# a toplevel window).
# char - Character that selects a menu. The case
# is ignored. If an empty string, nothing
# happens.
proc tkTraverseToMenu {w char} {
global tkPriv
if {[string equal $char ""]} {
return
}
while {[string equal [winfo class $w] "Menu"]} {
if {[string compare [$w cget -type] "menubar"] \
&& [string equal $tkPriv(postedMb) ""]} {
return
}
if {[string equal [$w cget -type] "menubar"]} {
break
}
set w [winfo parent $w]
}
set w [tkMenuFind [winfo toplevel $w] $char]
if {[string compare $w ""]} {
if {[string equal [winfo class $w] "Menu"]} {
tk_menuSetFocus $w
set tkPriv(window) $w
tkSaveGrabInfo $w
grab -global $w
tkTraverseWithinMenu $w $char
} else {
tkMbPost $w
tkMenuFirstEntry [$w cget -menu]
}
}
}
# tkFirstMenu --
# This procedure traverses to the first menubutton in the toplevel
# for a given window, and posts that menubutton's menu.
#
# Arguments:
# w - Name of a window. Selects which toplevel
# to search for menubuttons.
proc tkFirstMenu w {
set w [tkMenuFind [winfo toplevel $w] ""]
if {[string compare $w ""]} {
if {[string equal [winfo class $w] "Menu"]} {
tk_menuSetFocus $w
set tkPriv(window) $w
tkSaveGrabInfo $w
grab -global $w
tkMenuFirstEntry $w
} else {
tkMbPost $w
tkMenuFirstEntry [$w cget -menu]
}
}
}
# tkTraverseWithinMenu
# This procedure implements keyboard traversal within a menu. It
# searches for an entry in the menu that has "char" underlined. If
# such an entry is found, it is invoked and the menu is unposted.
#
# Arguments:
# w - The name of the menu widget.
# char - The character to look for; case is
# ignored. If the string is empty then
# nothing happens.
proc tkTraverseWithinMenu {w char} {
if {[string equal $char ""]} {
return
}
set char [string tolower $char]
set last [$w index last]
if {[string equal $last "none"]} {
return
}
for {set i 0} {$i <= $last} {incr i} {
if {[catch {set char2 [string index \
[$w entrycget $i -label] [$w entrycget $i -underline]]}]} {
continue
}
if {[string equal $char [string tolower $char2]]} {
if {[string equal [$w type $i] "cascade"]} {
$w activate $i
$w postcascade active
event generate $w <<MenuSelect>>
set m2 [$w entrycget $i -menu]
if {[string compare $m2 ""]} {
tkMenuFirstEntry $m2
}
} else {
tkMenuUnpost $w
uplevel #0 [list $w invoke $i]
}
return
}
}
}
# tkMenuFirstEntry --
# Given a menu, this procedure finds the first entry that isn't
# disabled or a tear-off or separator, and activates that entry.
# However, if there is already an active entry in the menu (e.g.,
# because of a previous call to tkPostOverPoint) then the active
# entry isn't changed. This procedure also sets the input focus
# to the menu.
#
# Arguments:
# menu - Name of the menu window (possibly empty).
proc tkMenuFirstEntry menu {
if {[string equal $menu ""]} {
return
}
tk_menuSetFocus $menu
if {[string compare [$menu index active] "none"]} {
return
}
set last [$menu index last]
if {[string equal $last "none"]} {
return
}
for {set i 0} {$i <= $last} {incr i} {
if {([catch {set state [$menu entrycget $i -state]}] == 0) \
&& [string compare $state "disabled"] \
&& [string compare [$menu type $i] "tearoff"]} {
$menu activate $i
tkGenerateMenuSelect $menu
# Only post the cascade if the current menu is a menubar;
# otherwise, if the first entry of the cascade is a cascade,
# we can get an annoying cascading effect resulting in a bunch of
# menus getting posted (bug 676)
if {[string equal [$menu type $i] "cascade"] && \
[string equal [$menu cget -type] "menubar"]} {
set cascade [$menu entrycget $i -menu]
if {[string compare $cascade ""]} {
$menu postcascade $i
tkMenuFirstEntry $cascade
}
}
return
}
}
}
# tkMenuFindName --
# Given a menu and a text string, return the index of the menu entry
# that displays the string as its label. If there is no such entry,
# return an empty string. This procedure is tricky because some names
# like "active" have a special meaning in menu commands, so we can't
# always use the "index" widget command.
#
# Arguments:
# menu - Name of the menu widget.
# s - String to look for.
proc tkMenuFindName {menu s} {
set i ""
if {![regexp {^active$|^last$|^none$|^[0-9]|^@} $s]} {
catch {set i [$menu index $s]}
return $i
}
set last [$menu index last]
if {[string equal $last "none"]} {
return
}
for {set i 0} {$i <= $last} {incr i} {
if {![catch {$menu entrycget $i -label} label]} {
if {[string equal $label $s]} {
return $i
}
}
}
return ""
}
# tkPostOverPoint --
# This procedure posts a given menu such that a given entry in the
# menu is centered over a given point in the root window. It also
# activates the given entry.
#
# Arguments:
# menu - Menu to post.
# x, y - Root coordinates of point.
# entry - Index of entry within menu to center over (x,y).
# If omitted or specified as {}, then the menu's
# upper-left corner goes at (x,y).
proc tkPostOverPoint {menu x y {entry {}}} {
global tcl_platform
if {[string compare $entry {}]} {
if {$entry == [$menu index last]} {
incr y [expr {-([$menu yposition $entry] \
+ [winfo reqheight $menu])/2}]
} else {
incr y [expr {-([$menu yposition $entry] \
+ [$menu yposition [expr {$entry+1}]])/2}]
}
incr x [expr {-[winfo reqwidth $menu]/2}]
}
$menu post $x $y
if {[string compare $entry {}] \
&& [string compare [$menu entrycget $entry -state] "disabled"]} {
$menu activate $entry
tkGenerateMenuSelect $menu
}
}
# tkSaveGrabInfo --
# Sets the variables tkPriv(oldGrab) and tkPriv(grabStatus) to record
# the state of any existing grab on the w's display.
#
# Arguments:
# w - Name of a window; used to select the display
# whose grab information is to be recorded.
proc tkSaveGrabInfo w {
global tkPriv
set tkPriv(oldGrab) [grab current $w]
if {[string compare $tkPriv(oldGrab) ""]} {
set tkPriv(grabStatus) [grab status $tkPriv(oldGrab)]
}
}
# tkRestoreOldGrab --
# Restores the grab to what it was before TkSaveGrabInfo was called.
#
proc tkRestoreOldGrab {} {
global tkPriv
if {[string compare $tkPriv(oldGrab) ""]} {
# Be careful restoring the old grab, since it's window may not
# be visible anymore.
catch {
if {[string equal $tkPriv(grabStatus) "global"]} {
grab set -global $tkPriv(oldGrab)
} else {
grab set $tkPriv(oldGrab)
}
}
set tkPriv(oldGrab) ""
}
}
proc tk_menuSetFocus {menu} {
global tkPriv
if {![info exists tkPriv(focus)] || [string equal $tkPriv(focus) {}]} {
set tkPriv(focus) [focus]
}
focus $menu
}
proc tkGenerateMenuSelect {menu} {
global tkPriv
if {[string equal $tkPriv(activeMenu) $menu] \
&& [string equal $tkPriv(activeItem) [$menu index active]]} {
return
}
set tkPriv(activeMenu) $menu
set tkPriv(activeItem) [$menu index active]
event generate $menu <<MenuSelect>>
}
# tk_popup --
# This procedure pops up a menu and sets things up for traversing
# the menu and its submenus.
#
# Arguments:
# menu - Name of the menu to be popped up.
# x, y - Root coordinates at which to pop up the
# menu.
# entry - Index of a menu entry to center over (x,y).
# If omitted or specified as {}, then menu's
# upper-left corner goes at (x,y).
proc tk_popup {menu x y {entry {}}} {
global tkPriv
global tcl_platform
if {[string compare $tkPriv(popup) ""] \
|| [string compare $tkPriv(postedMb) ""]} {
tkMenuUnpost {}
}
tkPostOverPoint $menu $x $y $entry
if {[string equal $tcl_platform(platform) "unix"] \
&& [winfo viewable $menu]} {
tkSaveGrabInfo $menu
grab -global $menu
set tkPriv(popup) $menu
tk_menuSetFocus $menu
}
}
{# optMenu.tcl --
#
# This file defines the procedure tk_optionMenu, which creates
# an option button and its associated menu.
#
# RCS: @(#) $Id: optMenu.tcl,v 1.3 1998/09/14 18:23:24 stanton Exp $
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# tk_optionMenu --
# This procedure creates an option button named $w and an associated
# menu. Together they provide the functionality of Motif option menus:
# they can be used to select one of many values, and the current value
# appears in the global variable varName, as well as in the text of
# the option menubutton. The name of the menu is returned as the
# procedure's result, so that the caller can use it to change configuration
# options on the menu or otherwise manipulate it.
#
# Arguments:
# w - The name to use for the menubutton.
# varName - Global variable to hold the currently selected value.
# firstValue - First of legal values for option (must be >= 1).
# args - Any number of additional values.
proc tk_optionMenu {w varName firstValue args} {
upvar #0 $varName var
if {![info exists var]} {
set var $firstValue
}
menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \
-relief raised -bd 2 -highlightthickness 2 -anchor c \
-direction flush
menu $w.menu -tearoff 0
$w.menu add radiobutton -label $firstValue -variable $varName
foreach i $args {
$w.menu add radiobutton -label $i -variable $varName
}
return $w.menu
}
ä# palette.tcl --
#
# This file contains procedures that change the color palette used
# by Tk.
#
# RCS: @(#) $Id: palette.tcl,v 1.5 1999/09/02 17:02:53 hobbs Exp $
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# tk_setPalette --
# Changes the default color scheme for a Tk application by setting
# default colors in the option database and by modifying all of the
# color options for existing widgets that have the default value.
#
# Arguments:
# The arguments consist of either a single color name, which
# will be used as the new background color (all other colors will
# be computed from this) or an even number of values consisting of
# option names and values. The name for an option is the one used
# for the option database, such as activeForeground, not -activeforeground.
proc tk_setPalette {args} {
if {[winfo depth .] == 1} {
# Just return on monochrome displays, otherwise errors will occur
return
}
global tkPalette
# Create an array that has the complete new palette. If some colors
# aren't specified, compute them from other colors that are specified.
if {[llength $args] == 1} {
set new(background) [lindex $args 0]
} else {
array set new $args
}
if {![info exists new(background)]} {
error "must specify a background color"
}
if {![info exists new(foreground)]} {
set new(foreground) black
}
set bg [winfo rgb . $new(background)]
set fg [winfo rgb . $new(foreground)]
set darkerBg [format #%02x%02x%02x [expr {(9*[lindex $bg 0])/2560}] \
[expr {(9*[lindex $bg 1])/2560}] [expr {(9*[lindex $bg 2])/2560}]]
foreach i {activeForeground insertBackground selectForeground \
highlightColor} {
if {![info exists new($i)]} {
set new($i) $new(foreground)
}
}
if {![info exists new(disabledForeground)]} {
set new(disabledForeground) [format #%02x%02x%02x \
[expr {(3*[lindex $bg 0] + [lindex $fg 0])/1024}] \
[expr {(3*[lindex $bg 1] + [lindex $fg 1])/1024}] \
[expr {(3*[lindex $bg 2] + [lindex $fg 2])/1024}]]
}
if {![info exists new(highlightBackground)]} {
set new(highlightBackground) $new(background)
}
if {![info exists new(activeBackground)]} {
# Pick a default active background that islighter than the
# normal background. To do this, round each color component
# up by 15% or 1/3 of the way to full white, whichever is
# greater.
foreach i {0 1 2} {
set light($i) [expr {[lindex $bg $i]/256}]
set inc1 [expr {($light($i)*15)/100}]
set inc2 [expr {(255-$light($i))/3}]
if {$inc1 > $inc2} {
incr light($i) $inc1
} else {
incr light($i) $inc2
}
if {$light($i) > 255} {
set light($i) 255
}
}
set new(activeBackground) [format #%02x%02x%02x $light(0) \
$light(1) $light(2)]
}
if {![info exists new(selectBackground)]} {
set new(selectBackground) $darkerBg
}
if {![info exists new(troughColor)]} {
set new(troughColor) $darkerBg
}
if {![info exists new(selectColor)]} {
set new(selectColor) #b03060
}
# let's make one of each of the widgets so we know what the
# defaults are currently for this platform.
toplevel .___tk_set_palette
wm withdraw .___tk_set_palette
foreach q {button canvas checkbutton entry frame label listbox \
menubutton menu message radiobutton scale scrollbar text} {
$q .___tk_set_palette.$q
}
# Walk the widget hierarchy, recoloring all existing windows.
# The option database must be set according to what we do here,
# but it breaks things if we set things in the database while
# we are changing colors...so, tkRecolorTree now returns the
# option database changes that need to be made, and they
# need to be evalled here to take effect.
# We have to walk the whole widget tree instead of just
# relying on the widgets we've created above to do the work
# because different extensions may provide other kinds
# of widgets that we don't currently know about, so we'll
# walk the whole hierarchy just in case.
eval [tkRecolorTree . new]
catch {destroy .___tk_set_palette}
# Change the option database so that future windows will get the
# same colors.
foreach option [array names new] {
option add *$option $new($option) widgetDefault
}
# Save the options in the global variable tkPalette, for use the
# next time we change the options.
array set tkPalette [array get new]
}
# tkRecolorTree --
# This procedure changes the colors in a window and all of its
# descendants, according to information provided by the colors
# argument. This looks at the defaults provided by the option
# database, if it exists, and if not, then it looks at the default
# value of the widget itself.
#
# Arguments:
# w - The name of a window. This window and all its
# descendants are recolored.
# colors - The name of an array variable in the caller,
# which contains color information. Each element
# is named after a widget configuration option, and
# each value is the value for that option.
proc tkRecolorTree {w colors} {
global tkPalette
upvar $colors c
set result {}
foreach dbOption [array names c] {
set option -[string tolower $dbOption]
if {![catch {$w config $option} value]} {
# if the option database has a preference for this
# dbOption, then use it, otherwise use the defaults
# for the widget.
set defaultcolor [option get $w $dbOption widgetDefault]
if {[string match {} $defaultcolor]} {
set defaultcolor [winfo rgb . [lindex $value 3]]
} else {
set defaultcolor [winfo rgb . $defaultcolor]
}
set chosencolor [winfo rgb . [lindex $value 4]]
if {[string match $defaultcolor $chosencolor]} {
# Change the option database so that future windows will get
# the same colors.
append result ";\noption add [list \
*[winfo class $w].$dbOption $c($dbOption) 60]"
$w configure $option $c($dbOption)
}
}
}
foreach child [winfo children $w] {
append result ";\n[tkRecolorTree $child c]"
}
return $result
}
# tkDarken --
# Given a color name, computes a new color value that darkens (or
# brightens) the given color by a given percent.
#
# Arguments:
# color - Name of starting color.
# perecent - Integer telling how much to brighten or darken as a
# percent: 50 means darken by 50%, 110 means brighten
# by 10%.
proc tkDarken {color percent} {
foreach {red green blue} [winfo rgb . $color] {
set red [expr {($red/256)*$percent/100}]
set green [expr {($green/256)*$percent/100}]
set blue [expr {($blue/256)*$percent/100}]
break
}
if {$red > 255} {
set red 255
}
if {$green > 255} {
set green 255
}
if {$blue > 255} {
set blue 255
}
return [format "#%02x%02x%02x" $red $green $blue]
}
# tk_bisque --
# Reset the Tk color palette to the old "bisque" colors.
#
# Arguments:
# None.
proc tk_bisque {} {
tk_setPalette activeBackground #e6ceb1 activeForeground black \
background #ffe4c4 disabledForeground #b0b0b0 foreground black \
highlightBackground #ffe4c4 highlightColor black \
insertBackground black selectColor #b03060 \
selectBackground #e6ceb1 selectForeground black \
troughColor #cdb79e
}
k# scale.tcl --
#
# This file defines the default bindings for Tk scale widgets and provides
# procedures that help in implementing the bindings.
#
# RCS: @(#) $Id: scale.tcl,v 1.7 2000/04/14 08:33:31 hobbs Exp $
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#-------------------------------------------------------------------------
# The code below creates the default class bindings for entries.
#-------------------------------------------------------------------------
# Standard Motif bindings:
bind Scale <Enter> {
if {$tk_strictMotif} {
set tkPriv(activeBg) [%W cget -activebackground]
%W config -activebackground [%W cget -background]
}
tkScaleActivate %W %x %y
}
bind Scale <Motion> {
tkScaleActivate %W %x %y
}
bind Scale <Leave> {
if {$tk_strictMotif} {
%W config -activebackground $tkPriv(activeBg)
}
if {[string equal [%W cget -state] "active"]} {
%W configure -state normal
}
}
bind Scale <1> {
tkScaleButtonDown %W %x %y
}
bind Scale <B1-Motion> {
tkScaleDrag %W %x %y
}
bind Scale <B1-Leave> { }
bind Scale <B1-Enter> { }
bind Scale <ButtonRelease-1> {
tkCancelRepeat
tkScaleEndDrag %W
tkScaleActivate %W %x %y
}
bind Scale <2> {
tkScaleButton2Down %W %x %y
}
bind Scale <B2-Motion> {
tkScaleDrag %W %x %y
}
bind Scale <B2-Leave> { }
bind Scale <B2-Enter> { }
bind Scale <ButtonRelease-2> {
tkCancelRepeat
tkScaleEndDrag %W
tkScaleActivate %W %x %y
}
bind Scale <Control-1> {
tkScaleControlPress %W %x %y
}
bind Scale <Up> {
tkScaleIncrement %W up little noRepeat
}
bind Scale <Down> {
tkScaleIncrement %W down little noRepeat
}
bind Scale <Left> {
tkScaleIncrement %W up little noRepeat
}
bind Scale <Right> {
tkScaleIncrement %W down little noRepeat
}
bind Scale <Control-Up> {
tkScaleIncrement %W up big noRepeat
}
bind Scale <Control-Down> {
tkScaleIncrement %W down big noRepeat
}
bind Scale <Control-Left> {
tkScaleIncrement %W up big noRepeat
}
bind Scale <Control-Right> {
tkScaleIncrement %W down big noRepeat
}
bind Scale <Home> {
%W set [%W cget -from]
}
bind Scale <End> {
%W set [%W cget -to]
}
# tkScaleActivate --
# This procedure is invoked to check a given x-y position in the
# scale and activate the slider if the x-y position falls within
# the slider.
#
# Arguments:
# w - The scale widget.
# x, y - Mouse coordinates.
proc tkScaleActivate {w x y} {
if {[string equal [$w cget -state] "disabled"]} {
return
}
if {[string equal [$w identify $x $y] "slider"]} {
set state active
} else {
set state normal
}
if {[string compare [$w cget -state] $state]} {
$w configure -state $state
}
}
# tkScaleButtonDown --
# This procedure is invoked when a button is pressed in a scale. It
# takes different actions depending on where the button was pressed.
#
# Arguments:
# w - The scale widget.
# x, y - Mouse coordinates of button press.
proc tkScaleButtonDown {w x y} {
global tkPriv
set tkPriv(dragging) 0
set el [$w identify $x $y]
if {[string equal $el "trough1"]} {
tkScaleIncrement $w up little initial
} elseif {[string equal $el "trough2"]} {
tkScaleIncrement $w down little initial
} elseif {[string equal $el "slider"]} {
set tkPriv(dragging) 1
set tkPriv(initValue) [$w get]
set coords [$w coords]
set tkPriv(deltaX) [expr {$x - [lindex $coords 0]}]
set tkPriv(deltaY) [expr {$y - [lindex $coords 1]}]
$w configure -sliderrelief sunken
}
}
# tkScaleDrag --
# This procedure is called when the mouse is dragged with
# mouse button 1 down. If the drag started inside the slider
# (i.e. the scale is active) then the scale's value is adjusted
# to reflect the mouse's position.
#
# Arguments:
# w - The scale widget.
# x, y - Mouse coordinates.
proc tkScaleDrag {w x y} {
global tkPriv
if {!$tkPriv(dragging)} {
return
}
$w set [$w get [expr {$x-$tkPriv(deltaX)}] [expr {$y-$tkPriv(deltaY)}]]
}
# tkScaleEndDrag --
# This procedure is called to end an interactive drag of the
# slider. It just marks the drag as over.
#
# Arguments:
# w - The scale widget.
proc tkScaleEndDrag {w} {
global tkPriv
set tkPriv(dragging) 0
$w configure -sliderrelief raised
}
# tkScaleIncrement --
# This procedure is invoked to increment the value of a scale and
# to set up auto-repeating of the action if that is desired. The
# way the value is incremented depends on the "dir" and "big"
# arguments.
#
# Arguments:
# w - The scale widget.
# dir - "up" means move value towards -from, "down" means
# move towards -to.
# big - Size of increments: "big" or "little".
# repeat - Whether and how to auto-repeat the action: "noRepeat"
# means don't auto-repeat, "initial" means this is the
# first action in an auto-repeat sequence, and "again"
# means this is the second repetition or later.
proc tkScaleIncrement {w dir big repeat} {
global tkPriv
if {![winfo exists $w]} return
if {[string equal $big "big"]} {
set inc [$w cget -bigincrement]
if {$inc == 0} {
set inc [expr {abs([$w cget -to] - [$w cget -from])/10.0}]
}
if {$inc < [$w cget -resolution]} {
set inc [$w cget -resolution]
}
} else {
set inc [$w cget -resolution]
}
if {([$w cget -from] > [$w cget -to]) ^ [string equal $dir "up"]} {
set inc [expr {-$inc}]
}
$w set [expr {[$w get] + $inc}]
if {[string equal $repeat "again"]} {
set tkPriv(afterId) [after [$w cget -repeatinterval] \
[list tkScaleIncrement $w $dir $big again]]
} elseif {[string equal $repeat "initial"]} {
set delay [$w cget -repeatdelay]
if {$delay > 0} {
set tkPriv(afterId) [after $delay \
[list tkScaleIncrement $w $dir $big again]]
}
}
}
# tkScaleControlPress --
# This procedure handles button presses that are made with the Control
# key down. Depending on the mouse position, it adjusts the scale
# value to one end of the range or the other.
#
# Arguments:
# w - The scale widget.
# x, y - Mouse coordinates where the button was pressed.
proc tkScaleControlPress {w x y} {
set el [$w identify $x $y]
if {[string equal $el "trough1"]} {
$w set [$w cget -from]
} elseif {[string equal $el "trough2"]} {
$w set [$w cget -to]
}
}
# tkScaleButton2Down
# This procedure is invoked when button 2 is pressed over a scale.
# It sets the value to correspond to the mouse position and starts
# a slider drag.
#
# Arguments:
# w - The scrollbar widget.
# x, y - Mouse coordinates within the widget.
proc tkScaleButton2Down {w x y} {
global tkPriv
if {[string equal [$w cget -state] "disabled"]} {
return
}
$w configure -state active
$w set [$w get $x $y]
set tkPriv(dragging) 1
set tkPriv(initValue) [$w get]
set coords "$x $y"
set tkPriv(deltaX) 0
set tkPriv(deltaY) 0
}
-ß# scrlbar.tcl --
#
# This file defines the default bindings for Tk scrollbar widgets.
# It also provides procedures that help in implementing the bindings.
#
# RCS: @(#) $Id: scrlbar.tcl,v 1.8 2000/01/06 02:22:24 hobbs Exp $
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#-------------------------------------------------------------------------
# The code below creates the default class bindings for scrollbars.
#-------------------------------------------------------------------------
# Standard Motif bindings:
if {[string compare $tcl_platform(platform) "windows"] && \
[string compare $tcl_platform(platform) "macintosh"]} {
bind Scrollbar <Enter> {
if {$tk_strictMotif} {
set tkPriv(activeBg) [%W cget -activebackground]
%W config -activebackground [%W cget -background]
}
%W activate [%W identify %x %y]
}
bind Scrollbar <Motion> {
%W activate [%W identify %x %y]
}
# The "info exists" command in the following binding handles the
# situation where a Leave event occurs for a scrollbar without the Enter
# event. This seems to happen on some systems (such as Solaris 2.4) for
# unknown reasons.
bind Scrollbar <Leave> {
if {$tk_strictMotif && [info exists tkPriv(activeBg)]} {
%W config -activebackground $tkPriv(activeBg)
}
%W activate {}
}
bind Scrollbar <1> {
tkScrollButtonDown %W %x %y
}
bind Scrollbar <B1-Motion> {
tkScrollDrag %W %x %y
}
bind Scrollbar <B1-B2-Motion> {
tkScrollDrag %W %x %y
}
bind Scrollbar <ButtonRelease-1> {
tkScrollButtonUp %W %x %y
}
bind Scrollbar <B1-Leave> {
# Prevents <Leave> binding from being invoked.
}
bind Scrollbar <B1-Enter> {
# Prevents <Enter> binding from being invoked.
}
bind Scrollbar <2> {
tkScrollButton2Down %W %x %y
}
bind Scrollbar <B1-2> {
# Do nothing, since button 1 is already down.
}
bind Scrollbar <B2-1> {
# Do nothing, since button 2 is already down.
}
bind Scrollbar <B2-Motion> {
tkScrollDrag %W %x %y
}
bind Scrollbar <ButtonRelease-2> {
tkScrollButtonUp %W %x %y
}
bind Scrollbar <B1-ButtonRelease-2> {
# Do nothing: B1 release will handle it.
}
bind Scrollbar <B2-ButtonRelease-1> {
# Do nothing: B2 release will handle it.
}
bind Scrollbar <B2-Leave> {
# Prevents <Leave> binding from being invoked.
}
bind Scrollbar <B2-Enter> {
# Prevents <Enter> binding from being invoked.
}
bind Scrollbar <Control-1> {
tkScrollTopBottom %W %x %y
}
bind Scrollbar <Control-2> {
tkScrollTopBottom %W %x %y
}
bind Scrollbar <Up> {
tkScrollByUnits %W v -1
}
bind Scrollbar <Down> {
tkScrollByUnits %W v 1
}
bind Scrollbar <Control-Up> {
tkScrollByPages %W v -1
}
bind Scrollbar <Control-Down> {
tkScrollByPages %W v 1
}
bind Scrollbar <Left> {
tkScrollByUnits %W h -1
}
bind Scrollbar <Right> {
tkScrollByUnits %W h 1
}
bind Scrollbar <Control-Left> {
tkScrollByPages %W h -1
}
bind Scrollbar <Control-Right> {
tkScrollByPages %W h 1
}
bind Scrollbar <Prior> {
tkScrollByPages %W hv -1
}
bind Scrollbar <Next> {
tkScrollByPages %W hv 1
}
bind Scrollbar <Home> {
tkScrollToPos %W 0
}
bind Scrollbar <End> {
tkScrollToPos %W 1
}
}
# tkScrollButtonDown --
# This procedure is invoked when a button is pressed in a scrollbar.
# It changes the way the scrollbar is displayed and takes actions
# depending on where the mouse is.
#
# Arguments:
# w - The scrollbar widget.
# x, y - Mouse coordinates.
proc tkScrollButtonDown {w x y} {
global tkPriv
set tkPriv(relief) [$w cget -activerelief]
$w configure -activerelief sunken
set element [$w identify $x $y]
if {[string equal $element "slider"]} {
tkScrollStartDrag $w $x $y
} else {
tkScrollSelect $w $element initial
}
}
# tkScrollButtonUp --
# This procedure is invoked when a button is released in a scrollbar.
# It cancels scans and auto-repeats that were in progress, and restores
# the way the active element is displayed.
#
# Arguments:
# w - The scrollbar widget.
# x, y - Mouse coordinates.
proc tkScrollButtonUp {w x y} {
global tkPriv
tkCancelRepeat
if {[info exists tkPriv(relief)]} {
# Avoid error due to spurious release events
$w configure -activerelief $tkPriv(relief)
tkScrollEndDrag $w $x $y
$w activate [$w identify $x $y]
}
}
# tkScrollSelect --
# This procedure is invoked when a button is pressed over the scrollbar.
# It invokes one of several scrolling actions depending on where in
# the scrollbar the button was pressed.
#
# Arguments:
# w - The scrollbar widget.
# element - The element of the scrollbar that was selected, such
# as "arrow1" or "trough2". Shouldn't be "slider".
# repeat - Whether and how to auto-repeat the action: "noRepeat"
# means don't auto-repeat, "initial" means this is the
# first action in an auto-repeat sequence, and "again"
# means this is the second repetition or later.
proc tkScrollSelect {w element repeat} {
global tkPriv
if {![winfo exists $w]} return
switch -- $element {
"arrow1" {tkScrollByUnits $w hv -1}
"trough1" {tkScrollByPages $w hv -1}
"trough2" {tkScrollByPages $w hv 1}
"arrow2" {tkScrollByUnits $w hv 1}
default {return}
}
if {[string equal $repeat "again"]} {
set tkPriv(afterId) [after [$w cget -repeatinterval] \
[list tkScrollSelect $w $element again]]
} elseif {[string equal $repeat "initial"]} {
set delay [$w cget -repeatdelay]
if {$delay > 0} {
set tkPriv(afterId) [after $delay \
[list tkScrollSelect $w $element again]]
}
}
}
# tkScrollStartDrag --
# This procedure is called to initiate a drag of the slider. It just
# remembers the starting position of the mouse and slider.
#
# Arguments:
# w - The scrollbar widget.
# x, y - The mouse position at the start of the drag operation.
proc tkScrollStartDrag {w x y} {
global tkPriv
if {[string equal [$w cget -command] ""]} {
return
}
set tkPriv(pressX) $x
set tkPriv(pressY) $y
set tkPriv(initValues) [$w get]
set iv0 [lindex $tkPriv(initValues) 0]
if {[llength $tkPriv(initValues)] == 2} {
set tkPriv(initPos) $iv0
} elseif {$iv0 == 0} {
set tkPriv(initPos) 0.0
} else {
set tkPriv(initPos) [expr {(double([lindex $tkPriv(initValues) 2])) \
/ [lindex $tkPriv(initValues) 0]}]
}
}
# tkScrollDrag --
# This procedure is called for each mouse motion even when the slider
# is being dragged. It notifies the associated widget if we're not
# jump scrolling, and it just updates the scrollbar if we are jump
# scrolling.
#
# Arguments:
# w - The scrollbar widget.
# x, y - The current mouse position.
proc tkScrollDrag {w x y} {
global tkPriv
if {[string equal $tkPriv(initPos) ""]} {
return
}
set delta [$w delta [expr {$x - $tkPriv(pressX)}] [expr {$y - $tkPriv(pressY)}]]
if {[$w cget -jump]} {
if {[llength $tkPriv(initValues)] == 2} {
$w set [expr {[lindex $tkPriv(initValues) 0] + $delta}] \
[expr {[lindex $tkPriv(initValues) 1] + $delta}]
} else {
set delta [expr {round($delta * [lindex $tkPriv(initValues) 0])}]
eval [list $w] set [lreplace $tkPriv(initValues) 2 3 \
[expr {[lindex $tkPriv(initValues) 2] + $delta}] \
[expr {[lindex $tkPriv(initValues) 3] + $delta}]]
}
} else {
tkScrollToPos $w [expr {$tkPriv(initPos) + $delta}]
}
}
# tkScrollEndDrag --
# This procedure is called to end an interactive drag of the slider.
# It scrolls the window if we're in jump mode, otherwise it does nothing.
#
# Arguments:
# w - The scrollbar widget.
# x, y - The mouse position at the end of the drag operation.
proc tkScrollEndDrag {w x y} {
global tkPriv
if {[string equal $tkPriv(initPos) ""]} {
return
}
if {[$w cget -jump]} {
set delta [$w delta [expr {$x - $tkPriv(pressX)}] \
[expr {$y - $tkPriv(pressY)}]]
tkScrollToPos $w [expr {$tkPriv(initPos) + $delta}]
}
set tkPriv(initPos) ""
}
# tkScrollByUnits --
# This procedure tells the scrollbar's associated widget to scroll up
# or down by a given number of units. It notifies the associated widget
# in different ways for old and new command syntaxes.
#
# Arguments:
# w - The scrollbar widget.
# orient - Which kinds of scrollbars this applies to: "h" for
# horizontal, "v" for vertical, "hv" for both.
# amount - How many units to scroll: typically 1 or -1.
proc tkScrollByUnits {w orient amount} {
set cmd [$w cget -command]
if {[string equal $cmd ""] || ([string first \
[string index [$w cget -orient] 0] $orient] < 0)} {
return
}
set info [$w get]
if {[llength $info] == 2} {
uplevel #0 $cmd scroll $amount units
} else {
uplevel #0 $cmd [expr {[lindex $info 2] + $amount}]
}
}
# tkScrollByPages --
# This procedure tells the scrollbar's associated widget to scroll up
# or down by a given number of screenfuls. It notifies the associated
# widget in different ways for old and new command syntaxes.
#
# Arguments:
# w - The scrollbar widget.
# orient - Which kinds of scrollbars this applies to: "h" for
# horizontal, "v" for vertical, "hv" for both.
# amount - How many screens to scroll: typically 1 or -1.
proc tkScrollByPages {w orient amount} {
set cmd [$w cget -command]
if {[string equal $cmd ""] || ([string first \
[string index [$w cget -orient] 0] $orient] < 0)} {
return
}
set info [$w get]
if {[llength $info] == 2} {
uplevel #0 $cmd scroll $amount pages
} else {
uplevel #0 $cmd [expr {[lindex $info 2] + $amount*([lindex $info 1] - 1)}]
}
}
# tkScrollToPos --
# This procedure tells the scrollbar's associated widget to scroll to
# a particular location, given by a fraction between 0 and 1. It notifies
# the associated widget in different ways for old and new command syntaxes.
#
# Arguments:
# w - The scrollbar widget.
# pos - A fraction between 0 and 1 indicating a desired position
# in the document.
proc tkScrollToPos {w pos} {
set cmd [$w cget -command]
if {[string equal $cmd ""]} {
return
}
set info [$w get]
if {[llength $info] == 2} {
uplevel #0 $cmd moveto $pos
} else {
uplevel #0 $cmd [expr {round([lindex $info 0]*$pos)}]
}
}
# tkScrollTopBottom
# Scroll to the top or bottom of the document, depending on the mouse
# position.
#
# Arguments:
# w - The scrollbar widget.
# x, y - Mouse coordinates within the widget.
proc tkScrollTopBottom {w x y} {
global tkPriv
set element [$w identify $x $y]
if {[string match *1 $element]} {
tkScrollToPos $w 0
} elseif {[string match *2 $element]} {
tkScrollToPos $w 1
}
# Set tkPriv(relief), since it's needed by tkScrollButtonUp.
set tkPriv(relief) [$w cget -activerelief]
}
# tkScrollButton2Down
# This procedure is invoked when button 2 is pressed over a scrollbar.
# If the button is over the trough or slider, it sets the scrollbar to
# the mouse position and starts a slider drag. Otherwise it just
# behaves the same as button 1.
#
# Arguments:
# w - The scrollbar widget.
# x, y - Mouse coordinates within the widget.
proc tkScrollButton2Down {w x y} {
global tkPriv
set element [$w identify $x $y]
if {[string match {arrow[12]} $element]} {
tkScrollButtonDown $w $x $y
return
}
tkScrollToPos $w [$w fraction $x $y]
set tkPriv(relief) [$w cget -activerelief]
# Need the "update idletasks" below so that the widget calls us
# back to reset the actual scrollbar position before we start the
# slider drag.
update idletasks
$w configure -activerelief sunken
$w activate slider
tkScrollStartDrag $w $x $y
}
1# tearoff.tcl --
#
# This file contains procedures that implement tear-off menus.
#
# RCS: @(#) $Id: tearoff.tcl,v 1.6 2000/01/06 02:22:24 hobbs Exp $
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# tkTearoffMenu --
# Given the name of a menu, this procedure creates a torn-off menu
# that is identical to the given menu (including nested submenus).
# The new torn-off menu exists as a toplevel window managed by the
# window manager. The return value is the name of the new menu.
# The window is created at the point specified by x and y
#
# Arguments:
# w - The menu to be torn-off (duplicated).
# x - x coordinate where window is created
# y - y coordinate where window is created
proc tkTearOffMenu {w {x 0} {y 0}} {
# Find a unique name to use for the torn-off menu. Find the first
# ancestor of w that is a toplevel but not a menu, and use this as
# the parent of the new menu. This guarantees that the torn off
# menu will be on the same screen as the original menu. By making
# it a child of the ancestor, rather than a child of the menu, it
# can continue to live even if the menu is deleted; it will go
# away when the toplevel goes away.
if {$x == 0} {
set x [winfo rootx $w]
}
if {$y == 0} {
set y [winfo rooty $w]
}
set parent [winfo parent $w]
while {[string compare [winfo toplevel $parent] $parent] \
|| [string equal [winfo class $parent] "Menu"]} {
set parent [winfo parent $parent]
}
if {[string equal $parent "."]} {
set parent ""
}
for {set i 1} 1 {incr i} {
set menu $parent.tearoff$i
if {![winfo exists $menu]} {
break
}
}
$w clone $menu tearoff
# Pick a title for the new menu by looking at the parent of the
# original: if the parent is a menu, then use the text of the active
# entry. If it's a menubutton then use its text.
set parent [winfo parent $w]
if {[string compare [$menu cget -title] ""]} {
wm title $menu [$menu cget -title]
} else {
switch [winfo class $parent] {
Menubutton {
wm title $menu [$parent cget -text]
}
Menu {
wm title $menu [$parent entrycget active -label]
}
}
}
$menu post $x $y
if {[winfo exists $menu] == 0} {
return ""
}
# Set tkPriv(focus) on entry: otherwise the focus will get lost
# after keyboard invocation of a sub-menu (it will stay on the
# submenu).
bind $menu <Enter> {
set tkPriv(focus) %W
}
# If there is a -tearoffcommand option for the menu, invoke it
# now.
set cmd [$w cget -tearoffcommand]
if {[string compare $cmd ""]} {
uplevel #0 $cmd [list $w $menu]
}
return $menu
}
# tkMenuDup --
# Given a menu (hierarchy), create a duplicate menu (hierarchy)
# in a given window.
#
# Arguments:
# src - Source window. Must be a menu. It and its
# menu descendants will be duplicated at dst.
# dst - Name to use for topmost menu in duplicate
# hierarchy.
proc tkMenuDup {src dst type} {
set cmd [list menu $dst -type $type]
foreach option [$src configure] {
if {[llength $option] == 2} {
continue
}
if {[string equal [lindex $option 0] "-type"]} {
continue
}
lappend cmd [lindex $option 0] [lindex $option 4]
}
eval $cmd
set last [$src index last]
if {[string equal $last "none"]} {
return
}
for {set i [$src cget -tearoff]} {$i <= $last} {incr i} {
set cmd [list $dst add [$src type $i]]
foreach option [$src entryconfigure $i] {
lappend cmd [lindex $option 0] [lindex $option 4]
}
eval $cmd
}
# Duplicate the binding tags and bindings from the source menu.
set tags [bindtags $src]
set srcLen [string length $src]
# Copy tags to x, replacing each substring of src with dst.
while {[set index [string first $src $tags]] != -1} {
append x [string range $tags 0 [expr {$index - 1}]]$dst
set tags [string range $tags [expr {$index + $srcLen}] end]
}
append x $tags
bindtags $dst $x
foreach event [bind $src] {
unset x
set script [bind $src $event]
set eventLen [string length $event]
# Copy script to x, replacing each substring of event with dst.
while {[set index [string first $event $script]] != -1} {
append x [string range $script 0 [expr {$index - 1}]]
append x $dst
set script [string range $script [expr {$index + $eventLen}] end]
}
append x $script
bind $dst $event $x
}
}
nØ# text.tcl --
#
# This file defines the default bindings for Tk text widgets and provides
# procedures that help in implementing the bindings.
#
# RCS: @(#) $Id: text.tcl,v 1.12.2.1 2001/04/04 07:57:17 hobbs Exp $
#
# Copyright (c) 1992-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#-------------------------------------------------------------------------
# Elements of tkPriv that are used in this file:
#
# afterId - If non-null, it means that auto-scanning is underway
# and it gives the "after" id for the next auto-scan
# command to be executed.
# char - Character position on the line; kept in order
# to allow moving up or down past short lines while
# still remembering the desired position.
# mouseMoved - Non-zero means the mouse has moved a significant
# amount since the button went down (so, for example,
# start dragging out a selection).
# prevPos - Used when moving up or down lines via the keyboard.
# Keeps track of the previous insert position, so
# we can distinguish a series of ups and downs, all
# in a row, from a new up or down.
# selectMode - The style of selection currently underway:
# char, word, or line.
# x, y - Last known mouse coordinates for scanning
# and auto-scanning.
#-------------------------------------------------------------------------
#-------------------------------------------------------------------------
# The code below creates the default class bindings for text widgets.
#-------------------------------------------------------------------------
# Standard Motif bindings:
bind Text <1> {
tkTextButton1 %W %x %y
%W tag remove sel 0.0 end
}
bind Text <B1-Motion> {
set tkPriv(x) %x
set tkPriv(y) %y
tkTextSelectTo %W %x %y
}
bind Text <Double-1> {
set tkPriv(selectMode) word
tkTextSelectTo %W %x %y
catch {%W mark set insert sel.last}
catch {%W mark set anchor sel.first}
}
bind Text <Triple-1> {
set tkPriv(selectMode) line
tkTextSelectTo %W %x %y
catch {%W mark set insert sel.last}
catch {%W mark set anchor sel.first}
}
bind Text <Shift-1> {
tkTextResetAnchor %W @%x,%y
set tkPriv(selectMode) char
tkTextSelectTo %W %x %y
}
bind Text <Double-Shift-1> {
set tkPriv(selectMode) word
tkTextSelectTo %W %x %y 1
}
bind Text <Triple-Shift-1> {
set tkPriv(selectMode) line
tkTextSelectTo %W %x %y
}
bind Text <B1-Leave> {
set tkPriv(x) %x
set tkPriv(y) %y
tkTextAutoScan %W
}
bind Text <B1-Enter> {
tkCancelRepeat
}
bind Text <ButtonRelease-1> {
tkCancelRepeat
}
bind Text <Control-1> {
%W mark set insert @%x,%y
}
bind Text <Left> {
tkTextSetCursor %W insert-1c
}
bind Text <Right> {
tkTextSetCursor %W insert+1c
}
bind Text <Up> {
tkTextSetCursor %W [tkTextUpDownLine %W -1]
}
bind Text <Down> {
tkTextSetCursor %W [tkTextUpDownLine %W 1]
}
bind Text <Shift-Left> {
tkTextKeySelect %W [%W index {insert - 1c}]
}
bind Text <Shift-Right> {
tkTextKeySelect %W [%W index {insert + 1c}]
}
bind Text <Shift-Up> {
tkTextKeySelect %W [tkTextUpDownLine %W -1]
}
bind Text <Shift-Down> {
tkTextKeySelect %W [tkTextUpDownLine %W 1]
}
bind Text <Control-Left> {
tkTextSetCursor %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]
}
bind Text <Control-Right> {
tkTextSetCursor %W [tkTextNextWord %W insert]
}
bind Text <Control-Up> {
tkTextSetCursor %W [tkTextPrevPara %W insert]
}
bind Text <Control-Down> {
tkTextSetCursor %W [tkTextNextPara %W insert]
}
bind Text <Shift-Control-Left> {
tkTextKeySelect %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]
}
bind Text <Shift-Control-Right> {
tkTextKeySelect %W [tkTextNextWord %W insert]
}
bind Text <Shift-Control-Up> {
tkTextKeySelect %W [tkTextPrevPara %W insert]
}
bind Text <Shift-Control-Down> {
tkTextKeySelect %W [tkTextNextPara %W insert]
}
bind Text <Prior> {
tkTextSetCursor %W [tkTextScrollPages %W -1]
}
bind Text <Shift-Prior> {
tkTextKeySelect %W [tkTextScrollPages %W -1]
}
bind Text <Next> {
tkTextSetCursor %W [tkTextScrollPages %W 1]
}
bind Text <Shift-Next> {
tkTextKeySelect %W [tkTextScrollPages %W 1]
}
bind Text <Control-Prior> {
%W xview scroll -1 page
}
bind Text <Control-Next> {
%W xview scroll 1 page
}
bind Text <Home> {
tkTextSetCursor %W {insert linestart}
}
bind Text <Shift-Home> {
tkTextKeySelect %W {insert linestart}
}
bind Text <End> {
tkTextSetCursor %W {insert lineend}
}
bind Text <Shift-End> {
tkTextKeySelect %W {insert lineend}
}
bind Text <Control-Home> {
tkTextSetCursor %W 1.0
}
bind Text <Control-Shift-Home> {
tkTextKeySelect %W 1.0
}
bind Text <Control-End> {
tkTextSetCursor %W {end - 1 char}
}
bind Text <Control-Shift-End> {
tkTextKeySelect %W {end - 1 char}
}
bind Text <Tab> {
if { [string equal [%W cget -state] "normal"] } {
tkTextInsert %W \t
focus %W
break
}
}
bind Text <Shift-Tab> {
# Needed only to keep <Tab> binding from triggering; doesn't
# have to actually do anything.
break
}
bind Text <Control-Tab> {
focus [tk_focusNext %W]
}
bind Text <Control-Shift-Tab> {
focus [tk_focusPrev %W]
}
bind Text <Control-i> {
tkTextInsert %W \t
}
bind Text <Return> {
tkTextInsert %W \n
}
bind Text <Delete> {
if {[string compare [%W tag nextrange sel 1.0 end] ""]} {
%W delete sel.first sel.last
} else {
%W delete insert
%W see insert
}
}
bind Text <BackSpace> {
if {[string compare [%W tag nextrange sel 1.0 end] ""]} {
%W delete sel.first sel.last
} elseif {[%W compare insert != 1.0]} {
%W delete insert-1c
%W see insert
}
}
bind Text <Control-space> {
%W mark set anchor insert
}
bind Text <Select> {
%W mark set anchor insert
}
bind Text <Control-Shift-space> {
set tkPriv(selectMode) char
tkTextKeyExtend %W insert
}
bind Text <Shift-Select> {
set tkPriv(selectMode) char
tkTextKeyExtend %W insert
}
bind Text <Control-slash> {
%W tag add sel 1.0 end
}
bind Text <Control-backslash> {
%W tag remove sel 1.0 end
}
bind Text <<Cut>> {
tk_textCut %W
}
bind Text <<Copy>> {
tk_textCopy %W
}
bind Text <<Paste>> {
tk_textPaste %W
}
bind Text <<Clear>> {
catch {%W delete sel.first sel.last}
}
bind Text <<PasteSelection>> {
if {!$tkPriv(mouseMoved) || $tk_strictMotif} {
tkTextPaste %W %x %y
}
}
bind Text <Insert> {
catch {tkTextInsert %W [selection get -displayof %W]}
}
bind Text <KeyPress> {
tkTextInsert %W %A
}
# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
# Otherwise, if a widget binding for one of these is defined, the
# <KeyPress> class binding will also fire and insert the character,
# which is wrong. Ditto for <Escape>.
bind Text <Alt-KeyPress> {# nothing }
bind Text <Meta-KeyPress> {# nothing}
bind Text <Control-KeyPress> {# nothing}
bind Text <Escape> {# nothing}
bind Text <KP_Enter> {# nothing}
if {[string equal $tcl_platform(platform) "macintosh"]} {
bind Text <Command-KeyPress> {# nothing}
}
# Additional emacs-like bindings:
bind Text <Control-a> {
if {!$tk_strictMotif} {
tkTextSetCursor %W {insert linestart}
}
}
bind Text <Control-b> {
if {!$tk_strictMotif} {
tkTextSetCursor %W insert-1c
}
}
bind Text <Control-d> {
if {!$tk_strictMotif} {
%W delete insert
}
}
bind Text <Control-e> {
if {!$tk_strictMotif} {
tkTextSetCursor %W {insert lineend}
}
}
bind Text <Control-f> {
if {!$tk_strictMotif} {
tkTextSetCursor %W insert+1c
}
}
bind Text <Control-k> {
if {!$tk_strictMotif} {
if {[%W compare insert == {insert lineend}]} {
%W delete insert
} else {
%W delete insert {insert lineend}
}
}
}
bind Text <Control-n> {
if {!$tk_strictMotif} {
tkTextSetCursor %W [tkTextUpDownLine %W 1]
}
}
bind Text <Control-o> {
if {!$tk_strictMotif} {
%W insert insert \n
%W mark set insert insert-1c
}
}
bind Text <Control-p> {
if {!$tk_strictMotif} {
tkTextSetCursor %W [tkTextUpDownLine %W -1]
}
}
bind Text <Control-t> {
if {!$tk_strictMotif} {
tkTextTranspose %W
}
}
if {[string compare $tcl_platform(platform) "windows"]} {
bind Text <Control-v> {
if {!$tk_strictMotif} {
tkTextScrollPages %W 1
}
}
}
bind Text <Meta-b> {
if {!$tk_strictMotif} {
tkTextSetCursor %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]
}
}
bind Text <Meta-d> {
if {!$tk_strictMotif} {
%W delete insert [tkTextNextWord %W insert]
}
}
bind Text <Meta-f> {
if {!$tk_strictMotif} {
tkTextSetCursor %W [tkTextNextWord %W insert]
}
}
bind Text <Meta-less> {
if {!$tk_strictMotif} {
tkTextSetCursor %W 1.0
}
}
bind Text <Meta-greater> {
if {!$tk_strictMotif} {
tkTextSetCursor %W end-1c
}
}
bind Text <Meta-BackSpace> {
if {!$tk_strictMotif} {
%W delete [tkTextPrevPos %W insert tcl_startOfPreviousWord] insert
}
}
bind Text <Meta-Delete> {
if {!$tk_strictMotif} {
%W delete [tkTextPrevPos %W insert tcl_startOfPreviousWord] insert
}
}
# Macintosh only bindings:
# if text black & highlight black -> text white, other text the same
if {[string equal $tcl_platform(platform) "macintosh"]} {
bind Text <FocusIn> {
%W tag configure sel -borderwidth 0
%W configure -selectbackground systemHighlight -selectforeground systemHighlightText
}
bind Text <FocusOut> {
%W tag configure sel -borderwidth 1
%W configure -selectbackground white -selectforeground black
}
bind Text <Option-Left> {
tkTextSetCursor %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]
}
bind Text <Option-Right> {
tkTextSetCursor %W [tkTextNextWord %W insert]
}
bind Text <Option-Up> {
tkTextSetCursor %W [tkTextPrevPara %W insert]
}
bind Text <Option-Down> {
tkTextSetCursor %W [tkTextNextPara %W insert]
}
bind Text <Shift-Option-Left> {
tkTextKeySelect %W [tkTextPrevPos %W insert tcl_startOfPreviousWord]
}
bind Text <Shift-Option-Right> {
tkTextKeySelect %W [tkTextNextWord %W insert]
}
bind Text <Shift-Option-Up> {
tkTextKeySelect %W [tkTextPrevPara %W insert]
}
bind Text <Shift-Option-Down> {
tkTextKeySelect %W [tkTextNextPara %W insert]
}
# End of Mac only bindings
}
# A few additional bindings of my own.
bind Text <Control-h> {
if {!$tk_strictMotif} {
if {[%W compare insert != 1.0]} {
%W delete insert-1c
%W see insert
}
}
}
bind Text <2> {
if {!$tk_strictMotif} {
%W scan mark %x %y
set tkPriv(x) %x
set tkPriv(y) %y
set tkPriv(mouseMoved) 0
}
}
bind Text <B2-Motion> {
if {!$tk_strictMotif} {
if {(%x != $tkPriv(x)) || (%y != $tkPriv(y))} {
set tkPriv(mouseMoved) 1
}
if {$tkPriv(mouseMoved)} {
%W scan dragto %x %y
}
}
}
set tkPriv(prevPos) {}
# The MouseWheel will typically only fire on Windows. However,
# someone could use the "event generate" command to produce one
# on other platforms.
bind Text <MouseWheel> {
%W yview scroll [expr {- (%D / 120) * 4}] units
}
if {[string equal "unix" $tcl_platform(platform)]} {
# Support for mousewheels on Linux/Unix commonly comes through mapping
# the wheel to the extended buttons. If you have a mousewheel, find
# Linux configuration info at:
# http://www.inria.fr/koala/colas/mouse-wheel-scroll/
bind Text <4> {
if {!$tk_strictMotif} {
%W yview scroll -5 units
}
}
bind Text <5> {
if {!$tk_strictMotif} {
%W yview scroll 5 units
}
}
}
# tkTextClosestGap --
# Given x and y coordinates, this procedure finds the closest boundary
# between characters to the given coordinates and returns the index
# of the character just after the boundary.
#
# Arguments:
# w - The text window.
# x - X-coordinate within the window.
# y - Y-coordinate within the window.
proc tkTextClosestGap {w x y} {
set pos [$w index @$x,$y]
set bbox [$w bbox $pos]
if {[string equal $bbox ""]} {
return $pos
}
if {($x - [lindex $bbox 0]) < ([lindex $bbox 2]/2)} {
return $pos
}
$w index "$pos + 1 char"
}
# tkTextButton1 --
# This procedure is invoked to handle button-1 presses in text
# widgets. It moves the insertion cursor, sets the selection anchor,
# and claims the input focus.
#
# Arguments:
# w - The text window in which the button was pressed.
# x - The x-coordinate of the button press.
# y - The x-coordinate of the button press.
proc tkTextButton1 {w x y} {
global tkPriv
set tkPriv(selectMode) char
set tkPriv(mouseMoved) 0
set tkPriv(pressX) $x
$w mark set insert [tkTextClosestGap $w $x $y]
$w mark set anchor insert
if {[string equal [$w cget -state] "normal"]} {focus $w}
}
# tkTextSelectTo --
# This procedure is invoked to extend the selection, typically when
# dragging it with the mouse. Depending on the selection mode (character,
# word, line) it selects in different-sized units. This procedure
# ignores mouse motions initially until the mouse has moved from
# one character to another or until there have been multiple clicks.
#
# Arguments:
# w - The text window in which the button was pressed.
# x - Mouse x position.
# y - Mouse y position.
proc tkTextSelectTo {w x y {extend 0}} {
global tkPriv tcl_platform
set cur [tkTextClosestGap $w $x $y]
if {[catch {$w index anchor}]} {
$w mark set anchor $cur
}
set anchor [$w index anchor]
if {[$w compare $cur != $anchor] || (abs($tkPriv(pressX) - $x) >= 3)} {
set tkPriv(mouseMoved) 1
}
switch $tkPriv(selectMode) {
char {
if {[$w compare $cur < anchor]} {
set first $cur
set last anchor
} else {
set first anchor
set last $cur
}
}
word {
if {[$w compare $cur < anchor]} {
set first [tkTextPrevPos $w "$cur + 1c" tcl_wordBreakBefore]
if { !$extend } {
set last [tkTextNextPos $w "anchor" tcl_wordBreakAfter]
} else {
set last anchor
}
} else {
set last [tkTextNextPos $w "$cur - 1c" tcl_wordBreakAfter]
if { !$extend } {
set first [tkTextPrevPos $w anchor tcl_wordBreakBefore]
} else {
set first anchor
}
}
}
line {
if {[$w compare $cur < anchor]} {
set first [$w index "$cur linestart"]
set last [$w index "anchor - 1c lineend + 1c"]
} else {
set first [$w index "anchor linestart"]
set last [$w index "$cur lineend + 1c"]
}
}
}
if {$tkPriv(mouseMoved) || [string compare $tkPriv(selectMode) "char"]} {
$w tag remove sel 0.0 end
$w mark set insert $cur
$w tag add sel $first $last
update idletasks
}
}
# tkTextKeyExtend --
# This procedure handles extending the selection from the keyboard,
# where the point to extend to is really the boundary between two
# characters rather than a particular character.
#
# Arguments:
# w - The text window.
# index - The point to which the selection is to be extended.
proc tkTextKeyExtend {w index} {
global tkPriv
set cur [$w index $index]
if {[catch {$w index anchor}]} {
$w mark set anchor $cur
}
set anchor [$w index anchor]
if {[$w compare $cur < anchor]} {
set first $cur
set last anchor
} else {
set first anchor
set last $cur
}
$w tag remove sel 0.0 $first
$w tag add sel $first $last
$w tag remove sel $last end
}
# tkTextPaste --
# This procedure sets the insertion cursor to the mouse position,
# inserts the selection, and sets the focus to the window.
#
# Arguments:
# w - The text window.
# x, y - Position of the mouse.
proc tkTextPaste {w x y} {
$w mark set insert [tkTextClosestGap $w $x $y]
catch {$w insert insert [selection get -displayof $w]}
if {[string equal [$w cget -state] "normal"]} {focus $w}
}
# tkTextAutoScan --
# This procedure is invoked when the mouse leaves a text window
# with button 1 down. It scrolls the window up, down, left, or right,
# depending on where the mouse is (this information was saved in
# tkPriv(x) and tkPriv(y)), and reschedules itself as an "after"
# command so that the window continues to scroll until the mouse
# moves back into the window or the mouse button is released.
#
# Arguments:
# w - The text window.
proc tkTextAutoScan {w} {
global tkPriv
if {![winfo exists $w]} return
if {$tkPriv(y) >= [winfo height $w]} {
$w yview scroll 2 units
} elseif {$tkPriv(y) < 0} {
$w yview scroll -2 units
} elseif {$tkPriv(x) >= [winfo width $w]} {
$w xview scroll 2 units
} elseif {$tkPriv(x) < 0} {
$w xview scroll -2 units
} else {
return
}
tkTextSelectTo $w $tkPriv(x) $tkPriv(y)
set tkPriv(afterId) [after 50 [list tkTextAutoScan $w]]
}
# tkTextSetCursor
# Move the insertion cursor to a given position in a text. Also
# clears the selection, if there is one in the text, and makes sure
# that the insertion cursor is visible. Also, don't let the insertion
# cursor appear on the dummy last line of the text.
#
# Arguments:
# w - The text window.
# pos - The desired new position for the cursor in the window.
proc tkTextSetCursor {w pos} {
global tkPriv
if {[$w compare $pos == end]} {
set pos {end - 1 chars}
}
$w mark set insert $pos
$w tag remove sel 1.0 end
$w see insert
}
# tkTextKeySelect
# This procedure is invoked when stroking out selections using the
# keyboard. It moves the cursor to a new position, then extends
# the selection to that position.
#
# Arguments:
# w - The text window.
# new - A new position for the insertion cursor (the cursor hasn't
# actually been moved to this position yet).
proc tkTextKeySelect {w new} {
global tkPriv
if {[string equal [$w tag nextrange sel 1.0 end] ""]} {
if {[$w compare $new < insert]} {
$w tag add sel $new insert
} else {
$w tag add sel insert $new
}
$w mark set anchor insert
} else {
if {[$w compare $new < anchor]} {
set first $new
set last anchor
} else {
set first anchor
set last $new
}
$w tag remove sel 1.0 $first
$w tag add sel $first $last
$w tag remove sel $last end
}
$w mark set insert $new
$w see insert
update idletasks
}
# tkTextResetAnchor --
# Set the selection anchor to whichever end is farthest from the
# index argument. One special trick: if the selection has two or
# fewer characters, just leave the anchor where it is. In this
# case it doesn't matter which point gets chosen for the anchor,
# and for the things like Shift-Left and Shift-Right this produces
# better behavior when the cursor moves back and forth across the
# anchor.
#
# Arguments:
# w - The text widget.
# index - Position at which mouse button was pressed, which determines
# which end of selection should be used as anchor point.
proc tkTextResetAnchor {w index} {
global tkPriv
if {[string equal [$w tag ranges sel] ""]} {
# Don't move the anchor if there is no selection now; this makes
# the widget behave "correctly" when the user clicks once, then
# shift-clicks somewhere -- ie, the area between the two clicks will be
# selected. [Bug: 5929].
return
}
set a [$w index $index]
set b [$w index sel.first]
set c [$w index sel.last]
if {[$w compare $a < $b]} {
$w mark set anchor sel.last
return
}
if {[$w compare $a > $c]} {
$w mark set anchor sel.first
return
}
scan $a "%d.%d" lineA chA
scan $b "%d.%d" lineB chB
scan $c "%d.%d" lineC chC
if {$lineB < $lineC+2} {
set total [string length [$w get $b $c]]
if {$total <= 2} {
return
}
if {[string length [$w get $b $a]] < ($total/2)} {
$w mark set anchor sel.last
} else {
$w mark set anchor sel.first
}
return
}
if {($lineA-$lineB) < ($lineC-$lineA)} {
$w mark set anchor sel.last
} else {
$w mark set anchor sel.first
}
}
# tkTextInsert --
# Insert a string into a text at the point of the insertion cursor.
# If there is a selection in the text, and it covers the point of the
# insertion cursor, then delete the selection before inserting.
#
# Arguments:
# w - The text window in which to insert the string
# s - The string to insert (usually just a single character)
proc tkTextInsert {w s} {
if {[string equal $s ""] || [string equal [$w cget -state] "disabled"]} {
return
}
catch {
if {[$w compare sel.first <= insert] \
&& [$w compare sel.last >= insert]} {
$w delete sel.first sel.last
}
}
$w insert insert $s
$w see insert
}
# tkTextUpDownLine --
# Returns the index of the character one line above or below the
# insertion cursor. There are two tricky things here. First,
# we want to maintain the original column across repeated operations,
# even though some lines that will get passed through don't have
# enough characters to cover the original column. Second, don't
# try to scroll past the beginning or end of the text.
#
# Arguments:
# w - The text window in which the cursor is to move.
# n - The number of lines to move: -1 for up one line,
# +1 for down one line.
proc tkTextUpDownLine {w n} {
global tkPriv
set i [$w index insert]
scan $i "%d.%d" line char
if {[string compare $tkPriv(prevPos) $i]} {
set tkPriv(char) $char
}
set new [$w index [expr {$line + $n}].$tkPriv(char)]
if {[$w compare $new == end] || [$w compare $new == "insert linestart"]} {
set new $i
}
set tkPriv(prevPos) $new
return $new
}
# tkTextPrevPara --
# Returns the index of the beginning of the paragraph just before a given
# position in the text (the beginning of a paragraph is the first non-blank
# character after a blank line).
#
# Arguments:
# w - The text window in which the cursor is to move.
# pos - Position at which to start search.
proc tkTextPrevPara {w pos} {
set pos [$w index "$pos linestart"]
while {1} {
if {([string equal [$w get "$pos - 1 line"] "\n"] \
&& [string compare [$w get $pos] "\n"]) \
|| [string equal $pos "1.0"]} {
if {[regexp -indices {^[ ]+(.)} [$w get $pos "$pos lineend"] \
dummy index]} {
set pos [$w index "$pos + [lindex $index 0] chars"]
}
if {[$w compare $pos != insert] || [string equal $pos 1.0]} {
return $pos
}
}
set pos [$w index "$pos - 1 line"]
}
}
# tkTextNextPara --
# Returns the index of the beginning of the paragraph just after a given
# position in the text (the beginning of a paragraph is the first non-blank
# character after a blank line).
#
# Arguments:
# w - The text window in which the cursor is to move.
# start - Position at which to start search.
proc tkTextNextPara {w start} {
set pos [$w index "$start linestart + 1 line"]
while {[string compare [$w get $pos] "\n"]} {
if {[$w compare $pos == end]} {
return [$w index "end - 1c"]
}
set pos [$w index "$pos + 1 line"]
}
while {[string equal [$w get $pos] "\n"]} {
set pos [$w index "$pos + 1 line"]
if {[$w compare $pos == end]} {
return [$w index "end - 1c"]
}
}
if {[regexp -indices {^[ ]+(.)} [$w get $pos "$pos lineend"] \
dummy index]} {
return [$w index "$pos + [lindex $index 0] chars"]
}
return $pos
}
# tkTextScrollPages --
# This is a utility procedure used in bindings for moving up and down
# pages and possibly extending the selection along the way. It scrolls
# the view in the widget by the number of pages, and it returns the
# index of the character that is at the same position in the new view
# as the insertion cursor used to be in the old view.
#
# Arguments:
# w - The text window in which the cursor is to move.
# count - Number of pages forward to scroll; may be negative
# to scroll backwards.
proc tkTextScrollPages {w count} {
set bbox [$w bbox insert]
$w yview scroll $count pages
if {[string equal $bbox ""]} {
return [$w index @[expr {[winfo height $w]/2}],0]
}
return [$w index @[lindex $bbox 0],[lindex $bbox 1]]
}
# tkTextTranspose --
# This procedure implements the "transpose" function for text widgets.
# It tranposes the characters on either side of the insertion cursor,
# unless the cursor is at the end of the line. In this case it
# transposes the two characters to the left of the cursor. In either
# case, the cursor ends up to the right of the transposed characters.
#
# Arguments:
# w - Text window in which to transpose.
proc tkTextTranspose w {
set pos insert
if {[$w compare $pos != "$pos lineend"]} {
set pos [$w index "$pos + 1 char"]
}
set new [$w get "$pos - 1 char"][$w get "$pos - 2 char"]
if {[$w compare "$pos - 1 char" == 1.0]} {
return
}
$w delete "$pos - 2 char" $pos
$w insert insert $new
$w see insert
}
# tk_textCopy --
# This procedure copies the selection from a text widget into the
# clipboard.
#
# Arguments:
# w - Name of a text widget.
proc tk_textCopy w {
if {![catch {set data [$w get sel.first sel.last]}]} {
clipboard clear -displayof $w
clipboard append -displayof $w $data
}
}
# tk_textCut --
# This procedure copies the selection from a text widget into the
# clipboard, then deletes the selection (if it exists in the given
# widget).
#
# Arguments:
# w - Name of a text widget.
proc tk_textCut w {
if {![catch {set data [$w get sel.first sel.last]}]} {
clipboard clear -displayof $w
clipboard append -displayof $w $data
$w delete sel.first sel.last
}
}
# tk_textPaste --
# This procedure pastes the contents of the clipboard to the insertion
# point in a text widget.
#
# Arguments:
# w - Name of a text widget.
proc tk_textPaste w {
global tcl_platform
catch {
if {[string compare $tcl_platform(platform) "unix"]} {
catch {
$w delete sel.first sel.last
}
}
$w insert insert [selection get -displayof $w -selection CLIPBOARD]
}
}
# tkTextNextWord --
# Returns the index of the next word position after a given position in the
# text. The next word is platform dependent and may be either the next
# end-of-word position or the next start-of-word position after the next
# end-of-word position.
#
# Arguments:
# w - The text window in which the cursor is to move.
# start - Position at which to start search.
if {[string equal $tcl_platform(platform) "windows"]} {
proc tkTextNextWord {w start} {
tkTextNextPos $w [tkTextNextPos $w $start tcl_endOfWord] \
tcl_startOfNextWord
}
} else {
proc tkTextNextWord {w start} {
tkTextNextPos $w $start tcl_endOfWord
}
}
# tkTextNextPos --
# Returns the index of the next position after the given starting
# position in the text as computed by a specified function.
#
# Arguments:
# w - The text window in which the cursor is to move.
# start - Position at which to start search.
# op - Function to use to find next position.
proc tkTextNextPos {w start op} {
set text ""
set cur $start
while {[$w compare $cur < end]} {
set text $text[$w get $cur "$cur lineend + 1c"]
set pos [$op $text 0]
if {$pos >= 0} {
## Adjust for embedded windows and images
## dump gives us 3 items per window/image
set dump [$w dump -image -window $start "$start + $pos c"]
if {[llength $dump]} {
set pos [expr {$pos + ([llength $dump]/3)}]
}
return [$w index "$start + $pos c"]
}
set cur [$w index "$cur lineend +1c"]
}
return end
}
# tkTextPrevPos --
# Returns the index of the previous position before the given starting
# position in the text as computed by a specified function.
#
# Arguments:
# w - The text window in which the cursor is to move.
# start - Position at which to start search.
# op - Function to use to find next position.
proc tkTextPrevPos {w start op} {
set text ""
set cur $start
while {[$w compare $cur > 0.0]} {
set text [$w get "$cur linestart - 1c" $cur]$text
set pos [$op $text end]
if {$pos >= 0} {
## Adjust for embedded windows and images
## dump gives us 3 items per window/image
set dump [$w dump -image -window "$cur linestart" "$start - 1c"]
if {[llength $dump]} {
## This is a hokey extra hack for control-arrow movement
## that should be in a while loop to be correct (hobbs)
if {[$w compare [lindex $dump 2] > \
"$cur linestart - 1c + $pos c"]} {
incr pos -1
}
set pos [expr {$pos + ([llength $dump]/3)}]
}
return [$w index "$cur linestart - 1c + $pos c"]
}
set cur [$w index "$cur linestart - 1c"]
}
return 0.0
}
!# bgerror.tcl --
#
# Implementation of the bgerror procedure. It posts a dialog box with
# the error message and gives the user a chance to see a more detailed
# stack trace, and possible do something more interesting with that
# trace (like save it to a log). This is adapted from work done by
# Donal K. Fellows.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# All rights reserved.
#
# RCS: @(#) $Id: bgerror.tcl,v 1.8.2.2 2001/10/17 19:29:51 das Exp $
package require msgcat
option add *ErrorDialog.function.text [::msgcat::mc "Save To Log"] \
widgetDefault
option add *ErrorDialog.function.command "::tk::dialog::error::saveToLog"
# create namespace hierarchy
namespace eval ::tk::dialog::error {}
proc ::tk::dialog::error::Return {} {
variable button
.bgerrorDialog.ok configure -state active -relief sunken
update idletasks
after 100
set button 0
}
proc ::tk::dialog::error::details {} {
set w .bgerrorDialog
set caption [option get $w.function text {}]
set command [option get $w.function command {}]
if { [string equal $caption ""] || [string equal $command ""] } {
grid forget $w.function
}
$w.function configure -text $caption \
-command [list ::tk::dialog::error::evalFunction $command]
grid $w.top.info - -sticky nsew -padx 3m -pady 3m
}
proc ::tk::dialog::error::evalFunction {cmd} {
uplevel \#0 [list $cmd [.bgerrorDialog.top.info.text get 1.0 end]]
}
proc ::tk::dialog::error::saveToLog {text} {
if { [string equal $::tcl_platform(platform) "windows"] } {
set allFiles "*.*"
} else {
set allFiles "*"
}
set types [list \
[list [::msgcat::mc "Log Files"] .log] \
[list [::msgcat::mc "Text Files"] .txt] \
[list [::msgcat::mc "All Files"] $allFiles] \
]
set filename [tk_getSaveFile -title [::msgcat::mc "Select Log File"] \
-filetypes $types -defaultextension .log -parent .bgerrorDialog]
if {![string length $filename]} {
return
}
set f [open $filename w]
puts -nonewline $f $text
close $f
}
proc ::tk::dialog::error::Destroy {w} {
if {".bgerrorDialog" == "$w"} {
variable button
set button -1
}
}
# ::bgerror --
# This is the default version of bgerror.
# It tries to execute tkerror, if that fails it posts a dialog box containing
# the error message and gives the user a chance to ask to see a stack
# trace.
# Arguments:
# err - The error message.
proc ::bgerror err {
global errorInfo tcl_platform
set butvar ::tk::dialog::error::button
set info $errorInfo
set ret [catch {tkerror $err} msg];
if {$ret != 1} {return -code $ret $msg}
# Ok the application's tkerror either failed or was not found
# we use the default dialog then :
if {$tcl_platform(platform) == "macintosh"} {
set ok [::msgcat::mc "Ok"]
set messageFont system
set textRelief "flat"
set textHilight 0
} else {
set ok [::msgcat::mc "OK"]
set messageFont {Times -18}
set textRelief "sunken"
set textHilight 1
}
# Truncate the message if it is too wide (longer than 30 characacters) or
# too tall (more than 4 newlines). Truncation occurs at the first point at
# which one of those conditions is met.
set displayedErr ""
set lines 0
foreach line [split $err "\n"] {
if { [string length $line] > 30 } {
append displayedErr "[string range $line 0 29]..."
break
}
if { $lines > 4 } {
append displayedErr "..."
break
} else {
append displayedErr "${line}\n"
}
incr lines
}
set w .bgerrorDialog
set title [::msgcat::mc "Application Error"]
set text [::msgcat::mc "Error: %1\$s" $err]
set buttons [list ok $ok dismiss [::msgcat::mc "Skip Messages"] \
function [::msgcat::mc "Details >>"]]
# 1. Create the top-level window and divide it into top
# and bottom parts.
catch {destroy .bgerrorDialog}
toplevel .bgerrorDialog -class ErrorDialog
wm title .bgerrorDialog $title
wm iconname .bgerrorDialog ErrorDialog
wm protocol .bgerrorDialog WM_DELETE_WINDOW { }
# The following, though surprising, works.
wm transient .bgerrorDialog .bgerrorDialog
if {$tcl_platform(platform) == "macintosh"} {
unsupported1 style .bgerrorDialog dBoxProc
}
frame .bgerrorDialog.bot
frame .bgerrorDialog.top
if {$tcl_platform(platform) == "unix"} {
.bgerrorDialog.bot configure -relief raised -bd 1
.bgerrorDialog.top configure -relief raised -bd 1
}
pack .bgerrorDialog.bot -side bottom -fill both
pack .bgerrorDialog.top -side top -fill both -expand 1
set W [frame $w.top.info]
text $W.text \
-bd 2 \
-yscrollcommand "$W.scroll set" \
-setgrid true \
-width 40 \
-height 10 \
-state normal \
-relief $textRelief \
-highlightthickness $textHilight \
-wrap char
scrollbar $W.scroll -relief sunken -command "$W.text yview"
pack $W.scroll -side right -fill y
pack $W.text -side left -expand yes -fill both
$W.text insert 0.0 "$err\n$info"
$W.text mark set insert 0.0
bind $W.text <ButtonPress-1> { focus %W }
$W.text configure -state disabled
# 2. Fill the top part with bitmap and message
label .bgerrorDialog.msg -justify left -text $text -font $messageFont
if { [string equal $tcl_platform(platform) "macintosh"] } {
# On the Macintosh, use the stop bitmap
label .bgerrorDialog.bitmap -bitmap stop
} else {
# On other platforms, make the error icon
canvas .bgerrorDialog.bitmap -width 32 -height 32 -highlightthickness 0
.bgerrorDialog.bitmap create oval 0 0 31 31 -fill red -outline black
.bgerrorDialog.bitmap create line 9 9 23 23 -fill white -width 4
.bgerrorDialog.bitmap create line 9 23 23 9 -fill white -width 4
}
grid .bgerrorDialog.bitmap .bgerrorDialog.msg \
-in .bgerrorDialog.top \
-row 0 \
-padx 3m \
-pady 3m
grid configure .bgerrorDialog.msg -sticky nsw
grid rowconfigure .bgerrorDialog.top 1 -weight 1
grid columnconfigure .bgerrorDialog.top 1 -weight 1
# 3. Create a row of buttons at the bottom of the dialog.
set i 0
foreach {name caption} $buttons {
button .bgerrorDialog.$name \
-text $caption \
-default normal \
-command [list set $butvar $i]
grid .bgerrorDialog.$name \
-in .bgerrorDialog.bot \
-column $i \
-row 0 \
-sticky ew \
-padx 10
grid columnconfigure .bgerrorDialog.bot $i -weight 1
# We boost the size of some Mac buttons for l&f
if {$tcl_platform(platform) == "macintosh"} {
if {($name == "ok") || ($name == "dismiss")} {
grid columnconfigure .bgerrorDialog.bot $i -minsize 79
}
}
incr i
}
# The "OK" button is the default for this dialog.
.bgerrorDialog.ok configure -default active
set ::tk::dialog::error::curh 0
bind .bgerrorDialog <Return> {::tk::dialog::error::Return}
bind .bgerrorDialog <Destroy> {::tk::dialog::error::Destroy %W}
.bgerrorDialog.function configure \
-command {::tk::dialog::error::details }
# 6. Withdraw the window, then update all the geometry information
# so we know how big it wants to be, then center the window in the
# display and de-iconify it.
wm withdraw .bgerrorDialog
update idletasks
set parent [winfo parent .bgerrorDialog]
set width [winfo reqwidth .bgerrorDialog]
set height [winfo reqheight .bgerrorDialog]
set x [expr {([winfo screenwidth .bgerrorDialog] - $width )/2 - \
[winfo vrootx $parent]}]
set y [expr {([winfo screenheight .bgerrorDialog] - $height)/2 - \
[winfo vrooty $parent]}]
.bgerrorDialog configure -width $width
wm geometry .bgerrorDialog +$x+$y
wm deiconify .bgerrorDialog
# 7. Set a grab and claim the focus too.
set oldFocus [focus]
set oldGrab [grab current .bgerrorDialog]
if {$oldGrab != ""} {
set grabStatus [grab status $oldGrab]
}
grab .bgerrorDialog
focus .bgerrorDialog.ok
# 8. Wait for the user to respond, then restore the focus and
# return the index of the selected button. Restore the focus
# before deleting the window, since otherwise the window manager
# may take the focus away so we can't redirect it. Finally,
# restore any grab that was in effect.
vwait $butvar
set button $::tk::dialog::error::button; # Save a copy...
catch {focus $oldFocus}
catch {destroy .bgerrorDialog}
if {$oldGrab != ""} {
if {$grabStatus == "global"} {
grab -global $oldGrab
} else {
grab $oldGrab
}
}
if {$button == 1} {
return -code break
}
}
f# console.tcl --
#
# This code constructs the console window for an application. It
# can be used by non-unix systems that do not have built-in support
# for shells.
#
# RCS: @(#) $Id: console.tcl,v 1.8.2.4 2001/10/19 19:40:17 das Exp $
#
# Copyright (c) 1998-1999 Scriptics Corp.
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# TODO: history - remember partially written command
package require msgcat
namespace eval ::tk::console {
variable blinkTime 500 ; # msecs to blink braced range for
variable blinkRange 1 ; # enable blinking of the entire braced range
variable magicKeys 1 ; # enable brace matching and proc/var recognition
variable maxLines 600 ; # maximum # of lines buffered in console
variable showMatches 1 ; # show multiple expand matches
variable inPlugin [info exists embed_args]
variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used
if {$inPlugin} {
set defaultPrompt {subst "[history nextid] % "}
} else {
set defaultPrompt {subst "([file tail [pwd]]) [history nextid] % "}
}
}
# simple compat function for tkcon code added for this console
interp alias {} EvalAttached {} consoleinterp eval
# tkConsoleInit --
# This procedure constructs and configures the console windows.
#
# Arguments:
# None.
proc tkConsoleInit {} {
global tcl_platform
if {![consoleinterp eval {set tcl_interactive}]} {
wm withdraw .
}
if {[string compare $tcl_platform(platform) "macintosh"]} {
set mod "Ctrl"
} else {
set mod "Cmd"
}
menu .menubar
.menubar add cascade -label File -menu .menubar.file -underline 0
.menubar add cascade -label Edit -menu .menubar.edit -underline 0
menu .menubar.file -tearoff 0
.menubar.file add command -label "Source..." -underline 0 \
-command tkConsoleSource
.menubar.file add command -label "Hide Console" -underline 0 \
-command {wm withdraw .}
.menubar.file add command -label [::msgcat::mc "Clear Console"] \
-underline 0 -command {.console delete 1.0 "promptEnd linestart"}
if {[string compare $tcl_platform(platform) "macintosh"]} {
.menubar.file add command -label "Exit" -underline 1 -command exit
} else {
.menubar.file add command -label "Quit" -command exit -accel Cmd-Q
}
menu .menubar.edit -tearoff 0
.menubar.edit add command -label "Cut" -underline 2 \
-command { event generate .console <<Cut>> } -accel "$mod+X"
.menubar.edit add command -label "Copy" -underline 0 \
-command { event generate .console <<Copy>> } -accel "$mod+C"
.menubar.edit add command -label "Paste" -underline 1 \
-command { event generate .console <<Paste>> } -accel "$mod+V"
if {[string compare $tcl_platform(platform) "windows"]} {
.menubar.edit add command -label "Clear" -underline 2 \
-command { event generate .console <<Clear>> }
} else {
.menubar.edit add command -label "Delete" -underline 0 \
-command { event generate .console <<Clear>> } -accel "Del"
.menubar add cascade -label Help -menu .menubar.help -underline 0
menu .menubar.help -tearoff 0
.menubar.help add command -label "About..." -underline 0 \
-command tkConsoleAbout
}
. configure -menu .menubar
set con [text .console -yscrollcommand [list .sb set] -setgrid true]
scrollbar .sb -command [list $con yview]
pack .sb -side right -fill both
pack $con -fill both -expand 1 -side left
switch -exact $tcl_platform(platform) {
"macintosh" {
$con configure -font {Monaco 9 normal} -highlightthickness 0
}
"windows" {
$con configure -font systemfixed
}
}
tkConsoleBind $con
$con tag configure stderr -foreground red
$con tag configure stdin -foreground blue
$con tag configure prompt -foreground \#8F4433
$con tag configure proc -foreground \#008800
$con tag configure var -background \#FFC0D0
$con tag raise sel
$con tag configure blink -background \#FFFF00
$con tag configure find -background \#FFFF00
focus $con
wm protocol . WM_DELETE_WINDOW { wm withdraw . }
wm title . "Console"
flush stdout
$con mark set output [$con index "end - 1 char"]
tkTextSetCursor $con end
$con mark set promptEnd insert
$con mark gravity promptEnd left
}
# tkConsoleSource --
#
# Prompts the user for a file to source in the main interpreter.
#
# Arguments:
# None.
proc tkConsoleSource {} {
set filename [tk_getOpenFile -defaultextension .tcl -parent . \
-title "Select a file to source" \
-filetypes {{"Tcl Scripts" .tcl} {"All Files" *}}]
if {[string compare $filename ""]} {
set cmd [list source $filename]
if {[catch {consoleinterp eval $cmd} result]} {
tkConsoleOutput stderr "$result\n"
}
}
}
# tkConsoleInvoke --
# Processes the command line input. If the command is complete it
# is evaled in the main interpreter. Otherwise, the continuation
# prompt is added and more input may be added.
#
# Arguments:
# None.
proc tkConsoleInvoke {args} {
set ranges [.console tag ranges input]
set cmd ""
if {[llength $ranges]} {
set pos 0
while {[string compare [lindex $ranges $pos] ""]} {
set start [lindex $ranges $pos]
set end [lindex $ranges [incr pos]]
append cmd [.console get $start $end]
incr pos
}
}
if {[string equal $cmd ""]} {
tkConsolePrompt
} elseif {[info complete $cmd]} {
.console mark set output end
.console tag delete input
set result [consoleinterp record $cmd]
if {[string compare $result ""]} {
puts $result
}
tkConsoleHistory reset
tkConsolePrompt
} else {
tkConsolePrompt partial
}
.console yview -pickplace insert
}
# tkConsoleHistory --
# This procedure implements command line history for the
# console. In general is evals the history command in the
# main interpreter to obtain the history. The global variable
# histNum is used to store the current location in the history.
#
# Arguments:
# cmd - Which action to take: prev, next, reset.
set histNum 1
proc tkConsoleHistory {cmd} {
global histNum
switch $cmd {
prev {
incr histNum -1
if {$histNum == 0} {
set cmd {history event [expr {[history nextid] -1}]}
} else {
set cmd "history event $histNum"
}
if {[catch {consoleinterp eval $cmd} cmd]} {
incr histNum
return
}
.console delete promptEnd end
.console insert promptEnd $cmd {input stdin}
}
next {
incr histNum
if {$histNum == 0} {
set cmd {history event [expr {[history nextid] -1}]}
} elseif {$histNum > 0} {
set cmd ""
set histNum 1
} else {
set cmd "history event $histNum"
}
if {[string compare $cmd ""]} {
catch {consoleinterp eval $cmd} cmd
}
.console delete promptEnd end
.console insert promptEnd $cmd {input stdin}
}
reset {
set histNum 1
}
}
}
# tkConsolePrompt --
# This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2
# exists in the main interpreter it will be called to generate the
# prompt. Otherwise, a hard coded default prompt is printed.
#
# Arguments:
# partial - Flag to specify which prompt to print.
proc tkConsolePrompt {{partial normal}} {
set w .console
if {[string equal $partial "normal"]} {
set temp [$w index "end - 1 char"]
$w mark set output end
if {[consoleinterp eval "info exists tcl_prompt1"]} {
consoleinterp eval "eval \[set tcl_prompt1\]"
} else {
puts -nonewline [EvalAttached $::tk::console::defaultPrompt]
}
} else {
set temp [$w index output]
$w mark set output end
if {[consoleinterp eval "info exists tcl_prompt2"]} {
consoleinterp eval "eval \[set tcl_prompt2\]"
} else {
puts -nonewline "> "
}
}
flush stdout
$w mark set output $temp
tkTextSetCursor $w end
$w mark set promptEnd insert
$w mark gravity promptEnd left
::tk::console::ConstrainBuffer $w $::tk::console::maxLines
$w see end
}
# tkConsoleBind --
# This procedure first ensures that the default bindings for the Text
# class have been defined. Then certain bindings are overridden for
# the class.
#
# Arguments:
# None.
proc tkConsoleBind {w} {
bindtags $w [list $w Console PostConsole [winfo toplevel $w] all]
## Get all Text bindings into Console
foreach ev [bind Text] { bind Console $ev [bind Text $ev] }
## We really didn't want the newline insertion
bind Console <Control-Key-o> {}
# For the moment, transpose isn't enabled until the console
# gets and overhaul of how it handles input -- hobbs
bind Console <Control-Key-t> {}
# Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
# Otherwise, if a widget binding for one of these is defined, the
bind Console <Alt-KeyPress> {# nothing }
bind Console <Meta-KeyPress> {# nothing}
bind Console <Control-KeyPress> {# nothing}
foreach {ev key} {
<<Console_Prev>> <Key-Up>
<<Console_Next>> <Key-Down>
<<Console_NextImmediate>> <Control-Key-n>
<<Console_PrevImmediate>> <Control-Key-p>
<<Console_PrevSearch>> <Control-Key-r>
<<Console_NextSearch>> <Control-Key-s>
<<Console_Expand>> <Key-Escape>
<<Console_ExpandFile>> <Control-Shift-Key-F>
<<Console_ExpandProc>> <Control-Shift-Key-P>
<<Console_ExpandVar>> <Control-Shift-Key-V>
<<Console_Tab>> <Control-Key-i>
<<Console_Tab>> <Meta-Key-i>
<<Console_Eval>> <Key-Return>
<<Console_Eval>> <Key-KP_Enter>
<<Console_Clear>> <Control-Key-l>
<<Console_KillLine>> <Control-Key-k>
<<Console_Transpose>> <Control-Key-t>
<<Console_ClearLine>> <Control-Key-u>
<<Console_SaveCommand>> <Control-Key-z>
} {
event add $ev $key
bind Console $key {}
}
bind Console <Tab> {
tkConsoleInsert %W \t
focus %W
break
}
bind Console <<Console_Expand>> {
if {[%W compare insert > promptEnd]} {::tk::console::Expand %W}
}
bind Console <<Console_ExpandFile>> {
if {[%W compare insert > promptEnd]} {::tk::console::Expand %W path}
}
bind Console <<Console_ExpandProc>> {
if {[%W compare insert > promptEnd]} {::tk::console::Expand %W proc}
}
bind Console <<Console_ExpandVar>> {
if {[%W compare insert > promptEnd]} {::tk::console::Expand %W var}
}
bind Console <<Console_Eval>> {
%W mark set insert {end - 1c}
tkConsoleInsert %W "\n"
tkConsoleInvoke
break
}
bind Console <Delete> {
if {[string compare {} [%W tag nextrange sel 1.0 end]] \
&& [%W compare sel.first >= promptEnd]} {
%W delete sel.first sel.last
} elseif {[%W compare insert >= promptEnd]} {
%W delete insert
%W see insert
}
}
bind Console <BackSpace> {
if {[string compare {} [%W tag nextrange sel 1.0 end]] \
&& [%W compare sel.first >= promptEnd]} {
%W delete sel.first sel.last
} elseif {[%W compare insert != 1.0] && \
[%W compare insert > promptEnd]} {
%W delete insert-1c
%W see insert
}
}
bind Console <Control-h> [bind Console <BackSpace>]
bind Console <Home> {
if {[%W compare insert < promptEnd]} {
tkTextSetCursor %W {insert linestart}
} else {
tkTextSetCursor %W promptEnd
}
}
bind Console <Control-a> [bind Console <Home>]
bind Console <End> {
tkTextSetCursor %W {insert lineend}
}
bind Console <Control-e> [bind Console <End>]
bind Console <Control-d> {
if {[%W compare insert < promptEnd]} break
%W delete insert
}
bind Console <<Console_KillLine>> {
if {[%W compare insert < promptEnd]} break
if {[%W compare insert == {insert lineend}]} {
%W delete insert
} else {
%W delete insert {insert lineend}
}
}
bind Console <<Console_Clear>> {
## Clear console display
%W delete 1.0 "promptEnd linestart"
}
bind Console <<Console_ClearLine>> {
## Clear command line (Unix shell staple)
%W delete promptEnd end
}
bind Console <Meta-d> {
if {[%W compare insert >= promptEnd]} {
%W delete insert {insert wordend}
}
}
bind Console <Meta-BackSpace> {
if {[%W compare {insert -1c wordstart} >= promptEnd]} {
%W delete {insert -1c wordstart} insert
}
}
bind Console <Meta-d> {
if {[%W compare insert >= promptEnd]} {
%W delete insert {insert wordend}
}
}
bind Console <Meta-BackSpace> {
if {[%W compare {insert -1c wordstart} >= promptEnd]} {
%W delete {insert -1c wordstart} insert
}
}
bind Console <Meta-Delete> {
if {[%W compare insert >= promptEnd]} {
%W delete insert {insert wordend}
}
}
bind Console <<Console_Prev>> {
tkConsoleHistory prev
}
bind Console <<Console_Next>> {
tkConsoleHistory next
}
bind Console <Insert> {
catch {tkConsoleInsert %W [::tk::GetSelection %W PRIMARY]}
}
bind Console <KeyPress> {
tkConsoleInsert %W %A
}
bind Console <F9> {
eval destroy [winfo child .]
if {[string equal $tcl_platform(platform) "macintosh"]} {
if {[catch {source $tk_library:console.tcl}]} {source -rsrc console}
} else {
source [file join $tk_library console.tcl]
}
}
bind Console <<Cut>> {
# Same as the copy event
if {![catch {set data [%W get sel.first sel.last]}]} {
clipboard clear -displayof %W
clipboard append -displayof %W $data
}
}
bind Console <<Copy>> {
if {![catch {set data [%W get sel.first sel.last]}]} {
clipboard clear -displayof %W
clipboard append -displayof %W $data
}
}
bind Console <<Paste>> {
catch {
set clip [::tk::GetSelection %W CLIPBOARD]
set list [split $clip \n\r]
tkConsoleInsert %W [lindex $list 0]
foreach x [lrange $list 1 end] {
%W mark set insert {end - 1c}
tkConsoleInsert %W "\n"
tkConsoleInvoke
tkConsoleInsert %W $x
}
}
}
##
## Bindings for doing special things based on certain keys
##
bind PostConsole <Key-parenright> {
if {[string compare \\ [%W get insert-2c]]} {
::tk::console::MatchPair %W \( \) promptEnd
}
}
bind PostConsole <Key-bracketright> {
if {[string compare \\ [%W get insert-2c]]} {
::tk::console::MatchPair %W \[ \] promptEnd
}
}
bind PostConsole <Key-braceright> {
if {[string compare \\ [%W get insert-2c]]} {
::tk::console::MatchPair %W \{ \} promptEnd
}
}
bind PostConsole <Key-quotedbl> {
if {[string compare \\ [%W get insert-2c]]} {
::tk::console::MatchQuote %W promptEnd
}
}
bind PostConsole <KeyPress> {
if {"%A" != ""} {
::tk::console::TagProc %W
}
break
}
}
# tkConsoleInsert --
# Insert a string into a text at the point of the insertion cursor.
# If there is a selection in the text, and it covers the point of the
# insertion cursor, then delete the selection before inserting. Insertion
# is restricted to the prompt area.
#
# Arguments:
# w - The text window in which to insert the string
# s - The string to insert (usually just a single character)
proc tkConsoleInsert {w s} {
if {[string equal $s ""]} {
return
}
catch {
if {[$w compare sel.first <= insert]
&& [$w compare sel.last >= insert]} {
$w tag remove sel sel.first promptEnd
$w delete sel.first sel.last
}
}
if {[$w compare insert < promptEnd]} {
$w mark set insert end
}
$w insert insert $s {input stdin}
$w see insert
}
# tkConsoleOutput --
#
# This routine is called directly by ConsolePutsCmd to cause a string
# to be displayed in the console.
#
# Arguments:
# dest - The output tag to be used: either "stderr" or "stdout".
# string - The string to be displayed.
proc tkConsoleOutput {dest string} {
set w .console
$w insert output $string $dest
::tk::console::ConstrainBuffer $w $::tk::console::maxLines
$w see insert
}
# tkConsoleExit --
#
# This routine is called by ConsoleEventProc when the main window of
# the application is destroyed. Don't call exit - that probably already
# happened. Just delete our window.
#
# Arguments:
# None.
proc tkConsoleExit {} {
destroy .
}
# tkConsoleAbout --
#
# This routine displays an About box to show Tcl/Tk version info.
#
# Arguments:
# None.
proc tkConsoleAbout {} {
global tk_patchLevel
tk_messageBox -type ok -message "Tcl for Windows
Tcl [info patchlevel]
Tk $tk_patchLevel"
}
# ::tk::console::TagProc --
#
# Tags a procedure in the console if it's recognized
# This procedure is not perfect. However, making it perfect wastes
# too much CPU time...
#
# Arguments:
# w - console text widget
proc ::tk::console::TagProc w {
if {!$::tk::console::magicKeys} { return }
set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]"
set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
if {$i == ""} {set i promptEnd} else {append i +2c}
regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c
if {[llength [EvalAttached [list info commands $c]]]} {
$w tag add proc $i "insert-1c wordend"
} else {
$w tag remove proc $i "insert-1c wordend"
}
if {[llength [EvalAttached [list info vars $c]]]} {
$w tag add var $i "insert-1c wordend"
} else {
$w tag remove var $i "insert-1c wordend"
}
}
# ::tk::console::MatchPair --
#
# Blinks a matching pair of characters
# c2 is assumed to be at the text index 'insert'.
# This proc is really loopy and took me an hour to figure out given
# all possible combinations with escaping except for escaped \'s.
# It doesn't take into account possible commenting... Oh well. If
# anyone has something better, I'd like to see/use it. This is really
# only efficient for small contexts.
#
# Arguments:
# w - console text widget
# c1 - first char of pair
# c2 - second char of pair
#
# Calls: ::tk::console::Blink
proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} {
if {!$::tk::console::magicKeys} { return }
if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} {
while {
[string match {\\} [$w get $ix-1c]] &&
[string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]]
} {}
set i1 insert-1c
while {[string compare {} $ix]} {
set i0 $ix
set j 0
while {[string compare {} [set i0 [$w search $c2 $i0 $i1]]]} {
append i0 +1c
if {[string match {\\} [$w get $i0-2c]]} continue
incr j
}
if {!$j} break
set i1 $ix
while {$j && [string compare {} \
[set ix [$w search -back $c1 $ix $lim]]]} {
if {[string match {\\} [$w get $ix-1c]]} continue
incr j -1
}
}
if {[string match {} $ix]} { set ix [$w index $lim] }
} else { set ix [$w index $lim] }
if {$::tk::console::blinkRange} {
Blink $w $ix [$w index insert]
} else {
Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert]
}
}
# ::tk::console::MatchQuote --
#
# Blinks between matching quotes.
# Blinks just the quote if it's unmatched, otherwise blinks quoted string
# The quote to match is assumed to be at the text index 'insert'.
#
# Arguments:
# w - console text widget
#
# Calls: ::tk::console::Blink
proc ::tk::console::MatchQuote {w {lim 1.0}} {
if {!$::tk::console::magicKeys} { return }
set i insert-1c
set j 0
while {[string compare [set i [$w search -back \" $i $lim]] {}]} {
if {[string match {\\} [$w get $i-1c]]} continue
if {!$j} {set i0 $i}
incr j
}
if {$j&1} {
if {$::tk::console::blinkRange} {
Blink $w $i0 [$w index insert]
} else {
Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert]
}
} else {
Blink $w [$w index insert-1c] [$w index insert]
}
}
# ::tk::console::Blink --
#
# Blinks between n index pairs for a specified duration.
#
# Arguments:
# w - console text widget
# i1 - start index to blink region
# i2 - end index of blink region
# dur - duration in usecs to blink for
#
# Outputs:
# blinks selected characters in $w
proc ::tk::console::Blink {w args} {
eval [list $w tag add blink] $args
after $::tk::console::blinkTime [list $w] tag remove blink $args
}
# ::tk::console::ConstrainBuffer --
#
# This limits the amount of data in the text widget
# Called by Prompt and ConsoleOutput
#
# Arguments:
# w - console text widget
# size - # of lines to constrain to
#
# Outputs:
# may delete data in console widget
proc ::tk::console::ConstrainBuffer {w size} {
if {[$w index end] > $size} {
$w delete 1.0 [expr {int([$w index end])-$size}].0
}
}
# ::tk::console::Expand --
#
# Arguments:
# ARGS: w - text widget in which to expand str
# type - type of expansion (path / proc / variable)
#
# Calls: ::tk::console::Expand(Pathname|Procname|Variable)
#
# Outputs: The string to match is expanded to the longest possible match.
# If ::tk::console::showMatches is non-zero and the longest match
# equaled the string to expand, then all possible matches are
# output to stdout. Triggers bell if no matches are found.
#
# Returns: number of matches found
proc ::tk::console::Expand {w {type ""}} {
set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]"
set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
if {$tmp == ""} {set tmp promptEnd} else {append tmp +2c}
if {[$w compare $tmp >= insert]} { return }
set str [$w get $tmp insert]
switch -glob $type {
path* { set res [ExpandPathname $str] }
proc* { set res [ExpandProcname $str] }
var* { set res [ExpandVariable $str] }
default {
set res {}
foreach t {Pathname Procname Variable} {
if {![catch {Expand$t $str} res] && ($res != "")} { break }
}
}
}
set len [llength $res]
if {$len} {
set repl [lindex $res 0]
$w delete $tmp insert
$w insert $tmp $repl {input stdin}
if {($len > 1) && $::tk::console::showMatches \
&& [string equal $repl $str]} {
puts stdout [lsort [lreplace $res 0 0]]
}
} else { bell }
return [incr len -1]
}
## ::tk::console::ExpandPathname --
#
# Expand a file pathname based on $str
# This is based on UNIX file name conventions
#
# Arguments:
# str - partial file pathname to expand
#
# Calls: ::tk::console::ExpandBestMatch
#
# Returns: list containing longest unique match followed by all the
# possible further matches
proc ::tk::console::ExpandPathname str {
set pwd [EvalAttached pwd]
if {[catch {EvalAttached [list cd [file dirname $str]]} err]} {
return -code error $err
}
set dir [file tail $str]
## Check to see if it was known to be a directory and keep the trailing
## slash if so (file tail cuts it off)
if {[string match */ $str]} { append dir / }
if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} {
set match {}
} else {
if {[llength $m] > 1} {
global tcl_platform
if {[string match windows $tcl_platform(platform)]} {
## Windows is screwy because it's case insensitive
set tmp [ExpandBestMatch [string tolower $m] \
[string tolower $dir]]
## Don't change case if we haven't changed the word
if {[string length $dir]==[string length $tmp]} {
set tmp $dir
}
} else {
set tmp [ExpandBestMatch $m $dir]
}
if {[string match ?*/* $str]} {
set tmp [file dirname $str]/$tmp
} elseif {[string match /* $str]} {
set tmp /$tmp
}
regsub -all { } $tmp {\\ } tmp
set match [linsert $m 0 $tmp]
} else {
## This may look goofy, but it handles spaces in path names
eval append match $m
if {[file isdir $match]} {append match /}
if {[string match ?*/* $str]} {
set match [file dirname $str]/$match
} elseif {[string match /* $str]} {
set match /$match
}
regsub -all { } $match {\\ } match
## Why is this one needed and the ones below aren't!!
set match [list $match]
}
}
EvalAttached [list cd $pwd]
return $match
}
# ::tk::console::ExpandProcname --
#
# Expand a tcl proc name based on $str
#
# Arguments:
# str - partial proc name to expand
#
# Calls: ::tk::console::ExpandBestMatch
#
# Returns: list containing longest unique match followed by all the
# possible further matches
proc ::tk::console::ExpandProcname str {
set match [EvalAttached [list info commands $str*]]
if {[llength $match] == 0} {
set ns [EvalAttached \
"namespace children \[namespace current\] [list $str*]"]
if {[llength $ns]==1} {
set match [EvalAttached [list info commands ${ns}::*]]
} else {
set match $ns
}
}
if {[llength $match] > 1} {
regsub -all { } [ExpandBestMatch $match $str] {\\ } str
set match [linsert $match 0 $str]
} else {
regsub -all { } $match {\\ } match
}
return $match
}
# ::tk::console::ExpandVariable --
#
# Expand a tcl variable name based on $str
#
# Arguments:
# str - partial tcl var name to expand
#
# Calls: ::tk::console::ExpandBestMatch
#
# Returns: list containing longest unique match followed by all the
# possible further matches
proc ::tk::console::ExpandVariable str {
if {[regexp {([^\(]*)\((.*)} $str junk ary str]} {
## Looks like they're trying to expand an array.
set match [EvalAttached [list array names $ary $str*]]
if {[llength $match] > 1} {
set vars $ary\([ExpandBestMatch $match $str]
foreach var $match {lappend vars $ary\($var\)}
return $vars
} else {set match $ary\($match\)}
## Space transformation avoided for array names.
} else {
set match [EvalAttached [list info vars $str*]]
if {[llength $match] > 1} {
regsub -all { } [ExpandBestMatch $match $str] {\\ } str
set match [linsert $match 0 $str]
} else {
regsub -all { } $match {\\ } match
}
}
return $match
}
# ::tk::console::ExpandBestMatch --
#
# Finds the best unique match in a list of names.
# The extra $e in this argument allows us to limit the innermost loop a little
# further. This improves speed as $l becomes large or $e becomes long.
#
# Arguments:
# l - list to find best unique match in
# e - currently best known unique match
#
# Returns: longest unique match in the list
proc ::tk::console::ExpandBestMatch {l {e {}}} {
set ec [lindex $l 0]
if {[llength $l]>1} {
set e [string length $e]; incr e -1
set ei [string length $ec]; incr ei -1
foreach l $l {
while {$ei>=$e && [string first $ec $l]} {
set ec [string range $ec 0 [incr ei -1]]
}
}
}
return $ec
}
# now initialize the console
tkConsoleInit
;Å# msgbox.tcl --
#
# Implements messageboxes for platforms that do not have native
# messagebox support.
#
# RCS: @(#) $Id: msgbox.tcl,v 1.10 2000/04/19 09:25:53 hobbs Exp $
#
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Ensure existence of ::tk::dialog namespace
#
namespace eval ::tk::dialog {}
image create bitmap ::tk::dialog::b1 -foreground black \
-data "#define b1_width 32\n#define b1_height 32
static unsigned char q1_bits[] = {
0x00, 0xf8, 0x1f, 0x00, 0x00, 0x07, 0xe0, 0x00, 0xc0, 0x00, 0x00, 0x03,
0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10,
0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80,
0x01, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x40,
0x04, 0x00, 0x00, 0x20, 0x08, 0x00, 0x00, 0x10, 0x10, 0x00, 0x00, 0x08,
0x60, 0x00, 0x00, 0x04, 0x80, 0x03, 0x80, 0x03, 0x00, 0x0c, 0x78, 0x00,
0x00, 0x30, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00, 0x00, 0x40, 0x04, 0x00,
0x00, 0x80, 0x04, 0x00, 0x00, 0x00, 0x05, 0x00, 0x00, 0x00, 0x06, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
image create bitmap ::tk::dialog::b2 -foreground white \
-data "#define b2_width 32\n#define b2_height 32
static unsigned char b2_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0x1f, 0x00, 0x00, 0xff, 0xff, 0x00,
0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f,
0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f, 0xfe, 0xff, 0xff, 0x7f,
0xfe, 0xff, 0xff, 0x7f, 0xfc, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x3f,
0xf8, 0xff, 0xff, 0x1f, 0xf0, 0xff, 0xff, 0x0f, 0xe0, 0xff, 0xff, 0x07,
0x80, 0xff, 0xff, 0x03, 0x00, 0xfc, 0x7f, 0x00, 0x00, 0xf0, 0x07, 0x00,
0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00, 0x00, 0x80, 0x03, 0x00,
0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
image create bitmap ::tk::dialog::q -foreground blue \
-data "#define q_width 32\n#define q_height 32
static unsigned char q_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0x00,
0x00, 0x10, 0x0f, 0x00, 0x00, 0x18, 0x1e, 0x00, 0x00, 0x38, 0x1e, 0x00,
0x00, 0x38, 0x1e, 0x00, 0x00, 0x10, 0x0f, 0x00, 0x00, 0x80, 0x07, 0x00,
0x00, 0xc0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0xe0, 0x01, 0x00,
0x00, 0xe0, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
image create bitmap ::tk::dialog::i -foreground blue \
-data "#define i_width 32\n#define i_height 32
static unsigned char i_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0xe0, 0x01, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00,
0x00, 0xe0, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0xf8, 0x03, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00,
0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x03, 0x00, 0x00, 0xf0, 0x07, 0x00,
0x00, 0xf8, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
image create bitmap ::tk::dialog::w1 -foreground black \
-data "#define w1_width 32\n#define w1_height 32
static unsigned char w1_bits[] = {
0x00, 0x80, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20, 0x04, 0x00,
0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x08, 0x00, 0x00, 0x08, 0x08, 0x00,
0x00, 0x08, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x20, 0x00,
0x00, 0x02, 0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01, 0x40, 0x00,
0x00, 0x01, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x80, 0x00, 0x00, 0x01,
0x40, 0x00, 0x00, 0x01, 0x40, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02,
0x20, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x04, 0x10, 0x00, 0x00, 0x08,
0x08, 0x00, 0x00, 0x08, 0x08, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10,
0x04, 0x00, 0x00, 0x20, 0x02, 0x00, 0x00, 0x20, 0x01, 0x00, 0x00, 0x40,
0x01, 0x00, 0x00, 0x40, 0x01, 0x00, 0x00, 0x40, 0x02, 0x00, 0x00, 0x20,
0xfc, 0xff, 0xff, 0x1f, 0x00, 0x00, 0x00, 0x00};"
image create bitmap ::tk::dialog::w2 -foreground yellow \
-data "#define w2_width 32\n#define w2_height 32
static unsigned char w2_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
0x00, 0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xf0, 0x07, 0x00,
0x00, 0xf0, 0x0f, 0x00, 0x00, 0xf8, 0x0f, 0x00, 0x00, 0xf8, 0x1f, 0x00,
0x00, 0xfc, 0x1f, 0x00, 0x00, 0xfc, 0x3f, 0x00, 0x00, 0xfe, 0x3f, 0x00,
0x00, 0xfe, 0x7f, 0x00, 0x00, 0xff, 0x7f, 0x00, 0x00, 0xff, 0xff, 0x00,
0x80, 0xff, 0xff, 0x00, 0x80, 0xff, 0xff, 0x01, 0xc0, 0xff, 0xff, 0x01,
0xc0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x03, 0xe0, 0xff, 0xff, 0x07,
0xf0, 0xff, 0xff, 0x07, 0xf0, 0xff, 0xff, 0x0f, 0xf8, 0xff, 0xff, 0x0f,
0xf8, 0xff, 0xff, 0x1f, 0xfc, 0xff, 0xff, 0x1f, 0xfe, 0xff, 0xff, 0x3f,
0xfe, 0xff, 0xff, 0x3f, 0xfe, 0xff, 0xff, 0x3f, 0xfc, 0xff, 0xff, 0x1f,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
image create bitmap ::tk::dialog::w3 -foreground black \
-data "#define w3_width 32\n#define w3_height 32
static unsigned char w3_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x07, 0x00,
0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x00, 0xc0, 0x03, 0x00,
0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x80, 0x01, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0xc0, 0x03, 0x00,
0x00, 0xc0, 0x03, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};"
# tkMessageBox --
#
# Pops up a messagebox with an application-supplied message with
# an icon and a list of buttons. This procedure will be called
# by tk_messageBox if the platform does not have native
# messagebox support, or if the particular type of messagebox is
# not supported natively.
#
# Color icons are used on Unix displays that have a color
# depth of 4 or more and $tk_strictMotif is not on.
#
# This procedure is a private procedure shouldn't be called
# directly. Call tk_messageBox instead.
#
# See the user documentation for details on what tk_messageBox does.
#
proc tkMessageBox {args} {
global tkPriv tcl_platform tk_strictMotif
set w tkPrivMsgBox
upvar #0 $w data
#
# The default value of the title is space (" ") not the empty string
# because for some window managers, a
# wm title .foo ""
# causes the window title to be "foo" instead of the empty string.
#
set specs {
{-default "" "" ""}
{-icon "" "" "info"}
{-message "" "" ""}
{-parent "" "" .}
{-title "" "" " "}
{-type "" "" "ok"}
}
tclParseConfigSpec $w $specs "" $args
if {[lsearch -exact {info warning error question} $data(-icon)] == -1} {
error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning"
}
if {[string equal $tcl_platform(platform) "macintosh"]} {
switch -- $data(-icon) {
"error" {set data(-icon) "stop"}
"warning" {set data(-icon) "caution"}
"info" {set data(-icon) "note"}
}
}
if {![winfo exists $data(-parent)]} {
error "bad window path name \"$data(-parent)\""
}
switch -- $data(-type) {
abortretryignore {
set buttons {
{abort -width 6 -text Abort -under 0}
{retry -width 6 -text Retry -under 0}
{ignore -width 6 -text Ignore -under 0}
}
}
ok {
set buttons {
{ok -width 6 -text OK -under 0}
}
if {[string equal $data(-default) ""]} {
set data(-default) "ok"
}
}
okcancel {
set buttons {
{ok -width 6 -text OK -under 0}
{cancel -width 6 -text Cancel -under 0}
}
}
retrycancel {
set buttons {
{retry -width 6 -text Retry -under 0}
{cancel -width 6 -text Cancel -under 0}
}
}
yesno {
set buttons {
{yes -width 6 -text Yes -under 0}
{no -width 6 -text No -under 0}
}
}
yesnocancel {
set buttons {
{yes -width 6 -text Yes -under 0}
{no -width 6 -text No -under 0}
{cancel -width 6 -text Cancel -under 0}
}
}
default {
error "bad -type value \"$data(-type)\": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel"
}
}
if {[string compare $data(-default) ""]} {
set valid 0
foreach btn $buttons {
if {[string equal [lindex $btn 0] $data(-default)]} {
set valid 1
break
}
}
if {!$valid} {
error "invalid default button \"$data(-default)\""
}
}
# 2. Set the dialog to be a child window of $parent
#
#
if {[string compare $data(-parent) .]} {
set w $data(-parent).__tk__messagebox
} else {
set w .__tk__messagebox
}
# 3. Create the top-level window and divide it into top
# and bottom parts.
catch {destroy $w}
toplevel $w -class Dialog
wm title $w $data(-title)
wm iconname $w Dialog
wm protocol $w WM_DELETE_WINDOW { }
# Message boxes should be transient with respect to their parent so that
# they always stay on top of the parent window. But some window managers
# will simply create the child window as withdrawn if the parent is not
# viewable (because it is withdrawn or iconified). This is not good for
# "grab"bed windows. So only make the message box transient if the parent
# is viewable.
#
if { [winfo viewable [winfo toplevel $data(-parent)]] } {
wm transient $w $data(-parent)
}
if {[string equal $tcl_platform(platform) "macintosh"]} {
unsupported1 style $w dBoxProc
}
frame $w.bot
pack $w.bot -side bottom -fill both
frame $w.top
pack $w.top -side top -fill both -expand 1
if {[string compare $tcl_platform(platform) "macintosh"]} {
$w.bot configure -relief raised -bd 1
$w.top configure -relief raised -bd 1
}
# 4. Fill the top part with bitmap and message (use the option
# database for -wraplength and -font so that they can be
# overridden by the caller).
option add *Dialog.msg.wrapLength 3i widgetDefault
if {[string equal $tcl_platform(platform) "macintosh"]} {
option add *Dialog.msg.font system widgetDefault
} else {
option add *Dialog.msg.font {Times 18} widgetDefault
}
label $w.msg -anchor nw -justify left -text $data(-message)
if {[string compare $data(-icon) ""]} {
if {[string equal $tcl_platform(platform) "macintosh"] \
|| ([winfo depth $w] < 4) || $tk_strictMotif} {
label $w.bitmap -bitmap $data(-icon)
} else {
canvas $w.bitmap -width 32 -height 32 -highlightthickness 0
switch $data(-icon) {
error {
$w.bitmap create oval 0 0 31 31 -fill red -outline black
$w.bitmap create line 9 9 23 23 -fill white -width 4
$w.bitmap create line 9 23 23 9 -fill white -width 4
}
info {
$w.bitmap create image 0 0 -anchor nw \
-image ::tk::dialog::b1
$w.bitmap create image 0 0 -anchor nw \
-image ::tk::dialog::b2
$w.bitmap create image 0 0 -anchor nw \
-image ::tk::dialog::i
}
question {
$w.bitmap create image 0 0 -anchor nw \
-image ::tk::dialog::b1
$w.bitmap create image 0 0 -anchor nw \
-image ::tk::dialog::b2
$w.bitmap create image 0 0 -anchor nw \
-image ::tk::dialog::q
}
default {
$w.bitmap create image 0 0 -anchor nw \
-image ::tk::dialog::w1
$w.bitmap create image 0 0 -anchor nw \
-image ::tk::dialog::w2
$w.bitmap create image 0 0 -anchor nw \
-image ::tk::dialog::w3
}
}
}
}
grid $w.bitmap $w.msg -in $w.top -sticky news -padx 2m -pady 2m
grid columnconfigure $w.top 1 -weight 1
grid rowconfigure $w.top 0 -weight 1
# 5. Create a row of buttons at the bottom of the dialog.
set i 0
foreach but $buttons {
set name [lindex $but 0]
set opts [lrange $but 1 end]
if {![llength $opts]} {
# Capitalize the first letter of $name
set capName [string toupper $name 0]
set opts [list -text $capName]
}
eval button [list $w.$name] $opts [list -command [list set tkPriv(button) $name]]
if {[string equal $name $data(-default)]} {
$w.$name configure -default active
}
pack $w.$name -in $w.bot -side left -expand 1 -padx 3m -pady 2m
# create the binding for the key accelerator, based on the underline
#
set underIdx [$w.$name cget -under]
if {$underIdx >= 0} {
set key [string index [$w.$name cget -text] $underIdx]
bind $w <Alt-[string tolower $key]> [list $w.$name invoke]
bind $w <Alt-[string toupper $key]> [list $w.$name invoke]
}
incr i
}
if {[string compare {} $data(-default)]} {
bind $w <FocusIn> {
if {[string equal Button [winfo class %W]]} {
%W configure -default active
}
}
bind $w <FocusOut> {
if {[string equal Button [winfo class %W]]} {
%W configure -default normal
}
}
}
# 6. Create a binding for <Return> on the dialog
bind $w <Return> {
if {[string equal Button [winfo class %W]]} {
tkButtonInvoke %W
}
}
# 7. Withdraw the window, then update all the geometry information
# so we know how big it wants to be, then center the window in the
# display and de-iconify it.
::tk::PlaceWindow $w widget $data(-parent)
# 8. Set a grab and claim the focus too.
if {[string compare $data(-default) ""]} {
set focus $w.$data(-default)
} else {
set focus $w
}
::tk::SetFocusGrab $w $focus
# 9. Wait for the user to respond, then restore the focus and
# return the index of the selected button. Restore the focus
# before deleting the window, since otherwise the window manager
# may take the focus away so we can't redirect it. Finally,
# restore any grab that was in effect.
tkwait variable tkPriv(button)
::tk::RestoreFocusGrab $w $focus
return $tkPriv(button)
}
# comdlg.tcl --
#
# Some functions needed for the common dialog boxes. Probably need to go
# in a different file.
#
# RCS: @(#) $Id: comdlg.tcl,v 1.7 2000/04/08 06:59:28 hobbs Exp $
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# tclParseConfigSpec --
#
# Parses a list of "-option value" pairs. If all options and
# values are legal, the values are stored in
# $data($option). Otherwise an error message is returned. When
# an error happens, the data() array may have been partially
# modified, but all the modified members of the data(0 array are
# guaranteed to have valid values. This is different than
# Tk_ConfigureWidget() which does not modify the value of a
# widget record if any error occurs.
#
# Arguments:
#
# w = widget record to modify. Must be the pathname of a widget.
#
# specs = {
# {-commandlineswitch resourceName ResourceClass defaultValue verifier}
# {....}
# }
#
# flags = currently unused.
#
# argList = The list of "-option value" pairs.
#
proc tclParseConfigSpec {w specs flags argList} {
upvar #0 $w data
# 1: Put the specs in associative arrays for faster access
#
foreach spec $specs {
if {[llength $spec] < 4} {
error "\"spec\" should contain 5 or 4 elements"
}
set cmdsw [lindex $spec 0]
set cmd($cmdsw) ""
set rname($cmdsw) [lindex $spec 1]
set rclass($cmdsw) [lindex $spec 2]
set def($cmdsw) [lindex $spec 3]
set verproc($cmdsw) [lindex $spec 4]
}
if {[llength $argList] & 1} {
set cmdsw [lindex $argList end]
if {![info exists cmd($cmdsw)]} {
error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
}
error "value for \"$cmdsw\" missing"
}
# 2: set the default values
#
foreach cmdsw [array names cmd] {
set data($cmdsw) $def($cmdsw)
}
# 3: parse the argument list
#
foreach {cmdsw value} $argList {
if {![info exists cmd($cmdsw)]} {
error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
}
set data($cmdsw) $value
}
# Done!
}
proc tclListValidFlags {v} {
upvar $v cmd
set len [llength [array names cmd]]
set i 1
set separator ""
set errormsg ""
foreach cmdsw [lsort [array names cmd]] {
append errormsg "$separator$cmdsw"
incr i
if {$i == $len} {
set separator ", or "
} else {
set separator ", "
}
}
return $errormsg
}
#----------------------------------------------------------------------
#
# Focus Group
#
# Focus groups are used to handle the user's focusing actions inside a
# toplevel.
#
# One example of using focus groups is: when the user focuses on an
# entry, the text in the entry is highlighted and the cursor is put to
# the end of the text. When the user changes focus to another widget,
# the text in the previously focused entry is validated.
#
#----------------------------------------------------------------------
# tkFocusGroup_Create --
#
# Create a focus group. All the widgets in a focus group must be
# within the same focus toplevel. Each toplevel can have only
# one focus group, which is identified by the name of the
# toplevel widget.
#
proc tkFocusGroup_Create {t} {
global tkPriv
if {[string compare [winfo toplevel $t] $t]} {
error "$t is not a toplevel window"
}
if {![info exists tkPriv(fg,$t)]} {
set tkPriv(fg,$t) 1
set tkPriv(focus,$t) ""
bind $t <FocusIn> [list tkFocusGroup_In $t %W %d]
bind $t <FocusOut> [list tkFocusGroup_Out $t %W %d]
bind $t <Destroy> [list tkFocusGroup_Destroy $t %W]
}
}
# tkFocusGroup_BindIn --
#
# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
# called when the widget is focused on by the user.
#
proc tkFocusGroup_BindIn {t w cmd} {
global tkFocusIn tkPriv
if {![info exists tkPriv(fg,$t)]} {
error "focus group \"$t\" doesn't exist"
}
set tkFocusIn($t,$w) $cmd
}
# tkFocusGroup_BindOut --
#
# Add a widget into the "FocusOut" list of the focus group. The
# $cmd will be called when the widget loses the focus (User
# types Tab or click on another widget).
#
proc tkFocusGroup_BindOut {t w cmd} {
global tkFocusOut tkPriv
if {![info exists tkPriv(fg,$t)]} {
error "focus group \"$t\" doesn't exist"
}
set tkFocusOut($t,$w) $cmd
}
# tkFocusGroup_Destroy --
#
# Cleans up when members of the focus group is deleted, or when the
# toplevel itself gets deleted.
#
proc tkFocusGroup_Destroy {t w} {
global tkPriv tkFocusIn tkFocusOut
if {[string equal $t $w]} {
unset tkPriv(fg,$t)
unset tkPriv(focus,$t)
foreach name [array names tkFocusIn $t,*] {
unset tkFocusIn($name)
}
foreach name [array names tkFocusOut $t,*] {
unset tkFocusOut($name)
}
} else {
if {[info exists tkPriv(focus,$t)] && \
[string equal $tkPriv(focus,$t) $w]} {
set tkPriv(focus,$t) ""
}
catch {
unset tkFocusIn($t,$w)
}
catch {
unset tkFocusOut($t,$w)
}
}
}
# tkFocusGroup_In --
#
# Handles the <FocusIn> event. Calls the FocusIn command for the newly
# focused widget in the focus group.
#
proc tkFocusGroup_In {t w detail} {
global tkPriv tkFocusIn
if {[string compare $detail NotifyNonlinear] && \
[string compare $detail NotifyNonlinearVirtual]} {
# This is caused by mouse moving out&in of the window *or*
# ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
return
}
if {![info exists tkFocusIn($t,$w)]} {
set tkFocusIn($t,$w) ""
return
}
if {![info exists tkPriv(focus,$t)]} {
return
}
if {[string equal $tkPriv(focus,$t) $w]} {
# This is already in focus
#
return
} else {
set tkPriv(focus,$t) $w
eval $tkFocusIn($t,$w)
}
}
# tkFocusGroup_Out --
#
# Handles the <FocusOut> event. Checks if this is really a lose
# focus event, not one generated by the mouse moving out of the
# toplevel window. Calls the FocusOut command for the widget
# who loses its focus.
#
proc tkFocusGroup_Out {t w detail} {
global tkPriv tkFocusOut
if {[string compare $detail NotifyNonlinear] && \
[string compare $detail NotifyNonlinearVirtual]} {
# This is caused by mouse moving out of the window
return
}
if {![info exists tkPriv(focus,$t)]} {
return
}
if {![info exists tkFocusOut($t,$w)]} {
return
} else {
eval $tkFocusOut($t,$w)
set tkPriv(focus,$t) ""
}
}
# tkFDGetFileTypes --
#
# Process the string given by the -filetypes option of the file
# dialogs. Similar to the C function TkGetFileFilters() on the Mac
# and Windows platform.
#
proc tkFDGetFileTypes {string} {
foreach t $string {
if {[llength $t] < 2 || [llength $t] > 3} {
error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
}
eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1]
}
set types {}
foreach t $string {
set label [lindex $t 0]
set exts {}
if {[info exists hasDoneType($label)]} {
continue
}
set name "$label ("
set sep ""
foreach ext $fileTypes($label) {
if {[string equal $ext ""]} {
continue
}
regsub {^[.]} $ext "*." ext
if {![info exists hasGotExt($label,$ext)]} {
append name $sep$ext
lappend exts $ext
set hasGotExt($label,$ext) 1
}
set sep ,
}
append name ")"
lappend types [list $name $exts]
set hasDoneType($label) 1
}
return $types
}
¦ § ÉOk l :uWish - Windowing Shell
based on Tcl 8.3.4 & Tk 8.3.4
Jim Ingham & Ray Johnson
© 2001 Tcl Core Team
jingham@apple.com w \@ Jâ# auto.tcl --
#
# utility procs formerly in init.tcl dealing with auto execution
# of commands and can be auto loaded themselves.
#
# RCS: @(#) $Id: auto.tcl,v 1.7 2000/02/08 10:06:12 hobbs Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# auto_reset --
#
# Destroy all cached information for auto-loading and auto-execution,
# so that the information gets recomputed the next time it's needed.
# Also delete any procedures that are listed in the auto-load index
# except those defined in this file.
#
# Arguments:
# None.
proc auto_reset {} {
global auto_execs auto_index auto_oldpath
foreach p [info procs] {
if {[info exists auto_index($p)] && ![string match auto_* $p]
&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
tcl_findLibrary pkg_compareExtension
tclMacPkgSearch tclPkgUnknown} $p] < 0)} {
rename $p {}
}
}
catch {unset auto_execs}
catch {unset auto_index}
catch {unset auto_oldpath}
}
# tcl_findLibrary --
#
# This is a utility for extensions that searches for a library directory
# using a canonical searching algorithm. A side effect is to source
# the initialization script and set a global library variable.
#
# Arguments:
# basename Prefix of the directory name, (e.g., "tk")
# version Version number of the package, (e.g., "8.0")
# patch Patchlevel of the package, (e.g., "8.0.3")
# initScript Initialization script to source (e.g., tk.tcl)
# enVarName environment variable to honor (e.g., TK_LIBRARY)
# varName Global variable to set when done (e.g., tk_library)
proc tcl_findLibrary {basename version patch initScript enVarName varName} {
upvar #0 $varName the_library
global env errorInfo
set dirs {}
set errors {}
# The C application may have hardwired a path, which we honor
if {[info exist the_library] && [string compare $the_library {}]} {
lappend dirs $the_library
} else {
# Do the canonical search
# 1. From an environment variable, if it exists
if {[info exists env($enVarName)]} {
lappend dirs $env($enVarName)
}
# 2. Relative to the Tcl library
lappend dirs [file join [file dirname [info library]] \
$basename$version]
# 3. Various locations relative to the executable
# ../lib/foo1.0 (From bin directory in install hierarchy)
# ../../lib/foo1.0 (From bin/arch directory in install hierarchy)
# ../library (From unix directory in build hierarchy)
# ../../library (From unix/arch directory in build hierarchy)
# ../../foo1.0b1/library (From unix directory in parallel build hierarchy)
# ../../../foo1.0b1/library (From unix/arch directory in parallel build hierarchy)
set parentDir [file dirname [file dirname [info nameofexecutable]]]
set grandParentDir [file dirname $parentDir]
lappend dirs [file join $parentDir lib $basename$version]
lappend dirs [file join $grandParentDir lib $basename$version]
lappend dirs [file join $parentDir library]
lappend dirs [file join $grandParentDir library]
if {![regexp {.*[ab][0-9]*} $patch ver]} {
set ver $version
}
lappend dirs [file join $grandParentDir $basename$ver library]
lappend dirs [file join [file dirname $grandParentDir] $basename$ver library]
}
foreach i $dirs {
set the_library $i
set file [file join $i $initScript]
# source everything when in a safe interpreter because
# we have a source command, but no file exists command
if {[interp issafe] || [file exists $file]} {
if {![catch {uplevel #0 [list source $file]} msg]} {
return
} else {
append errors "$file: $msg\n$errorInfo\n"
}
}
}
set msg "Can't find a usable $initScript in the following directories: \n"
append msg " $dirs\n\n"
append msg "$errors\n\n"
append msg "This probably means that $basename wasn't installed properly.\n"
error $msg
}
# ----------------------------------------------------------------------
# auto_mkindex
# ----------------------------------------------------------------------
# The following procedures are used to generate the tclIndex file
# from Tcl source files. They use a special safe interpreter to
# parse Tcl source files, writing out index entries as "proc"
# commands are encountered. This implementation won't work in a
# safe interpreter, since a safe interpreter can't create the
# special parser and mess with its commands.
if {[interp issafe]} {
return ;# Stop sourcing the file here
}
# auto_mkindex --
# Regenerate a tclIndex file from Tcl source files. Takes as argument
# the name of the directory in which the tclIndex file is to be placed,
# followed by any number of glob patterns to use in that directory to
# locate all of the relevant files.
#
# Arguments:
# dir - Name of the directory in which to create an index.
# args - Any number of additional arguments giving the
# names of files within dir. If no additional
# are given auto_mkindex will look for *.tcl.
proc auto_mkindex {dir args} {
global errorCode errorInfo
if {[interp issafe]} {
error "can't generate index within safe interpreter"
}
set oldDir [pwd]
cd $dir
set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {$args == ""} {
set args *.tcl
}
auto_mkindex_parser::init
foreach file [eval glob $args] {
if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
append index $msg
} else {
set code $errorCode
set info $errorInfo
cd $oldDir
error $msg $info $code
}
}
auto_mkindex_parser::cleanup
set fid [open "tclIndex" w]
puts -nonewline $fid $index
close $fid
cd $oldDir
}
# Original version of auto_mkindex that just searches the source
# code for "proc" at the beginning of the line.
proc auto_mkindex_old {dir args} {
global errorCode errorInfo
set oldDir [pwd]
cd $dir
set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {[string equal $args ""]} {
set args *.tcl
}
foreach file [eval glob $args] {
set f ""
set error [catch {
set f [open $file]
while {[gets $f line] >= 0} {
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
append index " \[list source \[file join \$dir [list $file]\]\]\n"
}
}
close $f
} msg]
if {$error} {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}
set f ""
set error [catch {
set f [open tclIndex w]
puts -nonewline $f $index
close $f
cd $oldDir
} msg]
if {$error} {
set code $errorCode
set info $errorInfo
catch {close $f}
cd $oldDir
error $msg $info $code
}
}
# Create a safe interpreter that can be used to parse Tcl source files
# generate a tclIndex file for autoloading. This interp contains
# commands for things that need index entries. Each time a command
# is executed, it writes an entry out to the index file.
namespace eval auto_mkindex_parser {
variable parser "" ;# parser used to build index
variable index "" ;# maintains index as it is built
variable scriptFile "" ;# name of file being processed
variable contextStack "" ;# stack of namespace scopes
variable imports "" ;# keeps track of all imported cmds
variable initCommands "" ;# list of commands that create aliases
proc init {} {
variable parser
variable initCommands
if {![interp issafe]} {
set parser [interp create -safe]
$parser hide info
$parser hide rename
$parser hide proc
$parser hide namespace
$parser hide eval
$parser hide puts
$parser invokehidden namespace delete ::
$parser invokehidden proc unknown {args} {}
# We'll need access to the "namespace" command within the
# interp. Put it back, but move it out of the way.
$parser expose namespace
$parser invokehidden rename namespace _%@namespace
$parser expose eval
$parser invokehidden rename eval _%@eval
# Install all the registered psuedo-command implementations
foreach cmd $initCommands {
eval $cmd
}
}
}
proc cleanup {} {
variable parser
interp delete $parser
unset parser
}
}
# auto_mkindex_parser::mkindex --
#
# Used by the "auto_mkindex" command to create a "tclIndex" file for
# the given Tcl source file. Executes the commands in the file, and
# handles things like the "proc" command by adding an entry for the
# index file. Returns a string that represents the index file.
#
# Arguments:
# file Name of Tcl source file to be indexed.
proc auto_mkindex_parser::mkindex {file} {
variable parser
variable index
variable scriptFile
variable contextStack
variable imports
set scriptFile $file
set fid [open $file]
set contents [read $fid]
close $fid
# There is one problem with sourcing files into the safe
# interpreter: references like "$x" will fail since code is not
# really being executed and variables do not really exist.
# To avoid this, we replace all $ with \0 (literally, the null char)
# later, when getting proc names we will have to reverse this replacement,
# in case there were any $ in the proc name. This will cause a problem
# if somebody actually tries to have a \0 in their proc name. Too bad
# for them.
regsub -all {\$} $contents "\0" contents
set index ""
set contextStack ""
set imports ""
$parser eval $contents
foreach name $imports {
catch {$parser eval [list _%@namespace forget $name]}
}
return $index
}
# auto_mkindex_parser::hook command
#
# Registers a Tcl command to evaluate when initializing the
# slave interpreter used by the mkindex parser.
# The command is evaluated in the master interpreter, and can
# use the variable auto_mkindex_parser::parser to get to the slave
proc auto_mkindex_parser::hook {cmd} {
variable initCommands
lappend initCommands $cmd
}
# auto_mkindex_parser::slavehook command
#
# Registers a Tcl command to evaluate when initializing the
# slave interpreter used by the mkindex parser.
# The command is evaluated in the slave interpreter.
proc auto_mkindex_parser::slavehook {cmd} {
variable initCommands
# The $parser variable is defined to be the name of the
# slave interpreter when this command is used later.
lappend initCommands "\$parser eval [list $cmd]"
}
# auto_mkindex_parser::command --
#
# Registers a new command with the "auto_mkindex_parser" interpreter
# that parses Tcl files. These commands are fake versions of things
# like the "proc" command. When you execute them, they simply write
# out an entry to a "tclIndex" file for auto-loading.
#
# This procedure allows extensions to register their own commands
# with the auto_mkindex facility. For example, a package like
# [incr Tcl] might register a "class" command so that class definitions
# could be added to a "tclIndex" file for auto-loading.
#
# Arguments:
# name Name of command recognized in Tcl files.
# arglist Argument list for command.
# body Implementation of command to handle indexing.
proc auto_mkindex_parser::command {name arglist body} {
hook [list auto_mkindex_parser::commandInit $name $arglist $body]
}
# auto_mkindex_parser::commandInit --
#
# This does the actual work set up by auto_mkindex_parser::command
# This is called when the interpreter used by the parser is created.
#
# Arguments:
# name Name of command recognized in Tcl files.
# arglist Argument list for command.
# body Implementation of command to handle indexing.
proc auto_mkindex_parser::commandInit {name arglist body} {
variable parser
set ns [namespace qualifiers $name]
set tail [namespace tail $name]
if {[string equal $ns ""]} {
set fakeName "[namespace current]::_%@fake_$tail"
} else {
set fakeName "_%@fake_$name"
regsub -all {::} $fakeName "_" fakeName
set fakeName "[namespace current]::$fakeName"
}
proc $fakeName $arglist $body
# YUK! Tcl won't let us alias fully qualified command names,
# so we can't handle names like "::itcl::class". Instead,
# we have to build procs with the fully qualified names, and
# have the procs point to the aliases.
if {[regexp {::} $name]} {
set exportCmd [list _%@namespace export [namespace tail $name]]
$parser eval [list _%@namespace eval $ns $exportCmd]
# The following proc definition does not work if you
# want to tolerate space or something else diabolical
# in the procedure name, (i.e., space in $alias)
# The following does not work:
# "_%@eval {$alias} \$args"
# because $alias gets concat'ed to $args.
# The following does not work because $cmd is somehow undefined
# "set cmd {$alias} \; _%@eval {\$cmd} \$args"
# A gold star to someone that can make test
# autoMkindex-3.3 work properly
set alias [namespace tail $fakeName]
$parser invokehidden proc $name {args} "_%@eval {$alias} \$args"
$parser alias $alias $fakeName
} else {
$parser alias $name $fakeName
}
return
}
# auto_mkindex_parser::fullname --
# Used by commands like "proc" within the auto_mkindex parser.
# Returns the qualified namespace name for the "name" argument.
# If the "name" does not start with "::", elements are added from
# the current namespace stack to produce a qualified name. Then,
# the name is examined to see whether or not it should really be
# qualified. If the name has more than the leading "::", it is
# returned as a fully qualified name. Otherwise, it is returned
# as a simple name. That way, the Tcl autoloader will recognize
# it properly.
#
# Arguments:
# name - Name that is being added to index.
proc auto_mkindex_parser::fullname {name} {
variable contextStack
if {![string match ::* $name]} {
foreach ns $contextStack {
set name "${ns}::$name"
if {[string match ::* $name]} {
break
}
}
}
if {[string equal [namespace qualifiers $name] ""]} {
set name [namespace tail $name]
} elseif {![string match ::* $name]} {
set name "::$name"
}
# Earlier, mkindex replaced all $'s with \0. Now, we have to reverse
# that replacement.
regsub -all "\0" $name "\$" name
return $name
}
# Register all of the procedures for the auto_mkindex parser that
# will build the "tclIndex" file.
# AUTO MKINDEX: proc name arglist body
# Adds an entry to the auto index list for the given procedure name.
auto_mkindex_parser::command proc {name args} {
variable index
variable scriptFile
# Do some fancy reformatting on the "source" call to handle platform
# differences with respect to pathnames. Use format just so that the
# command is a little easier to read (otherwise it'd be full of
# backslashed dollar signs, etc.
append index [list set auto_index([fullname $name])] \
[format { [list source [file join $dir %s]]} \
[file split $scriptFile]] "\n"
}
# Conditionally add support for Tcl byte code files. There are some
# tricky details here. First, we need to get the tbcload library
# initialized in the current interpreter. We cannot load tbcload into the
# slave until we have done so because it needs access to the tcl_patchLevel
# variable. Second, because the package index file may defer loading the
# library until we invoke a command, we need to explicitly invoke auto_load
# to force it to be loaded. This should be a noop if the package has
# already been loaded
auto_mkindex_parser::hook {
if {![catch {package require tbcload}]} {
if {[llength [info commands tbcload::bcproc]] == 0} {
auto_load tbcload::bcproc
}
load {} tbcload $auto_mkindex_parser::parser
# AUTO MKINDEX: tbcload::bcproc name arglist body
# Adds an entry to the auto index list for the given pre-compiled
# procedure name.
auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
variable index
variable scriptFile
# Do some nice reformatting of the "source" call, to get around
# path differences on different platforms. We use the format
# command just so that the code is a little easier to read.
append index [list set auto_index([fullname $name])] \
[format { [list source [file join $dir %s]]} \
[file split $scriptFile]] "\n"
}
}
}
# AUTO MKINDEX: namespace eval name command ?arg arg...?
# Adds the namespace name onto the context stack and evaluates the
# associated body of commands.
#
# AUTO MKINDEX: namespace import ?-force? pattern ?pattern...?
# Performs the "import" action in the parser interpreter. This is
# important for any commands contained in a namespace that affect
# the index. For example, a script may say "itcl::class ...",
# or it may import "itcl::*" and then say "class ...". This
# procedure does the import operation, but keeps track of imported
# patterns so we can remove the imports later.
auto_mkindex_parser::command namespace {op args} {
switch -- $op {
eval {
variable parser
variable contextStack
set name [lindex $args 0]
set args [lrange $args 1 end]
set contextStack [linsert $contextStack 0 $name]
$parser eval [list _%@namespace eval $name] $args
set contextStack [lrange $contextStack 1 end]
}
import {
variable parser
variable imports
foreach pattern $args {
if {[string compare $pattern "-force"]} {
lappend imports $pattern
}
}
catch {$parser eval "_%@namespace import $args"}
}
}
}
return
#/# history.tcl --
#
# Implementation of the history command.
#
# RCS: @(#) $Id: history.tcl,v 1.3.18.1 2000/08/07 21:31:47 hobbs Exp $
#
# Copyright (c) 1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# The tcl::history array holds the history list and
# some additional bookkeeping variables.
#
# nextid the index used for the next history list item.
# keep the max size of the history list
# oldest the index of the oldest item in the history.
namespace eval tcl {
variable history
if {![info exists history]} {
array set history {
nextid 0
keep 20
oldest -20
}
}
}
# history --
#
# This is the main history command. See the man page for its interface.
# This does argument checking and calls helper procedures in the
# history namespace.
proc history {args} {
set len [llength $args]
if {$len == 0} {
return [tcl::HistInfo]
}
set key [lindex $args 0]
set options "add, change, clear, event, info, keep, nextid, or redo"
switch -glob -- $key {
a* { # history add
if {$len > 3} {
return -code error "wrong # args: should be \"history add event ?exec?\""
}
if {![string match $key* add]} {
return -code error "bad option \"$key\": must be $options"
}
if {$len == 3} {
set arg [lindex $args 2]
if {! ([string match e* $arg] && [string match $arg* exec])} {
return -code error "bad argument \"$arg\": should be \"exec\""
}
}
return [tcl::HistAdd [lindex $args 1] [lindex $args 2]]
}
ch* { # history change
if {($len > 3) || ($len < 2)} {
return -code error "wrong # args: should be \"history change newValue ?event?\""
}
if {![string match $key* change]} {
return -code error "bad option \"$key\": must be $options"
}
if {$len == 2} {
set event 0
} else {
set event [lindex $args 2]
}
return [tcl::HistChange [lindex $args 1] $event]
}
cl* { # history clear
if {($len > 1)} {
return -code error "wrong # args: should be \"history clear\""
}
if {![string match $key* clear]} {
return -code error "bad option \"$key\": must be $options"
}
return [tcl::HistClear]
}
e* { # history event
if {$len > 2} {
return -code error "wrong # args: should be \"history event ?event?\""
}
if {![string match $key* event]} {
return -code error "bad option \"$key\": must be $options"
}
if {$len == 1} {
set event -1
} else {
set event [lindex $args 1]
}
return [tcl::HistEvent $event]
}
i* { # history info
if {$len > 2} {
return -code error "wrong # args: should be \"history info ?count?\""
}
if {![string match $key* info]} {
return -code error "bad option \"$key\": must be $options"
}
return [tcl::HistInfo [lindex $args 1]]
}
k* { # history keep
if {$len > 2} {
return -code error "wrong # args: should be \"history keep ?count?\""
}
if {$len == 1} {
return [tcl::HistKeep]
} else {
set limit [lindex $args 1]
if {[catch {expr {~$limit}}] || ($limit < 0)} {
return -code error "illegal keep count \"$limit\""
}
return [tcl::HistKeep $limit]
}
}
n* { # history nextid
if {$len > 1} {
return -code error "wrong # args: should be \"history nextid\""
}
if {![string match $key* nextid]} {
return -code error "bad option \"$key\": must be $options"
}
return [expr {$tcl::history(nextid) + 1}]
}
r* { # history redo
if {$len > 2} {
return -code error "wrong # args: should be \"history redo ?event?\""
}
if {![string match $key* redo]} {
return -code error "bad option \"$key\": must be $options"
}
return [tcl::HistRedo [lindex $args 1]]
}
default {
return -code error "bad option \"$key\": must be $options"
}
}
}
# tcl::HistAdd --
#
# Add an item to the history, and optionally eval it at the global scope
#
# Parameters:
# command the command to add
# exec (optional) a substring of "exec" causes the
# command to be evaled.
# Results:
# If executing, then the results of the command are returned
#
# Side Effects:
# Adds to the history list
proc tcl::HistAdd {command {exec {}}} {
variable history
set i [incr history(nextid)]
set history($i) $command
set j [incr history(oldest)]
if {[info exists history($j)]} {unset history($j)}
if {[string match e* $exec]} {
return [uplevel #0 $command]
} else {
return {}
}
}
# tcl::HistKeep --
#
# Set or query the limit on the length of the history list
#
# Parameters:
# limit (optional) the length of the history list
#
# Results:
# If no limit is specified, the current limit is returned
#
# Side Effects:
# Updates history(keep) if a limit is specified
proc tcl::HistKeep {{limit {}}} {
variable history
if {[string length $limit] == 0} {
return $history(keep)
} else {
set oldold $history(oldest)
set history(oldest) [expr {$history(nextid) - $limit}]
for {} {$oldold <= $history(oldest)} {incr oldold} {
if {[info exists history($oldold)]} {unset history($oldold)}
}
set history(keep) $limit
}
}
# tcl::HistClear --
#
# Erase the history list
#
# Parameters:
# none
#
# Results:
# none
#
# Side Effects:
# Resets the history array, except for the keep limit
proc tcl::HistClear {} {
variable history
set keep $history(keep)
unset history
array set history [list \
nextid 0 \
keep $keep \
oldest -$keep \
]
}
# tcl::HistInfo --
#
# Return a pretty-printed version of the history list
#
# Parameters:
# num (optional) the length of the history list to return
#
# Results:
# A formatted history list
proc tcl::HistInfo {{num {}}} {
variable history
if {$num == {}} {
set num [expr {$history(keep) + 1}]
}
set result {}
set newline ""
for {set i [expr {$history(nextid) - $num + 1}]} \
{$i <= $history(nextid)} {incr i} {
if {![info exists history($i)]} {
continue
}
set cmd [string trimright $history($i) \ \n]
regsub -all \n $cmd "\n\t" cmd
append result $newline[format "%6d %s" $i $cmd]
set newline \n
}
return $result
}
# tcl::HistRedo --
#
# Fetch the previous or specified event, execute it, and then
# replace the current history item with that event.
#
# Parameters:
# event (optional) index of history item to redo. Defaults to -1,
# which means the previous event.
#
# Results:
# Those of the command being redone.
#
# Side Effects:
# Replaces the current history list item with the one being redone.
proc tcl::HistRedo {{event -1}} {
variable history
if {[string length $event] == 0} {
set event -1
}
set i [HistIndex $event]
if {$i == $history(nextid)} {
return -code error "cannot redo the current event"
}
set cmd $history($i)
HistChange $cmd 0
uplevel #0 $cmd
}
# tcl::HistIndex --
#
# Map from an event specifier to an index in the history list.
#
# Parameters:
# event index of history item to redo.
# If this is a positive number, it is used directly.
# If it is a negative number, then it counts back to a previous
# event, where -1 is the most recent event.
# A string can be matched, either by being the prefix of
# a command or by matching a command with string match.
#
# Results:
# The index into history, or an error if the index didn't match.
proc tcl::HistIndex {event} {
variable history
if {[catch {expr {~$event}}]} {
for {set i [expr {$history(nextid)-1}]} {[info exists history($i)]} \
{incr i -1} {
if {[string match $event* $history($i)]} {
return $i;
}
if {[string match $event $history($i)]} {
return $i;
}
}
return -code error "no event matches \"$event\""
} elseif {$event <= 0} {
set i [expr {$history(nextid) + $event}]
} else {
set i $event
}
if {$i <= $history(oldest)} {
return -code error "event \"$event\" is too far in the past"
}
if {$i > $history(nextid)} {
return -code error "event \"$event\" hasn't occured yet"
}
return $i
}
# tcl::HistEvent --
#
# Map from an event specifier to the value in the history list.
#
# Parameters:
# event index of history item to redo. See index for a
# description of possible event patterns.
#
# Results:
# The value from the history list.
proc tcl::HistEvent {event} {
variable history
set i [HistIndex $event]
if {[info exists history($i)]} {
return [string trimright $history($i) \ \n]
} else {
return "";
}
}
# tcl::HistChange --
#
# Replace a value in the history list.
#
# Parameters:
# cmd The new value to put into the history list.
# event (optional) index of history item to redo. See index for a
# description of possible event patterns. This defaults
# to 0, which specifies the current event.
#
# Side Effects:
# Changes the history list.
proc tcl::HistChange {cmd {event 0}} {
variable history
set i [HistIndex $event]
set history($i) $cmd
}
D # init.tcl --
#
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.39.2.3 2001/08/24 16:19:09 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
package require -exact Tcl 8.3
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
#
# The environment variable TCLLIBPATH
#
# tcl_library, which is the directory containing this init.tcl script.
# tclInitScript.h searches around for the directory containing this
# init.tcl and defines tcl_library to that location before sourcing it.
#
# The parent directory of tcl_library. Adding the parent
# means that packages in peer directories will be found automatically.
#
# Also add the directory where the executable is located, plus ../lib
# relative to that path.
#
# tcl_pkgPath, which is set by the platform-specific initialization routines
# On UNIX it is compiled in
# On Windows, it is not used
# On Macintosh it is "Tool Command Language" in the Extensions folder
if {![info exists auto_path]} {
if {[info exist env(TCLLIBPATH)]} {
set auto_path $env(TCLLIBPATH)
} else {
set auto_path ""
}
}
if {[string compare [info library] {}]} {
foreach __dir [list [info library] [file dirname [info library]]] {
if {[lsearch -exact $auto_path $__dir] < 0} {
lappend auto_path $__dir
}
}
}
set __dir [file join [file dirname [file dirname \
[info nameofexecutable]]] lib]
if {[lsearch -exact $auto_path $__dir] < 0} {
lappend auto_path $__dir
}
if {[info exist tcl_pkgPath]} {
foreach __dir $tcl_pkgPath {
if {[lsearch -exact $auto_path $__dir] < 0} {
lappend auto_path $__dir
}
}
}
if {[info exists __dir]} {
unset __dir
}
# Windows specific end of initialization
if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} {
namespace eval tcl {
proc envTraceProc {lo n1 n2 op} {
set x $::env($n2)
set ::env($lo) $x
set ::env([string toupper $lo]) $x
}
}
foreach p [array names env] {
set u [string toupper $p]
if {[string compare $u $p]} {
switch -- $u {
COMSPEC -
PATH {
if {![info exists env($u)]} {
set env($u) $env($p)
}
trace variable env($p) w [list tcl::envTraceProc $p]
trace variable env($u) w [list tcl::envTraceProc $p]
}
}
}
}
if {[info exists p]} {
unset p
}
if {[info exists u]} {
unset u
}
if {![info exists env(COMSPEC)]} {
if {[string equal $tcl_platform(os) "Windows NT"]} {
set env(COMSPEC) cmd.exe
} else {
set env(COMSPEC) command.com
}
}
}
# Setup the unknown package handler
package unknown tclPkgUnknown
# Conditionalize for presence of exec.
if {[llength [info commands exec]] == 0} {
# Some machines, such as the Macintosh, do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
set auto_noexec 1
}
set errorCode ""
set errorInfo ""
# Define a log command (which can be overwitten to log errors
# differently, specially when stderr is not available)
if {[llength [info commands tclLog]] == 0} {
proc tclLog {string} {
catch {puts stderr $string}
}
}
# unknown --
# This procedure is called when a Tcl command is invoked that doesn't
# exist in the interpreter. It takes the following steps to make the
# command available:
#
# 1. See if the command has the form "namespace inscope ns cmd" and
# if so, concatenate its arguments onto the end and evaluate it.
# 2. See if the autoload facility can locate the command in a
# Tcl script file. If so, load it and execute it.
# 3. If the command was invoked interactively at top-level:
# (a) see if the command exists as an executable UNIX program.
# If so, "exec" the command.
# (b) see if the command requests csh-like history substitution
# in one of the common forms !!, !<number>, or ^old^new. If
# so, emulate csh's history substitution.
# (c) see if the command is a unique abbreviation for another
# command. If so, invoke the command.
#
# Arguments:
# args - A list whose elements are the words of the original
# command, including the command name.
proc unknown args {
global auto_noexec auto_noload env unknown_pending tcl_interactive
global errorCode errorInfo
# If the command word has the form "namespace inscope ns cmd"
# then concatenate its arguments onto the end and evaluate it.
set cmd [lindex $args 0]
if {[regexp "^namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
set arglist [lrange $args 1 end]
set ret [catch {uplevel 1 ::$cmd $arglist} result]
if {$ret == 0} {
return $result
} else {
return -code $ret -errorcode $errorCode $result
}
}
# Save the values of errorCode and errorInfo variables, since they
# may get modified if caught errors occur below. The variables will
# be restored just before re-executing the missing command.
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
set name [lindex $args 0]
if {![info exists auto_noload]} {
#
# Make sure we're not trying to load the same proc twice.
#
if {[info exists unknown_pending($name)]} {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
set unknown_pending($name) pending;
set ret [catch {auto_load $name [uplevel 1 {::namespace current}]} msg]
unset unknown_pending($name);
if {$ret != 0} {
append errorInfo "\n (autoloading \"$name\")"
return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg
}
if {![array size unknown_pending]} {
unset unknown_pending
}
if {$msg} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set code [catch {uplevel 1 $args} msg]
if {$code == 1} {
#
# Strip the last five lines off the error stack (they're
# from the "uplevel" command).
#
set new [split $errorInfo \n]
set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
return -code error -errorcode $errorCode \
-errorinfo $new $msg
} else {
return -code $code $msg
}
}
}
if {([info level] == 1) && [string equal [info script] ""] \
&& [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
if {[string compare {} $new]} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set redir ""
if {[string equal [info commands console] ""]} {
set redir ">&@stdout <@stdin"
}
return [uplevel 1 exec $redir $new [lrange $args 1 end]]
}
}
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
if {[string equal $name "!!"]} {
set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name dummy event]} {
set newcmd [history event $event]
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
set newcmd [history event -1]
catch {regsub -all -- $old $newcmd $new newcmd}
}
if {[info exists newcmd]} {
tclLog $newcmd
history change $newcmd 0
return [uplevel 1 $newcmd]
}
set ret [catch {set cmds [info commands $name*]} msg]
if {[string equal $name "::"]} {
set name ""
}
if {$ret != 0} {
return -code $ret -errorcode $errorCode \
"error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
}
if {[llength $cmds] == 1} {
return [uplevel 1 [lreplace $args 0 0 $cmds]]
}
if {[llength $cmds]} {
if {[string equal $name ""]} {
return -code error "empty command name \"\""
} else {
return -code error \
"ambiguous command name \"$name\": [lsort $cmds]"
}
}
}
return -code error "invalid command name \"$name\""
}
# auto_load --
# Checks a collection of library directories to see if a procedure
# is defined in one of them. If so, it sources the appropriate
# library file to create the procedure. Returns 1 if it successfully
# loaded the procedure, 0 otherwise.
#
# Arguments:
# cmd - Name of the command to find and load.
# namespace (optional) The namespace where the command is being used - must be
# a canonical namespace as returned [namespace current]
# for instance. If not given, namespace current is used.
proc auto_load {cmd {namespace {}}} {
global auto_index auto_oldpath auto_path
if {[string length $namespace] == 0} {
set namespace [uplevel 1 [list ::namespace current]]
}
set nameList [auto_qualify $cmd $namespace]
# workaround non canonical auto_index entries that might be around
# from older auto_mkindex versions
lappend nameList $cmd
foreach name $nameList {
if {[info exists auto_index($name)]} {
uplevel #0 $auto_index($name)
return [expr {[info commands $name] != ""}]
}
}
if {![info exists auto_path]} {
return 0
}
if {![auto_load_index]} {
return 0
}
foreach name $nameList {
if {[info exists auto_index($name)]} {
uplevel #0 $auto_index($name)
# There's a couple of ways to look for a command of a given
# name. One is to use
# info commands $name
# Unfortunately, if the name has glob-magic chars in it like *
# or [], it may not match. For our purposes here, a better
# route is to use
# namespace which -command $name
if { ![string equal [namespace which -command $name] ""] } {
return 1
}
}
}
return 0
}
# auto_load_index --
# Loads the contents of tclIndex files on the auto_path directory
# list. This is usually invoked within auto_load to load the index
# of available commands. Returns 1 if the index is loaded, and 0 if
# the index is already loaded and up to date.
#
# Arguments:
# None.
proc auto_load_index {} {
global auto_index auto_oldpath auto_path errorInfo errorCode
if {[info exists auto_oldpath] && \
[string equal $auto_oldpath $auto_path]} {
return 0
}
set auto_oldpath $auto_path
# Check if we are a safe interpreter. In that case, we support only
# newer format tclIndex files.
set issafe [interp issafe]
for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
set dir [lindex $auto_path $i]
set f ""
if {$issafe} {
catch {source [file join $dir tclIndex]}
} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
continue
} else {
set error [catch {
set id [gets $f]
if {[string equal $id \
"# Tcl autoload index file, version 2.0"]} {
eval [read $f]
} elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} {
while {[gets $f line] >= 0} {
if {[string equal [string index $line 0] "#"] \
|| ([llength $line] != 2)} {
continue
}
set name [lindex $line 0]
set auto_index($name) \
"source [file join $dir [lindex $line 1]]"
}
} else {
error "[file join $dir tclIndex] isn't a proper Tcl index file"
}
} msg]
if {[string compare $f ""]} {
close $f
}
if {$error} {
error $msg $errorInfo $errorCode
}
}
}
return 1
}
# auto_qualify --
#
# Compute a fully qualified names list for use in the auto_index array.
# For historical reasons, commands in the global namespace do not have leading
# :: in the index key. The list has two elements when the command name is
# relative (no leading ::) and the namespace is not the global one. Otherwise
# only one name is returned (and searched in the auto_index).
#
# Arguments -
# cmd The command name. Can be any name accepted for command
# invocations (Like "foo::::bar").
# namespace The namespace where the command is being used - must be
# a canonical namespace as returned by [namespace current]
# for instance.
proc auto_qualify {cmd namespace} {
# count separators and clean them up
# (making sure that foo:::::bar will be treated as foo::bar)
set n [regsub -all {::+} $cmd :: cmd]
# Ignore namespace if the name starts with ::
# Handle special case of only leading ::
# Before each return case we give an example of which category it is
# with the following form :
# ( inputCmd, inputNameSpace) -> output
if {[regexp {^::(.*)$} $cmd x tail]} {
if {$n > 1} {
# ( ::foo::bar , * ) -> ::foo::bar
return [list $cmd]
} else {
# ( ::global , * ) -> global
return [list $tail]
}
}
# Potentially returning 2 elements to try :
# (if the current namespace is not the global one)
if {$n == 0} {
if {[string equal $namespace ::]} {
# ( nocolons , :: ) -> nocolons
return [list $cmd]
} else {
# ( nocolons , ::sub ) -> ::sub::nocolons nocolons
return [list ${namespace}::$cmd $cmd]
}
} elseif {[string equal $namespace ::]} {
# ( foo::bar , :: ) -> ::foo::bar
return [list ::$cmd]
} else {
# ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
return [list ${namespace}::$cmd ::$cmd]
}
}
# auto_import --
#
# Invoked during "namespace import" to make see if the imported commands
# reside in an autoloaded library. If so, the commands are loaded so
# that they will be available for the import links. If not, then this
# procedure does nothing.
#
# Arguments -
# pattern The pattern of commands being imported (like "foo::*")
# a canonical namespace as returned by [namespace current]
proc auto_import {pattern} {
global auto_index
# If no namespace is specified, this will be an error case
if {![string match *::* $pattern]} {
return
}
set ns [uplevel 1 [list ::namespace current]]
set patternList [auto_qualify $pattern $ns]
auto_load_index
foreach pattern $patternList {
foreach name [array names auto_index $pattern] {
if {[string equal "" [info commands $name]]
&& [string equal [namespace qualifiers $pattern] \
[namespace qualifiers $name]]} {
uplevel #0 $auto_index($name)
}
}
}
}
# auto_execok --
#
# Returns string that indicates name of program to execute if
# name corresponds to a shell builtin or an executable in the
# Windows search path, or "" otherwise. Builds an associative
# array auto_execs that caches information about previous checks,
# for speed.
#
# Arguments:
# name - Name of a command.
if {[string equal windows $tcl_platform(platform)]} {
# Windows version.
#
# Note that info executable doesn't work under Windows, so we have to
# look for files with .exe, .com, or .bat extensions. Also, the path
# may be in the Path or PATH environment variables, and path
# components are separated with semicolons, not colons as under Unix.
#
proc auto_execok name {
global auto_execs env tcl_platform
if {[info exists auto_execs($name)]} {
return $auto_execs($name)
}
set auto_execs($name) ""
set shellBuiltins [list cls copy date del erase dir echo mkdir \
md rename ren rmdir rd time type ver vol]
if {[string equal $tcl_platform(os) "Windows NT"]} {
# NT includes the 'start' built-in
lappend shellBuiltins "start"
}
if {[info exists env(PATHEXT)]} {
# Add an initial ; to have the {} extension check first.
set execExtensions [split ";$env(PATHEXT)" ";"]
} else {
set execExtensions [list {} .com .exe .bat]
}
if {[lsearch -exact $shellBuiltins $name] != -1} {
return [set auto_execs($name) [list $env(COMSPEC) /c $name]]
}
if {[llength [file split $name]] != 1} {
foreach ext $execExtensions {
set file ${name}${ext}
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
}
}
return ""
}
set path "[file dirname [info nameof]];.;"
if {[info exists env(WINDIR)]} {
set windir $env(WINDIR)
}
if {[info exists windir]} {
if {[string equal $tcl_platform(os) "Windows NT"]} {
append path "$windir/system32;"
}
append path "$windir/system;$windir;"
}
foreach var {PATH Path path} {
if {[info exists env($var)]} {
append path ";$env($var)"
}
}
foreach dir [split $path {;}] {
# Skip already checked directories
if {[info exists checked($dir)] || [string equal {} $dir]} { continue }
set checked($dir) {}
foreach ext $execExtensions {
set file [file join $dir ${name}${ext}]
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
}
}
}
return ""
}
} else {
# Unix version.
#
proc auto_execok name {
global auto_execs env
if {[info exists auto_execs($name)]} {
return $auto_execs($name)
}
set auto_execs($name) ""
if {[llength [file split $name]] != 1} {
if {[file executable $name] && ![file isdirectory $name]} {
set auto_execs($name) [list $name]
}
return $auto_execs($name)
}
foreach dir [split $env(PATH) :] {
if {[string equal $dir ""]} {
set dir .
}
set file [file join $dir $name]
if {[file executable $file] && ![file isdirectory $file]} {
set auto_execs($name) [list $file]
return $auto_execs($name)
}
}
return ""
}
}
P`# package.tcl --
#
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
# RCS: @(#) $Id: package.tcl,v 1.14.2.2 2001/08/24 16:19:10 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Create the package namespace
namespace eval ::pkg {
}
# pkg_compareExtension --
#
# Used internally by pkg_mkIndex to compare the extension of a file to
# a given extension. On Windows, it uses a case-insensitive comparison
# because the file system can be file insensitive.
#
# Arguments:
# fileName name of a file whose extension is compared
# ext (optional) The extension to compare against; you must
# provide the starting dot.
# Defaults to [info sharedlibextension]
#
# Results:
# Returns 1 if the extension matches, 0 otherwise
proc pkg_compareExtension { fileName {ext {}} } {
global tcl_platform
if {![string length $ext]} {set ext [info sharedlibextension]}
if {[string equal $tcl_platform(platform) "windows"]} {
return [string equal -nocase [file extension $fileName] $ext]
} else {
# Some unices add trailing numbers after the .so, so
# we could have something like '.so.1.2'.
set root $fileName
while {1} {
set currExt [file extension $root]
if {[string equal $currExt $ext]} {
return 1
}
# The current extension does not match; if it is not a numeric
# value, quit, as we are only looking to ignore version number
# extensions. Otherwise we might return 1 in this case:
# pkg_compareExtension foo.so.bar .so
# which should not match.
if { ![string is integer -strict [string range $currExt 1 end]] } {
return 0
}
set root [file rootname $root]
}
}
}
# pkg_mkIndex --
# This procedure creates a package index in a given directory. The
# package index consists of a "pkgIndex.tcl" file whose contents are
# a Tcl script that sets up package information with "package require"
# commands. The commands describe all of the packages defined by the
# files given as arguments.
#
# Arguments:
# -direct (optional) If this flag is present, the generated
# code in pkgMkIndex.tcl will cause the package to be
# loaded when "package require" is executed, rather
# than lazily when the first reference to an exported
# procedure in the package is made.
# -verbose (optional) Verbose output; the name of each file that
# was successfully rocessed is printed out. Additionally,
# if processing of a file failed a message is printed.
# -load pat (optional) Preload any packages whose names match
# the pattern. Used to handle DLLs that depend on
# other packages during their Init procedure.
# dir - Name of the directory in which to create the index.
# args - Any number of additional arguments, each giving
# a glob pattern that matches the names of one or
# more shared libraries or Tcl script files in
# dir.
proc pkg_mkIndex {args} {
global errorCode errorInfo
set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"};
set argCount [llength $args]
if {$argCount < 1} {
return -code error "wrong # args: should be\n$usage"
}
set more ""
set direct 1
set doVerbose 0
set loadPat ""
for {set idx 0} {$idx < $argCount} {incr idx} {
set flag [lindex $args $idx]
switch -glob -- $flag {
-- {
# done with the flags
incr idx
break
}
-verbose {
set doVerbose 1
}
-lazy {
set direct 0
append more " -lazy"
}
-direct {
append more " -direct"
}
-load {
incr idx
set loadPat [lindex $args $idx]
append more " -load $loadPat"
}
-* {
return -code error "unknown flag $flag: should be\n$usage"
}
default {
# done with the flags
break
}
}
}
set dir [lindex $args $idx]
set patternList [lrange $args [expr {$idx + 1}] end]
if {[llength $patternList] == 0} {
set patternList [list "*.tcl" "*[info sharedlibextension]"]
}
set oldDir [pwd]
cd $dir
if {[catch {eval glob $patternList} fileList]} {
global errorCode errorInfo
cd $oldDir
return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
}
foreach file $fileList {
# For each file, figure out what commands and packages it provides.
# To do this, create a child interpreter, load the file into the
# interpreter, and get a list of the new commands and packages
# that are defined.
if {[string equal $file "pkgIndex.tcl"]} {
continue
}
# Changed back to the original directory before initializing the
# slave in case TCL_LIBRARY is a relative path (e.g. in the test
# suite).
cd $oldDir
set c [interp create]
# Load into the child any packages currently loaded in the parent
# interpreter that match the -load pattern.
if {[string length $loadPat]} {
if {$doVerbose} {
tclLog "currently loaded packages: '[info loaded]'"
tclLog "trying to load all packages matching $loadPat"
}
if {![llength [info loaded]]} {
tclLog "warning: no packages are currently loaded, nothing"
tclLog "can possibly match '$loadPat'"
}
}
foreach pkg [info loaded] {
if {! [string match $loadPat [lindex $pkg 1]]} {
continue
}
if {$doVerbose} {
tclLog "package [lindex $pkg 1] matches '$loadPat'"
}
if {[catch {
load [lindex $pkg 0] [lindex $pkg 1] $c
} err]} {
if {$doVerbose} {
tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
}
} elseif {$doVerbose} {
tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
}
if {[string equal [lindex $pkg 1] "Tk"]} {
# Withdraw . if Tk was loaded, to avoid showing a window.
$c eval [list wm withdraw .]
}
}
cd $dir
$c eval {
# Stub out the package command so packages can
# require other packages.
rename package __package_orig
proc package {what args} {
switch -- $what {
require { return ; # ignore transitive requires }
default { eval __package_orig {$what} $args }
}
}
proc tclPkgUnknown args {}
package unknown tclPkgUnknown
# Stub out the unknown command so package can call
# into each other during their initialilzation.
proc unknown {args} {}
# Stub out the auto_import mechanism
proc auto_import {args} {}
# reserve the ::tcl namespace for support procs
# and temporary variables. This might make it awkward
# to generate a pkgIndex.tcl file for the ::tcl namespace.
namespace eval ::tcl {
variable file ;# Current file being processed
variable direct ;# -direct flag value
variable x ;# Loop variable
variable debug ;# For debugging
variable type ;# "load" or "source", for -direct
variable namespaces ;# Existing namespaces (e.g., ::tcl)
variable packages ;# Existing packages (e.g., Tcl)
variable origCmds ;# Existing commands
variable newCmds ;# Newly created commands
variable newPkgs {} ;# Newly created packages
}
}
$c eval [list set ::tcl::file $file]
$c eval [list set ::tcl::direct $direct]
# Download needed procedures into the slave because we've
# just deleted the unknown procedure. This doesn't handle
# procedures with default arguments.
foreach p {pkg_compareExtension} {
$c eval [list proc $p [info args $p] [info body $p]]
}
if {[catch {
$c eval {
set ::tcl::debug "loading or sourcing"
# we need to track command defined by each package even in
# the -direct case, because they are needed internally by
# the "partial pkgIndex.tcl" step above.
proc ::tcl::GetAllNamespaces {{root ::}} {
set list $root
foreach ns [namespace children $root] {
eval lappend list [::tcl::GetAllNamespaces $ns]
}
return $list
}
# init the list of existing namespaces, packages, commands
foreach ::tcl::x [::tcl::GetAllNamespaces] {
set ::tcl::namespaces($::tcl::x) 1
}
foreach ::tcl::x [package names] {
set ::tcl::packages($::tcl::x) 1
}
set ::tcl::origCmds [info commands]
# Try to load the file if it has the shared library
# extension, otherwise source it. It's important not to
# try to load files that aren't shared libraries, because
# on some systems (like SunOS) the loader will abort the
# whole application when it gets an error.
if {[pkg_compareExtension $::tcl::file [info sharedlibextension]]} {
# The "file join ." command below is necessary.
# Without it, if the file name has no \'s and we're
# on UNIX, the load command will invoke the
# LD_LIBRARY_PATH search mechanism, which could cause
# the wrong file to be used.
set ::tcl::debug loading
load [file join . $::tcl::file]
set ::tcl::type load
} else {
set ::tcl::debug sourcing
source $::tcl::file
set ::tcl::type source
}
# As a performance optimization, if we are creating
# direct load packages, don't bother figuring out the
# set of commands created by the new packages. We
# only need that list for setting up the autoloading
# used in the non-direct case.
if { !$::tcl::direct } {
# See what new namespaces appeared, and import commands
# from them. Only exported commands go into the index.
foreach ::tcl::x [::tcl::GetAllNamespaces] {
if {! [info exists ::tcl::namespaces($::tcl::x)]} {
namespace import -force ${::tcl::x}::*
}
# Figure out what commands appeared
foreach ::tcl::x [info commands] {
set ::tcl::newCmds($::tcl::x) 1
}
foreach ::tcl::x $::tcl::origCmds {
catch {unset ::tcl::newCmds($::tcl::x)}
}
foreach ::tcl::x [array names ::tcl::newCmds] {
# determine which namespace a command comes from
set ::tcl::abs [namespace origin $::tcl::x]
# special case so that global names have no leading
# ::, this is required by the unknown command
set ::tcl::abs \
[lindex [auto_qualify $::tcl::abs ::] 0]
if {[string compare $::tcl::x $::tcl::abs]} {
# Name changed during qualification
set ::tcl::newCmds($::tcl::abs) 1
unset ::tcl::newCmds($::tcl::x)
}
}
}
}
# Look through the packages that appeared, and if there is
# a version provided, then record it
foreach ::tcl::x [package names] {
if {[string compare [package provide $::tcl::x] ""] \
&& ![info exists ::tcl::packages($::tcl::x)]} {
lappend ::tcl::newPkgs \
[list $::tcl::x [package provide $::tcl::x]]
}
}
}
} msg] == 1} {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "warning: error while $what $file: $msg"
}
} else {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "successful $what of $file"
}
set type [$c eval set ::tcl::type]
set cmds [lsort [$c eval array names ::tcl::newCmds]]
set pkgs [$c eval set ::tcl::newPkgs]
if {$doVerbose} {
tclLog "commands provided were $cmds"
tclLog "packages provided were $pkgs"
}
if {[llength $pkgs] > 1} {
tclLog "warning: \"$file\" provides more than one package ($pkgs)"
}
foreach pkg $pkgs {
# cmds is empty/not used in the direct case
lappend files($pkg) [list $file $type $cmds]
}
if {$doVerbose} {
tclLog "processed $file"
}
interp delete $c
}
}
append index "# Tcl package index file, version 1.1\n"
append index "# This file is generated by the \"pkg_mkIndex$more\" command\n"
append index "# and sourced either when an application starts up or\n"
append index "# by a \"package unknown\" script. It invokes the\n"
append index "# \"package ifneeded\" command to set up package-related\n"
append index "# information so that packages will be loaded automatically\n"
append index "# in response to \"package require\" commands. When this\n"
append index "# script is sourced, the variable \$dir must contain the\n"
append index "# full path name of this file's directory.\n"
foreach pkg [lsort [array names files]] {
set cmd {}
foreach {name version} $pkg {
break
}
lappend cmd ::pkg::create -name $name -version $version
foreach spec $files($pkg) {
foreach {file type procs} $spec {
if { $direct } {
set procs {}
}
lappend cmd "-$type" [list $file $procs]
}
}
append index "\n[eval $cmd]"
}
set f [open pkgIndex.tcl w]
puts $f $index
close $f
cd $oldDir
}
# tclPkgSetup --
# This is a utility procedure use by pkgIndex.tcl files. It is invoked
# as part of a "package ifneeded" script. It calls "package provide"
# to indicate that a package is available, then sets entries in the
# auto_index array so that the package's files will be auto-loaded when
# the commands are used.
#
# Arguments:
# dir - Directory containing all the files for this package.
# pkg - Name of the package (no version number).
# version - Version number for the package, such as 2.1.3.
# files - List of files that constitute the package. Each
# element is a sub-list with three elements. The first
# is the name of a file relative to $dir, the second is
# "load" or "source", indicating whether the file is a
# loadable binary or a script to source, and the third
# is a list of commands defined by this file.
proc tclPkgSetup {dir pkg version files} {
global auto_index
package provide $pkg $version
foreach fileInfo $files {
set f [lindex $fileInfo 0]
set type [lindex $fileInfo 1]
foreach cmd [lindex $fileInfo 2] {
if {[string equal $type "load"]} {
set auto_index($cmd) [list load [file join $dir $f] $pkg]
} else {
set auto_index($cmd) [list source [file join $dir $f]]
}
}
}
}
# tclMacPkgSearch --
# The procedure is used on the Macintosh to search a given directory for files
# with a TEXT resource named "pkgIndex". If it exists it is sourced in to the
# interpreter to setup the package database.
proc tclMacPkgSearch {dir} {
foreach x [glob -directory $dir -nocomplain *.shlb] {
if {[file isfile $x]} {
set res [resource open $x]
foreach y [resource list TEXT $res] {
if {[string equal $y "pkgIndex"]} {source -rsrc pkgIndex}
}
catch {resource close $res}
}
}
}
# tclPkgUnknown --
# This procedure provides the default for the "package unknown" function.
# It is invoked when a package that's needed can't be found. It scans
# the auto_path directories and their immediate children looking for
# pkgIndex.tcl files and sources any such files that are found to setup
# the package database. (On the Macintosh we also search for pkgIndex
# TEXT resources in all files.) As it searches, it will recognize changes
# to the auto_path and scan any new directories.
#
# Arguments:
# name - Name of desired package. Not used.
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
proc tclPkgUnknown {name version {exact {}}} {
global auto_path tcl_platform env
if {![info exists auto_path]} {
return
}
# Cache the auto_path, because it may change while we run through
# the first set of pkgIndex.tcl files
set old_path [set use_path $auto_path]
while {[llength $use_path]} {
set dir [lindex $use_path end]
# we can't use glob in safe interps, so enclose the following
# in a catch statement, where we get the pkgIndex files out
# of the subdirectories
catch {
foreach file [glob -directory $dir -join -nocomplain \
* pkgIndex.tcl] {
set dir [file dirname $file]
if {[file readable $file] && ![info exists procdDirs($dir)]} {
if {[catch {source $file} msg]} {
tclLog "error reading package index file $file: $msg"
} else {
set procdDirs($dir) 1
}
}
}
}
set dir [lindex $use_path end]
set file [file join $dir pkgIndex.tcl]
# safe interps usually don't have "file readable", nor stderr channel
if {([interp issafe] || [file readable $file]) && \
![info exists procdDirs($dir)]} {
if {[catch {source $file} msg] && ![interp issafe]} {
tclLog "error reading package index file $file: $msg"
} else {
set procdDirs($dir) 1
}
}
# On the Macintosh we also look in the resource fork
# of shared libraries
# We can't use tclMacPkgSearch in safe interps because it uses glob
if {(![interp issafe]) && \
[string equal $tcl_platform(platform) "macintosh"]} {
set dir [lindex $use_path end]
if {![info exists procdDirs($dir)]} {
tclMacPkgSearch $dir
set procdDirs($dir) 1
}
foreach x [glob -directory $dir -nocomplain *] {
if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
set dir $x
tclMacPkgSearch $dir
set procdDirs($dir) 1
}
}
}
set use_path [lrange $use_path 0 end-1]
if {[string compare $old_path $auto_path]} {
foreach dir $auto_path {
lappend use_path $dir
}
set old_path $auto_path
}
}
}
# ::pkg::create --
#
# Given a package specification generate a "package ifneeded" statement
# for the package, suitable for inclusion in a pkgIndex.tcl file.
#
# Arguments:
# args arguments used by the create function:
# -name packageName
# -version packageVersion
# -load {filename ?{procs}?}
# ...
# -source {filename ?{procs}?}
# ...
#
# Any number of -load and -source parameters may be
# specified, so long as there is at least one -load or
# -source parameter. If the procs component of a
# module specifier is left off, that module will be
# set up for direct loading; otherwise, it will be
# set up for lazy loading. If both -source and -load
# are specified, the -load'ed files will be loaded
# first, followed by the -source'd files.
#
# Results:
# An appropriate "package ifneeded" statement for the package.
proc ::pkg::create {args} {
append err(usage) "[lindex [info level 0] 0] "
append err(usage) "-name packageName -version packageVersion"
append err(usage) "?-load {filename ?{procs}?}? ... "
append err(usage) "?-source {filename ?{procs}?}? ..."
set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
set err(unknownOpt) "unknown option \"%s\": should be \"$err(usage)\""
set err(noLoadOrSource) "at least one of -load and -source must be given"
# process arguments
set len [llength $args]
if { $len < 6 } {
error $err(wrongNumArgs)
}
# Initialize parameters
set opts(-name) {}
set opts(-version) {}
set opts(-source) {}
set opts(-load) {}
# process parameters
for {set i 0} {$i < $len} {incr i} {
set flag [lindex $args $i]
incr i
switch -glob -- $flag {
"-name" -
"-version" {
if { $i >= $len } {
error [format $err(valueMissing) $flag]
}
set opts($flag) [lindex $args $i]
}
"-source" -
"-load" {
if { $i >= $len } {
error [format $err(valueMissing) $flag]
}
lappend opts($flag) [lindex $args $i]
}
default {
error [format $err(unknownOpt) [lindex $args $i]]
}
}
}
# Validate the parameters
if { [llength $opts(-name)] == 0 } {
error [format $err(valueMissing) "-name"]
}
if { [llength $opts(-version)] == 0 } {
error [format $err(valueMissing) "-version"]
}
if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
error $err(noLoadOrSource)
}
# OK, now everything is good. Generate the package ifneeded statment.
set cmdline "package ifneeded $opts(-name) $opts(-version) "
set cmdList {}
set lazyFileList {}
# Handle -load and -source specs
foreach key {load source} {
foreach filespec $opts(-$key) {
foreach {filename proclist} {{} {}} {
break
}
foreach {filename proclist} $filespec {
break
}
if { [llength $proclist] == 0 } {
set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
lappend cmdList $cmd
} else {
lappend lazyFileList [list $filename $key $proclist]
}
}
}
if { [llength $lazyFileList] > 0 } {
lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
$opts(-version) [list $lazyFileList]\]"
}
append cmdline [join $cmdList "\\n"]
return $cmdline
}
r# parray:
# Print the contents of a global array on stdout.
#
# RCS: @(#) $Id: parray.tcl,v 1.3 1998/09/14 18:40:03 stanton Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
proc parray {a {pattern *}} {
upvar 1 $a array
if {![array exists array]} {
error "\"$a\" isn't an array"
}
set maxl 0
foreach name [lsort [array names array $pattern]] {
if {[string length $name] > $maxl} {
set maxl [string length $name]
}
}
set maxl [expr {$maxl + [string length $a] + 2}]
foreach name [lsort [array names array $pattern]] {
set nameString [format %s(%s) $a $name]
puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
}
}
# word.tcl --
#
# This file defines various procedures for computing word boundaries
# in strings. This file is primarily needed so Tk text and entry
# widgets behave properly for different platforms.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
# Copyright (c) 1998 by Scritpics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: word.tcl,v 1.6 2000/01/21 02:25:38 hobbs Exp $
# The following variables are used to determine which characters are
# interpreted as white space.
if {[string equal $tcl_platform(platform) "windows"]} {
# Windows style - any but a unicode space char
set tcl_wordchars "\\S"
set tcl_nonwordchars "\\s"
} else {
# Motif style - any unicode word char (number, letter, or underscore)
set tcl_wordchars "\\w"
set tcl_nonwordchars "\\W"
}
# tcl_wordBreakAfter --
#
# This procedure returns the index of the first word boundary
# after the starting point in the given string, or -1 if there
# are no more boundaries in the given string. The index returned refers
# to the first character of the pair that comprises a boundary.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_wordBreakAfter {str start} {
global tcl_nonwordchars tcl_wordchars
set str [string range $str $start end]
if {[regexp -indices "$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars" $str result]} {
return [expr {[lindex $result 1] + $start}]
}
return -1
}
# tcl_wordBreakBefore --
#
# This procedure returns the index of the first word boundary
# before the starting point in the given string, or -1 if there
# are no more boundaries in the given string. The index returned
# refers to the second character of the pair that comprises a boundary.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_wordBreakBefore {str start} {
global tcl_nonwordchars tcl_wordchars
if {[string equal $start end]} {
set start [string length $str]
}
if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} {
return [lindex $result 1]
}
return -1
}
# tcl_endOfWord --
#
# This procedure returns the index of the first end-of-word location
# after a starting index in the given string. An end-of-word location
# is defined to be the first whitespace character following the first
# non-whitespace character after the starting point. Returns -1 if
# there are no more words after the starting point.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_endOfWord {str start} {
global tcl_nonwordchars tcl_wordchars
if {[regexp -indices "$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars" \
[string range $str $start end] result]} {
return [expr {[lindex $result 1] + $start}]
}
return -1
}
# tcl_startOfNextWord --
#
# This procedure returns the index of the first start-of-word location
# after a starting index in the given string. A start-of-word
# location is defined to be a non-whitespace character following a
# whitespace character. Returns -1 if there are no more start-of-word
# locations after the starting point.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_startOfNextWord {str start} {
global tcl_nonwordchars tcl_wordchars
if {[regexp -indices "$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars" \
[string range $str $start end] result]} {
return [expr {[lindex $result 1] + $start}]
}
return -1
}
# tcl_startOfPreviousWord --
#
# This procedure returns the index of the first start-of-word location
# before a starting index in the given string.
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_startOfPreviousWord {str start} {
global tcl_nonwordchars tcl_wordchars
if {[string equal $start end]} {
set start [string length $str]
}
if {[regexp -indices \
"$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \
[string range $str 0 [expr {$start - 1}]] result word]} {
return [lindex $word 0]
}
return -1
}
Ù©sí?å20 ¸a-7¸a+
jackjansen
tkpython.rsrc ÍAdded the modules I missed first time around. Still not good enough, though: bgerror does a "package require msgcat" and I don't see a way to put packages into resources. Off to the mactcl list for help... ²u ±u BSORT Æ CNTL bCURS T nDITL jDLOG MDEF MENU ¦PICT ²SICN ¾SIZE ÊTEXT Öckid êcrsr ö è r ÿ ê w G ë ~ ì
× í î g ï ¡ ¯ ð © ÷ ¸ ² ? ¹ » º Á Ï » Ò ¼ á _ ½ æ § ¾ ï ï ¿ 7 À Á" Ç Â- Ã8 W ÄC ÅJ ç ÆP / Ç[ w Èa ¿ Éo Êy O Ë Ì ß Í ' Î o Ï« · з ÿ Ñ G ÒË ÓÑ × ÔÙ Õß g Öå ¯ ×ë ÷ Øñ ? Ùö Ú Ï Û
Ü _ Ý § Þ( ï ß1 7 à: á> Ç âK ! ãQ !W äX ! å_ !ç æd "/ çs "w è} "¿ é # ê #O ë # ì§ #ß í° $' î¾ $o ïÐ $· ðÞ $ÿ ñí %G òù % ó %× ô & õ &g ö! &¯ ÷* &÷ ø/ '? ù6 ' ú= 'Ï ûL ( ü\ (_ ým (§ þv (ï ÿ~ )7 ) )Ç * *W ¤ * ª ´ *ç  + ÿÿ +µ Oÿÿ +ÑXl, ÿÿ ,£Xl4 ÿÿ ,· ÿÿ @_Xl0ÿÿÿÿ AC ÐT Ë ÑG ² ÒY$KoXfÓL ã Ôh$IXfÕa$ÓXf ¹Ô$ AQXf| º× mx »Þ { ¼å ²É ½ë ñ ¾ñ Ð ¿ù 9 Àþ É7 Á ϶  ì Ã
Ä 5ð Å$ H% Æ) · Ç1 Ø È9 ?9 É@ { m °XXfè % é ¼ Å o Æ % Í Ó 0 # Ô 8 y × > Ç â D Å ã J C ó Q ö Y
ï ÷ b m ÿ g c l ¹ File Types menuhandfistboatclock
coffee_muggobblergumbyheartmousepencilshuttlespraycanstartrekwatchhandbucketcancelResizeeyedrop eyedrop-fullzoom-inzoom-outX_cursorarrowbased_arrow_downbased_arrow_upboatbogositybottom_left_cornerbottom_right_corner bottom_side
bottom_tee
box_spiral
center_ptrcircleclock
coffee_mugcross
cross_reverse crosshair
diamond_crossdotdotbox double_arrow draft_large draft_small
draped_boxexchangefleurgobblergumbyhand1hand2hearticon
iron_crossleft_ptr left_sideleft_tee
leftbuttonll_anglelr_angleman middlebuttonmousepencilpirateplusquestion_arrow right_ptr
right_side right_tee rightbuttonrtl_logosailboat
sb_down_arrowsb_h_double_arrow
sb_left_arrowsb_right_arrow sb_up_arrowsb_v_double_arrowshuttlesizingspiderspraycanstartargettcrosstop_left_arrowtop_left_cornertop_right_cornertop_sidetop_teetrekul_angleumbrellaur_anglewatchxterm About Box
File Open BoxDefault About BoxtkbuttondialogentryfocuslistboxmenuoptMenupalettescalescrlbartearofftextbgerrorconsolemsgboxcomdlgAutoHistoryInitPackageParrayWordProjector DatarsrcRSED u ¹ 