cpython/Mac/Resources/tkpython.rsrc

	> 
^b[<5B>rsrcRSED
u<00>
PoOoR<>y
o 
`.;<3B>
<<3C><><EFBFBD>
4<13><>Bg<<3C><><EFBFBD>]
tkpython.rsrc.crcpoolertAD MErlrsrcRSED<00>ct<63><03>0<EFBFBD>
~=G
.N^ _TON<4F>NV<4E><56> 
>(o
.MgpB<70>Gl<10>x<02><>B<><05><>B`\~B`X<>P
	Z<>
<01>_V<5F>P

B2 x
<01><><EFBFBD>)
o<1C>P
B0<1F>@V<>P	Z2 >
<01>@
`<1A>P

B<EFBFBD>
<01><>V<EFBFBD>P !!<00><00>
,
P<00><03>
File Type:<00><>
`<00>
<01>p&H&JMIh	<09>
<01>@  
<01><1B>?<3F>?<3F><1F><1F>o<EFBFBD><6F><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F>?<3F><1F><0F><07><07><00>HH
<00><03><03>
}u<>
}u<>]u<>]u<><<3C>U<EFBFBD><55><EFBFBD>UW<55><57>U\5UU\
UU\
UUpUUp<00>U<EFBFBD>5U<35>5U<35><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01><><EFBFBD>̙<EFBFBD><00><>
`<00>
<0A>L
   
<0A><1F><1F><0F><1F>?<3F>?<3F>?<3F><1F><0F><07><07><00>HH
<00><00><>]u<>UU<55><00>U\<03>U\
UU\
UU\
UUpUUp<00>U<EFBFBD>5U<35>5U<35><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01><><EFBFBD>̙<EFBFBD>
Z<>
`<00>
<03><>`<60><> @<40><>
<03><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><00>HH

<00><><00>2%<25>o<><6F><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>"""""<1F>""""!<21>3333O<00><><EFBFBD><EFBFBD><EFBFBD><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><02><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><03><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><04><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>DDDDDD
Z<>
`<00><1F>3<EFBFBD>dfI<66>OD"c<>?<3F>)<29>)<29>)<29>+<2B>i<EFBFBD>x<><EFBFBD><1F>?<3F><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F>?<3F>?<3F>?<3F>?<3F><EFBFBD><EFBFBD><EFBFBD><EFBFBD><00>HH

<0F><><EFBFBD><EFBFBD><EFBFBD><00><05><>Po`_V<><06><00>!<21><00><00><><00>_<00><00>`<05><>P<06><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><00><>
<00><>
<00><>!<00><><1F><0F><>!<0F><0F><>_O<5F><0F><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><0F><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
DDDDDD<02><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><03><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>UUUUUU<05><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>wwwwww
R<>
`<00><03>
3<>p
<01>
<01>
<01>
<0A>UzU6<55><10>
<07><03><0F><1F><1F>?<3F><EFBFBD><7F><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F><1F><1F><0F><07><00>HH

<00><><EFBFBD><EFBFBD><00>B""O<>B!"O<0F><1F><00>$<24><><EFBFBD><EFBFBD>/_"""""/<2F>/"""""/<2F>"""""/<2F>O<>"$<24>/<2F>/<2F><>////_<><5F>S_//<00>O<EFBFBD><4F><EFBFBD><EFBFBD>/""<22><>"/B""""O<00>"""$<24><0F><><EFBFBD><EFBFBD><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01>̙<EFBFBD>ff<02><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>3333ff<04><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ffff<66><66>
R<>
`<00>xp@6O<36><EFBFBD>~0|008<00><0F><00><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F><1F><1F><1F><1F><00>HH

" 
 
aa
DDDQDDDDDQQ##<00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01>̙<EFBFBD>ff<02><><03><>ff33<04><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><05><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><06><><EFBFBD>̙<EFBFBD>
J<>
`<00>?<10><> <20><><EFBFBD> ˠ<>88>&&	.	&	 !><3E>?<1F><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F><0F><0F><0F><0F><0F><1F>?<3F>><3E><00>HH

<00><><EFBFBD><12><00><00>11<31><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><00><00>11<31><00><00><><EFBFBD><EFBFBD>O<><4F>!!<21><><00><><12><>@<00>!!<21><0F><00><12><0F><00>/!<21><><EFBFBD><00><12><0F><00>/!<21><00>!/!!<21><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<00><><02><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><03><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>DDDDDD<00><>
`<00>><3E>c<EFBFBD><63><06><02><02><02><02>`00`<06><03>><3E><EFBFBD><7F><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F><1F><0F><07><03><00>HH
<00><0F><><EFBFBD>:<3A><>p雙<70><E99B99>e<EFBFBD>\陙<><E99999>ff\陙<><E99999>ff\5<><35>p
fe<66>Y<><00>\5p<0F><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01><><02><>ff<66><66>
z<>
`<00><00>

