1# 2# This file is part of: 3# 4# gpsman --- GPS Manager: a manager for GPS receiver data 5# 6# Copyright (c) 1998-2013 Miguel Filgueiras migfilg@t-online.de 7# 8# This program is free software; you can redistribute it and/or modify 9# it under the terms of the GNU General Public License as published by 10# the Free Software Foundation; either version 3 of the License, or 11# (at your option) any later version. 12# 13# This program is distributed in the hope that it will be useful, 14# but WITHOUT ANY WARRANTY; without even the implied warranty of 15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16# GNU General Public License for more details. 17# 18# You should have received a copy of the GNU General Public License 19# along with this program. 20# 21# File: gendials.tcl 22# Last change: 6 October 2013 23# 24# Includes contributions by 25# - Brian Baulch (baulchb_AT_onthenet.com.au) marked "BSB contribution" 26# - Stefan Heinen (stefan.heinen_AT_djh-freeweb.de) marked "SH contribution" 27# 28 29 # creating toplevels 30 31proc GMToplevel {w title geom trans prots binds} { 32 # create a toplevel with given geometry 33 # $w window path 34 # $title if not empty title given as either "==TITLE" for TITLE, 35 # or as an index in TXT array 36 # $trans if not void is path of window of which $w is a transient 37 # $prots list with in sequence a wm protocol and a command 38 # $binds list with in sequence an event and a command 39 # return $w 40 global TXT 41 42 if { $title != "" && ! [regsub {^==} $title "" title] } { 43 set title $TXT($title) 44 } 45 toplevel $w 46 if { $title != "" } { wm title $w "$title/GPSMan" } 47 wm geometry $w $geom 48 if { $trans != {} } { wm transient $w $trans } 49 wm group $w . 50 foreach {p c} $prots { wm protocol $w $p $c } 51 foreach {e c} $binds { bind $w $e $c } 52 return $w 53} 54 55 # modal dialogs 56 57proc GMMessage {mess args} { 58 # create modal dialog for displaying message 59 # if $args=="wait" return only when user acknowledges message 60 # except in command-line mode or if using the slow op window 61 # single button: OK; binding: return 62 global COLOUR EPOSX EPOSY TXT UNIX CMDLINE 63 64 if { $CMDLINE } { 65 puts stderr $mess 66 flush stderr 67 return 68 } 69 if { [winfo exists .slowop] } { 70 SlowOpMessage $mess 71 return 72 } 73 if { [winfo exists .mess] } { 74 # add new message 75 foreach s [pack slaves .mess.fr] { 76 if { $s == ".mess.fr.ok" } { break } 77 set last $s 78 } 79 if { ! [regexp {^\.mess\.fr\.text(.*)$} $last x n] } { 80 BUG bad last message field in .mess 81 return 82 } 83 if { $n == "" } { 84 set n 1 85 } else { 86 if { $n == 4 } { 87 .mess.fr.text4 configure -text $mess 88 update idletasks 89 return 90 } 91 incr n 92 } 93 label .mess.fr.text$n -text $mess 94 pack .mess.fr.text$n -side top -pady 5 -before .mess.fr.ok 95 update idletasks 96 return 97 } 98 # this avoids bugs but may create havoc with grabs 99 set gs [grab current] 100 GMToplevel .mess message +$EPOSX+$EPOSY . \ 101 [list WM_DELETE_WINDOW [list DestroyRGrabs .mess $gs]] \ 102 [list <Key-Return> [list DestroyRGrabs .mess $gs]] 103 if { ! $UNIX } { 104 # SH contribution 105 focus .mess 106 } 107 108 frame .mess.fr -borderwidth 5 -bg $COLOUR(messbg) 109 label .mess.fr.title -text "!!!" -relief sunken 110 label .mess.fr.text -text $mess 111 button .mess.fr.ok -text $TXT(ok) -command [list DestroyRGrabs .mess $gs] 112 pack .mess.fr -side top 113 # changes in packing order must be reflected above when adding 114 # new messages to existing window 115 pack .mess.fr.title .mess.fr.text .mess.fr.ok -side top -pady 5 116 RaiseWindow .mess 117 update idletasks 118 grab .mess 119 if { $args == "wait" } { 120 while 1 { 121 after 500 122 update 123 if { ! [winfo exists .mess] } { return } 124 } 125 } 126 return 127} 128 129proc GMConfirm {mess} { 130 # create modal dialog for asking for confirmation 131 # buttons: OK, Cancel; bindings: return, delete 132 global GMResConf COLOUR EPOSX EPOSY TXT CMDLINE 133 134 if { $CMDLINE } { return 1 } 135 destroy .messres 136 GMToplevel .messres message +$EPOSX+$EPOSY . \ 137 {WM_DELETE_WINDOW {set GMResConf 0}} \ 138 [list <Key-Return> {set GMResConf 1} \ 139 <Key-Delete> {set GMResConf 0}] 140 141 frame .messres.fr -borderwidth 5 -bg $COLOUR(confbg) 142 label .messres.fr.title -text "???" -relief sunken 143 label .messres.fr.text -text $mess 144 frame .messres.fr.bs 145 button .messres.fr.bs.ok -text $TXT(ok) -command { set GMResConf 1 } 146 button .messres.fr.bs.cancel -text $TXT(no) -command { set GMResConf 0 } 147 pack .messres.fr.bs.ok .messres.fr.bs.cancel -side left -pady 5 148 pack .messres.fr.title .messres.fr.text .messres.fr.bs -side top -pady 5 149 pack .messres.fr -side top 150 update idletasks 151 set gs [grab current] 152 grab .messres 153 RaiseWindow .messres 154 tkwait variable GMResConf 155 DestroyRGrabs .messres $gs 156 update idletasks 157 return $GMResConf 158} 159 160proc GMSelect {mess blist vlist} { 161 # create modal dialog for selecting values from $vlist under names in 162 # $blist; if an element in $blist has the form @LIST then the 163 # corresponding $vlist element is a list with one less element than LIST 164 # menubuttons are created for each @LIST element whose label is the 165 # first element of LIST, buttons being used for the other elements 166 # bindings: return for first, delete for last element, or their 167 # first elements in case of @LIST 168 # (see proc GMChooseFrom for selection using a listbox) 169 global GMResSel COLOUR EPOSX EPOSY TXT 170 171 # assumes first and last elements of vlist are return values for 172 # Return and Delete keys, respectively 173 174 destroy .messres 175 set e [lindex $blist 0] 176 if { [string first "@" $e] == 0 } { 177 set e [lindex [lindex $vlist 0] 0] 178 } else { set e [lindex $vlist 0] } 179 GMToplevel .messres selection +$EPOSX+$EPOSY . \ 180 [list WM_DELETE_WINDOW "set GMResSel [lindex $vlist 0]"] \ 181 [list <Key-Return> "set GMResSel $e"] 182 183 frame .messres.fr -borderwidth 5 -bg $COLOUR(selbg) 184 label .messres.fr.title -text "???" -relief sunken 185 label .messres.fr.text -text $mess 186 frame .messres.fr.frsel 187 set max 4 ; set c 0 ; set r 0 ; set lval "" ; set menus 0 188 foreach e $blist v $vlist { 189 set b .messres.fr.frsel.b$r$c 190 if { [regexp {^@(.+)$} $e x e] } { 191 if { [llength $e] != [llength $v]+1 } { 192 BUG GMSelect bad lengths of @LIST lists 193 } 194 incr menus 195 set lval [lindex $v 0] 196 menubutton $b -text [lindex $e 0] -menu $b.m 197 menu $b.m 198 foreach x [lreplace $e 0 0] y $v { 199 $b.m add command -label $x -command "set GMResSel $y" 200 } 201 } else { 202 set lval $v 203 button $b -text $e -command "set GMResSel $v" 204 } 205 grid $b -column $c -row $r -sticky ew 206 if { [incr c] >= $max } { 207 set c 0 ; incr r 208 } 209 } 210 bind .messres <Key-Delete> "set GMResSel $lval" 211 212 pack .messres.fr -side top 213 pack .messres.fr.title .messres.fr.text .messres.fr.frsel -side top -pady 5 214 set gs [grab current] 215 update idletasks 216 grab .messres 217 if { $menus } { 218 Raise .messres 219 } else { RaiseWindow .messres } 220 tkwait variable GMResSel 221 DestroyRGrabs .messres $gs 222 update idletasks 223 return $GMResSel 224} 225 226proc GMChooseFrom {how mess wd blist vlist args} { 227 # create modal dialog for selecting elements from list $blist 228 # with associated return values in $vlist 229 # $how in {single, many, many_0} defines number of elements that can 230 # be selected, many_0 meaning that 0 is an alternative 231 # a listbox is used with width $wd 232 # $args if present is a pair with $vars $descs, suitable for use 233 # with proc GMSetupParams, so that parameters may be selected 234 # buttons: OK, Cancel 235 # bindings: return for commit, extended select mode on listbox, 236 # make visible by initial char on listbox 237 # return list with selected values upon normal termination, and 238 # an empty list or -1 if $how==many_0 239 # (see also proc GMSelect for selection of only one element with buttons) 240 global GMResult DPOSX DPOSY COLOUR TXT UNIX 241 242 set w .gmchoosefr 243 if { [winfo exists $w] } { Raise $w ; bell ; return } 244 245 GMToplevel $w "==$mess" +$DPOSX+$DPOSY . \ 246 {WM_DELETE_WINDOW {set GMResult cnc}} \ 247 [list <Key-Return> {set GMResult ok}] 248 249 frame $w.fr -borderwidth 5 -bg $COLOUR(dialbg) 250 label $w.fr.text -text $mess 251 252 # adjust list height according to number of parameters 253 set lh [expr 15-[llength [lindex $args 0]]] 254 if { [set ll [llength $blist]] > $lh } { 255 set ll $lh 256 } 257 frame $w.fr.frbx 258 if { $how == "single" } { 259 set mode single 260 } else { set mode extended } 261 listbox $w.fr.frbx.bx -height $ll -width $wd -relief flat \ 262 -selectmode $mode -yscrollcommand "$w.fr.frbx.bscr set" \ 263 -exportselection 0 264 # SH contribution: no such bindings in non-unix systems 265 if { $UNIX } { 266 bind $w.fr.frbx.bx <Enter> { focus %W } 267 bind $w.fr.frbx.bx <Leave> "focus $w.fr.frbx" 268 } 269 bind $w.fr.frbx.bx <Key> { ScrollListIndex %W %A } 270 scrollbar $w.fr.frbx.bscr -command "$w.fr.frbx.bx yview" 271 foreach i $blist { $w.fr.frbx.bx insert end $i } 272 if { $ll == 1 } { $w.fr.frbx.bx selection set 0 } 273 274 if { $args != "" } { 275 set opts 1 276 frame $w.fr.fopt 277 foreach "menus es" \ 278 [GMSetupParams $w.fr.fopt [lindex $args 0] [lindex $args 1]] {} 279 } else { set opts 0 ; set menus 0 } 280 281 frame $w.fr.frbt 282 button $w.fr.frbt.ok -text $TXT(ok) -command { set GMResult ok } 283 button $w.fr.frbt.cnc -text $TXT(cancel) -command { set GMResult cnc } 284 285 pack $w.fr.frbt.ok $w.fr.frbt.cnc -side left -pady 5 286 pack $w.fr.frbx.bx $w.fr.frbx.bscr -side left -fill y 287 if { $opts } { 288 pack $w.fr.text $w.fr.frbx $w.fr.fopt $w.fr.frbt -side top -pady 5 289 } else { 290 pack $w.fr.text $w.fr.frbx $w.fr.frbt -side top -pady 5 291 } 292 pack $w.fr 293 294 update idletasks 295 set gs [grab current] 296 grab $w 297 if { $menus } { 298 Raise .fdlg 299 } else { RaiseWindow .fdlg } 300 while 1 { 301 tkwait variable GMResult 302 303 switch $GMResult { 304 "" { } 305 cnc { 306 if { $how == "many_0" } { set res -1 } else { set res "" } 307 break 308 } 309 ok { 310 set ss [$w.fr.frbx.bx curselection] 311 if { $ss == "" && $how != "many_0" } { 312 bell 313 continue 314 } 315 set res "" 316 foreach i $ss { 317 lappend res [lindex $vlist $i] 318 } 319 if { $opts } { 320 GMUseEntries $w.fr.fopt $es 321 } 322 break 323 } 324 } 325 } 326 DestroyRGrabs $w $gs 327 update idletasks 328 return $res 329} 330 331proc GMChooseParams {mess vars descs} { 332 # create modal dialog for choosing parameters 333 # $vars and $descs are as described in GMSetupParams 334 # buttons: OK, Cancel 335 # bindings: return for commit 336 # return 0 if cancelled 337 global GMResult DPOSX DPOSY COLOUR TXT 338 339 set w .gmchooseprsr 340 if { [winfo exists $w] } { Raise $w ; bell ; return } 341 342 GMToplevel $w "==$mess" +$DPOSX+$DPOSY . \ 343 {WM_DELETE_WINDOW {set GMResult cnc}} \ 344 [list <Key-Return> {set GMResult ok}] 345 346 frame $w.fr -borderwidth 5 -bg $COLOUR(dialbg) 347 label $w.fr.text -text $mess 348 349 frame $w.fr.fopt 350 foreach "menus es" [GMSetupParams $w.fr.fopt $vars $descs] {} 351 352 frame $w.fr.frbt 353 button $w.fr.frbt.ok -text $TXT(ok) -command { set GMResult ok } 354 button $w.fr.frbt.cnc -text $TXT(cancel) -command { set GMResult cnc } 355 356 pack $w.fr.frbt.ok $w.fr.frbt.cnc -side left -pady 5 357 pack $w.fr.text $w.fr.fopt $w.fr.frbt -side top -pady 5 358 pack $w.fr 359 360 update idletasks 361 set gs [grab current] 362 grab $w 363 if { $menus } { 364 Raise .fdlg 365 } else { RaiseWindow .fdlg } 366 while 1 { 367 tkwait variable GMResult 368 369 switch $GMResult { 370 "" { } 371 cnc { 372 set res 0 ; break 373 } 374 ok { 375 GMUseEntries $w.fr.fopt $es 376 set res 1 ; break 377 } 378 } 379 } 380 DestroyRGrabs $w $gs 381 update idletasks 382 return $res 383} 384 385proc GMLogin {service} { 386 # get or retrieve login information for accessing a given service 387 # $service is a unique name for the service, needed for displaying 388 # a message and indexing saved login information 389 # save the login information for use in the current session if the user 390 # asks for it 391 # return list with user name and password or an empty list if cancelled 392 global MESS TXT GMPInfo 393 394 if { ! [catch {set up $GMPInfo($service)}] } { return $up } 395 if { [GMChooseParams [format $MESS(loginto) $service] \ 396 {GMPInfo(__tmp,u) GMPInfo(__tmp,p) GMPInfo(__tmp,s)} \ 397 [list =$TXT(uname) =@$TXT(pword) @$TXT(remember)]] \ 398 == 0 } { return {} } 399 set up [list $GMPInfo(__tmp,u) $GMPInfo(__tmp,p)] 400 unset GMPInfo(__tmp,p) 401 if { $GMPInfo(__tmp,s) } { set GMPInfo($service) $up } 402 return $up 403} 404 405##### information window 406 407proc DisplayInfo {mess args} { 408 # display information on a dialog 409 # the dialog is created if it not exists, otherwise the message 410 # will be added to it 411 # $args may be "" or "tabs" followed by tabs list (man 3tk text) in 412 # which negative numbers are to be converted from chars to screen 413 # distances 414 global CMDLINE COLOUR EPOSX EPOSY TXT FixedFont DInfo 415 416 if { $CMDLINE } { return } 417 418 set frt .gminfo.fr.frt 419 if { ! [winfo exists .gminfo] } { 420 GMToplevel .gminfo info +$EPOSX+$EPOSY {} \ 421 {WM_DELETE_WINDOW {destroy .gminfo}} {} 422 423 frame .gminfo.fr -borderwidth 5 -bg $COLOUR(messbg) 424 label .gminfo.fr.title -text $TXT(info) -relief sunken 425 426 frame $frt -relief flat -borderwidth 0 427 text $frt.txt -width 80 -font $FixedFont -wrap word \ 428 -exportselection 1 -yscrollcommand "$frt.tscrl set" 429 bind $frt.txt <space> "$frt.txt yview scroll 1 pages ; break" 430 bind $frt.txt <Key-Delete> "$frt.txt yview scroll -1 pages ; break" 431 bind $frt.txt <Any-Key> break 432 bind $frt.txt <Button-2> break 433 scrollbar $frt.tscrl -command "$frt.txt yview" 434 435 set frb .gminfo.fr.frb 436 frame $frb -relief flat -borderwidth 0 437 button $frb.save -text $TXT(save) \ 438 -command "SaveDisplayInfo $frt.txt" 439 button $frb.ok -text $TXT(ok) -command { destroy .gminfo } 440 441 grid config $frt.txt -column 0 -row 1 -sticky nesw 442 grid config $frt.tscrl -column 1 -row 1 -sticky nesw 443 grid config $frb.save -column 0 -row 0 444 grid config $frb.ok -column 1 -row 0 445 pack .gminfo.fr.title $frt $frb -side top -pady 5 446 pack .gminfo.fr 447 448 # info on this window 449 catch {unset DInfo} 450 # to help setting tabs, make public the "ex" in pixels 451 set x20 "xxxxxxxxxxxxxxxxxxxx" 452 set DInfo(ex) [expr round([font measure $FixedFont $x20]/20.0)] 453 # number of next free tag; tags will have names started by "itg" 454 set DInfo(nxttag) 1 455 } 456 if { $args != "" } { 457 set tags "" 458 switch -- [lindex $args 0] { 459 tabs { 460 set tlst "" 461 foreach x [lindex $args 1] { 462 if { [regexp {^-([0-9]+)$} $x m n] } { 463 # to pixels 464 set x [expr $n*$DInfo(ex)] 465 } 466 lappend tlst $x 467 } 468 if { [catch {set tgname $DInfo($tlst)}] } { 469 set tgname itg$DInfo(nxttag) 470 incr DInfo(nxttag) 471 $frt.txt tag configure $tgname -tabs $tlst 472 set DInfo($tlst) $tgname 473 } 474 lappend tags $tgname 475 } 476 default { 477 BUG bad args to DisplayInfo 478 return 479 } 480 } 481 $frt.txt insert end "$mess\n" $tags 482 } else { $frt.txt insert end "$mess\n" } 483 $frt.txt see end 484 update idletasks 485 return 486} 487 488proc SaveDisplayInfo {wtxt} { 489 # save text in $wtxt text widget to file 490 global TXT 491 492 if { [set txt [$wtxt get 1.0 end]] == "" || \ 493 [set f [GMOpenFile $TXT(saveto) Info wapp]] == ".." } { return } 494 puts $f $txt 495 close $f 496 return 497} 498 499### dialog window for controlling slow operations 500 501proc SlowOpWindow {mess} { 502 # create dialog for controlling slow operation 503 # to be called by application before entering the main loop of the slow 504 # operation 505 # within the loop there should be calls to proc SlowOpAborted that 506 # returns 1 if the operation is to be aborted, or updates the interface 507 # and returns 0 otherwise 508 # any call within the loop to GMMessage will be diverted to this dialog 509 # after the main loop there should be a call to proc SlowOpFinish with 510 # the unique identifier that is returned by proc SlowOpWindow 511 # returns a unique identifier to be used when calling proc SlowOpWindow 512 global SlowOp COLOUR MAPCOLOUR EPOSX EPOSY TXT CMDLINE USESLOWOPWINDOW \ 513 FixedFont 514 515 if { $CMDLINE || ! $USESLOWOPWINDOW } { return } 516 if { [winfo exists .slowop] } { 517 set SlowOp(id) [clock seconds] 518 set SlowOp(ids) [linsert $SlowOp(ids) 0 $SlowOp(id)] 519 .slowop.fr.title configure -text $mess 520 return $SlowOp(id) 521 } 522 523 set id [clock seconds] 524 array set SlowOp [list aborting 0 id $id ids $id \ 525 status "$TXT(working)..." grabs [grab current]] 526 # avoid completely covering other dialogs 527 set pos [expr $EPOSX+150] 528 GMToplevel .slowop opinprogr +$pos+$EPOSY {} \ 529 {WM_DELETE_WINDOW {set SlowOp(aborting) 1}} {} 530 531 frame .slowop.fr -borderwidth 5 -bg $COLOUR(messbg) 532 label .slowop.fr.title -text $mess -relief sunken 533 534 set frs .slowop.fr.frs 535 frame $frs -relief flat -borderwidth 0 536 label $frs.st -textvariable SlowOp(status) -fg $MAPCOLOUR(trvwrnimportant) 537 checkbutton $frs.light -disabledforeground $COLOUR(check) -state disabled 538 539 set frt .slowop.fr.frt 540 frame $frt -relief flat -borderwidth 0 541 text $frt.txt -width 50 -font $FixedFont -wrap word \ 542 -yscrollcommand "$frt.tscrl set" 543 bind $frt.txt <space> "$frt.txt yview scroll 1 pages ; break" 544 bind $frt.txt <Key-Delete> "$frt.txt yview scroll -1 pages ; break" 545 bind $frt.txt <Any-Key> break 546 scrollbar $frt.tscrl -command "$frt.txt yview" 547 548 set frb .slowop.fr.frb 549 frame $frb -relief flat -borderwidth 0 550 button $frb.abort -text $TXT(abort) -command SlowOpAbort 551 button $frb.ok -text $TXT(ok) -state disabled \ 552 -command [list DestroyRGrabs .slowop $SlowOp(grabs)] 553 554 pack $frs.st $frs.light -side left 555 grid config $frt.txt -column 0 -row 1 -sticky nesw 556 grid config $frt.tscrl -column 1 -row 1 -sticky nesw 557 grid config $frb.abort -column 0 -row 0 558 grid config $frb.ok -column 1 -row 0 559 pack .slowop.fr.title $frs $frt $frb -side top -pady 5 560 pack .slowop.fr 561 update idletasks 562 grab .slowop 563 RaiseWindow .slowop 564 return $id 565} 566 567proc SlowOpFinish {id mess} { 568 # to be called by application when the operation ends (either normally 569 # or not) 570 # $id is unique identifier that was returned by proc SlowOpWindow 571 # if $id is not in the $SlowOp(ids) stack the message is displayed 572 # and nothing else happens 573 # $mess will be displayed if not empty 574 # the dialog window will be closed only when the stack of calls to 575 # proc SlowOpWindow is empty 576 # the dialog window is closed silently if there were no messages, 577 # otherwise the Ok button is activated and the user must acknowledge it 578 global SlowOp TXT 579 580 if { ! [winfo exists .slowop] } { 581 if { $mess != "" } { GMMessage $mess } 582 return 583 } 584 if { $mess != "" } { SlowOpMessage $mess } 585 if { [set ix [lsearch -exact $SlowOp(ids) $id]] == -1 || \ 586 [set SlowOp(ids) [lreplace $SlowOp(ids) 0 $ix]] != {} } { 587 return 588 } 589 if { ! $SlowOp(aborting) } { set SlowOp(status) $TXT(errwarn) } 590 set SlowOp(aborting) 0 591 set txt .slowop.fr.frt.txt 592 if { [$txt index end] == 2.0 } { 593 DestroyRGrabs .slowop $SlowOp(grabs) 594 return 595 } 596 set frb .slowop.fr.frb 597 foreach b "abort ok" st "disabled normal" { 598 $frb.$b configure -state $st 599 } 600 return 601} 602 603proc SlowOpAbort {} { 604 # the user aborted the operation 605 # not to be called directly from the application 606 global SlowOp TXT 607 608 set SlowOp(aborting) 1 609 set SlowOp(status) $TXT(aborted) 610 return 611} 612 613proc SlowOpMessage {mess} { 614 # show message in slow operation dialog window 615 # not to be called directly from the application 616 617 set txt .slowop.fr.frt.txt 618 $txt insert end "$mess\n" 619 $txt see end 620 update idletasks 621 return 622} 623 624proc SlowOpAborted {} { 625 # to be called by the application to test if the operation was aborted 626 # if not a call to update is made to ensure that the window is usable 627 # return 1 if yes 628 global SlowOp TXT 629 630 if { ! [winfo exists .slowop] } { return 0 } 631 if { $SlowOp(aborting) } { 632 set SlowOp(status) $TXT(aborted) 633 return 1 634 } 635 set frs .slowop.fr.frs 636 $frs.light toggle 637 update 638 return 0 639} 640 641### opening files 642 643proc GMOpenFile {act wh mode} { 644 # create modal dialog for selecting and opening a file 645 # $act is string describing the action to do on the file 646 # $wh in $filetypes (see proc GMStart, setup.tcl) 647 # $mode in {r, w, wapp} with wapp meaning write or possibly append 648 # buttons: OK, Cancel 649 # binding: return and double-left for commit, left-click for select 650 global GMResult COLOUR DPOSX DPOSY LISTHEIGHT File TXT MESS UNIX 651 652 if { [set f $File($wh)] == "" || [catch {cd [file dirname $f]}] } { 653 set currfile "" 654 } else { set currfile [file tail $f] } 655 if { $mode == "wapp" } { set mode a } 656 657 GMToplevel .fdlg file +$DPOSX+$DPOSY . \ 658 {WM_DELETE_WINDOW {set GMResult cnc}} \ 659 [list <Key-Return> {set GMResult ok}] 660 661 frame .fdlg.fr -borderwidth 5 -bg $COLOUR(selbg) 662 label .fdlg.fr.title -text [format $MESS(fileact) $act $TXT(name$wh)] \ 663 -relief sunken 664 if { ! $UNIX } { 665 menubutton .fdlg.fr.vols -text $TXT(volume) -menu .fdlg.fr.vols.m 666 menu .fdlg.fr.vols.m 667 bind .fdlg.fr.vols <Button-1> { 668 FillMenuExec .fdlg.fr.vols.m {ChangeVolume .fdlg} file volume 669 } 670 } 671 entry .fdlg.fr.wdir -width 30 672 ShowTEdit .fdlg.fr.wdir [pwd] 0 673 674 frame .fdlg.fr.frbx 675 listbox .fdlg.fr.frbx.box -height $LISTHEIGHT -width 30 \ 676 -yscrollcommand ".fdlg.fr.frbx.bscr set" \ 677 -selectmode single -exportselection 1 678 bind .fdlg.fr.frbx.box <Double-1> { 679 global GMResult 680 set GMResult [%W nearest %y] 681 } 682 bind .fdlg.fr.frbx.box <Button-1> { 683 .fdlg.fr.fn delete 0 end 684 .fdlg.fr.fn insert 0 [%W get [%W nearest %y]] 685 } 686 scrollbar .fdlg.fr.frbx.bscr -command ".fdlg.fr.frbx.box yview" 687 FillDir .fdlg.fr.frbx.box 688 689 entry .fdlg.fr.fn -width 30 690 .fdlg.fr.fn insert 0 $currfile 691 TextBindings .fdlg.fr.fn 692 693 frame .fdlg.fr.bs 694 button .fdlg.fr.bs.ok -text $TXT(ok) -command { set GMResult ok } 695 button .fdlg.fr.bs.cnc -text $TXT(cancel) \ 696 -command { set GMResult cnc } 697 698 pack .fdlg.fr.bs.ok .fdlg.fr.bs.cnc -side left -pady 5 699 pack .fdlg.fr.frbx.box .fdlg.fr.frbx.bscr -side left -fill y 700 if { $UNIX } { 701 pack .fdlg.fr.title .fdlg.fr.wdir .fdlg.fr.frbx .fdlg.fr.fn \ 702 .fdlg.fr.bs -side top -pady 5 703 } else { 704 pack .fdlg.fr.title .fdlg.fr.vols .fdlg.fr.wdir .fdlg.fr.frbx \ 705 .fdlg.fr.fn .fdlg.fr.bs -side top -pady 5 706 } 707 pack .fdlg.fr -side top 708 709 update idletasks 710 set gs [grab current] 711 grab .fdlg 712 RaiseWindow .fdlg 713 while 1 { 714 tkwait variable GMResult 715 716 switch $GMResult { 717 "" { } 718 cnc { 719 set res ".." 720 break 721 } 722 ok { 723 set fn [.fdlg.fr.fn get] 724 set f [GMCheckFile open $fn $mode] 725 if { $f != ".." } { 726 set File($wh) [file join [pwd] $fn] 727 set res $f 728 break 729 } 730 } 731 0 { 732 cd .. 733 ShowTEdit .fdlg.fr.wdir [pwd] 0 734 .fdlg.fr.frbx.box delete 0 end ; FillDir .fdlg.fr.frbx.box 735 .fdlg.fr.fn delete 0 end 736 } 737 default { 738 set fn [.fdlg.fr.frbx.box get $GMResult] 739 set f [GMCheckFile open $fn $mode] 740 if { $f != ".." } { 741 set File($wh) [file join [pwd] $fn] 742 set res $f 743 break 744 } 745 } 746 } 747 } 748 DestroyRGrabs .fdlg $gs 749 update idletasks 750 return $res 751} 752 753proc GMOpenFileParms {act wh mode vars vals} { 754 # create modal dialog for selecting and opening a file and parameters 755 # see arguments of proc GMGetFileName 756 757 set fname [GMGetFileName $act $wh $mode $vars $vals] 758 if { $fname == ".." } { return ".." } 759 if { $mode == "wapp" } { set mode a } 760 return [open $fname $mode] 761} 762 763proc GMGetFileName {act wh mode vars vals} { 764 # create modal dialog for selecting a file name and parameters 765 # $act is string describing the action to do on the file 766 # $wh in $filetypes (see proc GMStart, setup.tcl) 767 # $mode in {r, w, wapp} with wapp meaning write or possibly append 768 # $vars is list of (global) vars to set 769 # $vals is associated list of value descriptions (see proc GMSetupParams) 770 # buttons: OK, Cancel 771 # binding: return and double-left for commit, left-click for select 772 global GMResult COLOUR DPOSX DPOSY LISTHEIGHT File TXT MESS UNIX 773 774 if { [set f $File($wh)] == "" || [catch {cd [file dirname $f]}] } { 775 set currfile "" 776 } else { set currfile [file tail $f] } 777 778 GMToplevel .fdlg file +$DPOSX+$DPOSY . \ 779 {WM_DELETE_WINDOW {set GMResult cnc}} \ 780 [list <Key-Return> {set GMResult ok}] 781 782 frame .fdlg.fr -borderwidth 5 -bg $COLOUR(selbg) 783 label .fdlg.fr.title -text [format $MESS(fileact) $act $TXT(name$wh)] \ 784 -relief sunken 785 if { ! $UNIX } { 786 menubutton .fdlg.fr.vols -text $TXT(volume) -menu .fdlg.fr.vols.m 787 menu .fdlg.fr.vols.m 788 bind .fdlg.fr.vols <Button-1> { 789 FillMenuExec .fdlg.fr.vols.m {ChangeVolume .fdlg} file volume 790 } 791 } 792 entry .fdlg.fr.wdir -width 30 793 ShowTEdit .fdlg.fr.wdir [pwd] 0 794 795 # adjust list height according to number of parameters 796 set lh [expr $LISTHEIGHT-[llength $vars]] 797 frame .fdlg.fr.frbx 798 listbox .fdlg.fr.frbx.box -height $lh -width 30 \ 799 -yscrollcommand ".fdlg.fr.frbx.bscr set" \ 800 -selectmode single -exportselection 1 801 bind .fdlg.fr.frbx.box <Double-1> { 802 global GMResult 803 set GMResult [%W nearest %y] 804 } 805 bind .fdlg.fr.frbx.box <Button-1> { 806 .fdlg.fr.fn delete 0 end 807 .fdlg.fr.fn insert 0 [%W get [%W nearest %y]] 808 } 809 scrollbar .fdlg.fr.frbx.bscr -command ".fdlg.fr.frbx.box yview" 810 FillDir .fdlg.fr.frbx.box 811 # BSB contribution: wheelmouse scrolling 812 Mscroll .fdlg.fr.frbx.box 813 814 entry .fdlg.fr.fn -width 30 815 .fdlg.fr.fn insert 0 $currfile 816 TextBindings .fdlg.fr.fn 817 818 frame .fdlg.fr.fopt 819 foreach "menus es" [GMSetupParams .fdlg.fr.fopt $vars $vals] {} 820 821 frame .fdlg.fr.bs 822 button .fdlg.fr.bs.ok -text $TXT(ok) -command { set GMResult ok } 823 button .fdlg.fr.bs.cnc -text $TXT(cancel) \ 824 -command { set GMResult cnc } 825 826 pack .fdlg.fr.bs.ok .fdlg.fr.bs.cnc -side left -pady 5 827 pack .fdlg.fr.frbx.box .fdlg.fr.frbx.bscr -side left -fill y 828 if { $UNIX } { 829 pack .fdlg.fr.title .fdlg.fr.wdir .fdlg.fr.frbx .fdlg.fr.fn \ 830 .fdlg.fr.fopt .fdlg.fr.bs -side top -pady 5 831 } else { 832 pack .fdlg.fr.title .fdlg.fr.vols .fdlg.fr.wdir .fdlg.fr.frbx \ 833 .fdlg.fr.fn .fdlg.fr.fopt .fdlg.fr.bs -side top -pady 5 834 } 835 pack .fdlg.fr -side top 836 837 update idletasks 838 set gs [grab current] 839 grab .fdlg 840 if { $menus } { 841 Raise .fdlg 842 } else { RaiseWindow .fdlg } 843 while 1 { 844 tkwait variable GMResult 845 846 switch $GMResult { 847 "" { } 848 cnc { 849 set res ".." ; break 850 } 851 ok { 852 set fn [.fdlg.fr.fn get] 853 set f [GMCheckFile check $fn $mode] 854 if { $f != ".." } { 855 set File($wh) [file join [pwd] $fn] 856 GMUseEntries .fdlg.fr.fopt $es 857 set res $fn 858 break 859 } 860 } 861 0 { 862 cd .. 863 ShowTEdit .fdlg.fr.wdir [pwd] 0 864 .fdlg.fr.frbx.box delete 0 end ; FillDir .fdlg.fr.frbx.box 865 .fdlg.fr.fn delete 0 end 866 } 867 default { 868 set fn [.fdlg.fr.frbx.box get $GMResult] 869 set f [GMCheckFile check $fn $mode] 870 if { $f != ".." } { 871 set File($wh) [file join [pwd] $fn] 872 GMUseEntries .fdlg.fr.fopt $es 873 set res $fn 874 break 875 } 876 } 877 } 878 } 879 DestroyRGrabs .fdlg $gs 880 update idletasks 881 return $res 882} 883 884proc GMCheckFile {how f mode} { 885 # check name of file $f and if ok either open it and return file descriptor 886 # or return file name; otherwise return ".." 887 # $how in {open check} 888 # $mode in {r, w, wapp} 889 global PERMS TXT MESS 890 891 if { $f == "" } { bell ; return ".." } 892 if { [file isdirectory $f] } { 893 if { [file executable $f] } { 894 cd $f 895 ShowTEdit .fdlg.fr.wdir [pwd] 0 896 .fdlg.fr.frbx.box delete 0 end 897 FillDir .fdlg.fr.frbx.box 898 .fdlg.fr.fn delete 0 end 899 } else { 900 bell 901 } 902 } elseif { $mode == "r" } { 903 if { [file readable $f] } { 904 switch $how { 905 open { return [open $f r] } 906 check { return $f } 907 } 908 } else { bell } 909 } elseif { [file exists $f] } { 910 if { [file writable $f] } { 911 if { $mode == "w" } { 912 set l [list $TXT(ovwrt) $TXT(cancel)] 913 set r {w 0} 914 } else { 915 # appending is an option 916 set l [list $TXT(ovwrt) $TXT(app) $TXT(cancel)] 917 set r {w a 0} 918 } 919 if { [set m [GMSelect $MESS(filexists) $l $r]] != 0 } { 920 switch $how { 921 open { return [open $f $m $PERMS] } 922 check { return $f } 923 } 924 } 925 } else { bell } 926 } elseif { [file writable [pwd]] } { 927 switch $how { 928 open { 929 if { $mode == "wapp" } { set mode a } 930 return [open $f $mode $PERMS] 931 } 932 check { return $f } 933 } 934 } else { 935 bell 936 } 937 return ".." 938} 939 940proc ChangeVolume {w vol} { 941 # file volume has changed $vol in file-selection dialog $w 942 943 if { ! [file isdirectory $vol] } { bell ; return } 944 cd $vol 945 ShowTEdit .fdlg.fr.wdir [pwd] 0 946 .fdlg.fr.frbx.box delete 0 end ; FillDir .fdlg.fr.frbx.box 947 .fdlg.fr.fn delete 0 end 948 return 949} 950 951### font selection 952 953proc GMSelectFont {args} { 954 # dialog for selecting a font 955 # $args may contain the font description to return if the 956 # default is selected; if empty "default" is returned 957 # a font is defined by giving 958 # one of [font families] and 959 # the size in points or pixels, an integer > 0 960 # the weight, one of {normal bold} 961 # the slant, one of {roman italic} 962 # whether to use underline 963 # whether to use overstrike 964 # return empty list if cancelled, "default" or the description 965 # in $args, or list with family, size, and other style 966 # indicators in {normal bold roman italic underline overstrike} 967 # where size follows the Tk convention (negative if in pixels) 968 global GMFtDial TXT MESS LISTHEIGHT EPOSX EPOSY COLOUR 969 970 array set GMFtDial { 971 size 12 972 units points 973 weight normal 974 slant roman 975 underline 0 976 overstrike 0 977 } 978 979 if { [winfo exists .gmselfont] } { destroy .gmselfont } 980 set w [GMToplevel .gmselfont selfont +$EPOSX+$EPOSY . \ 981 {WM_DELETE_WINDOW {set GMFtDial(act) cancel}} \ 982 [list <Key-Return> {set GMFtDial(act) ok}]] 983 984 frame $w.fr -borderwidth 5 -bg $COLOUR(selbg) 985 label $w.fr.tit -text $TXT(selfont) 986 set frbx $w.fr.frbx 987 frame $frbx 988 listbox $frbx.box -height $LISTHEIGHT -width 40 -selectmode single \ 989 -yscrollcommand "$frbx.bscr set" -exportselection 1 990 scrollbar $frbx.bscr -command "$frbx.box yview" 991 grid $frbx.box -row 0 -column 0 992 grid $frbx.bscr -row 0 -column 1 -sticky ns 993 grid rowconfigure $frbx 0 -weight 1 994 grid columnconfigure $frbx 0 -weight 1 995 foreach fam [lsort -dictionary [font families]] { 996 $frbx.box insert end $fam 997 } 998 999 frame $w.fr.frp 1000 set vars {} ; set descs {} 1001 foreach v {size units weight slant underline overstrike} { 1002 lappend vars GMFtDial($v) 1003 } 1004 set descs [list "=$TXT(size)" \ 1005 "~$TXT(units)/[list points pixels]" \ 1006 "~$TXT(weight)/[list normal bold]" \ 1007 "~$TXT(slant)/[list roman italic]" \ 1008 "@$TXT(underline)" "@$TXT(overstrike)"] 1009 set pes [lindex [GMSetupParams $w.fr.frp $vars $descs] 1] 1010 1011 set frbs $w.fr.frbs 1012 frame $frbs 1013 foreach x {ok default cancel} { 1014 button $frbs.$x -text $TXT($x) -command "set GMFtDial(act) $x" 1015 pack $frbs.$x -side left 1016 } 1017 1018 pack $w.fr.tit 1019 pack $frbs -side bottom -pady 5 1020 pack $w.fr.frp -side bottom -pady 5 1021 # must be the last one 1022 pack $w.fr.frbx -fill both -expand 1 -pady 5 1023 1024 grid $w.fr 1025 grid rowconfigure $w.fr 0 -weight 1 1026 grid columnconfigure $w.fr 0 -weight 1 1027 grid rowconfigure $w 0 -weight 1 1028 grid columnconfigure $w 0 -weight 1 1029 1030 update idletasks 1031 # cannot use RaiseWindow because of menus 1032 set grabs [grab current] 1033 grab $w 1034 while 1 { 1035 tkwait variable GMFtDial(act) 1036 switch $GMFtDial(act) { 1037 cancel { 1038 set res {} ; break 1039 } 1040 default { 1041 if { [set res [lindex $args 0]] == {} } { 1042 set res default 1043 } 1044 break 1045 } 1046 ok { 1047 if { [set ix [$frbx.box curselection]] == {} } { 1048 GMMessage $MESS(mustselftfam) 1049 continue 1050 } 1051 GMUseEntries $w.fr.frp $pes 1052 set n [string trim $GMFtDial(size)] 1053 if { ! [CheckNumber GMMessage $n] } { continue } 1054 if { $n < 1 } { 1055 GMMessage [format $MESS(xcantbey) $TXT(size) 0] 1056 continue 1057 } 1058 if { $GMFtDial(units) == "pixels" } { 1059 set n [expr -$n] 1060 } 1061 set res [list [$frbx.box get $ix]] 1062 lappend res $n 1063 foreach x {weight slant} { lappend res $GMFtDial($x) } 1064 foreach x {underline overstrike} { 1065 if { $GMFtDial($x) } { lappend res $x } 1066 } 1067 break 1068 } 1069 } 1070 } 1071 DestroyRGrabs $w $grabs 1072 destroy $w 1073 return $res 1074} 1075 1076### utilities for dealing with parameters in a dialog 1077 1078proc GMSetupParams {w vars descs} { 1079 # set-up widgets for setting parameters in a dialog 1080 # $w is window parent 1081 # $vars is list of (global) vars to set; they must have a value 1082 # except those associated to entries which will be initialised to "" 1083 # and to menubuttons that if undefined will be initialised to ""; 1084 # array elements may also be given instead of normal variables but 1085 # the indices must be alphanumeric 1086 # $descs is associated list of value descriptions as: 1087 # @@TEXT button creating a balloon help with $TXT(TEXT), associated 1088 # variable declared as global but not used nor set 1089 # @TEXT checkbutton with label TEXT, values 0 1 1090 # =@TEXT non-echo entry with label TEXT 1091 # =TEXT entry with label TEXT 1092 # !TEXT=MENUPROC/ARGS menubutton with label TEXT and menu filled by 1093 # proc MENUPROC; the arguments to the MENUPROC call are: 1094 # - the menu window 1095 # - the command to be associated with final entries, whose 1096 # arguments are the selected value and the menu window 1097 # - the elements of the list ARGS 1098 # |TEXT/LIST label TEXT and menubutton with text-variable for values 1099 # in LIST 1100 # +TEXT/LIST radiobuttons with possible values in LIST, label TEXT 1101 # /TEXT|LIST radiobuttons with possible values in LIST, label TEXT 1102 # ~TEXT/LIST radiobuttons with possible values in LIST but their 1103 # names are in the array TXT, label TEXT 1104 # LIST radiobutton with possible values in LIST 1105 # LISTs above cannot have repeated elements 1106 # return pair with flag set if there are menubuttons, and list of entries, 1107 # each as a triple, usually with path from $w to entry, the name of 1108 # global (array or normal) variable to be used in "global" and complete 1109 # name of variable to be used in "set"; for non-echo entries the 1110 # path is prefixed by a "@"; the list can be processed by proc GMUseEntries 1111 global COLOUR TXT NEEntry 1112 1113 set i 0 ; set es "" ; set menus 0 1114 foreach v $vars os $descs { 1115 if { [regexp {^([^(]+)[(]([^)]+)[)]$} $v x vname el] } { 1116 set vid "${vname}___ARR_$el" 1117 } else { set vid $v ; set vname $v } 1118 global $vname 1119 frame $w.f$i 1120 switch -glob -- $os { 1121 @@* { 1122 set os [string replace $os 0 1] 1123 set bh $w.f$i.bh$vid 1124 BalloonButton $bh $os 1125 pack $bh 1126 } 1127 @* { 1128 set os [string replace $os 0 0] 1129 set cb $w.f$i.c$vid 1130 checkbutton $cb -text $os -variable $v -anchor w \ 1131 -onvalue 1 -offvalue 0 -selectcolor $COLOUR(check) 1132 if { [set $v] } { 1133 $cb select 1134 } else { $cb deselect } 1135 pack $cb 1136 } 1137 =* { 1138 if { [string index $os 1] == "@" } { 1139 set z 1 1140 } else { set z 0 } 1141 set os [string replace $os 0 $z] 1142 set wl [label $w.f$i.l$vid -text $os] 1143 set ppath f$i.e$vid 1144 set we [entry $w.f$i.e$vid -width 30] 1145 TextBindings $we 1146 if { $z } { 1147 set NEEntry($we) "" 1148 bind $we <Delete> "GMNEEntry $we _ BackSpace ; break" 1149 bind $we <Any-Key> "GMNEEntry $we %A %K ; break" 1150 set ppath "@$ppath" 1151 } 1152 if { [catch {set $v}] } { 1153 set $v "" 1154 } elseif { $z == 0 } { $we insert 0 [set $v] } 1155 pack $wl $we -side left 1156 lappend es [list $ppath $vname $v] 1157 } 1158 !* { 1159 set menus 1 1160 if { ! [regexp {^!([^=]+)=([^/]+)/(.*)$} $os \ 1161 m lab menuproc mpargs] } { 1162 BUG Bad argument to GMSetupParams ! 1163 } 1164 set mb $w.f$i.mb$vid 1165 menubutton $mb -text $lab -relief raised \ 1166 -direction below -menu $mb.m 1167 menu $mb.m 1168 eval $menuproc $mb.m GMChangeParam $mpargs 1169 if { [catch {set $v}] } { 1170 set $v "" 1171 } 1172 set wl [label $w.f$i.l$vid -textvariable $v] 1173 pack $mb $wl -side left 1174 } 1175 |* { 1176 set menus 1 1177 if { ! [regexp {^[|]([^/]+)/(.*)$} $os \ 1178 m lab lst] } { 1179 BUG Bad argument to GMSetupParams | 1180 } 1181 set wl [label $w.f$i.t$vid -text $lab -width 16] 1182 set mb $w.f$i.mb$vid 1183 menubutton $mb -textvariable $v -relief raised \ 1184 -direction below -menu $mb.m 1185 menu $mb.m 1186 foreach x $lst { 1187 $mb.m add command -label $x -command "set $v $x" 1188 } 1189 pack $wl $mb -side left 1190 } 1191 +* - /* - ~* { 1192 set labval [string first "~" $os] 1193 if { ! [regexp {^.([^/]+)/(.+)$} $os m lab lst] } { 1194 BUG Bad argument to GMSetupParams +/~ 1195 continue 1196 } 1197 1198 pack [label $w.f$i.l$vid -text $lab] -side left 1199 set k 0 1200 set wrb $w.f$i.r_${vid}_0 1201 foreach o $lst { 1202 if { $labval } { 1203 set lv $o 1204 } else { set lv $TXT($o) } 1205 set rb $w.f$i.r_${vid}_$k 1206 radiobutton $rb -text $lv -variable $v \ 1207 -value $o -anchor w -selectcolor $COLOUR(check) 1208 pack $rb -side left -padx 2 1209 if { [set $v] == $o } { set wrb $rb } 1210 incr k 1211 } 1212 $wrb invoke 1213 } 1214 default { 1215 set k 0 1216 set wrb $w.f$i.rd_${vid}_0 1217 foreach o $os { 1218 set rb $w.f$i.rd_${vid}_$k 1219 radiobutton $rb -text $o -variable $v \ 1220 -value $o -anchor w -selectcolor $COLOUR(check) 1221 pack $rb -side left -padx 2 1222 if { [set $v] == $o } { set wrb $rb } 1223 incr k 1224 } 1225 $wrb invoke 1226 } 1227 } 1228 pack $w.f$i -side top -fill x -expand 1 1229 incr i 1230 } 1231 return [list $menus $es] 1232} 1233 1234proc GMNEEntry {e char ksym} { 1235 # keep track of characters typed in a non-echo entry $e 1236 # current contents are kept on global NEEntry($e) that should be unset 1237 # after use 1238 global NEEntry PASSWDECHO 1239 1240 if { $PASSWDECHO == "none" } { 1241 echo 0 1242 $e delete 0 end 1243 } else { set echo 1 } 1244 if { $ksym == "BackSpace" } { 1245 set NEEntry($e) [string replace $NEEntry($e) end end] 1246 if { $echo } { $e delete 0 } 1247 return 1248 } 1249 if { $ksym == $char || $ksym == "??" || [regexp {^[a-z]} $ksym] } { 1250 append NEEntry($e) $char 1251 if { $echo } { $e insert end $PASSWDECHO } 1252 } 1253 return 1254} 1255 1256proc GMChangeParam {val varmenu args} { 1257 # parameter value changed by a selection in a menu 1258 # $varmenu is either the menu path assumed to have a single occurrence 1259 # of .mbVARID. or has the form =VARID where VARID either is the name 1260 # of the global simple variable to set, or has is the string 1261 # concatenation of a global array identifier, "___ARR_" and 1262 # an array index 1263 # $args may be TXT to force value to be $TXT($val) 1264 global TXT 1265 1266 if { ! [regexp {^=(.+)$} $varmenu x v] } { 1267 regexp {\.mb([^.]+)\.} $varmenu x v 1268 } 1269 if { [regexp {^(.+)___ARR_(.+)$} $v x v ix] } { 1270 global $v 1271 append v "(" $ix ")" 1272 } else { global $v } 1273 if { $args == "TXT" } { 1274 set val $TXT($val) 1275 } 1276 set $v $val 1277 return 1278} 1279 1280proc GMUseEntries {w es} { 1281 # set global variables according to entries set-up by proc GMSetupParams 1282 # $w is window parent 1283 # $es is list of triples usually with path from $w to entry, 1284 # name of global (array or normal) variable to be used in "global" and 1285 # complete name of variable to be used in "set"; for non-echo entries 1286 # the path is prefixed with a "@" 1287 # current contents of non-echo entries are kept on global array NEEntry 1288 # (see proc GMNEEntry) and corresponding elements are unset here 1289 global NEEntry 1290 1291 foreach e $es { 1292 global [lindex $e 1] 1293 if { [string index [set ppath [lindex $e 0]] 0] == "@" } { 1294 set ppath $w.[string replace $ppath 0 0] 1295 set v $NEEntry($ppath) 1296 unset NEEntry($ppath) 1297 } else { set v [$w.$ppath get] } 1298 set [lindex $e 2] $v 1299 } 1300 return 1301} 1302 1303### image listbox widget 1304 1305proc ImageListbox {act path args} { 1306 # implements a new widget whose model is a listbox but has entries 1307 # with an image and possibly a text label 1308 # $act is the action to perform and determines $args 1309 # create SIZE WIDTH EHEIGHT SELECTMODE ?SCROLLBAR? 1310 # insert INDEX IMAGE TEXT ?TAGS?; return either index or -1 if entry 1311 # can not be inserted because IMAGE cannot be displayed and TEXT 1312 # is empty 1313 # delete INDEX ?INDEX? 1314 # get INDEX ?INDEX? ; return list of texts in entries 1315 # gettags INDEX ?INDEX? ; return list of tags in entries 1316 # selclr INDEX ?INDEX? ; clear selected 1317 # selset INDEX ?INDEX? ; set as selected (irrespective of SELECTMODE) 1318 # cursel "" ; return list of indices of currently selected entries 1319 # getsel "" ; return list of texts in currently selected entries 1320 # getseltags "" ; return list of lists each with the tags in currently 1321 # selected entries 1322 # seldel "" ; delete selected entries 1323 # index Y ; return index of entry at y-coordinate (inside listbox) 1324 # destroyall "" ; destroy all image listboxes under window $path 1325 # where 1326 # SELECTMODE is one of {single, extended} 1327 # EHEIGHT is the height for the entries in pixels (minimum used: 5) 1328 # INDEX is either a numeric index from 0 or "end" 1329 # TAGS is a list 1330 # the widget should be packed or grided by caller after being created 1331 # images that have more than EHEIGHT-4 in width or height are either 1332 # truncated to that size if they are of type photo, or not displayed 1333 # information related to these widgets is stored in global array GMIBox 1334 # auxiliary images are created but never deleted; their names can be 1335 # retrieved from GMIBox(img,*) entries 1336 # bindings on entries: 1337 # <Button-1> deselects everything, selects entry 1338 # if SELECTMODE=="extended": 1339 # <Control-Button-1> toggles selection state of entry 1340 # <Shift-Button-1> selects range from last selected entry to entry 1341 global GMIBox COLOUR 1342 1343 if { $act == "destroyall" } { 1344 foreach n [array names GMIBox $path*,csize] { 1345 regsub {,csize$} $n "" lbox 1346 destroy $lbox 1347 } 1348 array unset GMIBox $path* 1349 return 1350 } 1351 if { [set nargs [llength $args]] != 0 } { 1352 foreach "a1 a2 a3 a4 a5" $args { break } 1353 } 1354 if { $act != "create" } { 1355 if { [catch {set csize $GMIBox($path,csize)}] } { 1356 BUG trying to use non-existing ImageListbox 1357 } 1358 set end $csize 1359 if { $end > 0 } { incr end -1 } 1360 foreach x "sel eh ew mode" { 1361 set $x $GMIBox($path,$x) 1362 } 1363 } 1364 set res "" 1365 switch $act { 1366 create { 1367 # SIZE WIDTH EHEIGHT MODE ?SCROLLBAR? 1368 if { $nargs < 4 } { BUG missing args to ImageListbox create } 1369 if { $a3 < 5 } { set a3 5 } 1370 set height [expr $a1*$a3] 1371 foreach x "csize sel eh ew mode anchor base height" \ 1372 v "0 {} $a3 $a2 $a4 {} 0 $height" { 1373 set GMIBox($path,$x) $v 1374 } 1375 canvas $path -height $height -width $a2 -confine 1 \ 1376 -borderwidth 2 -relief sunken 1377 if { $a5 != "" } { 1378 $path configure -yscrollincrement $a3 \ 1379 -yscrollcommand "ImageListboxScroll $path $a5" \ 1380 -scrollregion "0 0 $a2 $height" 1381 trace variable GMIBox($path,csize) w ImageListboxResize 1382 } 1383 $path bind entry <Shift-Button-1> \ 1384 "ImageListboxESButton $path %y ; break" 1385 $path bind entry <Control-Button-1> \ 1386 "ImageListboxECButton $path %y ; break" 1387 $path bind entry <Button-1> "ImageListboxEButton $path %y" 1388 } 1389 insert { 1390 # INDEX IMAGE TEXT ?TAGS? 1391 if { $nargs < 3 } { BUG missing args to ImageListbox insert } 1392 set ih [expr $eh-2] 1393 if { $a2 != "" && \ 1394 ([image width $a2] > $ih || [image height $a2] > $ih) } { 1395 if { [image type $a2] != "photo" } { 1396 if { $a3 == "" } { return -1 } 1397 set a2 "" 1398 } else { 1399 if { [catch {set im $GMIBox(img,for,$a2)}] } { 1400 set im [image create photo -width $ih -height $ih] 1401 $im copy $a2 -from 0 0 $ih $ih 1402 set GMIBox(img,for,$a2) $im 1403 } 1404 set a2 $im 1405 } 1406 } 1407 if { $a1 != "end" } { 1408 set na1 [ImageListboxIndices $path $end $a1] 1409 if { $a1 > $na1 } { 1410 # assuming given index must be an integer 1411 set na1 $csize 1412 } 1413 # update selection 1414 set s "" 1415 foreach e $GMIBox($path,sel) { 1416 if { $e >= $na1 } { incr e } 1417 lappend s $e 1418 } 1419 set GMIBox($path,sel) $s 1420 # move lower entries down 1421 set y0 [expr $na1*$eh] 1422 if { $csize > 0 && $na1 < $csize } { 1423 foreach it [$path find withtag entry] { 1424 if { [lindex [$path coords $it] 1] >= $y0 } { 1425 $path move $it 0 $eh 1426 } 1427 } 1428 } 1429 } else { set y0 [expr $csize*$eh] } 1430 $path create rectangle 1 [expr $y0+1] $ew [expr $y0+$eh] \ 1431 -fill $COLOUR(bg) -outline $COLOUR(bg) \ 1432 -tags [list txt entry bg "tgs=$a4"] 1433 # texts are created even if empty so that they can be retrieved 1434 $path create text [expr $eh+8] [expr $y0+$eh/2] -anchor w \ 1435 -text $a3 -fill $COLOUR(fg) \ 1436 -tags [list txt entry "txt=$a3"] 1437 if { $a2 != "" } { 1438 $path create image 5 [expr $y0+2] -anchor nw -image $a2 \ 1439 -tags "img entry" 1440 } 1441 incr GMIBox($path,csize) 1442 update idletasks 1443 } 1444 delete { 1445 # INDEX ?INDEX? 1446 if { $nargs < 1 } { BUG missing args to ImageListbox delete } 1447 foreach "a1 a2" [ImageListboxIndices $path $end [list $a1 $a2]] {} 1448 if { $a2 == "" } { set a2 $a1 } 1449 if { [set ndel [expr $a2-$a1+1]] == $csize } { 1450 $path delete all 1451 set GMIBox($path,sel) "" 1452 } else { 1453 # update selection 1454 set s "" 1455 foreach e $GMIBox($path,sel) { 1456 if { $e < $a1 } { 1457 lappend s $e 1458 } elseif { $e > $a2 } { 1459 lappend s [expr $e-$ndel] 1460 } 1461 } 1462 set GMIBox($path,sel) $s 1463 # move lower entries up 1464 set y0 [expr $a1*$eh] ; set yn [expr ($a2+1)*$eh] 1465 set dy [expr -$ndel*$eh] 1466 foreach it [$path find withtag entry] { 1467 if { [set y [lindex [$path coords $it] 1]] >= $y0 } { 1468 if { $y >= $yn } { 1469 $path move $it 0 $dy 1470 } else { $path delete $it } 1471 } 1472 } 1473 } 1474 set GMIBox($path,csize) [expr $csize-$ndel] 1475 update idletasks 1476 } 1477 get { 1478 # INDEX ?INDEX? 1479 if { $nargs < 1 } { BUG missing args to ImageListbox get } 1480 foreach "a1 a2" [ImageListboxIndices $path $end [list $a1 $a2]] {} 1481 if { $a2 == "" } { set a2 $a1 } 1482 set y0 [expr $a1*$eh] ; set yn [expr ($a2+1)*$eh] 1483 set r "" 1484 foreach it [$path find withtag txt] { 1485 if { [set y [lindex [$path coords $it] 1]] >= $y0 && \ 1486 $y < $yn } { 1487 foreach t [$path gettags $it] { 1488 if { [regsub {^txt=} $t "" tx] } { 1489 lappend r [list [expr round($y)] $tx] 1490 break 1491 } 1492 } 1493 } 1494 } 1495 foreach p [lsort -integer -index 0 $r] { 1496 lappend res [lindex $p 1] 1497 } 1498 } 1499 gettags { 1500 # INDEX ?INDEX? 1501 if { $nargs < 1 } { BUG missing args to ImageListbox gettags } 1502 foreach "a1 a2" [ImageListboxIndices $path $end [list $a1 $a2]] {} 1503 if { $a2 == "" } { set a2 $a1 } 1504 set y0 [expr $a1*$eh] ; set yn [expr ($a2+1)*$eh] 1505 set r "" 1506 foreach it [$path find withtag txt] { 1507 if { [set y [lindex [$path coords $it] 1]] >= $y0 && \ 1508 $y < $yn } { 1509 foreach t [$path gettags $it] { 1510 if { [regsub {^tgs=} $t "" tgs] } { 1511 lappend r [list [expr round($y)] $tgs] 1512 break 1513 } 1514 } 1515 } 1516 } 1517 foreach p [lsort -integer -index 0 $r] { 1518 lappend res [lindex $p 1] 1519 } 1520 } 1521 selset { 1522 # INDEX ?INDEX? 1523 # add to selection, irrespective of $mode 1524 # keep selection list ordered 1525 if { $nargs < 1 } { BUG missing args to ImageListbox selset } 1526 foreach "a1 a2" [ImageListboxIndices $path $end [list $a1 $a2]] {} 1527 if { $a2 == "" } { set a2 $a1 } 1528 set y0 [expr $a1*$eh+2] 1529 set s "" 1530 foreach ix $sel { 1531 if { $ix == $a1 } { 1532 if { [incr a1] > $a2 } { 1533 set a1 1e10 1534 } else { set y0 [expr $y0+$eh] } 1535 } else { 1536 while { $a1 < $ix } { 1537 ImageListboxSelect sel $path $y0 1538 lappend s $a1 1539 if { [incr a1] > $a2 } { 1540 set a1 1e10 1541 } else { set y0 [expr $y0+$eh] } 1542 } 1543 } 1544 lappend s $ix 1545 } 1546 while { $a1 <= $a2 } { 1547 ImageListboxSelect sel $path $y0 1548 lappend s $a1 1549 incr a1 ; set y0 [expr $y0+$eh] 1550 } 1551 set GMIBox($path,sel) $s 1552 update idletasks 1553 } 1554 selclr { 1555 # INDEX ?INDEX? 1556 # keep selection list ordered 1557 if { $nargs < 1 } { BUG missing args to ImageListbox selclr } 1558 foreach "a1 a2" [ImageListboxIndices $path $end [list $a1 $a2]] {} 1559 if { $a2 == "" } { set a2 $a1 } 1560 set s "" 1561 foreach ix $sel { 1562 if { $ix >= $a1 && $ix <= $a2 } { 1563 ImageListboxSelect clear $path [expr $ix*$eh+2] 1564 } else { lappend s $ix } 1565 } 1566 set GMIBox($path,sel) $s 1567 update idletasks 1568 } 1569 cursel { 1570 set res $sel 1571 } 1572 getsel { 1573 set dy [expr $eh-1] 1574 foreach ix $sel { 1575 set y0 [expr $ix*$eh] 1576 foreach it [$path find overlapping 0 $y0 100 [expr $y0+$dy]] { 1577 foreach t [$path gettags $it] { 1578 if { [regsub {^txt=} $t "" tx] } { 1579 lappend res $tx 1580 break 1581 } 1582 } 1583 } 1584 } 1585 } 1586 getseltags { 1587 foreach ix $sel { 1588 set y0 [expr ($ix+0.5)*$eh] 1589 foreach it [$path find overlapping 0 $y0 100 [expr $y0+4]] { 1590 foreach t [$path gettags $it] { 1591 if { [regsub {^tgs=} $t "" tgs] } { 1592 lappend res $tgs 1593 break 1594 } 1595 } 1596 } 1597 } 1598 } 1599 seldel { 1600 set dy [expr -$eh] 1601 foreach ix [lsort -integer -decreasing $sel] { 1602 # move lower entries up 1603 set y0 [expr $ix*$eh] ; set yn [expr $y0+$eh] 1604 foreach it [$path find withtag entry] { 1605 if { [set y [lindex [$path coords $it] 1]] >= $yn } { 1606 $path move $it 0 $dy 1607 } elseif { $y >= $y0 } { $path delete $it } 1608 } 1609 } 1610 set GMIBox($path,csize) [expr $csize-[llength $sel]] 1611 set GMIBox($path,sel) "" 1612 update idletasks 1613 } 1614 index { 1615 # Y (coordinates inside listbox) 1616 if { $nargs < 1 } { BUG missing args to ImageListbox index } 1617 set res [expr int($a1/$GMIBox($path,eh))+$GMIBox($path,base)] 1618 if { $res > $end } { set res $end } 1619 } 1620 default { BUG calling ImageListbox with wrong action } 1621 } 1622 return $res 1623} 1624 1625proc ImageListboxScroll {path scr pos0 posf} { 1626 # scrolling image listbox 1627 # $scr is scrollbar 1628 # $pos0, $posf are the arguments to the scrolling command 1629 # percentage of vertical dimension for top and bottom positions 1630 global GMIBox 1631 1632 set s $GMIBox($path,csize) 1633 set GMIBox($path,base) [expr round($s*$pos0)] 1634 $scr set $pos0 $posf 1635 return 1636} 1637 1638proc ImageListboxResize {a aix op} { 1639 # called by trace when $GMIBox($path,csize) has been changed 1640 # resize scroll region after a change of size in image listbox 1641 global GMIBox 1642 1643 regsub {,csize} $aix "" path 1644 if { ! [winfo exists $path] } { return } 1645 if { [set nh [expr $GMIBox($path,csize)*$GMIBox($path,eh)]] < \ 1646 [set max $GMIBox($path,height)] } { 1647 set nh $max 1648 } 1649 $path configure -scrollregion "0 0 $GMIBox($path,ew) $nh" 1650 return 1651} 1652 1653proc ImageListboxSelect {act path y0} { 1654 # change aspect of entry when selection state changes 1655 # $act in {sel, clear} 1656 global GMIBox COLOUR 1657 1658 if { $act != "sel" } { set act "" } 1659 foreach it [$path find overlapping 0 $y0 100 [expr $y0+4]]] { 1660 if { [lsearch -exact [$path gettags $it] bg] != -1 } { 1661 $path itemconfigure $it -fill $COLOUR(${act}bg) 1662 break 1663 } 1664 } 1665 return 1666} 1667 1668proc ImageListboxIndices {path end ixs} { 1669 # check indices of image-listbox widget that must be in (non-strict) 1670 # increasing order 1671 # $ixs is list of non-negative integers, "end", or "" (discarded) 1672 # $end is either 0 or current size-1 1673 # return list of integers in the 0..$end range 1674 1675 set r "" ; set min 0 1676 foreach ix $ixs { 1677 if { $ix == "" } { continue } 1678 if { $ix == "end" } { 1679 set ix $end 1680 } elseif { ! [regexp {^[1-9]*[0-9]+$} $ix] } { 1681 if { $ix != "end" } { BUG bad index for ImageListbox } 1682 set ix $end 1683 } elseif { $ix > $end } { 1684 set ix $end 1685 } 1686 if { $ix < $min } { BUG bad index for ImageListbox } 1687 set min $ix 1688 lappend r $ix 1689 } 1690 return $r 1691} 1692 1693proc ImageListboxEButton {path y} { 1694 # mouse button-1 on ImageListbox entry 1695 global GMIBox 1696 1697 if { $GMIBox($path,sel) != "" } { ImageListbox selclr $path 0 end } 1698 set ix [expr int($y/$GMIBox($path,eh))+$GMIBox($path,base)] 1699 ImageListbox selset $path $ix 1700 set GMIBox($path,anchor) $ix 1701 return 1702} 1703 1704proc ImageListboxECButton {path y} { 1705 # mouse control-button-1 on ImageListbox entry 1706 global GMIBox 1707 1708 if { $GMIBox($path,mode) != "extended" } { return } 1709 set ix [expr int($y/$GMIBox($path,eh))+$GMIBox($path,base)] 1710 if { [lsearch -exact $GMIBox($path,sel) $ix] != -1 } { 1711 ImageListbox selclr $path $ix 1712 set GMIBox($path,anchor) "" 1713 } else { 1714 ImageListbox selset $path $ix 1715 set GMIBox($path,anchor) $ix 1716 } 1717 return 1718} 1719 1720proc ImageListboxESButton {path y} { 1721 # mouse shift-button-1 on ImageListbox entry 1722 global GMIBox 1723 1724 if { $GMIBox($path,mode) != "extended" } { return } 1725 if { [set a $GMIBox($path,anchor)] == "" } { 1726 ImageListboxEButton $path $y 1727 return 1728 } 1729 if { [set ix [expr int($y/$GMIBox($path,eh))+$GMIBox($path,base)]] \ 1730 != $a } { 1731 if { $ix > $a } { 1732 ImageListbox selset $path $a $ix 1733 } else { ImageListbox selset $path $ix $a } 1734 } 1735 set GMIBox($path,anchor) $ix 1736 return 1737} 1738 1739