PageRenderTime 69ms CodeModel.GetById 26ms RepoModel.GetById 1ms app.codeStats 0ms

/gpsman-6.4.1/gmsrc/gendials.tcl

#
TCL | 1720 lines | 1307 code | 130 blank | 283 comment | 306 complexity | 72ec04680a4c2356bee014397655da62 MD5 | raw file
Possible License(s): GPL-2.0

Large files files are truncated, but you can click here to view the full file

    

  1. #
    2. 

  2. #  gpsman --- GPS Manager: a manager for GPS receiver data
    3. 

  3. #
    4. 

  4. # Copyright (c) 1998-2009 Miguel Filgueiras mig@ncc.up.pt Universidade do Porto
    5. 

  5. #
    6. 

  6. #    This program is free software; you can redistribute it and/or modify
    7. 

  7. #      it under the terms of the GNU General Public License as published by
    8. 

  8. #      the Free Software Foundation; either version 2 of the License, or
    9. 

  9. #      (at your option) any later version.
    10. 

  10. #
    11. 

  11. #      This program is distributed in the hope that it will be useful,
    12. 

  12. #      but WITHOUT ANY WARRANTY; without even the implied warranty of
    13. 

  13. #      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14. 

  14. #      GNU General Public License for more details.
    15. 

  15. #
    16. 

  16. #      You should have received a copy of the GNU General Public License
    17. 

  17. #      along with this program.
    18. 

  18. #
    19. 

  19. #  File: gendials.tcl
    20. 

  20. #  Last change:  27 December 2009
    21. 

  21. #
    22. 

  22. # Includes contributions by
    23. 

  23. #  - Brian Baulch (baulchb_AT_onthenet.com.au) marked "BSB contribution"
    24. 

  24. #  - Stefan Heinen (stefan.heinen_AT_djh-freeweb.de) marked "SH contribution"
    25. 

  25. #
    26. 

  26. 

  27.   # creating toplevels
    28. 

  28. 

  29. proc GMToplevel {w title geom trans prots binds} {
    30. 

  30.     # create a toplevel with given geometry
    31. 

  31.     #   $w      window path
    32. 

  32.     #   $title  if not empty title given as either "==TITLE" for TITLE,
    33. 

  33.     #            or as an index in TXT array
    34. 

  34.     #   $trans  if not void is path of window of which $w is a transient
    35. 

  35.     #   $prots  list with in sequence a wm protocol and a command
    36. 

  36.     #   $binds  list with in sequence an event and a command
    37. 

  37.     # return $w
    38. 

  38.     global TXT
    39. 

  39. 

  40.     if { $title != "" && ! [regsub {^==} $title "" title] } {
    41. 

  41. 	set title $TXT($title)
    42. 

  42.     }
    43. 

  43.     toplevel $w
    44. 

  44.     if { $title != "" } { wm title $w "$title/GPSMan" }
    45. 

  45.     wm geometry $w $geom
    46. 

  46.     if { $trans != {} } { wm transient $w $trans }
    47. 

  47.     wm group $w .
    48. 

  48.     foreach {p c} $prots { wm protocol $w $p $c }
    49. 

  49.     foreach {e c} $binds { bind $w $e $c }
    50. 

  50.     return $w
    51. 

  51. }
    52. 

  52. 

  53.   # modal dialogs
    54. 

  54. 

  55. proc GMMessage {mess args} {
    56. 

  56.     # create modal dialog for displaying message
    57. 

  57.     #  if $args=="wait"  return only when user acknowledges message
    58. 

  58.     #      except in command-line mode or if using the slow op window
    59. 

  59.     # single button: OK; binding: return
    60. 

  60.     global COLOUR EPOSX EPOSY TXT UNIX CMDLINE
    61. 

  61. 

  62.     if { $CMDLINE } {
    63. 

  63. 	puts stderr $mess
    64. 

  64. 	flush stderr
    65. 

  65. 	return
    66. 

  66.     }
    67. 

  67.     if { [winfo exists .slowop] } {
    68. 

  68. 	SlowOpMessage $mess
    69. 

  69. 	return
    70. 

  70.     }
    71. 

  71.     if { [winfo exists .mess] } {
    72. 

  72. 	# add new message
    73. 

  73. 	foreach s [pack slaves .mess.fr] {
    74. 

  74. 	    if { $s == ".mess.fr.ok" } { break }
    75. 

  75. 	    set last $s
    76. 

  76. 	}
    77. 

  77. 	if { ! [regexp {^\.mess\.fr\.text(.*)$} $last x n] } {
    78. 

  78. 	    BUG bad last message field in .mess
    79. 

  79. 	    return
    80. 

  80. 	}
    81. 

  81. 	if { $n == "" } {
    82. 

  82. 	    set n 1
    83. 

  83. 	} else {
    84. 

  84. 	    if { $n == 4 } {
    85. 

  85. 		.mess.fr.text4 configure -text $mess
    86. 

  86. 		update idletasks
    87. 

  87. 		return
    88. 

  88. 	    }
    89. 

  89. 	    incr n
    90. 

  90. 	}
    91. 

  91. 	label .mess.fr.text$n -text $mess
    92. 

  92. 	pack .mess.fr.text$n -side top -pady 5 -before .mess.fr.ok
    93. 

  93. 	update idletasks
    94. 

  94. 	return
    95. 

  95.     }
    96. 

  96.     # this avoids bugs but may create havoc with grabs
    97. 

  97.     set gs [grab current]
    98. 

  98.     GMToplevel .mess message +$EPOSX+$EPOSY . \
    99. 

  99.         [list WM_DELETE_WINDOW  [list DestroyRGrabs .mess $gs]] \
    100. 

  100.         [list <Key-Return> [list DestroyRGrabs .mess $gs]]
    101. 

  101.     if { ! $UNIX } {
    102. 

  102. 	# SH contribution
    103. 

  103. 	focus .mess
    104. 

  104.     }
    105. 

  105. 

  106.     frame .mess.fr -borderwidth 5 -bg $COLOUR(messbg)
    107. 

  107.     label .mess.fr.title -text "!!!" -relief sunken
    108. 

  108.     label .mess.fr.text -text $mess
    109. 

  109.     button .mess.fr.ok -text $TXT(ok) -command [list DestroyRGrabs .mess $gs]
    110. 

  110.     pack .mess.fr -side top
    111. 

  111.     # changes in packing order must be reflected above when adding
    112. 

  112.     #  new messages to existing window
    113. 

  113.     pack .mess.fr.title .mess.fr.text .mess.fr.ok -side top -pady 5
    114. 

  114.     RaiseWindow .mess
    115. 

  115.     update idletasks
    116. 

  116.     grab .mess
    117. 

  117.     if { $args == "wait" } {
    118. 

  118. 	while 1 {
    119. 

  119. 	    after 500
    120. 

  120. 	    update
    121. 

  121. 	    if { ! [winfo exists .mess] } { return }
    122. 

  122. 	}
    123. 

  123.     }
    124. 

  124.     return
    125. 

  125. }
    126. 

  126. 

  127. proc GMConfirm {mess} {
    128. 

  128.     # create modal dialog for asking for confirmation
    129. 

  129.     #  buttons: OK, Cancel; bindings: return, delete
    130. 

  130.     global GMResConf COLOUR EPOSX EPOSY TXT CMDLINE
    131. 

  131. 

  132.     if { $CMDLINE } { return 1 }
    133. 

  133.     destroy .messres
    134. 

  134.     GMToplevel .messres message +$EPOSX+$EPOSY . \
    135. 

  135.         {WM_DELETE_WINDOW {set GMResConf 0}} \
    136. 

  136.         [list <Key-Return> {set GMResConf 1} \
    137. 

  137. 	     <Key-Delete> {set GMResConf 0}]
    138. 

  138. 

  139.     frame .messres.fr -borderwidth 5 -bg $COLOUR(confbg)
    140. 

  140.     label .messres.fr.title -text "???" -relief sunken
    141. 

  141.     label .messres.fr.text -text $mess
    142. 

  142.     frame .messres.fr.bs
    143. 

  143.     button .messres.fr.bs.ok -text $TXT(ok) -command { set GMResConf 1 }
    144. 

  144.     button .messres.fr.bs.cancel -text $TXT(no) -command { set GMResConf 0 }
    145. 

  145.     pack .messres.fr.bs.ok .messres.fr.bs.cancel -side left -pady 5
    146. 

  146.     pack .messres.fr.title .messres.fr.text .messres.fr.bs -side top -pady 5
    147. 

  147.     pack .messres.fr -side top
    148. 

  148.     update idletasks
    149. 

  149.     set gs [grab current]
    150. 

  150.     grab .messres
    151. 

  151.     RaiseWindow .messres
    152. 

  152.     tkwait variable GMResConf
    153. 

  153.     DestroyRGrabs .messres $gs
    154. 

  154.     update idletasks
    155. 

  155.     return $GMResConf
    156. 

  156. }
    157. 

  157. 

  158. proc GMSelect {mess blist vlist} {
    159. 

  159.     # create modal dialog for selecting values from $vlist under names in
    160. 

  160.     #  $blist; if an element in $blist has the form  @LIST  then the
    161. 

  161.     #  corresponding $vlist element is a list with one less element than LIST
    162. 

  162.     # menubuttons are created for each @LIST element whose label is the
    163. 

  163.     #  first element of LIST, buttons being used for the other elements
    164. 

  164.     #  bindings: return for first, delete for last element, or their
    165. 

  165.     #   first elements in case of @LIST
    166. 

  166.     # (see proc GMChooseFrom for selection using a listbox)
    167. 

  167.     global GMResSel COLOUR EPOSX EPOSY TXT
    168. 

  168. 

  169.     # assumes first and last elements of vlist are return values for
    170. 

  170.     #  Return and Delete keys, respectively
    171. 

  171. 

  172.     destroy .messres
    173. 

  173.     set e [lindex $blist 0]
    174. 

  174.     if { [string first "@" $e] == 0 } {
    175. 

  175. 	set e [lindex [lindex $vlist 0] 0]
    176. 

  176.     } else { set e [lindex $vlist 0] }
    177. 

  177.     GMToplevel .messres selection +$EPOSX+$EPOSY . \
    178. 

  178.         [list WM_DELETE_WINDOW  "set GMResSel [lindex $vlist 0]"] \
    179. 

  179.         [list <Key-Return> "set GMResSel $e"]
    180. 

  180. 

  181.     frame .messres.fr -borderwidth 5 -bg $COLOUR(selbg)
    182. 

  182.     label .messres.fr.title -text "???" -relief sunken
    183. 

  183.     label .messres.fr.text -text $mess
    184. 

  184.     frame .messres.fr.frsel
    185. 

  185.     set max 4 ; set c 0 ; set r 0 ; set lval "" ; set menus 0
    186. 

  186.     foreach e $blist v $vlist {
    187. 

  187. 	set b .messres.fr.frsel.b$r$c
    188. 

  188. 	if { [regexp {^@(.+)$} $e x e] } {
    189. 

  189. 	    if { [llength $e] != [llength $v]+1 } {
    190. 

  190. 		BUG GMSelect bad lengths of @LIST lists
    191. 

  191. 	    }
    192. 

  192. 	    incr menus
    193. 

  193. 	    set lval [lindex $v 0]
    194. 

  194. 	    menubutton $b -text [lindex $e 0] -menu $b.m
    195. 

  195. 	    menu $b.m
    196. 

  196. 	    foreach x [lreplace $e 0 0] y $v {
    197. 

  197. 		$b.m add command -label $x -command "set GMResSel $y"
    198. 

  198. 	    }
    199. 

  199. 	} else {
    200. 

  200. 	    set lval $v
    201. 

  201. 	    button $b -text $e -command "set GMResSel $v"
    202. 

  202. 	}
    203. 

  203. 	grid $b -column $c -row $r -sticky ew
    204. 

  204. 	if { [incr c] >= $max } {
    205. 

  205. 	    set c 0 ; incr r
    206. 

  206. 	}
    207. 

  207.     }
    208. 

  208.     bind .messres <Key-Delete> "set GMResSel $lval"
    209. 

  209. 

  210.     pack .messres.fr -side top
    211. 

  211.     pack .messres.fr.title .messres.fr.text .messres.fr.frsel -side top -pady 5
    212. 

  212.     set gs [grab current]
    213. 

  213.     update idletasks
    214. 

  214.     grab .messres
    215. 

  215.     if { $menus } {
    216. 

  216. 	Raise .messres
    217. 

  217.     } else { RaiseWindow .messres }
    218. 

  218.     tkwait variable GMResSel
    219. 

  219.     DestroyRGrabs .messres $gs
    220. 

  220.     update idletasks
    221. 

  221.     return $GMResSel
    222. 

  222. }
    223. 

  223. 

  224. proc GMChooseFrom {how mess wd blist vlist args} {
    225. 

  225.     # create modal dialog for selecting elements from list $blist
    226. 

  226.     #  with associated return values in $vlist
    227. 

  227.     #  $how in {single, many, many_0} defines number of elements that can
    228. 

  228.     #   be selected, many_0 meaning that 0 is an alternative
    229. 

  229.     # a listbox is used with width $wd
    230. 

  230.     #  $args if present is a pair with $vars $descs, suitable for use
    231. 

  231.     #   with proc GMSetupParams, so that parameters may be selected
    232. 

  232.     # buttons: OK, Cancel
    233. 

  233.     # bindings: return for commit, extended select mode on listbox,
    234. 

  234.     #  make visible by initial char on listbox
    235. 

  235.     # return list with selected values upon normal termination, and
    236. 

  236.     #  an empty list or -1 if $how==many_0
    237. 

  237.     # (see also proc GMSelect for selection of only one element with buttons)
    238. 

  238.     global GMResult DPOSX DPOSY COLOUR TXT UNIX
    239. 

  239. 

  240.     set w .gmchoosefr
    241. 

  241.     if { [winfo exists $w] } { Raise $w ; bell ; return }
    242. 

  242. 

  243.     GMToplevel $w "==$mess" +$DPOSX+$DPOSY . \
    244. 

  244.         {WM_DELETE_WINDOW {set GMResult cnc}} \
    245. 

  245.         [list <Key-Return> {set GMResult ok}]
    246. 

  246. 

  247.     frame $w.fr -borderwidth 5 -bg $COLOUR(dialbg)
    248. 

  248.     label $w.fr.text -text $mess
    249. 

  249. 

  250.     # adjust list height according to number of parameters
    251. 

  251.     set lh [expr 15-[llength [lindex $args 0]]]
    252. 

  252.     if { [set ll [llength $blist]] > $lh } {
    253. 

  253. 	set ll $lh
    254. 

  254.     }
    255. 

  255.     frame $w.fr.frbx
    256. 

  256.     if { $how == "single" } {
    257. 

  257. 	set mode single
    258. 

  258.     } else { set mode extended }
    259. 

  259.     listbox $w.fr.frbx.bx -height $ll -width $wd -relief flat \
    260. 

  260. 	    -selectmode $mode -yscrollcommand "$w.fr.frbx.bscr set" \
    261. 

  261. 	    -exportselection 0
    262. 

  262.     # SH contribution: no such bindings in non-unix systems
    263. 

  263.     if { $UNIX } {
    264. 

  264. 	bind $w.fr.frbx.bx <Enter> { focus %W }
    265. 

  265. 	bind $w.fr.frbx.bx <Leave> "focus $w.fr.frbx"
    266. 

  266.     }
    267. 

  267.     bind $w.fr.frbx.bx <Key> { ScrollListIndex %W %A }
    268. 

  268.     scrollbar $w.fr.frbx.bscr -command "$w.fr.frbx.bx yview"
    269. 

  269.     foreach i $blist { $w.fr.frbx.bx insert end $i }
    270. 

  270.     if { $ll == 1 } { $w.fr.frbx.bx selection set 0 }
    271. 

  271. 

  272.     if { $args != "" } {
    273. 

  273. 	set opts 1
    274. 

  274. 	frame $w.fr.fopt
    275. 

  275. 	foreach "menus es" \
    276. 

  276. 	    [GMSetupParams $w.fr.fopt [lindex $args 0] [lindex $args 1]] {}
    277. 

  277.     } else { set opts 0 ; set menus 0 }
    278. 

  278. 

  279.     frame $w.fr.frbt
    280. 

  280.     button $w.fr.frbt.ok -text $TXT(ok) -command { set GMResult ok }
    281. 

  281.     button $w.fr.frbt.cnc -text $TXT(cancel) -command { set GMResult cnc }
    282. 

  282. 

  283.     pack $w.fr.frbt.ok $w.fr.frbt.cnc -side left -pady 5
    284. 

  284.     pack $w.fr.frbx.bx $w.fr.frbx.bscr -side left -fill y
    285. 

  285.     if { $opts } {
    286. 

  286. 	pack $w.fr.text $w.fr.frbx $w.fr.fopt $w.fr.frbt -side top -pady 5
    287. 

  287.     } else {
    288. 

  288. 	pack $w.fr.text $w.fr.frbx $w.fr.frbt -side top -pady 5
    289. 

  289.     }
    290. 

  290.     pack $w.fr
    291. 

  291. 

  292.     update idletasks
    293. 

  293.     set gs [grab current]
    294. 

  294.     grab $w
    295. 

  295.     if { $menus } {
    296. 

  296. 	Raise .fdlg
    297. 

  297.     } else { RaiseWindow .fdlg }
    298. 

  298.     while 1 {
    299. 

  299. 	tkwait variable GMResult
    300. 

  300. 

  301. 	switch $GMResult {
    302. 

  302. 	    ""  { }
    303. 

  303. 	    cnc { 
    304. 

  304. 		if { $how == "many_0" } { set res -1 } else { set res "" }
    305. 

  305. 		break
    306. 

  306. 	    }
    307. 

  307. 	    ok {
    308. 

  308. 		set ss [$w.fr.frbx.bx curselection]
    309. 

  309. 		if { $ss == "" && $how != "many_0" } {
    310. 

  310. 		    bell
    311. 

  311. 		    continue
    312. 

  312. 		}
    313. 

  313. 		set res ""
    314. 

  314. 		foreach i $ss {
    315. 

  315. 		    lappend res [lindex $vlist $i]
    316. 

  316. 		}
    317. 

  317. 		if { $opts } {
    318. 

  318. 		    GMUseEntries $w.fr.fopt $es
    319. 

  319. 		}
    320. 

  320. 		break
    321. 

  321. 	    }
    322. 

  322. 	}
    323. 

  323.     }
    324. 

  324.     DestroyRGrabs $w $gs
    325. 

  325.     update idletasks
    326. 

  326.     return $res
    327. 

  327. }
    328. 

  328. 

  329. proc GMChooseParams {mess vars descs} {
    330. 

  330.     # create modal dialog for choosing parameters
    331. 

  331.     #  $vars and $descs are as described in GMSetupParams
    332. 

  332.     #  buttons: OK, Cancel
    333. 

  333.     #  bindings: return for commit
    334. 

  334.     # return 0 if cancelled
    335. 

  335.     global GMResult DPOSX DPOSY COLOUR TXT
    336. 

  336. 

  337.     set w .gmchooseprsr
    338. 

  338.     if { [winfo exists $w] } { Raise $w ; bell ; return }
    339. 

  339. 

  340.     GMToplevel $w "==$mess" +$DPOSX+$DPOSY . \
    341. 

  341.         {WM_DELETE_WINDOW {set GMResult cnc}} \
    342. 

  342.         [list <Key-Return> {set GMResult ok}]
    343. 

  343. 

  344.     frame $w.fr -borderwidth 5 -bg $COLOUR(dialbg)
    345. 

  345.     label $w.fr.text -text $mess
    346. 

  346. 

  347.     frame $w.fr.fopt
    348. 

  348.     foreach "menus es" [GMSetupParams $w.fr.fopt $vars $descs] {}
    349. 

  349. 

  350.     frame $w.fr.frbt
    351. 

  351.     button $w.fr.frbt.ok -text $TXT(ok) -command { set GMResult ok }
    352. 

  352.     button $w.fr.frbt.cnc -text $TXT(cancel) -command { set GMResult cnc }
    353. 

  353. 

  354.     pack $w.fr.frbt.ok $w.fr.frbt.cnc -side left -pady 5
    355. 

  355.     pack $w.fr.text $w.fr.fopt $w.fr.frbt -side top -pady 5
    356. 

  356.     pack $w.fr
    357. 

  357. 

  358.     update idletasks
    359. 

  359.     set gs [grab current]
    360. 

  360.     grab $w
    361. 

  361.     if { $menus } {
    362. 

  362. 	Raise .fdlg
    363. 

  363.     } else { RaiseWindow .fdlg }
    364. 

  364.     while 1 {
    365. 

  365. 	tkwait variable GMResult
    366. 

  366. 

  367. 	switch $GMResult {
    368. 

  368. 	    ""  { }
    369. 

  369. 	    cnc { 
    370. 

  370. 		set res 0 ; break
    371. 

  371. 	    }
    372. 

  372. 	    ok {
    373. 

  373. 		GMUseEntries $w.fr.fopt $es
    374. 

  374. 		set res 1 ; break
    375. 

  375. 	    }
    376. 

  376. 	}
    377. 

  377.     }
    378. 

  378.     DestroyRGrabs $w $gs
    379. 

  379.     update idletasks
    380. 

  380.     return $res
    381. 

  381. }
    382. 

  382. 

  383. proc GMLogin {service} {
    384. 

  384.     # get or retrieve login information for accessing a given service
    385. 

  385.     #  $service is a unique name for the service, needed for displaying
    386. 

  386.     #    a message and indexing saved login information
    387. 

  387.     # save the login information for use in the current session if the user
    388. 

  388.     #  asks for it
    389. 

  389.     # return list with user name and password or an empty list if cancelled
    390. 

  390.     global MESS TXT GMPInfo
    391. 

  391. 

  392.     if { ! [catch {set up $GMPInfo($service)}] } { return $up }
    393. 

  393.     if { [GMChooseParams [format $MESS(loginto) $service] \
    394. 

  394. 	      {GMPInfo(__tmp,u) GMPInfo(__tmp,p) GMPInfo(__tmp,s)} \
    395. 

  395. 	      [list =$TXT(uname) =@$TXT(pword) @$TXT(remember)]] \
    396. 

  396. 	     == 0 } { return {} }
    397. 

  397.     set up [list $GMPInfo(__tmp,u) $GMPInfo(__tmp,p)]
    398. 

  398.     unset GMPInfo(__tmp,p)
    399. 

  399.     if { $GMPInfo(__tmp,s) } { set GMPInfo($service) $up }
    400. 

  400.     return $up
    401. 

  401. }
    402. 

  402. 

  403. ##### information window
    404. 

  404. 

  405. proc DisplayInfo {mess args} {
    406. 

  406.     # display information on a dialog
    407. 

  407.     # the dialog is created if it not exists, otherwise the message
    408. 

  408.     #  will be added to it
    409. 

  409.     #  $args may be "" or  "tabs" followed by tabs list (man 3tk text) in
    410. 

  410.     #     which negative numbers are to be converted from chars to screen
    411. 

  411.     #     distances
    412. 

  412.     global CMDLINE COLOUR EPOSX EPOSY TXT FixedFont DInfo
    413. 

  413. 

  414.     if { $CMDLINE } { return }
    415. 

  415. 

  416.     set frt .gminfo.fr.frt
    417. 

  417.     if { ! [winfo exists .gminfo] } {
    418. 

  418. 	GMToplevel .gminfo info +$EPOSX+$EPOSY {} \
    419. 

  419. 	    {WM_DELETE_WINDOW {destroy .gminfo}} {}
    420. 

  420. 

  421. 	frame .gminfo.fr -borderwidth 5 -bg $COLOUR(messbg)
    422. 

  422. 	label .gminfo.fr.title -text $TXT(info) -relief sunken
    423. 

  423. 

  424. 	frame $frt -relief flat -borderwidth 0
    425. 

  425. 	text $frt.txt -width 80 -font $FixedFont -wrap word \
    426. 

  426. 	    -exportselection 1 -yscrollcommand "$frt.tscrl set"
    427. 

  427. 	bind $frt.txt <space> "$frt.txt yview scroll 1 pages ; break"
    428. 

  428. 	bind $frt.txt <Key-Delete> "$frt.txt yview scroll -1 pages ; break"
    429. 

  429. 	bind $frt.txt <Any-Key> break
    430. 

  430. 	bind $frt.txt <Button-2> break
    431. 

  431. 	scrollbar $frt.tscrl -command "$frt.txt yview"
    432. 

  432. 

  433. 	set frb .gminfo.fr.frb
    434. 

  434. 	frame $frb -relief flat -borderwidth 0
    435. 

  435. 	button $frb.save -text $TXT(save) \
    436. 

  436. 	    -command "SaveDisplayInfo $frt.txt"
    437. 

  437. 	button $frb.ok -text $TXT(ok) -command { destroy .gminfo }
    438. 

  438. 

  439. 	grid config $frt.txt -column 0 -row 1 -sticky nesw
    440. 

  440. 	grid config $frt.tscrl -column 1 -row 1 -sticky nesw
    441. 

  441. 	grid config $frb.save -column 0 -row 0
    442. 

  442. 	grid config $frb.ok -column 1 -row 0
    443. 

  443. 	pack .gminfo.fr.title $frt $frb -side top -pady 5
    444. 

  444. 	pack .gminfo.fr
    445. 

  445. 

  446. 	# info on this window
    447. 

  447. 	catch {unset DInfo}
    448. 

  448. 	# to help setting tabs, make public the "ex" in pixels
    449. 

  449. 	set x20 "xxxxxxxxxxxxxxxxxxxx"
    450. 

  450. 	set DInfo(ex) [expr round([font measure $FixedFont $x20]/20.0)]
    451. 

  451. 	# number of next free tag; tags will have names started by "itg"
    452. 

  452. 	set DInfo(nxttag) 1
    453. 

  453.     }
    454. 

  454.     if { $args != "" } {
    455. 

  455. 	set tags ""
    456. 

  456. 	switch -- [lindex $args 0] {
    457. 

  457. 	    tabs {
    458. 

  458. 		set tlst ""
    459. 

  459. 		foreach x [lindex $args 1] {
    460. 

  460. 		    if { [regexp {^-([0-9]+)$} $x m n] } {
    461. 

  461. 			# to pixels
    462. 

  462. 			set x [expr $n*$DInfo(ex)]
    463. 

  463. 		    }
    464. 

  464. 		    lappend tlst $x
    465. 

  465. 		}
    466. 

  466. 		if { [catch {set tgname $DInfo($tlst)}] } {
    467. 

  467. 		    set tgname itg$DInfo(nxttag)
    468. 

  468. 		    incr DInfo(nxttag)
    469. 

  469. 		    $frt.txt tag configure $tgname -tabs $tlst
    470. 

  470. 		    set DInfo($tlst) $tgname
    471. 

  471. 		}
    472. 

  472. 		lappend tags $tgname
    473. 

  473. 	    }
    474. 

  474. 	    default {
    475. 

  475. 		BUG bad args to DisplayInfo
    476. 

  476. 		return
    477. 

  477. 	    }
    478. 

  478. 	}
    479. 

  479. 	$frt.txt insert end "$mess\n" $tags
    480. 

  480.     } else { $frt.txt insert end "$mess\n" }
    481. 

  481.     $frt.txt see end
    482. 

  482.     update idletasks
    483. 

  483.     return
    484. 

  484. }
    485. 

  485. 

  486. proc SaveDisplayInfo {wtxt} {
    487. 

  487.     # save text in $wtxt text widget to file
    488. 

  488.     global TXT
    489. 

  489. 

  490.     if { [set txt [$wtxt get 1.0 end]] == "" || \
    491. 

  491. 	     [set f [GMOpenFile $TXT(saveto) Info w]] == ".." } { return }
    492. 

  492.     puts $f $txt
    493. 

  493.     close $f
    494. 

  494.     return
    495. 

  495. }
    496. 

  496. 

  497. ### dialog window for controlling slow operations
    498. 

  498. 

  499. proc SlowOpWindow {mess} {
    500. 

  500.     # create dialog for controlling slow operation
    501. 

  501.     # to be called by application before entering the main loop of the slow
    502. 

  502.     #  operation
    503. 

  503.     # within the loop there should be calls to proc SlowOpAborted that
    504. 

  504.     #  returns 1 if the operation is to be aborted, or updates the interface
    505. 

  505.     #  and returns 0  otherwise
    506. 

  506.     # any call within the loop to GMMessage will be diverted to this dialog
    507. 

  507.     # after the main loop there should be a call to proc SlowOpFinish with
    508. 

  508.     #  the unique identifier that is returned by proc SlowOpWindow
    509. 

  509.     # returns a unique identifier to be used when calling proc SlowOpWindow
    510. 

  510.     global SlowOp COLOUR MAPCOLOUR EPOSX EPOSY TXT CMDLINE USESLOWOPWINDOW \
    511. 

  511. 	FixedFont
    512. 

  512. 

  513.     if { $CMDLINE || ! $USESLOWOPWINDOW } { return }
    514. 

  514.     if { [winfo exists .slowop] } {
    515. 

  515. 	set SlowOp(id) [clock seconds]
    516. 

  516. 	set SlowOp(ids) [linsert $SlowOp(ids) 0 $SlowOp(id)]
    517. 

  517. 	.slowop.fr.title configure -text $mess
    518. 

  518. 	return $SlowOp(id)
    519. 

  519.     }
    520. 

  520. 

  521.     set id [clock seconds]
    522. 

  522.     array set SlowOp [list aborting 0  id $id  ids $id \
    523. 

  523. 			  status "$TXT(working)..." grabs [grab current]]
    524. 

  524.     # avoid completely covering other dialogs
    525. 

  525.     set pos [expr $EPOSX+150]
    526. 

  526.     GMToplevel .slowop opinprogr +$pos+$EPOSY {} \
    527. 

  527.         {WM_DELETE_WINDOW {set SlowOp(aborting) 1}} {}
    528. 

  528. 

  529.     frame .slowop.fr -borderwidth 5 -bg $COLOUR(messbg)
    530. 

  530.     label .slowop.fr.title -text $mess -relief sunken
    531. 

  531. 

  532.     set frs .slowop.fr.frs
    533. 

  533.     frame $frs -relief flat -borderwidth 0
    534. 

  534.     label $frs.st -textvariable SlowOp(status) -fg $MAPCOLOUR(trvwrnimportant)
    535. 

  535.     checkbutton $frs.light -disabledforeground $COLOUR(check) -state disabled
    536. 

  536. 

  537.     set frt .slowop.fr.frt
    538. 

  538.     frame $frt -relief flat -borderwidth 0
    539. 

  539.     text $frt.txt -width 50 -font $FixedFont -wrap word \
    540. 

  540. 	    -yscrollcommand "$frt.tscrl set"
    541. 

  541.     bind $frt.txt <space> "$frt.txt yview scroll 1 pages ; break"
    542. 

  542.     bind $frt.txt <Key-Delete> "$frt.txt yview scroll -1 pages ; break"
    543. 

  543.     bind $frt.txt <Any-Key> break
    544. 

  544.     scrollbar $frt.tscrl -command "$frt.txt yview"
    545. 

  545. 

  546.     set frb .slowop.fr.frb
    547. 

  547.     frame $frb -relief flat -borderwidth 0
    548. 

  548.     button $frb.abort -text $TXT(abort) -command SlowOpAbort
    549. 

  549.     button $frb.ok -text $TXT(ok) -state disabled \
    550. 

  550. 	    -command [list DestroyRGrabs .slowop $SlowOp(grabs)]
    551. 

  551. 

  552.     pack $frs.st $frs.light -side left
    553. 

  553.     grid config $frt.txt -column 0 -row 1 -sticky nesw
    554. 

  554.     grid config $frt.tscrl -column 1 -row 1 -sticky nesw
    555. 

  555.     grid config $frb.abort -column 0 -row 0
    556. 

  556.     grid config $frb.ok -column 1 -row 0
    557. 

  557.     pack .slowop.fr.title $frs $frt $frb -side top -pady 5
    558. 

  558.     pack .slowop.fr
    559. 

  559.     update idletasks
    560. 

  560.     grab .slowop
    561. 

  561.     RaiseWindow .slowop
    562. 

  562.     return $id
    563. 

  563. }
    564. 

  564. 

  565. proc SlowOpFinish {id mess} {
    566. 

  566.     # to be called by application when the operation ends (either normally
    567. 

  567.     #  or not)
    568. 

  568.     #  $id is unique identifier that was returned by proc SlowOpWindow
    569. 

  569.     #    if $id is not in the $SlowOp(ids) stack the message is displayed
    570. 

  570.     #    and nothing else happens
    571. 

  571.     #  $mess will be displayed if not empty
    572. 

  572.     # the dialog window will be closed only when the stack of calls to
    573. 

  573.     #  proc SlowOpWindow is empty
    574. 

  574.     # the dialog window is closed silently if there were no messages,
    575. 

  575.     #  otherwise the Ok button is activated and the user must acknowledge it
    576. 

  576.     global SlowOp TXT
    577. 

  577. 

  578.     if { ! [winfo exists .slowop] } {
    579. 

  579. 	if { $mess != "" } { GMMessage $mess }
    580. 

  580. 	return
    581. 

  581.     }
    582. 

  582.     if { $mess != "" } { SlowOpMessage $mess }
    583. 

  583.     if { [set ix [lsearch -exact $SlowOp(ids) $id]] == -1 || \
    584. 

  584. 	     [set SlowOp(ids) [lreplace $SlowOp(ids) 0 $ix]] != {} } {
    585. 

  585. 	return
    586. 

  586.     }
    587. 

  587.     if { ! $SlowOp(aborting) } { set SlowOp(status) $TXT(errwarn) }
    588. 

  588.     set SlowOp(aborting) 0
    589. 

  589.     set txt .slowop.fr.frt.txt
    590. 

  590.     if { [$txt index end] == 2.0 } {
    591. 

  591. 	DestroyRGrabs .slowop $SlowOp(grabs)
    592. 

  592. 	return
    593. 

  593.     }
    594. 

  594.     set frb .slowop.fr.frb
    595. 

  595.     foreach b "abort ok" st "disabled normal" {
    596. 

  596. 	$frb.$b configure -state $st
    597. 

  597.     }
    598. 

  598.     return
    599. 

  599. }
    600. 

  600. 

  601. proc SlowOpAbort {} {
    602. 

  602.     # the user aborted the operation
    603. 

  603.     # not to be called directly from the application
    604. 

  604.     global SlowOp TXT
    605. 

  605. 

  606.     set SlowOp(aborting) 1
    607. 

  607.     set SlowOp(status) $TXT(aborted)
    608. 

  608.     return
    609. 

  609. }
    610. 

  610. 

  611. proc SlowOpMessage {mess} {
    612. 

  612.     # show message in slow operation dialog window
    613. 

  613.     # not to be called directly from the application
    614. 

  614. 

  615.     set txt .slowop.fr.frt.txt
    616. 

  616.     $txt insert end "$mess\n"
    617. 

  617.     $txt see end
    618. 

  618.     update idletasks
    619. 

  619.     return
    620. 

  620. }    
    621. 

  621. 

  622. proc SlowOpAborted {} {
    623. 

  623.     # to be called by the application to test if the operation was aborted
    624. 

  624.     # if not a call to update is made to ensure that the window is usable
    625. 

  625.     # return 1 if yes
    626. 

  626.     global SlowOp TXT
    627. 

  627. 

  628.     if { ! [winfo exists .slowop] } { return 0 }
    629. 

  629.     if { $SlowOp(aborting) } {
    630. 

  630. 	set SlowOp(status) $TXT(aborted)
    631. 

  631. 	return 1
    632. 

  632.     }
    633. 

  633.     set frs .slowop.fr.frs
    634. 

  634.     $frs.light toggle
    635. 

  635.     update
    636. 

  636.     return 0
    637. 

  637. }
    638. 

  638. 

  639. ### opening files
    640. 

  640. 

  641. proc GMOpenFile {act wh mode} {
    642. 

  642.     # create modal dialog for selecting and opening a file
    643. 

  643.     #  $act is string describing the action to do on the file
    644. 

  644.     #  $wh in $filetypes (see proc GMStart, setup.tcl)
    645. 

  645.     #  $mode in {r, w}
    646. 

  646.     #  buttons: OK, Cancel
    647. 

  647.     #  binding: return and double-left for commit, left-click for select
    648. 

  648.     global GMResult COLOUR DPOSX DPOSY LISTHEIGHT File TXT MESS UNIX
    649. 

  649. 

  650.     if { [set f $File($wh)] == "" || [catch {cd [file dirname $f]}] } {
    651. 

  651. 	set currfile ""
    652. 

  652.     } else { set currfile [file tail $f] }
    653. 

  653. 

  654.     GMToplevel .fdlg file +$DPOSX+$DPOSY . \
    655. 

  655.         {WM_DELETE_WINDOW {set GMResult cnc}} \
    656. 

  656.         [list <Key-Return> {set GMResult ok}]
    657. 

  657. 

  658.     frame .fdlg.fr -borderwidth 5 -bg $COLOUR(selbg)
    659. 

  659.     label .fdlg.fr.title -text [format $MESS(fileact) $act $TXT(name$wh)] \
    660. 

  660. 	    -relief sunken
    661. 

  661.     if { ! $UNIX } {
    662. 

  662. 	menubutton .fdlg.fr.vols -text $TXT(volume) -menu .fdlg.fr.vols.m
    663. 

  663. 	menu .fdlg.fr.vols.m
    664. 

  664. 	bind .fdlg.fr.vols <Button-1> {
    665. 

  665. 	    FillMenuExec .fdlg.fr.vols.m {ChangeVolume .fdlg} file volume
    666. 

  666. 	}
    667. 

  667.     }
    668. 

  668.     entry .fdlg.fr.wdir -width 30
    669. 

  669.     ShowTEdit .fdlg.fr.wdir [pwd] 0
    670. 

  670. 

  671.     frame .fdlg.fr.frbx
    672. 

  672.     listbox .fdlg.fr.frbx.box -height $LISTHEIGHT -width 30 \
    673. 

  673. 	    -yscrollcommand ".fdlg.fr.frbx.bscr set" \
    674. 

  674.  	    -selectmode single -exportselection 1
    675. 

  675.     bind .fdlg.fr.frbx.box <Double-1> {
    676. 

  676.             global GMResult
    677. 

  677.             set GMResult [%W nearest %y]
    678. 

  678.     }
    679. 

  679.     bind .fdlg.fr.frbx.box <Button-1> {
    680. 

  680. 	.fdlg.fr.fn delete 0 end
    681. 

  681. 	.fdlg.fr.fn insert 0 [%W get [%W nearest %y]]
    682. 

  682.     }
    683. 

  683.     scrollbar .fdlg.fr.frbx.bscr -command ".fdlg.fr.frbx.box yview"
    684. 

  684.     FillDir .fdlg.fr.frbx.box
    685. 

  685. 

  686.     entry .fdlg.fr.fn -width 30
    687. 

  687.     .fdlg.fr.fn insert 0 $currfile
    688. 

  688.     TextBindings .fdlg.fr.fn
    689. 

  689.     
    690. 

  690.     frame .fdlg.fr.bs
    691. 

  691.     button .fdlg.fr.bs.ok -text $TXT(ok) -command { set GMResult ok }
    692. 

  692.     button .fdlg.fr.bs.cnc -text $TXT(cancel) \
    693. 

  693. 	    -command { set GMResult cnc }
    694. 

  694. 

  695.     pack .fdlg.fr.bs.ok .fdlg.fr.bs.cnc -side left -pady 5
    696. 

  696.     pack .fdlg.fr.frbx.box .fdlg.fr.frbx.bscr -side left -fill y
    697. 

  697.     if { $UNIX } {
    698. 

  698. 	pack .fdlg.fr.title .fdlg.fr.wdir .fdlg.fr.frbx .fdlg.fr.fn \
    699. 

  699. 		.fdlg.fr.bs -side top -pady 5
    700. 

  700.     } else {
    701. 

  701. 	pack .fdlg.fr.title .fdlg.fr.vols .fdlg.fr.wdir .fdlg.fr.frbx \
    702. 

  702. 		.fdlg.fr.fn .fdlg.fr.bs -side top -pady 5
    703. 

  703.     }
    704. 

  704.     pack .fdlg.fr -side top
    705. 

  705. 

  706.     update idletasks
    707. 

  707.     set gs [grab current]
    708. 

  708.     grab .fdlg
    709. 

  709.     RaiseWindow .fdlg
    710. 

  710.     while 1 {
    711. 

  711. 	tkwait variable GMResult
    712. 

  712. 

  713. 	switch $GMResult {
    714. 

  714. 	    ""  { }
    715. 

  715. 	    cnc { 
    716. 

  716. 		set res ".."
    717. 

  717. 		break
    718. 

  718. 	    }
    719. 

  719. 	    ok {
    720. 

  720. 		set fn [.fdlg.fr.fn get]
    721. 

  721. 		set f [GMCheckFile open $fn $mode]
    722. 

  722. 		if { $f != ".." } {
    723. 

  723. 		    set File($wh) [file join [pwd] $fn]
    724. 

  724. 		    set res $f
    725. 

  725. 		    break
    726. 

  726. 		}
    727. 

  727. 	    }
    728. 

  728. 	    0 {
    729. 

  729. 		cd ..
    730. 

  730. 		ShowTEdit .fdlg.fr.wdir [pwd] 0
    731. 

  731. 		.fdlg.fr.frbx.box delete 0 end ; FillDir .fdlg.fr.frbx.box
    732. 

  732. 		.fdlg.fr.fn delete 0 end
    733. 

  733. 	    }
    734. 

  734. 	    default {
    735. 

  735. 		set fn [.fdlg.fr.frbx.box get $GMResult]
    736. 

  736. 		set f [GMCheckFile open $fn $mode]
    737. 

  737. 		if { $f != ".." } {
    738. 

  738. 		    set File($wh) [file join [pwd] $fn]
    739. 

  739. 		    set res $f
    740. 

  740. 		    break
    741. 

  741. 		}
    742. 

  742. 	    }
    743. 

  743. 	}
    744. 

  744.     }
    745. 

  745.     DestroyRGrabs .fdlg $gs
    746. 

  746.     update idletasks
    747. 

  747.     return $res
    748. 

  748. }
    749. 

  749. 

  750. proc GMOpenFileParms {act wh mode vars vals} {
    751. 

  751.     # create modal dialog for selecting and opening a file and parameters
    752. 

  752.     # see arguments of proc GMGetFileName
    753. 

  753. 

  754.     set fname [GMGetFileName $act $wh $mode $vars $vals]
    755. 

  755.     if { $fname == ".." } { return ".." }
    756. 

  756.     return [open $fname $mode]
    757. 

  757. }
    758. 

  758. 

  759. proc GMGetFileName {act wh mode vars vals} {
    760. 

  760.     # create modal dialog for selecting a file name and parameters
    761. 

  761.     #  $act is string describing the action to do on the file
    762. 

  762.     #  $wh in $filetypes (see proc GMStart, setup.tcl)
    763. 

  763.     #  $mode in {r, w}
    764. 

  764.     #  $vars is list of (global) vars to set
    765. 

  765.     #  $vals is associated list of value descriptions (see proc GMSetupParams)
    766. 

  766.     #  buttons: OK, Cancel
    767. 

  767.     #  binding: return and double-left for commit, left-click for select
    768. 

  768.     global GMResult COLOUR DPOSX DPOSY LISTHEIGHT File TXT MESS UNIX
    769. 

  769. 

  770.     if { [set f $File($wh)] == "" || [catch {cd [file dirname $f]}] } {
    771. 

  771. 	set currfile ""
    772. 

  772.     } else { set currfile [file tail $f] }
    773. 

  773. 

  774.     GMToplevel .fdlg file +$DPOSX+$DPOSY . \
    775. 

  775.         {WM_DELETE_WINDOW {set GMResult cnc}} \
    776. 

  776.         [list <Key-Return> {set GMResult ok}]
    777. 

  777. 

  778.     frame .fdlg.fr -borderwidth 5 -bg $COLOUR(selbg)
    779. 

  779.     label .fdlg.fr.title -text [format $MESS(fileact) $act $TXT(name$wh)] \
    780. 

  780. 	    -relief sunken
    781. 

  781.     if { ! $UNIX } {
    782. 

  782. 	menubutton .fdlg.fr.vols -text $TXT(volume) -menu .fdlg.fr.vols.m
    783. 

  783. 	menu .fdlg.fr.vols.m
    784. 

  784. 	bind .fdlg.fr.vols <Button-1> {
    785. 

  785. 	    FillMenuExec .fdlg.fr.vols.m {ChangeVolume .fdlg} file volume
    786. 

  786. 	}
    787. 

  787.     }
    788. 

  788.     entry .fdlg.fr.wdir -width 30
    789. 

  789.     ShowTEdit .fdlg.fr.wdir [pwd] 0
    790. 

  790. 

  791.     # adjust list height according to number of parameters
    792. 

  792.     set lh [expr $LISTHEIGHT-[llength $vars]]
    793. 

  793.     frame .fdlg.fr.frbx
    794. 

  794.     listbox .fdlg.fr.frbx.box -height $lh -width 30 \
    795. 

  795. 	    -yscrollcommand ".fdlg.fr.frbx.bscr set" \
    796. 

  796.  	    -selectmode single -exportselection 1
    797. 

  797.     bind .fdlg.fr.frbx.box <Double-1> {
    798. 

  798.             global GMResult
    799. 

  799.             set GMResult [%W nearest %y]
    800. 

  800.     }
    801. 

  801.     bind .fdlg.fr.frbx.box <Button-1> {
    802. 

  802. 	.fdlg.fr.fn delete 0 end
    803. 

  803. 	.fdlg.fr.fn insert 0 [%W get [%W nearest %y]]
    804. 

  804.     }
    805. 

  805.     scrollbar .fdlg.fr.frbx.bscr -command ".fdlg.fr.frbx.box yview"
    806. 

  806.     FillDir .fdlg.fr.frbx.box
    807. 

  807.     # BSB contribution: wheelmouse scrolling
    808. 

  808.     Mscroll .fdlg.fr.frbx.box
    809. 

  809. 

  810.     entry .fdlg.fr.fn -width 30
    811. 

  811.     .fdlg.fr.fn insert 0 $currfile
    812. 

  812.     TextBindings .fdlg.fr.fn
    813. 

  813. 

  814.     frame .fdlg.fr.fopt
    815. 

  815.     foreach "menus es" [GMSetupParams .fdlg.fr.fopt $vars $vals] {}
    816. 

  816. 

  817.     frame .fdlg.fr.bs
    818. 

  818.     button .fdlg.fr.bs.ok -text $TXT(ok) -command { set GMResult ok }
    819. 

  819.     button .fdlg.fr.bs.cnc -text $TXT(cancel) \
    820. 

  820. 	-command { set GMResult cnc }
    821. 

  821. 

  822.     pack .fdlg.fr.bs.ok .fdlg.fr.bs.cnc -side left -pady 5
    823. 

  823.     pack .fdlg.fr.frbx.box .fdlg.fr.frbx.bscr -side left -fill y
    824. 

  824.     if { $UNIX } {
    825. 

  825. 	pack .fdlg.fr.title .fdlg.fr.wdir .fdlg.fr.frbx .fdlg.fr.fn \
    826. 

  826. 		.fdlg.fr.fopt .fdlg.fr.bs -side top -pady 5
    827. 

  827.     } else {
    828. 

  828. 	pack .fdlg.fr.title .fdlg.fr.vols .fdlg.fr.wdir .fdlg.fr.frbx \
    829. 

  829. 		.fdlg.fr.fn .fdlg.fr.fopt .fdlg.fr.bs -side top -pady 5
    830. 

  830.     }
    831. 

  831.     pack .fdlg.fr -side top
    832. 

  832. 

  833.     update idletasks
    834. 

  834.     set gs [grab current]
    835. 

  835.     grab .fdlg
    836. 

  836.     if { $menus } {
    837. 

  837. 	Raise .fdlg
    838. 

  838.     } else { RaiseWindow .fdlg }
    839. 

  839.     while 1 {
    840. 

  840. 	tkwait variable GMResult
    841. 

  841. 

  842. 	switch $GMResult {
    843. 

  843. 	    ""  { }
    844. 

  844. 	    cnc { 
    845. 

  845. 		set res ".." ; break
    846. 

  846. 	    }
    847. 

  847. 	    ok {
    848. 

  848. 		set fn [.fdlg.fr.fn get]
    849. 

  849. 		set f [GMCheckFile check $fn $mode]
    850. 

  850. 		if { $f != ".." } {
    851. 

  851. 		    set File($wh) [file join [pwd] $fn]
    852. 

  852. 		    GMUseEntries .fdlg.fr.fopt $es
    853. 

  853. 		    set res $fn
    854. 

  854. 		    break
    855. 

  855. 		}
    856. 

  856. 	    }
    857. 

  857. 	    0 {
    858. 

  858. 		cd ..
    859. 

  859. 		ShowTEdit .fdlg.fr.wdir [pwd] 0
    860. 

  860. 		.fdlg.fr.frbx.box delete 0 end ; FillDir .fdlg.fr.frbx.box
    861. 

  861. 		.fdlg.fr.fn delete 0 end
    862. 

  862. 	    }
    863. 

  863. 	    default {
    864. 

  864. 		set fn [.fdlg.fr.frbx.box get $GMResult]
    865. 

  865. 		set f [GMCheckFile check $fn $mode]
    866. 

  866. 		if { $f != ".." } {
    867. 

  867. 		    set File($wh) [file join [pwd] $fn]
    868. 

  868. 		    set res $fn
    869. 

  869. 		    break
    870. 

  870. 		}
    871. 

  871. 	    }
    872. 

  872. 	}
    873. 

  873.     }
    874. 

  874.     DestroyRGrabs .fdlg $gs
    875. 

  875.     update idletasks
    876. 

  876.     return $res
    877. 

  877. }
    878. 

  878. 

  879. proc GMCheckFile {how f mode} {
    880. 

  880.     # check name of file $f and if ok either open it and return file descriptor
    881. 

  881.     #  or return file name; otherwise return ".."
    882. 

  882.     #  $how in {open check}
    883. 

  883.     #  $mode in {r, w}
    884. 

  884.     global PERMS TXT MESS
    885. 

  885. 

  886.     if { $f == "" } { bell ; return ".." }
    887. 

  887.     if { [file isdirectory $f] } {
    888. 

  888. 	if { [file executable $f] } {
    889. 

  889. 	    cd $f
    890. 

  890. 	    ShowTEdit .fdlg.fr.wdir [pwd] 0
    891. 

  891. 	    .fdlg.fr.frbx.box delete 0 end
    892. 

  892. 	    FillDir .fdlg.fr.frbx.box
    893. 

  893. 	    .fdlg.fr.fn delete 0 end
    894. 

  894. 	} else {
    895. 

  895. 	    bell
    896. 

  896. 	}
    897. 

  897.     } elseif { $mode == "r" } {
    898. 

  898. 	if { [file readable $f] } {
    899. 

  899. 	    switch $how {
    900. 

  900. 		open { return [open $f r] }
    901. 

  901. 		check { return $f }
    902. 

  902. 	    }
    903. 

  903. 	} else {
    904. 

  904. 	    bell
    905. 

  905. 	}
    906. 

  906.     } elseif { [file exists $f] } {
    907. 

  907. 	if { [file writable $f] } {
    908. 

  908. 	    set m [GMSelect $MESS(filexists) \
    909. 

  909. 		    [list $TXT(ovwrt) $TXT(app) $TXT(cancel)] "w a 0"]
    910. 

  910. 	    if { $m != 0 } {
    911. 

  911. 		switch $how {
    912. 

  912. 		    open { return [open $f $m $PERMS] }
    913. 

  913. 		    check { return $f }
    914. 

  914. 		}
    915. 

  915. 	    }
    916. 

  916. 	} else {
    917. 

  917. 	    bell
    918. 

  918. 	}
    919. 

  919.     } elseif { [file writable [pwd]] } {
    920. 

  920. 	switch $how {
    921. 

  921. 	    open { return [open $f $mode $PERMS] }
    922. 

  922. 	    check { return $f }
    923. 

  923. 	}
    924. 

  924.     } else {
    925. 

  925. 	bell
    926. 

  926.     }
    927. 

  927.     return ".."
    928. 

  928. }
    929. 

  929. 

  930. proc ChangeVolume {w vol} {
    931. 

  931.     # file volume has changed $vol in file-selection dialog $w
    932. 

  932. 

  933.     if { ! [file isdirectory $vol] } { bell ; return }
    934. 

  934.     cd $vol
    935. 

  935.     ShowTEdit .fdlg.fr.wdir [pwd] 0
    936. 

  936.     .fdlg.fr.frbx.box delete 0 end ; FillDir .fdlg.fr.frbx.box
    937. 

  937.     .fdlg.fr.fn delete 0 end
    938. 

  938.     return
    939. 

  939. }
    940. 

  940. 

  941. ### font selection
    942. 

  942. 

  943. proc GMSelectFont {args} {
    944. 

  944.     # dialog for selecting a font
    945. 

  945.     #  $args may contain the font description to return if the
    946. 

  946.     #        default is selected; if empty "default" is returned
    947. 

  947.     # a font is defined by giving
    948. 

  948.     #   one of [font families] and
    949. 

  949.     #   the size in points or pixels, an integer > 0
    950. 

  950.     #   the weight, one of {normal bold}
    951. 

  951.     #   the slant, one of {roman italic}
    952. 

  952.     #   whether to use underline
    953. 

  953.     #   whether to use overstrike
    954. 

  954.     # return empty list if cancelled, "default" or the description
    955. 

  955.     #   in $args, or list with family, size, and other style
    956. 

  956.     #   indicators in {normal bold roman italic underline overstrike}
    957. 

  957.     #   where size follows the Tk convention (negative if in pixels)
    958. 

  958.     global GMFtDial TXT MESS LISTHEIGHT EPOSX EPOSY COLOUR
    959. 

  959. 

  960.     array set GMFtDial {
    961. 

  961. 	size 12
    962. 

  962. 	units points
    963. 

  963. 	weight normal
    964. 

  964. 	slant roman
    965. 

  965. 	underline 0
    966. 

  966. 	overstrike 0
    967. 

  967.     }
    968. 

  968. 

  969.     if { [winfo exists .gmselfont] } { destroy .gmselfont }
    970. 

  970.     set w [GMToplevel .gmselfont selfont +$EPOSX+$EPOSY . \
    971. 

  971. 	       {WM_DELETE_WINDOW {set GMFtDial(act) cancel}} \
    972. 

  972. 	       [list <Key-Return> {set GMFtDial(act) ok}]]
    973. 

  973. 

  974.     frame $w.fr -borderwidth 5 -bg $COLOUR(selbg)
    975. 

  975.     label $w.fr.tit -text $TXT(selfont)
    976. 

  976.     set frbx $w.fr.frbx
    977. 

  977.     frame $frbx
    978. 

  978.     listbox $frbx.box -height $LISTHEIGHT -width 40 -selectmode single \
    979. 

  979. 	-yscrollcommand "$frbx.bscr set" -exportselection 1
    980. 

  980.     scrollbar $frbx.bscr -command "$frbx.box yview"
    981. 

  981.     grid $frbx.box -row 0 -column 0
    982. 

  982.     grid $frbx.bscr -row 0 -column 1 -sticky ns
    983. 

  983.     grid rowconfigure $frbx 0 -weight 1
    984. 

  984.     grid columnconfigure $frbx 0 -weight 1
    985. 

  985.     foreach fam [lsort -dictionary [font families]] {
    986. 

  986. 	$frbx.box insert end $fam
    987. 

  987.     }
    988. 

  988. 

  989.     frame $w.fr.frp
    990. 

  990.     set vars {} ; set descs {}
    991. 

  991.     foreach v {size units weight slant underline overstrike} {
    992. 

  992. 	lappend vars GMFtDial($v)
    993. 

  993.     }
    994. 

  994.     set descs [list "=$TXT(size)" \
    995. 

  995. 		   "~$TXT(units)/[list points pixels]" \
    996. 

  996. 		   "~$TXT(weight)/[list normal bold]" \
    997. 

  997. 		   "~$TXT(slant)/[list roman italic]" \
    998. 

  998. 		   "@$TXT(underline)" "@$TXT(overstrike)"]
    999. 

  999.     set pes [lindex [GMSetupParams $w.fr.frp $vars $descs] 1]
    1000. 

  1000. 

  1001.     set frbs $w.fr.frbs
    1002. 

  1002.     frame $frbs
    1003. 

  1003.     foreach x {ok default cancel} {
    1004. 

  1004. 	button $frbs.$x -text $TXT($x) -command "set GMFtDial(act) $x"
    1005. 

  1005. 	pack $frbs.$x -side left
    1006. 

  1006.     }
    1007. 

  1007. 

  1008.     pack $w.fr.tit
    1009. 

  1009.     pack $frbs -side bottom -pady 5
    1010. 

  1010.     pack $w.fr.frp -side bottom -pady 5
    1011. 

  1011.     # must be the last one
    1012. 

  1012.     pack $w.fr.frbx -fill both -expand 1 -pady 5
    1013. 

  1013. 

  1014.     grid $w.fr
    1015. 

  1015.     grid rowconfigure $w.fr 0 -weight 1
    1016. 

  1016.     grid columnconfigure $w.fr 0 -weight 1
    1017. 

  1017.     grid rowconfigure $w 0 -weight 1
    1018. 

  1018.     grid columnconfigure $w 0 -weight 1
    1019. 

  1019. 

  1020.     update idletasks
    1021. 

  1021.     # cannot use RaiseWindow because of menus
    1022. 

  1022.     set grabs [grab current]
    1023. 

  1023.     grab $w
    1024. 

  1024.     while 1 {
    1025. 

  1025. 	tkwait variable GMFtDial(act)
    1026. 

  1026. 	switch $GMFtDial(act) {
    1027. 

  1027. 	    cancel {
    1028. 

  1028. 		set res {} ; break
    1029. 

  1029. 	    }
    1030. 

  1030. 	    default {
    1031. 

  1031. 		if { [set res [lindex $args 0]] == {} } {
    1032. 

  1032. 		    set res default
    1033. 

  1033. 		}
    1034. 

  1034. 		break
    1035. 

  1035. 	    }
    1036. 

  1036. 	    ok {
    1037. 

  1037. 		if { [set ix [$frbx.box curselection]] == {} } {
    1038. 

  1038. 		    GMMessage $MESS(mustselftfam)
    1039. 

  1039. 		    continue
    1040. 

  1040. 		}
    1041. 

  1041. 		GMUseEntries $w.fr.frp $pes
    1042. 

  1042. 		set n [string trim $GMFtDial(size)]
    1043. 

  1043. 		if { ! [CheckNumber GMMessage $n] } { continue }
    1044. 

  1044. 		if { $n < 1 } {
    1045. 

  1045. 		    GMMessage [format $MESS(xcantbey) $TXT(size) 0]
    1046. 

  1046. 		    continue
    1047. 

  1047. 		}
    1048. 

  1048. 		if { $GMFtDial(units) == "pixels" } {
    1049. 

  1049. 		    set n [expr -$n]
    1050. 

  1050. 		}
    1051. 

  1051. 		set res [list [$frbx.box get $ix]]
    1052. 

  1052. 		lappend res $n
    1053. 

  1053. 		foreach x {weight slant} { lappend res $GMFtDial($x) }
    1054. 

  1054. 		foreach x {underline overstrike} {
    1055. 

  1055. 		    if { $GMFtDial($x) } { lappend res $x }
    1056. 

  1056. 		}
    1057. 

  1057. 		break
    1058. 

  1058. 	    }
    1059. 

  1059. 	}
    1060. 

  1060.     }
    1061. 

  1061.     DestroyRGrabs $w $grabs
    1062. 

  1062.     destroy $w
    1063. 

  1063.     return $res
    1064. 

  1064. }
    1065. 

  1065. 

  1066. ### utilities for dealing with parameters in a dialog
    1067. 

  1067. 

  1068. proc GMSetupParams {w vars descs} {
    1069. 

  1069.     # set-up widgets for setting parameters in a dialog
    1070. 

  1070.     #  $w is window parent
    1071. 

  1071.     #  $vars is list of (global) vars to set; they must have a value
    1072. 

  1072.     #    except those associated to entries which will be initialised to ""
    1073. 

  1073.     #    and to menubuttons that if undefined will be initialised to "";
    1074. 

  1074.     #    array elements may also be given instead of normal variables but
    1075. 

  1075.     #    the indices must be alphanumeric
    1076. 

  1076.     #  $descs is associated list of value descriptions as:
    1077. 

  1077.     #      @TEXT   checkbutton with label TEXT, values 0 1
    1078. 

  1078.     #      =@TEXT  non-echo entry with label TEXT
    1079. 

  1079.     #      =TEXT   entry with label TEXT
    1080. 

  1080.     #      !TEXT=MENUPROC/ARGS menubutton with label TEXT and menu filled by
    1081. 

  1081.     #         proc MENUPROC; the arguments to the MENUPROC call are:
    1082. 

  1082.     #                - the menu window
    1083. 

  1083.     #                - the command to be associated with final entries, whose
    1084. 

  1084.     #                arguments are the selected value and the menu window
    1085. 

  1085.     #                - the elements of the list ARGS
    1086. 

  1086.     #      |TEXT/LIST label TEXT and menubutton with text-variable for values
    1087. 

  1087.     #         in LIST
    1088. 

  1088.     #      +TEXT/LIST radiobuttons with possible values in LIST, label TEXT
    1089. 

  1089.     #      /TEXT|LIST radiobuttons with possible values in LIST, label TEXT
    1090. 

  1090.     #      ~TEXT/LIST radiobuttons with possible values in LIST but their
    1091. 

  1091.     #         names are in the array TXT, label TEXT
    1092. 

  1092.     #      LIST    radiobutton with possible values in LIST
    1093. 

  1093.     # LISTs above cannot have repeated elements
    1094. 

  1094.     # return pair with flag set if there are menubuttons, and list of entries,
    1095. 

  1095.     #  each as a triple, usually with path from $w to entry, the name of
    1096. 

  1096.     #  global (array or normal) variable to be used in "global" and complete
    1097. 

  1097.     #  name of variable to be used in "set"; for non-echo entries the
    1098. 

  1098.     #  path is prefixed by a "@"; the list can be processed by proc GMUseEntries
    1099. 

  1099.     global COLOUR TXT NEEntry
    1100. 

  1100. 

  1101.     set i 0 ; set es "" ; set menus 0
    1102. 

  1102.     foreach v $vars os $descs {
    1103. 

  1103. 	if { [regexp {^([^(]+)[(]([^)]+)[)]$} $v x vname el] } {
    1104. 

  1104. 	    set vid "${vname}___ARR_$el"
    1105. 

  1105. 	} else { set vid $v ; set vname $v }
    1106. 

  1106. 	global $vname
    1107. 

  1107. 	frame $w.f$i
    1108. 

  1108. 	switch -glob -- $os {
    1109. 

  1109. 	    @* {
    1110. 

  1110. 		set os [string replace $os 0 0]
    1111. 

  1111. 		set cb $w.f$i.c$vid
    1112. 

  1112. 		checkbutton $cb -text $os -variable $v -anchor w \
    1113. 

  1113. 		    -onvalue 1 -offvalue 0 -selectcolor $COLOUR(check)
    1114. 

  1114. 		if { [set $v] } {
    1115. 

  1115. 		    $cb select
    1116. 

  1116. 		} else { $cb deselect }
    1117. 

  1117. 		pack $cb
    1118. 

  1118. 	    }
    1119. 

  1119. 	    =* {
    1120. 

  1120. 		if { [string index $os 1] == "@" } {
    1121. 

  1121. 		    set z 1
    1122. 

  1122. 		} else { set z 0 }
    1123. 

  1123. 		set os [string replace $os 0 $z]
    1124. 

  1124. 		set wl [label $w.f$i.l$vid -text $os]
    1125. 

  1125. 		set ppath f$i.e$vid
    1126. 

  1126. 		set we [entry $w.f$i.e$vid -width 30]
    1127. 

  1127. 		TextBindings $we
    1128. 

  1128. 		if { $z } {
    1129. 

  1129. 		    set NEEntry($we) ""
    1130. 

  1130. 		    bind $we <Delete> "GMNEEntry $we _ BackSpace ; break"
    1131. 

  1131. 		    bind $we <Any-Key> "GMNEEntry $we %A %K ; break"
    1132. 

  1132. 		    set ppath "@$ppath"
    1133. 

  1133. 		}
    1134. 

  1134. 		if { [catch {set $v}] } {
    1135. 

  1135. 		    set $v ""
    1136. 

  1136. 		} elseif { $z == 0 } { $we insert 0 [set $v] }
    1137. 

  1137. 		pack $wl $we -side left
    1138. 

  1138. 		lappend es [list $ppath $vname $v]
    1139. 

  1139. 	    }
    1140. 

  1140. 	    !* {
    1141. 

  1141. 		set menus 1
    1142. 

  1142. 		if { ! [regexp {^!([^=]+)=([^/]+)/(.*)$} $os \
    1143. 

  1143. 			    m lab menuproc mpargs] } {
    1144. 

  1144. 		    BUG Bad argument to GMSetupParams !
    1145. 

  1145. 		}
    1146. 

  1146. 		set mb $w.f$i.mb$vid
    1147. 

  1147. 		menubutton $mb -text $lab -relief raised \
    1148. 

  1148. 		    -direction below -menu $mb.m
    1149. 

  1149. 		menu $mb.m
    1150. 

  1150. 		eval $menuproc $mb.m GMChangeParam $mpargs
    1151. 

  1151. 		if { [catch {set $v}] } {
    1152. 

  1152. 		    set $v ""
    1153. 

  1153. 		}
    1154. 

  1154. 		set wl [label $w.f$i.l$vid -textvariable $v]
    1155. 

  1155. 		pack $mb $wl -side left
    1156. 

  1156. 	    }
    1157. 

  1157. 	    |* {
    1158. 

  1158. 		set menus 1
    1159. 

  1159. 		if { ! [regexp {^[|]([^/]+)/(.*)$} $os \
    1160. 

  1160. 			    m lab lst] } {
    1161. 

  1161. 		    BUG Bad argument to GMSetupParams |
    1162. 

  1162. 		}
    1163. 

  1163. 		set wl [label $w.f$i.t$vid -text $lab -width 16]
    1164. 

  1164. 		set mb $w.f$i.mb$vid
    1165. 

  1165. 		menubutton $mb -textvariable $v -relief raised \
    1166. 

  1166. 		    -direction below -menu $mb.m
    1167. 

  1167. 		menu $mb.m
    1168. 

  1168. 		foreach x $lst {
    1169. 

  1169. 		    $mb.m add command -label $x -command "set $v $x"
    1170. 

  1170. 		}
    1171. 

  1171. 		pack $wl $mb -side left
    1172. 

  1172. 	    }
    1173. 

  1173. 	    +* -  /* -  ~* {
    1174. 

  1174. 		set labval [string first "~" $os]
    1175. 

  1175. 		if { ! [regexp {^.([^/]+)/(.+)$} $os m lab lst] } {
    1176. 

  1176. 		    BUG Bad argument to GMSetupParams +/~
    1177. 

  1177. 		    continue
    1178. 

  1178. 		}
    1179. 

  1179. 		
    1180. 

  1180. 		pack [label $w.f$i.l$vid -text $lab] -side left
    1181. 

  1181. 		set k 0
    1182. 

  1182. 		set wrb $w.f$i.r_${vid}_0
    1183. 

  1183. 		foreach o $lst {
    1184. 

  1184. 		    if { $labval } {
    1185. 

  1185. 			set lv $o
    1186. 

  1186. 		    } else { set lv $TXT($o) }
    1187. 

  1187. 		    set rb $w.f$i.r_${vid}_$k
    1188. 

  1188. 		    radiobutton $rb -text $lv -variable $v \
    1189. 

  1189. 			-value $o -anchor w -selectcolor $COLOUR(check)
    1190. 

  1190. 		    pack $rb -side left -padx 2
    1191. 

  1191. 		    if { [set $v] == $o } { set wrb $rb }
    1192. 

  1192. 		    incr k
    1193. 

  1193. 		}
    1194. 

  1194. 		$wrb invoke
    1195. 

  1195. 	    }
    1196. 

  1196. 	    default {
    1197. 

  1197. 		set k 0
    1198. 

  1198. 		set wrb $w.f$i.rd_${vid}_0
    1199. 

  1199. 		foreach o $os {
    1200. 

  1200. 		    set rb $w.f$i.rd_${vid}_$k
    1201. 

  1201. 		    radiobutton $rb -text $o -variable $v \
    1202. 

  1202. 			-value $o -anchor w -selectcolor $COLOUR(check)
    1203. 

  1203. 		    pack $rb -side left -padx 2
    1204. 

  1204. 		    if { [set $v] == $o } { set wrb $rb }
    1205. 

  1205. 		    incr k
    1206. 

  1206. 		}
    1207. 

  1207. 		$wrb invoke
    1208. 

  1208. 	    }
    1209. 

  1209. 	}
    1210. 

  1210. 	pack $w.f$i -side top -fill x -expand 1
    1211. 

  1211. 	incr i
    1212. 

  1212.     }
    1213. 

  1213.     return [list $menus $es]
    1214. 

  1214. }
    1215. 

    1216. 

  1216. proc GMNEEntry {e char ksym} {
    1217. 

  1217.     # keep track of characters typed in a non-echo entry $e
    1218. 

  1218.     # current contents are kept on global NEEntry($e) that should be unset
    1219. 

  1219.     #  after use
    1220. 

  1220.     global NEEntry PASSWDECHO
    1221. 

    1222. 

  1222.     if { $PASSWDECHO == "none" } {
    1223. 

  1223. 	echo 0
    1224. 

  1224. 	$e delete 0 end
    1225. 

  1225.     } else { set echo 1 }
    1226. 

  1226.     if { $ksym == "BackSpace" } {
    1227. 

  1227. 	set NEEntry($e) [string replace $NEEntry($e) end end]
    1228. 

  1228. 	if { $echo } { $e delete 0 }
    1229. 

  1229. 	return
    1230. 

  1230.     }
    1231. 

  1231.     if { $ksym == $char || $ksym == "??" || [regexp {^[a-z]} $ksym] } {
    1232. 

  1232. 	append NEEntry($e) $char
    1233. 

  1233. 	if { $echo } { $e insert end $PASSWDECHO }
    1234. 

  1234.     }
    1235. 

  1235.     return
    1236. 

  1236. }
    1237. 

    1238. 

  1238. proc GMChangeParam {val varmenu args} {
    1239. 

  1239.     # parameter value changed by a selection in a menu
    1240. 

  1240.     #  $varmenu is either the menu path assumed to have a single occurrence
    1241. 

  1241.     #   of .mbVARID. or has the form =VARID where VARID either is the name
    1242. 

  1242.     #   of the global simple variable to set, or has is the string
    1243. 

  1243.     #   concatenation of a global array identifier, "___ARR_" and
    1244. 

  1244.     #   an array index
    1245. 

  1245.     #  $args may be TXT to force value to be $TXT($val)
    1246. 

  1246.     global TXT
    1247. 

    1248. 

  1248.     if { ! [regexp {^=(.+)$} $varmenu x v] } {
    1249. 

  1249. 	regexp {\.mb([^.]+)\.} $varmenu x v
    1250. 

  1250.     }
    1251. 

  1251.     if { [regexp {^(.+)___ARR_(.+)$} $v x v ix] } {
    1252. 

  1252. 	global $v
    1253. 

  1253. 	append v "(" $ix ")"
    1254. 

  1254.     } else { global $v }
    1255. 

  1255.     if { $args == "TXT" } {
    1256. 

  1256. 	set val $TXT($val)
    1257. 

  1257.     }
    1258. 

  1258.     set $v $val
    1259. 

  1259.     return
    1260. 

  1260. }
    1261. 

    1262. 

  1262. proc GMUseEntries {w es} {
    1263. 

  1263.     # set global variables according to entries set-up by proc GMSetupParams
    1264. 

  1264.     #  $w is window parent
    1265. 

  1265.     #  $es is list of triples usually with path from $w to entry,
    1266. 

  1266.     #   name of global (array or normal) variable to be used in "global" and
    1267. 

  1267.     #   complete name of variable to be used in "set"; for non-echo entries
    1268. 

  1268.     #   the path is prefixed with a "@"
    1269. 

  1269.     # current contents of non-echo entries are kept on global array NEEntry
    1270. 

  1270.     #  (see proc GMNEEntry) and corresponding elements are unset here
    1271. 

  1271.     global NEEntry
    1272. 

    1273. 

  1273.     foreach e $es {
    1274. 

  1274. 	global [lindex $e 1]
    1275. 

  1275. 	if { [string index [set ppath [lindex $e 0]] 0] == "@" } {
    1276. 

  1276. 	    set ppath $w.[string replace $ppath 0 0]
    1277. 

  1277. 	    set v $NEEntry($ppath)
    1278. 

  1278. 	    unset NEEntry($ppath)
    1279. 

  1279. 	} else { set v [$w.$ppath get] }
    1280. 

  1280. 	set [lindex $e 2] $v
    1281. 

  1281.     }
    1282. 

  1282.     return
    1283. 

  1283. }
    1284. 

    1285. 

  1285. ### image listbox widget
    1286. 

    1287. 

  1287. proc ImageListbox {act path args} {
    1288. 

  1288.     # implements a new widget whose model is a listbox but has entries
    1289. 

  1289.     #  with an image and possibly a text label
    1290. 

  1290.     #  $act is the action to perform and determines $args
    1291. 

  1291.     #    create  SIZE WIDTH EHEIGHT SELECTMODE ?SCROLLBAR?
    1292. 

  1292.     #    insert  INDEX IMAGE TEXT ?TAGS?; return either index or -1 if entry
    1293. 

  1293.     #      can not be inserted because IMAGE cannot be displayed and TEXT
    1294. 

  1294.     #      is empty
    1295. 

  1295.     #    delete  INDEX ?INDEX?
    1296. 

  1296.     #    get     INDEX ?INDEX? ; return list of texts in entries
    1297. 

  1297.     #    gettags INDEX ?INDEX? ; return list of tags in entries
    1298. 

  1298.     #    selclr  INDEX ?INDEX? ; clear selected
    1299. 

  1299.     #    selset  INDEX ?INDEX? ; set as selected (irrespective of SELECTMODE)
    1300. 

  1300.     #    cursel  "" ; return list of indices of currently selected entries
    1301. 

  1301.     #    getsel  "" ; return list of texts in currently selected entries
    1302. 

  1302.     #    getseltags "" ; return list of lists each with the tags in currently
    1303. 

  1303.     #      selected entries
    1304. 

  1304.     #    seldel  "" ; delete selected entries
    1305. 

  1305.     #    index   Y ; return index of entry at y-coordinate (inside listbox)
    1306. 

  1306.     #    destroyall "" ; destroy all image listboxes under window $path
    1307. 

  1307.     #  where
    1308. 

  1308.     #     SELECTMODE is one of {single, extended}
    1309. 

  1309.     #     EHEIGHT is the height for the entries in pixels (minimum used: 5)
    1310. 

  1310.     #     INDEX is either a numeric index from 0 or "end"
    1311. 

  1311.     #     TAGS is a list
    1312. 

  1312.     # the widget should be packed or grided by caller after being created
    1313. 

  1313.     # images that have more than EHEIGHT-4 in width or height are either
    1314. 

  1314.     #  truncated to that size if they are of type photo, or not displayed
    1315. 

  1315.     # information related to these widgets is stored in global array GMIBox
    1316. 

  1316.     # auxiliary images are created but never deleted; their names can be
    1317. 

  1317.     #  retrieved from GMIBox(img,*) entries
    1318. 

  1318.     # bindings on entries:
    1319. 

  1319.     #  <Button-1> deselects everything, selects entry
    1320. 

  1320.     #  if SELECTMODE=="extended":
    1321. 

  1321.     #    <Control-Button-1> toggles selection state of entry
    1322. 

  1322.     #    <Shift-Button-1> selects range from last selected entry to entry
    1323. 

  1323.     global GMIBox COLOUR
    1324. 

    1325. 

  1325.     if { $act == "destroyall" } {
    1326. 

  1326. 	foreach n [array names GMIBox $path*,csize] {
    1327. 

  1327. 	    regsub {,csize$} $n "" lbox
    1328. 

  1328. 	    destroy $lbox
    1329. 

  1329. 	}
    1330. 

  1330. 	foreach n [array names GMIBox $path*] { unset GMIBox($n) }
    1331. 

  1331. 	return
    1332. 

  1332.     }
    1333. 

  1333.     if { [set nargs [llength $args]] != 0 } {
    1334. 

  1334. 	foreach "a1 a2 a3 a4 a5" $args { break }
    1335. 

  1335.     }
    1336. 

  1336.     if { $act != "create" } {
    1337. 

  1337. 	if { [catch {set csize $GMIBox($path,csize)}] } {
    1338. 

  1338. 	    BUG trying to use non-existing ImageListbox	
    1339. 

  1339. 	}
    1340. 

  1340. 	set end $csize
    1341. 

  1341. 	if { $end > 0 } { incr end -1 }
    1342. 

  1342. 	foreach x "sel eh ew mode" {
    1343. 

  1343. 	    set $x $GMIBox($path,$x)
    1344. 

  1344. 	}
    1345. 

  1345.     }
    1346. 

  1346.     set res ""
    1347. 

  1347.     switch $act {
    1348. 

  1348. 	create {
    1349. 

  1349. 	    # SIZE WIDTH EHEIGHT MODE ?SCROLLBAR?
    1350. 

  1350. 	    if { $nargs < 4 } { BUG missing args to ImageListbox create }
    1351. 

  1351. 	    if { $a3 < 5 } { set a3 5 }
    1352. 

  1352. 	    set height [expr $a1*$a3]
    1353. 

  1353. 	    foreach x "csize sel eh ew mode anchor base height" \
    1354. 

  1354. 		    v "0 {} $a3 $a2 $a4 {} 0 $height" {
    1355. 

  1355. 		set GMIBox($path,$x) $v
    1356. 

  1356. 	    }
    1357. 

  1357. 	    canvas $path -height $height -width $a2 -confine 1 \
    1358. 

  1358. 		-borderwidth 2 -relief sunken
    1359. 

  1359. 	    if { $a5 != "" } {
    1360. 

  1360. 		$path configure -yscrollincrement $a3 \
    1361. 

  1361. 		    -yscrollcommand "ImageListboxScroll $path $a5" \
    1362. 

  1362. 		    -scrollregion "0 0 $a2 $height"
    1363. 

  1363. 		trace variable GMIBox($path,csize) w ImageListboxResize
    1364. 

  1364. 	    }
    1365. 

  1365. 	    $path bind entry <Shift-Button-1> \
    1366. 

  1366. 		"ImageListboxESButton $path %y ; break"
    1367. 

  1367. 	    $path bind entry <Control-Button-1> \
    1368. 

  1368. 		"ImageListboxECButton $path %y ; break"
    1369. 

  1369. 	    $path bind entry <Button-1> "ImageListboxEButton $path %y"
    1370. 

  1370. 	}
    1371. 

  1371. 	insert {
    1372. 

  1372. 	    # INDEX IMAGE TEXT ?TAGS?
    1373. 

  1373. 	    if { $nargs < 3 } { BUG missing args to ImageListbox insert }
    1374. 

  1374. 	    set ih [expr $eh-2]
    1375. 

  1375. 	    if { $a2 != "" && \
    1376. 

  1376. 		     ([image width $a2] > $ih || [image height $a2] > $ih) } {
    1377. 

  1377. 		if { [image type $a2] != "photo" } {
    1378. 

  1378. 		    if { $a3 == "" } { return -1 }
    1379. 

  1379. 		    set a2 ""
    1380. 

  1380. 		} else {
    1381. 

  1381. 		    if { [catch {set im $GMIBox(img,for,$a2)}] } {
    1382. 

  1382. 			set im [image create photo -width $ih -height $ih]
    1383. 

  1383. 			$im copy $a2 -from 0 0 $ih $ih
    1384. 

  1384. 			set GMIBox(img,for,$a2) $im
    1385. 

  1385. 		    }
    1386. 

  1386. 		    set a2 $im
    1387. 

  1387. 		}
    1388. 

  1388. 	    }
    1389. 

  1389. 	    if { $a1 != "end" } {
    1390. 

  1390. 		set na1 [ImageListboxIndices $path $end $a1]
    1391. 

  1391. 		if { $a1 > $na1 } {
    1392. 

  1392. 		    # assuming given index must be an integer
    1393. 

  1393. 		    set na1 $csize
    1394. 

  1394. 		}
    1395. 

  1395. 		# update selection
    1396. 

  1396. 		set s ""
    1397. 

  1397. 		foreach e $GMIBox($path,sel) {
    1398. 

  1398. 		    if { $e >= $na1 } { incr e }
    1399. 

  1399. 		    lappend s $e
    1400. 

  1400. 		}
    1401. 

  1401. 		set GMIBox($path,sel) $s
    1402. 

  1402. 		# move lower entries down
    1403. 

  1403. 		set y0 [expr $na1*$eh]
    1404. 

  1404. 		if { $csize > 0  && $na1 < $csize } {
    1405. 

  1405. 		    foreach it [$path find withtag entry] {
    1406. 

  1406. 			if { [lindex [$path coords $it] 1] >= $y0 } {
    1407. 

  1407. 			    $path move $it 0 $eh
    1408. 

  1408. 			}
    1409. 

  1409. 		    }
    1410. 

  1410. 		}
    1411. 

  1411. 	    } else { set y0 [expr $csize*$eh] }
    1412. 

  1412. 	    $path create rectangle 1 [expr $y0+1] $ew [expr $y0+$eh] \
    1413. 

  1413. 		-fill $COLOUR(bg) -outline $COLOUR(bg) \
    1414. 

  1414. 		-tags [list txt entry bg "tgs=$a4"]
    1415. 

  1415. 	    # texts are created even if empty so that they can be retrieved
    1416. 

  1416. 	    $path create text [expr $eh+8] [expr $y0+$eh/2] -anchor w \
    1417. 

  1417. 		-text $a3 -fill $COLOUR(fg) \
    1418. 

  1418. 		-tags [list txt entry "txt=$a3"]
    1419. 

  1419. 	    if { $a2 != "" } {
    1420. 

  1420. 		$path create image 5 [expr $y0+2] -anchor nw -image $a2 \
    1421. 

  1421. 		    -tags "img entry"
    1422. 

  1422. 	    }
    1423. 

  1423. 	    incr GMIBox($path,csize)
    1424. 

  1424. 	    update idletasks
    1425. 

  1425. 	}
    1426. 

  1426. 	delete {
    1427. 

  1427. 	    # INDEX ?INDEX?
    1428. 

  1428. 	    if { $nargs < 1 } { BUG missing args to ImageListbox delete }
    1429. 

  1429. 	    foreach "a1 a2" [ImageListboxIndices $path $end [list $a1 $a2]] {}
    1430. 

  1430. 	    if { $a2 == "" } { set a2 $a1 }
    1431. 

  1431. 	    if { [set ndel [expr $a2-$a1+1]] == $csize } {
    1432. 

  1432. 		$path delete all
    1433. 

  1433. 		set GMIBox($path,sel) ""
    1434. 

  1434. 	    } else {
    1435. 

  1435. 		# update selection
    1436. 

  1436. 		set s ""
    1437. 

  1437. 		foreach e $GMIBox($path,sel) {
    1438. 

  1438. 		    if { $e < $a1 } {
    1439. 

  1439. 			lappend s $e
    1440. 

  1440. 		    } elseif { $e > $a2 } {
    1441. 

  1441. 			lappend s [expr $e-$ndel]
    1442. 

  1442. 		    }
    1443. 

  1443. 		}
    1444. 

  1444. 		set GMIBox($path,sel) $s
    1445. 

  1445. 		# move lower entries up
    1446. 

  1446. 		set y0 [expr $a1*$eh] ; set yn [expr ($a2+1)*$eh]
    1447. 

  1447. 		set dy [expr -$ndel*$eh]
    1448. 

  1448. 		foreach it [$path find withtag entry] {
    1449. 

  1449. 		    if { [set y [lindex [$path coords $it] 1]] >= $y0 } {
    1450. 

  1450. 			if { $y >= $yn } {
    1451. 

  1451. 			    $path move $it 0 $dy
    1452. 

  1452. 			} else { $path delete $it }
    1453. 

  1453. 		    }
    1454. 

  1454. 		}
    1455. 

  1455. 	    }
    1456. 

  1456. 	    set GMIBox($path,csize) [expr $csize-$ndel]
    1457. 

  1457. 	    update idletasks
    1458. 

  1458. 	}
    1459. 

  1459. 	get {
    1460. 

  1460. 	    # INDEX ?INDEX?
    1461. 

  1461. 	    if { $nargs < 1 } { BUG missing args to ImageListbox get }
    1462. 

  1462. 	    foreach "a1 a2" [ImageListboxIndices $path $end [list $a1 $a2]] {}
    1463. 

  1463. 	    if { $a2 == "" } { set a2 $a1 }
    1464. 

  1464. 	    set y0 [expr $a1*$eh] ; set yn [expr ($a2+1)*$eh]
    1465. 

  1465. 	    set r ""
    1466. 

  1466. 	    foreach it [$path find withtag txt] {
    1467. 

  1467. 		if { [set y [lindex [$path coords $it] 1]] >= $y0 && \
    1468. 

  1468. 			 $y < $yn } {
    1469. 

  1469. 		    foreach t [$path gettags $it] {
    1470. 

  1470. 			if { [regsub {^txt=} $t "" tx] } {
    1471. 

  1471. 			    lappend r [list [expr round($y)] $tx]
    1472. 

  1472. 			    break
    1473. 

  1473. 			}
    1474. 

  1474. 		    }
    1475. 

  1475. 		}
    1476. 

  1476. 	    }
    1477. 

  1477. 	    foreach p [lsort -integer -index 0 $r] {
    1478. 

  1478. 		lappend res [lindex $p 1]
    1479. 

  1479. 	    }
    1480. 

  1480. 	}
    1481. 

  1481. 	gettags {
    1482. 

  1482. 	    # INDEX ?INDEX?
    1483. 

  1483. 	    if { $nargs < 1 } { BUG missing args to ImageListbox gettags }
    1484. 

  1484. 	    foreach "a1 a2" [ImageListboxIndices $path $end [list $a1 $a2]] {}
    1485. 

  1485. 	    if { $a2 == "" } { set a2 $a1 }
    1486. 

  1486. 	    set y0 [expr $a1*$eh] ; set yn [expr ($a2+1)*$eh]
    1487. 

  1487. 	    set r ""
    1488. 

  1488. 	    foreach it [$path find withtag txt] {
    1489. 

  1489. 		if { [set y [lindex [$path coords $it] 1]] >= $y0 && \
    1490. 

  1490. 			 $y < $yn } {
    1491. 

  1491. 		    foreach t [$path gettags $it] {
    1492. 

  1492. 			if { [regsub {^tgs=} $t "" tgs] } {
    1493. 

  1493. 			    lappend r [list [expr round($y)] $tgs]
    1494. 

  1494. 			    break
    1495. 

  1495. 			}
    1496. 

  1496. 		    }
    1497. 

  1497. 		}
    1498. 

  1498. 	    }
    1499. 

  1499. 	    foreach p [lsort -integer -index 0 $r] {
    1500. 

  1500. 		lappend res [lindex $p 1]
    1501. 

  1501. 	    }
    1502. 

  1502. 	}
    1503. 

  1503. 	selset {
    1504. 

  1504. 	    # INDEX ?INDEX?
    1505. 

  1505. 	    # add to selection, irrespective of $mode
    1506. 

  1506. 	    # keep selection list ordered
    1507. 

  1507. 	    if { $nargs < 1 } { BUG missing args to ImageListbox selset }
    1508. 

  1508. 	    foreach "a1 a2" [ImageListboxIndices $path $end [list $a1 $a2]] {}
    1509. 

  1509. 	    if { $a2 == "" } { set a2 $a1 }
    1510. 

  1510. 	    set y0 [expr $a1*$eh+2]
    1511. 

  1511. 	    set s ""
    1512. 

  1512. 	    foreach ix $sel {
    1513. 

  1513. 		if { $ix == $a1 } {
    1514. 

  1514. 		    if { [incr a1] > $a2 } {
    1515. 

  1515. 			set a1 1e10
    1516. 

  1516. 		    } else { set y0 [expr $y0+$eh] }
    1517. 

  1517. 		} else {
    1518. 

  1518. 		    while { $a1 < $ix } {
    1519. 

  1519. 			ImageListboxSelect sel $path $y0
    1520. 

  1520. 			lappend s $a1
    1521. 

  1521. 			if { [incr a1] > $a2 } {
    1522. 

  1522. 			    set a1 1e10
    1523. 

  1523. 			} else { set y0 [expr $y0+$eh] }
    1524. 

  1524. 		    }
    1525. 

  1525. 		}
    1526. 

  1526. 		lappend s $ix
    1527. 

  1527. 	    }
    1528. 

  1528. 	    while { $a1 <= $a2 } {
    1529. 

  1529. 		ImageListboxSelect sel $path $y0
    1530. 

  1530. 		lappend s $a1
    1531. 

  1531. 		incr a1 ; set y0 [expr $y0+$eh]
    1532. 

  1532. 	    }
    1533. 

  1533. 	    set GMIBox($path,sel) $s
    1534. 

  1534. 	    update idletasks
    1535. 

  1535. 	}
    1536. 

  1536. 	selclr {
    1537. 

  1537. 	    # INDEX ?INDEX?
    1538. 

  1538. 	    # keep selection list ordered
    1539. 

  1539. 	    if { $nargs < 1 } { BUG missing args to ImageListbox selclr }
    1540. 

  1540. 	    foreach "a1 a2" [ImageListboxIndices $path $end [list $a1 $a2]] {}
    1541. 

  1541. 	    if { $a2 == "" } { set a2 $a1 }
    1542. 

  1542. 	    set s ""
    1543. 

  1543. 	    foreach ix $sel {
    1544. 

  1544. 		if { $ix >= $a1 && $ix <= $a2 } {
    1545. 

  1545. 		    ImageListboxSelect clear $path [expr $ix*$eh+2]
    1546. 

  1546. 		} else { lappend s $ix }
    1547. 

  1547. 	    }
    1548. 

  1548. 	    set GMIBox($path,sel) $s
    1549. 

  1549. 	    update idletasks
    1550. 

  1550. 	}
    1551. 

  1551. 	cursel {
    1552. 

  1552. 	    set res $sel
    1553. 

  1553. 	}
    1554. 

  1554. 	getsel {
    1555. 

  1555. 	    set dy [expr $eh-1]
    1556. 

  1556. 	    foreach ix $sel {
    1557. 

  1557. 		set y0 [expr $ix*$eh]
    1558. 

  1558. 		foreach it [$path find overlapping 0 $y0 100 [expr $y0+$dy]] {
    1559. 

  1559. 		    foreach t [$path gettags $it] {
    1560. 

  1560. 			if { [regsub {^txt=} $t "" tx] } {
    1561. 

  1561. 			    lappend res $tx
    1562. 

  1562. 			    break
    1563. 

  1563. 			}
    1564. 

  1564. 		    }
    1565. 

  1565. 		}
    1566. 

  1566. 	    }
    1567. 

  1567. 	}
    1568. 

  1568. 	getseltags {
    1569. 

  1569. 	    foreach ix $sel {
    1570. 

  1570. 		set y0 [expr ($ix+0.5)*$eh]
    1571. 

  1571. 		foreach it [$path find overlapping 0 $y0 100 [expr $y0+4]] {
    1572. 

  1572. 		    foreach t [$path gettags $it] {
    1573. 

  1573. 			if { [regsub {^tgs=} $t "" tgs] } {
    1574. 

  1574. 			    lappend res $tgs
    1575. 

  1575. 			    break
    1576. 

  1576. 			}
    1577. 

  1577. 		    }
    1578. 

  1578. 		}
    1579. 

  1579. 	    }
    1580. 

  1580. 	}
    1581. 

  1581. 	seldel {
    1582. 

  1582. 	    set dy [expr -$eh]
    1583. 

  1583. 	    foreach ix [lsort -integer -decreasing $sel] {
    1584. 

  1584. 		# move lower entries up
    1585. 

  1585. 		set y0 [expr $ix*$eh] ; set yn [expr $y0+$eh]
    1586. 

  1586. 		foreach it [$path find withtag entry] {
    1587. 

  1587. 		    if { [set y [lindex [$path coords $it] 1]] >= $yn } {
    1588. 

  1588. 			$path move $it 0 $dy
    1589. 

  1589. 		    } elseif { $y >= $y0 } { $path delete $it }
    1590. 

  1590. 		}
    1591. 

  1591. 	    }
    1592. 

  1592. 	    set GMIBox($path,csize) [expr $csize-[llength $sel]]
    1593. 

  1593. 	    set GMIBox($path,sel) ""
    1594. 

  1594. 	    update idletasks
    1595. 

  1595. 	}
    1596. 

  1596. 	index {
    1597. 

  1597. 	    # Y (coordinates inside listbox)
    1598. 

  1598. 	    if { $nargs < 1 } { BUG missing args to ImageListbox index }
    1599. 

  1599. 	    set res [expr int($a1/$GMIBox($path,eh))+$GMIBox($path,base)]
    1600. 

  1600. 	    if { $res > $end } { set res $end }
    1601. 

  1601. 	}
    1602. 

  1602. 	default { BUG calling ImageListbox with wrong action }
    1603. 

  1603.     }
    1604. 

  1604.     return $res
    1605. 

  1605. }
    1606. 

    1607. 

  1607. proc ImageListboxScroll {path scr pos0 posf} {
    1608. 

  1608.     # scrolling image listbox
    1609. 

  1609.     #  $scr is scrollbar
    1610. 

  1610.     #  $pos0, $posf are the arguments to the scrolling command
    1611. 

  1611.     #     percentage of vertical dimension for top and bottom positions
    1612. 

  1612.     global GMIBox
    1613. 

    1614. 

  1614.     set s $GMIBox($path,csize)
    1615. 

  1615.     set GMIBox($path,base) [expr round($s*$pos0)]
    1616. 

  1616.     $scr set $pos0 $posf…
    1617.

Large files files are truncated, but you can click here to view the full file