<01><0F><17>((<17><0F><>

<01><0F><1F><1F><1F><1F><1F><1F><1F><1F><1F><1F><1F><0F>
<00>HH

yJ<79><0F><00><><EFBFBD><EFBFBD>!<12>6UUc<55>5Q<>533Q<33>6UUa<55>3<11>3333<33>3333<33>""""<22><0F><><EFBFBD><EFBFBD><EFBFBD>x<><78><EFBFBD><EFBFBD><00><><EFBFBD><EFBFBD><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><02><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><03><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>DDDDDD""""""UUUUUU<07><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><08><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>	wwwwww

R<>
`<00><00><00>

<01>p @@<08><08><00><00>
<01>
<01><03><03><07><07><0F><0F><00>HH

<00><><00><04>@B<><0F>/<00>?<3F><00>R<EFBFBD>5S/<00>2<EFBFBD><00><12>5/<0F><><0F><0F><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><02><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><03><><EFBFBD><EFBFBD><04><><05><>ff33
R<>
`<00> p<00>
<01><05>	<09><11><11><11><11>1<EFBFBD>q<EFBFBD><71><EFBFBD><18>x0 p<00>
<01><07><0F><1F><1F><1F><1F>?<3F><EFBFBD><7F><EFBFBD><18>x0
<00>HH

<00>?<00>C<EFBFBD>4?<3F>O4?<3F><00>_4?<3F>P_4?<3F>_4?<3F>_4?<3F>_4?<3F><00>_4?<3F>3P_4?<3F><><EFBFBD>?O4?<3F><0F>"
<00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01><>ff33<02><>DDDDDD<04><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><05><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
z<>
`<00>@
@?!9)9)99!!????????????<00>HH

 `<00>` 3<>`<10> <00><><EFBFBD><00><00><><00><><00><><00><><00><><00><><00><00><00><><EFBFBD><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>wwwwwwUUUUUU""""""DDDDDD<06><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><07><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><08><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>	ffff<66><66>
<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><00><>
`<00>
<02><02><02>@@@98<39>88	 <12>$H((0 
<03><03><03><07><07><07>?<3F><><EFBFBD>?<3F><0F><1E><x880 <00>HH
<00>
<0A>
<0A>
<0A>5p5p5p<0F>_<EFBFBD><5F>UU|<0F>_<EFBFBD><00>\\<5C>
p5<70>
<0A>
<0A><03><00><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01><><EFBFBD><EFBFBD>
R<>
`<00>
<03><07><0F><0E><0F><07><03>
<0B>
`	   <03><07><0F><1F><1F><1F><0F><07><0B><1F><1F><1F>pp <00>HH

<00><>1?<00>"#<23><00><11><00><13>1?<00><><00><><EFBFBD><EFBFBD><00><0F>@@@@@@<00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><02><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><03><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>3333ff<05><>
B<>
`<00><07><07><07><07><10><10><10><13><07><07><07><07><07><07><07><07><0F><1F><1F><1F><1F><1F><1F><0F><07><07><07><07>
<00>HH

<0F><><EFBFBD><0F><><EFBFBD><0F><><EFBFBD><0F><><EFBFBD><00>  /"<22>!<21>""<22>#<23>"<22>!<21>"<22><>#<23>""!<21>"""<13><00>11?<0F><><EFBFBD><0F><><EFBFBD><0F><><EFBFBD><0F><><EFBFBD><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<01><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><02><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><03><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D
<01>p&H&JMIh	<09>
<01>@  
<01><1B>?<3F>?<3F><1F><1F>o<EFBFBD><6F><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F>?<3F><1F><0F><07><07>	D	<09>	@0
	<12>!,L<08>	<09>	<09><0B><0F><0F><1F>?<3F><1F><0F>
D1<>J@J@?<3F>
?<3F>J@JF1<46>1<>{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F><EFBFBD><7F><EFBFBD><EFBFBD><EFBFBD>{<7B>1<EFBFBD>D<><44><EFBFBD>
<01>
<01><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
<0A>
<0A>
<0A><><EFBFBD><EFBFBD><EFBFBD>
<01><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D<00>~<00>
(@<08>"DH<00>@<00>~<00>
<01><03><07><0F>>|x<00>@D<00>~<00>
(<07><0F>>|x<00>@<00>~<00>
<01><03><07><0F>>|x<00>@D<07>`'<27>XhP(<28><14>ԯԠP(Xh'<27>|<07><07><1F>?<3F>xxp8<70><1C><><EFBFBD><EFBFBD><EFBFBD>p8xx?<3F><1F><07>D<07>`'<27>XhS(<28><14>ԯԣS(Xh'<27>|<07><07><1F>?<3F>xxs8<73><1C><><EFBFBD><EFBFBD><EFBFBD>s8xx?<3F><1F><07>D<><07><0F>|>>|<1F><0F><07><07><0F><1F>>||><3E><1F><0F>`p88p<07><03><03><07>p88p`D|
<01><07><00>
<01><03>  8p 
<01><07><1F><EFBFBD><03><07><0F>p>`|`<60>@p@ 
D<1F><1F>@<07><1F><1F><07><07>?<3F><1F><0F><07>D<07>@<1F><1F><07><0F><1F>?<3F><07><07><1F><1F>D
<03><>`<60><> @<40><>
<03><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Dq<>QQQQ<>q<><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>
D<00><00> <20>@Ȁ<><00><00><00><><EFBFBD><00><00><><EFBFBD><EFBFBD> @<08>	
<0F>D
<00>S3<03><0F><0F>
<00>P0<03>D




	 @<03>
<><EFBFBD>




	 @<03>
D
<01>
<01>
<01>
<01>
<01>
<01>
<01><EFBFBD><EFBFBD>D<><44><EFBFBD><00><><EFBFBD><02><><EFBFBD>
<EFBFBD><EFBFBD><EFBFBD>*<2A><><EFBFBD><EFBFBD><EFBFBD>*<2A><><EFBFBD>
<EFBFBD><EFBFBD><EFBFBD><02><>D<07><07><0F><0F><1F><1F>30#<07><07><0F><0F><1F><1F>?<3F>?<3F><EFBFBD>w<EFBFBD>g<EFBFBD><07><07><07><07>
D<03><0F><1F><<8pppp8<<<1F><0F><03><03><0F><1F>?<3F><EFBFBD>|><3E><1F><1F><1F>|><>?<3F><1F><0F><03>D<1F>3<EFBFBD>dfI<66>OD"c<>?<3F>)<29>)<29>)<29>+<2B>i<EFBFBD>x<><EFBFBD><1F>?<3F><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F>?<3F>?<3F>?<3F>?<3F><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D<03>
3<>p
<01>
<01>
<01>
<0A>UzU6<55><10>
<07><03><0F><1F><1F>?<3F><EFBFBD><7F><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F><1F><1F><0F><07>D<02><02><02><02><02><02><><EFBFBD><00><><02><02><02><02><02><02><03><03><03><03><03><03><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><03><03><03><03><03><03>DB<44><42><EFBFBD>R<EFBFBD>*<2A><16>
<EFBFBD><EFBFBD>~<02><>~
<EFBFBD><16>*<2A>R<EFBFBD><52><EFBFBD>B<EFBFBD>C<><43><EFBFBD>s<EFBFBD>;<3B><1F><0F><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><0F><1F>;<3B>s<EFBFBD><73><EFBFBD>C<EFBFBD>D






<00><>






D<02><06>
<EFBFBD><12>"<22>B<EFBFBD><42><EFBFBD><00><>B<EFBFBD>"<22><12>
<EFBFBD><06><02><02><06><0E><1E>><3E>~<7E><><EFBFBD><00><>~<7E>><3E><1E><0E><06><02>D<07><1F><1F>?<3F>?<3F>?<3F>?<3F><1F><1F><07><07><1F>?<3F>?<3F><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F>?<3F><1F><07>D?<3F>    !<21>!<21>    ?<3F>?<3F>?<3F>001<>3<EFBFBD>3<EFBFBD>1<EFBFBD>00?<3F>?<3F>D
<01><03><07>
<0A><19>
<01>
<01>
<01>
<01><19>
<0A><07><03>
<01>
<01><03><07><0F><1F>?<3F>;<3B><03><03>;<3B>?<3F><1F><0F><07><03>
<01>D<<00><03><0F><00>
``@@ @><00><03><0F>?<3F><><EFBFBD><03><07><0E><1C>8<EFBFBD>p<EFBFBD><70><EFBFBD>@<40>
D<<00><03>p<00>
   @><00><03><0F>?<3F>
<01><03>p``8@p@<40>@
D?<3F>"D&d,48!<21>!<21>8,4&d"D?<3F>?<3F>>|>|<<9<>#<23>#<23>9<EFBFBD><<>|>|?<3F>DG<>o<EFBFBD>|0HL~<00>d$|<0F><07><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>8<EFBFBD><10><00><><03>
<01><10>8~?<3F><1F><0F><07>D
<01><03><07>
<01><11>1<EFBFBD><EFBFBD><EFBFBD>1<EFBFBD><11>
<01><07><03>
<01>
<01><03><07><0F><17>;<3B><EFBFBD><7F><EFBFBD><EFBFBD><EFBFBD><EFBFBD>;<3B><17><0F><07><03>
<01>Dxp@6O<36><EFBFBD>~0|008<00><0F><00><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F><1F><1F><1F><1F>D?<10><> <20><><EFBFBD> ˠ<>88>&&	.	&	 !><3E>?<1F><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F><0F><0F><0F><0F><0F><1F>?<3F>><3E>D<<00>
<01><03><07><0F>/<2F><EFBFBD>_<EFBFBD><07><07>Jb4<<00>
<01><03><07><0F>/<2F><EFBFBD><EFBFBD><EFBFBD><EFBFBD>~~<
D?<3F>@ ?"A
<01>
$<00>P ?<3F><EFBFBD>?<3F><0F><07><0F><07><0F><07>
<01>
<01><00>p 
D><3E>c<EFBFBD><63><06><02><02><02><02>`00`<06><03>><3E><EFBFBD><7F><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F><1F><0F><07><03>D<><44><EFBFBD>U<EFBFBD><55><EFBFBD>U<EFBFBD><0B><05><0B><05><0B><05><0B><05><><EFBFBD>U<EFBFBD><55><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><0F><0F><0F><0F><0F><0F><0F><0F><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D?<3F><1F>O<EFBFBD>g<EFBFBD>s<EFBFBD>y<EFBFBD><EFBFBD><EFBFBD>y<EFBFBD>s<EFBFBD>g<EFBFBD>O<EFBFBD><1F>?<3F><><EFBFBD><7F><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D<0F><0F><0F><0F><0F>
<0A><08><00>``<1F><1F><1F><1F><1F><1F><1F><1D><19><10><00>p
D```<60>abdo<>dba`<60>``<00>
<0F>
<00>D<0F><0F>D<><><EFBFBD>DDETETETETDD<44><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><7F><02><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D<0F><0F>D0000000<1F><1F>D<03><1E><02><>C<>$Kp@@<02>@	 <12>Px<<3C>?<03><1F><03><>C<>'<27><1F><07><07><03><07><0F><1E>px<<3C>?
D<><><EFBFBD>DDTTTTTTTTDD<44><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><7F><02><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D

<01><0F><17>((<17><0F>

<01><0F><1F><1F><1F><1F><1F><1F><1F><1F><1F><1F><1F><0F>D<00><00>

<01>p @@<08><08><00><00>
<01>
<01><03><03><07><07><0F><0F>D<03><07><0F><19><19><0F><07><03>C<EFBFBD>C<EFBFBD>!<21>8<03><0F>x@<07><0F><1F>?<3F>?<3F><1F><0F>G<EFBFBD><47><EFBFBD><EFBFBD><EFBFBD><EFBFBD>?<3F><1F><EFBFBD><7F><EFBFBD><EFBFBD>
D
<01>
<01>
<01>
<01><1F><1F>
<01>
<01>
<01>
<01>D<07><0F>p00p<00><03><03><02><02><0E><06><03>
?<3F><1F><0F><07><03>
D0p<00>
<01><03><07><0F>
<01>
<01>8x<00>
<01><03><07><0F><1F>?<3F><03><07><07>
D
<00>F&?<3F>&F<00>

<00>@ ?<3F> @<00>
D000000<1F><1F>000000
D<><><EFBFBD>DDUDUDUDUDDD<44><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><7F><02><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D<>@"@"@"<>D"D"D"D"G<>DDD<><><EFBFBD>`v<76><EFBFBD>|6l6l6l>o<>o<EFBFBD>n<><EFBFBD>D@@
`
``pppxxx|>8@<00>
<01><03><03><07><07><0F><0F><1F><1F>?<3F>?<3F>|~8D<02><02><02><02><02><02><02><02><02><02><02><0F><07><03>
<03><03><03><03><03><03><03><03><03><03><03><1F><0F><07><03>
D?<3F>x?<3F>8<><7F><EFBFBD><EFBFBD>8D?<3F>x?<3F>8<><7F><EFBFBD><EFBFBD>8
D<18><><1E><><1C><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D<00>
<01><03><07>
@
@
@
@
@
@
@
@
@
@
@<00>
<01><03><07><0F>
<01>
<01>
<01>
<01>
<01>
<01>
<01>
<01>
<01>
<01>
<01>
D
<03><07><0F><02><02><02><02><02><02><0F><07><03>

<03><07><0F><1F><03><03><03><03><03><03><1F><0F><07><03>
D p<00>
<01><05>	<09><11><11><11><11>1<EFBFBD>q<EFBFBD><71><EFBFBD><18>x0 p<00>
<01><07><0F><1F><1F><1F><1F>?<3F><EFBFBD><7F><EFBFBD><18>x0
D<>@@@G<>D D"D""<07>

<01><00><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><00><><EFBFBD><EFBFBD><EFBFBD>7<EFBFBD>7<EFBFBD>7<EFBFBD>7<0F><0F><03><03><03>D   @@<40><>g<EFBFBD><1F><1F>g<EFBFBD><67><EFBFBD>@@   p88p8p<1C><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><7F><EFBFBD><EFBFBD>ߟ<EFBFBD><1C>8p8pp8D@
@?!9)9)99!!????????????D
<02><02><02>@@@98<39>88	 <12>$H((0 
<03><03><03><07><07><07>?<3F><><EFBFBD>?<3F><0F><1E><x880 D<03><0F>p0`<0C>†<>`0p<0F><03><03><0F><1F><xp<1C><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>p<x<1F><0F><03>D






<00><>






D`x>?<3F><1F>
<0C>@ <00><00><00><><EFBFBD>?<3F>?<3F><1F><1F><0E>p8

D<><44><EFBFBD><EFBFBD><EFBFBD><00><00><><EFBFBD><00><00>Ȁ<>@<40> <20><0F>
	<08>@ D<0F><0F><03>3S<00>
<03>0P<00>
D<><EFBFBD>
<03>@	 





<03>@	 




D<><EFBFBD>
<01>
<01>
<01>
<01>
<01>
<01>
<01>D
<03><07><0F><0E><0F><07><03>
<0B>
`	   <03><07><0F><1F><1F><1F><0F><07><0B><1F><1F><1F>pp D<0F><0F>D<08>(I<>'<27>0a





@
@<00><0F><1F><EFBFBD><EFBFBD><7F><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><03><03><03><03><03><03>
<01><00>D<1F><1F>0000000D<07><07><07><07><10><10><10><13><07><07><07><07><07><07><07><07><0F><1F><1F><1F><1F><1F><1F><0F><07><07><07><07>
D`<02>











<02>`<00><00><00><00><00>Okl<00>
:<3A>sWish - Windowing Shell
based on Tcl 8.3.0 & Tk 8.3.0

Ray Johnson & Jim Ingham
Scriptics Inc.
jim.ingham@cygnus.comw\@<00><00>	<00><00><00>
LOpenh<00>|
LCancel<00>
<00><00>
Q <00>4
LEject<<00>P
LDesktop<00><00><00>[<00>\
M<><00><00>
,<00>Uk

<01>


<00>(
<00>
X
<00><00>`
MDEFON<>NuH<75>0O<30><4F><EFBFBD>8/6$o&&|MDEFYO.<2E>T.<2E>UO><3E>

?_UO><3E>
?_x<><78>\f x\ P/h/h
D
f6?//4//4//4/
HoN<>/!<21>T?/1<>

?/1<>
D
f*<2A>Rg&x<><78>\g x\ P!o!o
!<21>	<09>!<21>	<09>O<EFBFBD>L<>Nt<00>
<01><><13><13>dD<02><00><>HHdD

dD<00><>DdDHH

<00>
ZZ<5A><00>76<37><00><00>55<35><00><00>44<34><00><00>33<33><00>f76<37><00>355<35><00>44<34><00><00>33<33><00><00>76<37><00><00>55<35><00>f<00><><EFBFBD><00>333<33><00>10<31><00><00>//<2F><00><00><00><><EFBFBD><00><00><00><><EFBFBD><00>f10<31><00>3//<2F><00>..<2E>f<00><00><><EFBFBD>f<00>10<31>f<00>//<2F>ff..<2E>f3--<2D>f10<31>3<00>//<2F>3<00>..<2E>3<00>--<2D>3f10<31>33//<2F>3..<2E><00>--<2D><00>10<31><00>//<2F>f..<2E>3-<2D><>+*<2A><00><00>))<29><00><00>((<28><00><00>'<27><><00>f+*<2A><00>3))<29><00>((<28><00><00>''<27><00><00>+*<2A><00><00>))<29><00>f((<28><00>3''<27><00>+*<2A><00><00>))<29><00><00>((<28><00><00>''<27><00>f<00><><EFBFBD><00>3GG<47><00>FF<46>f<00>EE<45>f<00><00><><EFBFBD>f<00>GG<47>ffFF<46>f3EE<45>f<00><><EFBFBD>3<00>GG<47>3<00>FF<46>3<00>EE<45>3f<00><><EFBFBD>33AA<41>3@@<40><00>??<3F><00>CB<43><00>AA<41>f@@<40>3??<3F>CB<43><00><00>AA<41><00><00>@@<40><00><00>??<3F><00>fCB<43><00>3AA<41><00>@@<40><00><00>??<3F><00><00>CB<43><00><00>AA<41><00>f@@<40><00>3??<3F><00>CB<43><00><00>AA<41><00><00>@@<40><00><00>??<3F><00>f=<<3C><00>3;;<3B><00>::<3A>f<00>99<39>f<00>=<<3C>f<00>;;<3B>ff::<3A>f399<39>f=<<3C>3<00>;;<3B>3<00>::<3A>3<00>99<39>3f=<<3C>33;;<3B>3::<3A><00>99<39><00>=<<3C><00>;;<3B>f::<3A>399<39>=<f<00><00>;;f<00><00>::f<00><00>99f<00>f=<f<00>3;;f<00>::f<00><00>99f<00><00>76f<00><00>55f<00>f44f<00>333f<00>76f<00><00>55f<00><00>44f<00><00>33f<00>f76f<00>355f<00>44ff<00>33ff<00>76ff<00>55fff44ff333ff76f3<00>55f3<00>44f3<00>33f3f76f3355f344f<00>33f<00>10f<00>//ff..f3<00><>f103<00><00>//3<00><00>..3<00><00><00><>3<00>f103<00>3//3<00>..3<00><00>--3<00><00>103<00><00>//3<00>f..3<00>3--3<00>103<00><00>//3<00><00>..3<00><00>--3<00>f103<00>3//3<00>..3f<00>-<2D>3f<00>+*3f<00>))3ff((3f3'<27>3f+*33<00>))33<00>((33<00>''33f+*333))33((3<00>''3<00>+*3<00>))3f((33''3IH<00><00>GG<00><00>FF<00><00>EE<00>fIH<00>3GG<00>FF<00><00>EE<00><00>IH<00><00>GG<00>fFF<00>3EE<00>CB<00><00>AA<00><00>@@<00><00>??<00>fCB<00>3AA<00>@@f<00>??f<00>CBf<00>AAff@@f3??fCB3<00>AA3<00>@@3<00>??3fCB33AA3@@<00>??<00>CB<00>AAf@@3??<3F>=<<3C>;;<3B>::<3A>99<39>=<w;;U::D99"=<;;<00>::<00>99<00>=<<00>;;<00>::w99U=<D;;"::99<00>=<<00>;;<00>::<00>99<00>=<w;;U::D99"7655<35><00><00>44<34><00><00>33<33><00><00>76<37><00><00>55<35><00><00>44www33UUU76DDD55"""4433dDdD
dD<02><13>
<01><><EFBFBD><07>223<32>9<0E><1D>
<01><><EFBFBD><08>223<32>9:<3A>@<40>A@3<07>
<0E>@<40>A9<0E><><02><><EFBFBD><EFBFBD>
2<>A@923<32>9:<3A>@<40>A
2
<0E>A

<0E>A

<0E>A

<0E>A
	
<07>A@<40>
<07>A
GG<47>A@
<07>AG<>A
;;<3B>A@
<07>AG;;GAAG;G<>A:
<00><>A
<0B>AG;;<3B>A9<00>@<40>AG;;GAGA;GG<47>A9<00>@<40>AG<0B>AGAG<41>A3@<40>AGG<>A5G<35>A<EFBFBD>G<EFBFBD>A2@<40>A;GAG5<0B>AGA9@G<>A!@<40>A;GAA5G<35>AG@<07><02>@G<>A#@<40>AG5AAG;AG<41>A	G:<3A><00>OU<4F>G<>A":<3A>A
G;<3B>A
<0B>AG:<3A>U<><55><EFBFBD>
V@<40>A9<>AGA;G<>AG@<40><><EFBFBD><EFBFBD><EFBFBD>
<01>]<5D>A<02>9<>AG;AG<41>AG@<07><><EFBFBD><EFBFBD>d<>A@<40>9<>AG<0B>AG*<2A><><EFBFBD>
d<><64>A@<40>%9<>A;G<>AG<0F><><EFBFBD><EFBFBD>ȇ<><C887>A<EFBFBD>G<EFBFBD>AG<>A:<3A>(9<>A;G<>AG9<00><><EFBFBD><00><>A	;;AAG;;G<>A9<>$3<>AGA<0B>A
y<><79>d<>A5<0B>A
<0B>A9<>(2<>AG;<0B>AG9<47><39><EFBFBD>
<01><><EFBFBD>AGA<0B>AG<0B>A9<>,2<>AG;<11>A
y<><79><05>@AAGG<47>A
GAGAAG5G<>A2<>/<0E>AG;G<>AG@<40><><EFBFBD><EFBFBD>d<>A@99<39>AG;;G<>A5AG<41>A<0E>'<0E>AG;;G<>AGy<><79><0C>A@2<>:GAG;<05>A<0E>'<0E>AG;;G<>A
<0E><><EFBFBD>
<01><><EFBFBD><EFBFBD>y9GAGG<>A<07><0E>A@+<2B><><EFBFBD><08>3GAA;G<>A<07><08>AG:U<><55>]9GGA<0B>A<00><><07>AG9y<39><79>99GG5G<>A
@<40><><07>AG9<47><39><EFBFBD><08>@GAAG<41>A@<40><07>AG9<47><39><EFBFBD><07>AGAG<>A@<40><07>AG9<47><39><EFBFBD>c<>2GG;;G<>A:<3A><00>@<40>AG9<47><39><EFBFBD>9<>@GA;<3B>A9<><00>@<40>A
@<40><><EFBFBD>
Ȥ<><C8A4><03>G<>A9<><1A>@<40>A@<40><>
<01><><EFBFBD><EFBFBD><03>@G<>A2<><1A>@<40>A<00><><EFBFBD><02><><EFBFBD><EFBFBD><EFBFBD>VG<>A2<><19>@<40>A<00><><EFBFBD>dV<64><56><EFBFBD>
<01>2<EFBFBD>A<0E><1B>@<40>A@G<><47><EFBFBD>
@U<><55>
<01>@<40>A<08><1A>:<3A>A@<40><>Ϋ9y<39><79><00><>A<07><1C>:<3A>A<00><><EFBFBD>·3y<33><79>AGG<47>A<07><1E>9<>A*<2A><><EFBFBD>Έ<0E><><EFBFBD>d99<39>A
@<40><><1C>9<>A
O<><4F>d<><64><EFBFBD><EFBFBD><03><><EFBFBD><07>A@<40><1C>9<>A
y<><79><03>@+<2B><><EFBFBD><02>G<>A@<40><1C>9<>A
y<><79><03>@<40><><EFBFBD><EFBFBD><02>G<>A@<40><1E>:<3A>AGy<><79><03>@<40><><EFBFBD><EFBFBD><03><>:G<>A@<40><1E>:<3A>AGV<><56><03>:<3A><><EFBFBD><EFBFBD><02><>@<40>A
@<40><><1E>@<40>A	GV<><56>Ȉ9<C888><39><EFBFBD><EFBFBD>V
@<40>A
@<40><><1C>@<40>A	G92<39><32>Ȉ9*<2A><><EFBFBD>
V<07>A<00><><1B>@<40>AG:2<><32><EFBFBD>d*<2A><>
2<07>A<07><1A>@<40>A@2<><32><EFBFBD>d9N<39><4E>
:<07>A<07><00>@<40>A@<0E><><EFBFBD>dN<><4E><03>@@<40>A<07><00>@<40>A<0F><><EFBFBD>d3N<33><4E><02>@<0E>A<0E><00><>AG<15><><EFBFBD>d3N<33><4E><03>G<>A<0E><07>AG<16><><EFBFBD>d3N<33><4E>c@G<>A<0E><07>A@<40><><EFBFBD>d9N<39><4E>9@G<>A2<><07>A9<>Έ9<CE88><39><EFBFBD><04>AA9@<40>A2<><07>AG:<3A>Έ9<CE88><39><EFBFBD><EFBFBD>d<15><>@<40>A3<><07>A@<40>·9*<2A>ΫA@<40><><EFBFBD>A9<><0E>A
GA<47>ȇ9<C887><39>Ϋ<EFBFBD>Τ<07>A9<><0E>A	G99G<39>ȫ@<40><><EFBFBD><EFBFBD>
<01><0E>A9<><0E>A	G:<07>Ϋ@<40><><EFBFBD><EFBFBD>UG<>A9<><0E>Ay<><79><EFBFBD>@<40><><EFBFBD><EFBFBD>+9G<39>A:<3A><0E>AG9y<39><79>d<07><><EFBFBD><02>@<40>A@<40>2<>A2<><32>Έy<><79><02>G<>A@<40>2<>AG@<40><>·y<><79>
2@<40>A@<40>3<>AG@<40>ȫU<>΀G<>A@<40>3<>AG@<40><>9O<39><4F>]<5D>A
@<40><>9<>AGd<47>9+ȫ<>A<00><>9<>A@<40><>d<EFBFBD>A<07>9<>A:<0E>A@G<>A@9G<39>A<07>'9<>A
GG<47>A@<40>A9G<39>A
GG<47>A99G<39>A<07>)9<>A
@9<>A	G<0E>@AAG3G<33>A
9:<3A>AG99G<39>A<08>6:<3A>AG@<40>AGA@<40>A	G<0E>@AAG3G<>AG@G<>AG99A<39>@<40>A<0E>::<3A>AG@@GAAG99@<40>AG<0E>@AAG9<0E>A9<>AG99@9<>A<0E>5@<40>A@<40>A
G@9A2GAAG<0E>@<40>A
@<08>A:<0E>AG9993<39>A<0E>9@<40>AG@<40>AG2@A9@<40>AG<0E>@<40>A
@<40>AG@G<>AG9<07>@G<>A2<>:@<40>AG@GAAG@GG<47>AG<0E>@<40>A
G9GAAG@G<>AG9AG<41>A2<>8@<40>AG<00>AG9:G@9<>AG<0E><>A
G33GAAG@G<>AG999<0E>A3<>:<00>@<40>AG29<>A@3:GAA:<07>9<EFBFBD>AG:<0E>A@<40>3@AA@@@<40>A9<>)<00>@<40>A
99<39>A::@<40>A<EFBFBD>@<40>A@@<40>A@9@<40>A<EFBFBD>@<40>A9<>*
<00><>A
GG<47>A
GG<47>A
GG<47>A
9@<40>A
GG<47>AG<>AG<>A9<>

<07>A@<40>A:<3A>	
<07>A:<3A>	
<07>A@<40>	
<07>A@<40>	
<07>A@<40>

<0E>A@<40>	
<0E>A<02>	
<0E>A	
<0E>A
<0E>A<EFBFBD>@:<3A>@<40>A+
2<>A<EFBFBD>@<40>92<07><><EFBFBD><02><><EFBFBD><EFBFBD><07>2233<33>9
::<3A>@
992<07><><EFBFBD><02><00><00><00><00><00><00><00><00><00><00><00><00><00>"A<00><><EFBFBD><EFBFBD>"""><00><><EFBFBD><EFBFBD><EFBFBD>p	<04>p
0<00><00><><EFBFBD>`1<>c<00><><EFBFBD><EFBFBD><00><><EFBFBD><EFBFBD>c?<3F><1F><0F><07><03>

<03><07><0F><1F>?<3F>
X<EFBFBD><00> c'SCHEDULE_NAME=Agent Controller Schedule8SCHEDULE_PATH=Lozoya:System Folder:Tcl Lib:Tcl-Scheduler(R# 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.19 2000/02/08 10:00:55 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

# 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]
    }
    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
	}
    }
}

# 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 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 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::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" { 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
}
,<2C># 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]
    }
}

s# 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.7 2000/01/12 11:45:14 hobbs 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 { }

    # The following command means that the dialog won't be posted if
    # [winfo parent $w] is iconified, but it's really needed;  otherwise
    # the dialog can become obscured by other windows in the application,
    # even though its grab keeps the rest of the application from being used.

    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)
}
=<3D># 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 2000/01/06 02:22:24 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 equal [$w cget -state] "normal"]} {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
	}
    }
    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 equal [$w cget -state] "normal"]} {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
}
<13># focus.tcl --
#
# This file defines several procedures for managing the input
# focus.
#
# RCS: @(#) $Id: focus.tcl,v 1.5 1999/09/02 17:02:52 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) && [string compare $value ""]} {
	if {$value == 0} {
	    return 0
	} elseif {$value == 1} {
	    return [winfo viewable $w]
	} else {
	    set value [uplevel #0 $value $w]
	    if {[string compare $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
    }
}
4b# 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.10 2000/02/10 08:52:50 hobbs 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 {$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>>
}
<00># 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.8 1999/09/02 17:02:52 hobbs 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
    	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) ""]} {
	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"]} {
	tkMenuUnpost $w
	tkTearOffMenu $w
    } elseif {[string equal [$w cget -type] "menubar"]} {
	$w postcascade none
	$w activate none
	event generate $w <<MenuSelect>>
	tkMenuUnpost $w
    } 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
	    if {[string equal [$menu type $i] "cascade"]} {
		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
}
<1C># 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
}
;# 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.6 2000/01/06 02:22:24 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} {
    global tkPriv
    if {[string equal [$w cget -state] "disabled"]} {
	return
    }
    if {[string equal [$w identify $x $y] "slider"]} {
	$w configure -state active
    } else {
	$w configure -state normal
    }
}

# 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
}
-<2D># 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
    }
}
m<># 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.10 2000/02/10 08:52:50 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 entries.
#-------------------------------------------------------------------------

# 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.first}
}
bind Text <Triple-1> {
    set tkPriv(selectMode) line
    tkTextSelectTo %W %x %y
    catch {%W mark set insert 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
}
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> {
    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} {
    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]
		set last [tkTextNextPos $w "anchor" tcl_wordBreakAfter]
	    } else {
		set first [tkTextPrevPos $w anchor tcl_wordBreakBefore]
		set last [tkTextNextPos $w "$cur - 1c" tcl_wordBreakAfter]
	    }
	}
	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"]} {
	if {[string compare $tcl_platform(platform) "unix"] \
		&& [$w compare $cur < anchor]} {
	    $w mark set insert $first
	} else {
	    $w mark set insert $last
	}
	$w tag remove sel 0.0 $first
	$w tag add sel $first $last
	$w tag remove sel $last end
	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] ""]} {
	$w mark set anchor $index
	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
}

<0A># bgerror.tcl --
#
# This file contains a default version 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.
#
# RCS: @(#) $Id: bgerror.tcl,v 1.5 1999/04/16 01:51:25 stanton 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.


# 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

    # save errorInfo which would be erased in the catch below otherwise.
    set info $errorInfo ;

    # For backward compatibility :
    # Let's try to execute "tkerror" (using catch {tkerror ...} 
    # instead of searching it with info procs so the application gets
    # a chance to auto load it using its favorite "unknown" mecanism.
    # (we do the default dialog only if we get a TCL_ERROR (=1) return
    #  code from the tkerror trial, other ret codes are passed back
    #  to our caller (tcl background error handler) so the called "tkerror"
    #  can still use  return -code break, to skip remaining messages
    #  in the error queue for instance)

    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 Ok
    } else {
	set ok OK
    }
    set button [tk_dialog .bgerrorDialog "Error in Tcl Script" \
	    "Error: $err" error 0 $ok "Skip Messages" "Stack Trace"]
    if {$button == 0} {
	return
    } elseif {$button == 1} {
	return -code break
    }

    set w .bgerrorTrace
    catch {destroy $w}
    toplevel $w -class ErrorTrace
    wm minsize $w 1 1
    wm title $w "Stack Trace for Error"
    wm iconname $w "Stack Trace"
    button $w.ok -text OK -command "destroy $w" -default active
    if {![string compare $tcl_platform(platform) "macintosh"]} {
      text $w.text -relief flat -bd 2 -highlightthickness 0 -setgrid true \
	    -yscrollcommand "$w.scroll set" -width 60 -height 20
    } else {
      text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" \
	    -setgrid true -width 60 -height 20
    }
    scrollbar $w.scroll -relief sunken -command "$w.text yview"
    pack $w.ok -side bottom -padx 3m -pady 2m
    pack $w.scroll -side right -fill y
    pack $w.text -side left -expand yes -fill both
    $w.text insert 0.0 $info
    $w.text mark set insert 0.0

    bind $w <Return> "destroy $w"
    bind $w.text <Return> "destroy $w; break"

    # Center the window on the screen.

    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

    # Be sure to release any grabs that might be present on the
    # screen, since they could make it impossible for the user
    # to interact with the stack trace.

    if {[string compare [grab current .] ""]} {
	grab release [grab current .]
    }
}
02# 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.7 1999/09/02 17:02:52 hobbs 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

# 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 .}
    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

    text .console  -yscrollcommand ".sb set" -setgrid true 
    scrollbar .sb -command ".console yview"
    pack .sb -side right -fill both
    pack .console -fill both -expand 1 -side left
    if {[string equal $tcl_platform(platform) "macintosh"]} {
        .console configure -font {Monaco 9 normal} -highlightthickness 0
    }

    tkConsoleBind .console

    .console tag configure stderr -foreground red
    .console tag configure stdin -foreground blue

    focus .console
    
    wm protocol . WM_DELETE_WINDOW { wm withdraw . }
    wm title . "Console"
    flush stdout
    .console mark set output [.console index "end - 1 char"]
    tkTextSetCursor .console end
    .console mark set promptEnd insert
    .console 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}} {
    if {[string equal $partial "normal"]} {
	set temp [.console index "end - 1 char"]
	.console mark set output end
    	if {[consoleinterp eval "info exists tcl_prompt1"]} {
    	    consoleinterp eval "eval \[set tcl_prompt1\]"
    	} else {
    	    puts -nonewline "% "
    	}
    } else {
	set temp [.console index output]
	.console mark set output end
    	if {[consoleinterp eval "info exists tcl_prompt2"]} {
    	    consoleinterp eval "eval \[set tcl_prompt2\]"
    	} else {
	    puts -nonewline "> "
    	}
    }
    flush stdout
    .console mark set output $temp
    tkTextSetCursor .console end
    .console mark set promptEnd insert
    .console mark gravity promptEnd left
}

# 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 {win} {
    bindtags $win "$win Text . all"

    # 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 $win <Alt-KeyPress> {# nothing }
    bind $win <Meta-KeyPress> {# nothing}
    bind $win <Control-KeyPress> {# nothing}
    bind $win <Escape> {# nothing}
    bind $win <KP_Enter> {# nothing}

    bind $win <Tab> {
	tkConsoleInsert %W \t
	focus %W
	break
    }
    bind $win <Return> {
	%W mark set insert {end - 1c}
	tkConsoleInsert %W "\n"
	tkConsoleInvoke
	break
    }
    bind $win <Delete> {
	if {[string compare [%W tag nextrange sel 1.0 end] ""]} {
	    %W tag remove sel sel.first promptEnd
	} elseif {[%W compare insert < promptEnd]} {
	    break
	}
    }
    bind $win <BackSpace> {
	if {[string compare [%W tag nextrange sel 1.0 end] ""]} {
	    %W tag remove sel sel.first promptEnd
	} elseif {[%W compare insert <= promptEnd]} {
	    break
	}
    }
    foreach left {Control-a Home} {
	bind $win <$left> {
	    if {[%W compare insert < promptEnd]} {
		tkTextSetCursor %W {insert linestart}
	    } else {
		tkTextSetCursor %W promptEnd
            }
	    break
	}
    }
    foreach right {Control-e End} {
	bind $win <$right> {
	    tkTextSetCursor %W {insert lineend}
	    break
	}
    }
    bind $win <Control-d> {
	if {[%W compare insert < promptEnd]} {
	    break
	}
    }
    bind $win <Control-k> {
	if {[%W compare insert < promptEnd]} {
	    %W mark set insert promptEnd
	}
    }
    bind $win <Control-t> {
	if {[%W compare insert < promptEnd]} {
	    break
	}
    }
    bind $win <Meta-d> {
	if {[%W compare insert < promptEnd]} {
	    break
	}
    }
    bind $win <Meta-BackSpace> {
	if {[%W compare insert <= promptEnd]} {
	    break
	}
    }
    bind $win <Control-h> {
	if {[%W compare insert <= promptEnd]} {
	    break
	}
    }
    foreach prev {Control-p Up} {
	bind $win <$prev> {
	    tkConsoleHistory prev
	    break
	}
    }
    foreach prev {Control-n Down} {
	bind $win <$prev> {
	    tkConsoleHistory next
	    break
	}
    }
    bind $win <Insert> {
	catch {tkConsoleInsert %W [selection get -displayof %W]}
	break
    }
    bind $win <KeyPress> {
	tkConsoleInsert %W %A
	break
    }
    foreach left {Control-b Left} {
	bind $win <$left> {
	    if {[%W compare insert == promptEnd]} {
		break
	    }
	    tkTextSetCursor %W insert-1c
	    break
	}
    }
    foreach right {Control-f Right} {
	bind $win <$right> {
	    tkTextSetCursor %W insert+1c
	    break
	}
    }
    bind $win <F9> {
	eval destroy [winfo child .]
	if {[string equal $tcl_platform(platform) "macintosh"]} {
	    source -rsrc Console
	} else {
	    source [file join $tk_library console.tcl]
	}
    }
    bind $win <<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
	}
	break
    }
    bind $win <<Copy>> {
 	if {![catch {set data [%W get sel.first sel.last]}]} {
	    clipboard clear -displayof %W
	    clipboard append -displayof %W $data
	}
	break
    }
    bind $win <<Paste>> {
	catch {
	    set clip [selection get -displayof %W -selection 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
	    }
	}
	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} {
    .console insert output $string $dest
    .console 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
Copyright \251 1999 Scriptics Corporation

Tcl [info patchlevel]
Tk $tk_patchLevel"
}

# now initialize the console

tkConsoleInit
9<># msgbox.tcl --
#
#	Implements messageboxes for platforms that do not have native
#	messagebox support.
#
# RCS: @(#) $Id: msgbox.tcl,v 1.8 1999/12/03 07:15:02 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 { }
    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 -justify left -text $data(-message)
    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
    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
		}
	    }
	}
	pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
    }

    # 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.6 1999/12/07 03:04:43 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 {![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
}
B<># init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.39 2000/02/01 19:26:08 ericm 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 $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 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 $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 [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 {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

    set ns [uplevel namespace current]
    set patternList [auto_qualify $pattern $ns]

    auto_load_index

    foreach pattern $patternList {
        foreach name [array names auto_index] {
            if {[string match $pattern $name] && \
		    [string equal "" [info commands $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 {[lsearch -exact $shellBuiltins $name] != -1} {
	return [set auto_execs($name) [list $env(COMSPEC) /c $name]]
    }

    if {[llength [file split $name]] != 1} {
	foreach ext {{} .com .exe .bat} {
	    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 {{} .com .exe .bat} {
	    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 ""
}

}
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
H<# package.tcl --
#
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
# RCS: @(#) $Id: package.tcl,v 1.11 2000/02/07 22:33:17 ericm 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] == 0} {
	set ext [info sharedlibextension]
    }
    if {[string equal $tcl_platform(platform) "windows"]} {
	return [string equal -nocase [file extension $fileName] $ext]
    } else {
	return [string equal [file extension $fileName] $ext]
    }
}

# 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? ?-verbose? ?-load pattern? ?--? 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.

	foreach pkg [info loaded] {
	    if {! [string match $loadPat [lindex $pkg 1]]} {
		continue
	    }
	    if {[string equal [lindex $pkg 1] "Tk"]} {
		$c eval {set argv {-geometry +0+0}}
	    }
	    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]"
	    }
	}
	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 type [$c eval set ::tcl::type]
	    set cmds [lsort [$c eval array names ::tcl::newCmds]]
	    set pkgs [$c eval set ::tcl::newPkgs]
	    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 -nocomplain [file join $dir *.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.)
#
# 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
    }
    for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
	# we can't use glob in safe interps, so enclose the following
	# in a catch statement
	catch {
	    foreach file [glob -nocomplain [file join [lindex $auto_path $i] \
		    * pkgIndex.tcl]] {
		set dir [file dirname $file]
		if {[file readable $file]} {
		    if {[catch {source $file} msg]} {
			tclLog "error reading package index file $file: $msg"
		    }
		}
	    }
	}
	set dir [lindex $auto_path $i]
	set file [file join $dir pkgIndex.tcl]
	# safe interps usually don't have "file readable", nor stderr channel
	if {[interp issafe] || [file readable $file]} {
	    if {[catch {source $file} msg] && ![interp issafe]}  {
		tclLog "error reading package index file $file: $msg"
	    }
	}
	# 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 $auto_path $i]
	    tclMacPkgSearch $dir
	    foreach x [glob -nocomplain [file join $dir *]] {
		if {[file isdirectory $x]} {
		    set dir $x
		    tclMacPkgSearch $dir
		}
	    }
	}
    }
}

# ::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
}

## history.tcl --
#
# Implementation of the history command.
#
# RCS: @(#) $Id: history.tcl,v 1.3 1998/09/14 18:40:03 stanton 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 $history(nextid)} {[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
}
# 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
}
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)]
    }
}

PoOoR<06><><EFBFBD><04><06>CNTLbcrsrnCURST
"DITL
DLOG
6MDEFNMENUZPICTfSICNrSIZE~STR#<05>TEXT<05><00> <03>%<03>
<0B> <0B>o<0B>%<04><0B>0#<0B>8y<0B>><08><0B>D 	<09><0B>J C<0B>Q<0C><0B>Y
<0A><0B>bm<0B>gcl <11><03>r<12><03>wG<03>~<13><03><00><13><03><00><03><00>g<03><00><14><03><00><14><0B><00>?<0B><00><15><0B><00><15><0B><00><0B><00>_<0B><00><16><0B><00><16><0B>
7<0B>
<0B>
"<17><0B>
-<0B>
8W<0B>
C<18><0B>
J<18><0B>
P/<0B>
[w<0B>
a<19><0B>
o<0B>
yO<0B>
<01><1A><0B>
<01><1A><0B>
<01>'<0B>
<01>o<0B>
<01><1B><0B>
<01><1B><0B>
<01>G<0B>
<01><1C><0B>
<01><1C><0B>
<01><0B>
<01>g<0B>
<01><1D><0B>
<01><1D><0B>
<01>?<0B>
<01><1E><0B>
<1E><0B>
<0B>_<0B><1F><0B>(<1F><0B>1 7<0B>: <0B>> <20><0B>K!<0B>Q!W<0B>X!<21><0B>_!<21><0B>d"/<0B>s"w<0B>}"<22><0B><02>#<0B><02>#O<0B><02>#<23><0B><02>#<23><0B><02>$'<0B><02>$o<0B><02>$<24><0B><02>$<24><0B><02>%G<0B><02>%<25><0B>%<25><0B>&<0B>&g<0B>!&<26><0B>*&<26><0B>/'?<0B>6'<27><0B>='<27><0B>L(<0B>\(_<0B>m(<28><0B>v(<28><0B>~)7<03>)
<03>)<29><03>*<03>*W<03>*<2A><00><03> *<2A><00><03> +<2B><00><03> ,A<00><><EFBFBD> ,]O<><4F>,y<00><><EFBFBD>-K<00><><EFBFBD>-_<00><><EFBFBD>A<00><><EFBFBD><EFBFBD>A<><00><03>A<>
<03>$B`<03>$j<><03>$<00><>
<03>$<00>0$<00>.$
<00>$
5]$
<01>#$
<01><>+$
<01><>1$%;$.C$@=H$<02><>P$<02><>X$<02><>_$%<25><07>f A<><07>k <03><><07>p$ω<07>x <17><07><04>$:<3A><07><04>$K<>File Types menuhandfistboatclock
coffee_muggobblergumbyheartmousepencilshuttlespraycanstartrekwatchhandbucketcancelResizeeyedropeyedrop-fullzoom-inzoom-outX_cursorarrowbased_arrow_downbased_arrow_upboatbogositybottom_left_cornerbottom_right_cornerbottom_side
bottom_tee
box_spiral
center_ptrcircleclock
coffee_mugcross
cross_reverse	crosshair
diamond_crossdotdotboxdouble_arrowdraft_largedraft_small
draped_boxexchangefleurgobblergumbyhand1hand2hearticon
iron_crossleft_ptr	left_sideleft_tee
leftbuttonll_anglelr_anglemanmiddlebuttonmousepencilpirateplusquestion_arrow	right_ptr
right_side	right_teerightbuttonrtl_logosailboat
sb_down_arrowsb_h_double_arrow
sb_left_arrowsb_right_arrowsb_up_arrowsb_v_double_arrowshuttlesizingspiderspraycanstartargettcrosstop_left_arrowtop_left_cornertop_right_cornertop_sidetop_teetrekul_angleumbrellaur_anglewatchxterm	About Box
File Open BoxDefault About BoxTcl Environment Variablestkbuttondialogentryfocuslistboxmenu
optionMenupalettescale	scrollbartearofftexttkerrorConsolemsgboxcomdlgInitAutoPackageHistoryWordParray