1#!/usr/bin/wish -f 2# 3# sam2p.tk 4# by pts@fazekas.hu at Sat Apr 6 13:14:37 CEST 2002 5# 6# OK: confirm quit 7# Imp: don't update widgets when error in job file 8# Imp: newline mangling when loading/saving files 9# Imp: /DCT, ability to type literal MiniPS code to an `entry' 10# Imp: Perl parser should signal error on <hex123> etc. 11# Imp: B2Press + Move + B2Release; inserts twice 12# Imp: initial `focus' 13# Imp: default values 14# Imp: tk-start with sh 15# Imp: to center of the resized window 16# Imp: tooltips (mouse button 2, 3) 17# Imp: less vertical padding 18# Imp: really detect what kind of -*-fixed fonts we have 19# Dat: TCL 8.0 doesn't have `string equal' 20# Dat: never do `.text mark set sel.first 1.5', beacuse this will override tag `sel' 21# Dat: `entry' widgets don't accept "insert + 1 chars" as a character index 22# Dat: tag-parser treats comments as legal tokens 23# Dat: <Insert> matches <Shift-Insert>, <Key-Insert> does not. 24# Dat: <Motion> is mouse motion event over the sub-window 25# Dat: <Enter> and <Leave> is an event sent when 26# SUXX: Tcl: 8.0 doesn't have [string map ...] 27# SUXX: Tk: radio and checkbuttons cannot be made smaller or larger 28# SUXX: Tk: color for -relief cannot be specified 29# SUXX: Tk: on UNIX, Tk converts "Times New Roman" to "times" unless specified as "-*-times new roman-*-*-*-*-*-*-*-*-*-*-iso8859-1" 30# SUXX: Tk: .text cursor width cannot be extended to the right only (not to the left) 31# SUXX: Tk: .text cannot show the last line on the top unless first==last 32# SUXX: Tk bug: echo `bind . <ButtonRelease-2> {put got}' | wish 33# Test: 1. press button2 2. move mouse 3. release button 4. move mouse 34# `got' is printed twice. Strange: works fine with button 1 and 3. 35# Even the following doesn't help: 36# echo `bind . <B2-ButtonRelease-2> {put got}' | wish 37# Even event parameters are useless to distinguish normal and duplicate 38# events. This is a bug even on all other X11 clients. May be a GPM bug 39# or an xlib bug?? 40 41# puts [file type alma] 42 43proc pts_PATH_sep {} { 44 global tcl_platform 45 if {0==[string compare windows $tcl_platform(platform)]} {return ;} 46 return : 47 # Imp: `macintosh' 48} 49 50proc pts_read_ok {filename} { 51 if {0==[string length $filename]} {return 0} 52 if {[catch {set t [file type $filename]}]} { 53 if {[catch {set t [file type [file dirname $filename]]}]} {return !d} 54 return !e 55 } 56 if {0!=[string compare $t file]} {return !f} 57 if {![file readable $filename]} {return !r} 58 return OK 59} 60 61proc pts_write_ok {filename} { 62 if {0==[string length $filename]} {return 0} 63 if {[catch {set t [file type $filename]}]} { 64 if {[catch {set t [file type [set dir [file dirname $filename]]]}]} {return !d} 65 if {0==[string compare $t directory] && [file writable $dir]} {return ++} 66 return !dw 67 } 68 if {0!=[string compare $t file]} {return !f} 69 if {![file writable $filename]} {return !w} 70 return OK 71} 72 73proc pts_direct_bindtags {w} { 74 #** Moves all binds associated with widget $w to directly widget itself. 75 ## Half idea: bindtags $w "$w [bindtags $w]" 76 # Dat: this assumes [lindex [bindtags $w] 0] == $w 77 foreach tag [bindtags $w] { 78 if {0!=[string compare $tag $w]} { 79 foreach evtseq [bind $tag] { 80 bind $w $evtseq [bind $w $evtseq]\n[bind $tag $evtseq] 81 } 82 } 83 } 84 bindtags $w $w 85} 86 87proc pts_readonly {w} { 88 #** @param $w text or entry 89 #** Makes the specified widget read-only. [$w configure -state disabled] 90 #** is not OK, because it makes the insertion cursor invisible. 91 pts_direct_bindtags $w 92 # SUXX: cannot be avoided. Example: we must disable <Key> (typing letters), 93 # but allow <Key-Left> 94 bind $w <Meta-Key-d> break 95 bind $w <Meta-Key-f> break 96 bind $w <Meta-Key-Delete> break 97 bind $w <Meta-Key-BackSpace> break 98 bind $w <Control-Key-d> break 99 bind $w <Control-Key-i> break 100 bind $w <Control-Key-k> break 101 bind $w <Control-Key-h> break 102 bind $w <Control-Key-t> break 103 bind $w <Key-BackSpace> break 104 bind $w <Key-Delete> break 105 bind $w <Key-Return> break 106 bind $w <Key-KP_Enter> break 107 bind $w <Key> break 108 bind $w <<PasteSelection>> break 109 bind $w <<Paste>> break 110 bind $w <<Cut>> break 111 bind $w <<Clear>> break 112} 113 114proc pts_readonly_color {w} { 115 #** Calls [pts_readonly $w], and sets widget colors etc. to make the user 116 #** see that it's a read-only widget. 117 pts_readonly $w 118 $w configure -background [[winfo toplevel $w] cget -background] -relief sunken 119} 120 121proc pts_listrev {list} { 122 # by pts@fazekas.hu at Sun Apr 21 21:08:20 CEST 2002 123 set i [llength $list] 124 set ret {} 125 while {$i>0} {incr i -1; lappend ret [lindex $list $i]} 126 return $ret 127} 128 129proc pts_listrev1 {list} { 130 #** Chops the 1st element of list, and returns the reverse of the rest. 131 # by pts@fazekas.hu at Sun Apr 21 21:08:20 CEST 2002 132 set i [llength $list] 133 set ret {} 134 while {$i>1} {incr i -1; lappend ret [lindex $list $i]} 135 return $ret 136} 137 138## puts [pts_listrev {1 2 {3 4}}]; exit 139 140set pts_unknown_font [font actual ..unknown..] 141proc pts_has_font {f} { 142 # by pts@fazekas.hu at Sat Apr 6 16:26:24 CEST 2002 143 # This is rather dirty, because there is no clean way to test whether a font 144 # exists in Tk. 145 #** return 1 or 0 146 global pts_unknown_font 147 if {0==[string compare fixed $f]} {return 1} 148 if {[string match -*-fixed-* $f]} {return 1} ;# Imp: first `*' shouldn't contain `-' 149 # Dat: pts_unknown_font is `fixed' on UNIX systems... 150 if {0==[string compare $pts_unknown_font [font actual $f]]} {return 0} 151 return 1 152} 153 154proc pts_last_font {first args} { 155 #** @param first,args list of font names (suitable arg for `-font' of widgets) 156 #** @return the last font name that is available 157 for {set i [llength $args]} {$i>0} {} { 158 incr i -1 159 if {[pts_has_font [set f [lindex $args $i]]]} {return $f} 160 } 161 return $first 162} 163 164proc pts_fix_shift_tab {} { 165 # by pts@fazekas.hu at Sat Apr 6 15:22:58 CEST 2002 166 set tmp [bind all <Shift-Key-Tab>] 167 ## puts $tmp 168 if {[string length $tmp]==0} {set tmp {tkTabToWindow [tk_focusPrev %]}} 169 bind all <Shift-Key-Tab> $tmp 170 catch {bind all <Key-ISO_Left_Tab> $tmp} 171 # ^^^ Dat: catch is here because some systems don't have ISO_Left_Tab 172} 173 174proc pts_fix_one_tab {wPath} { 175 # by pts@fazekas.hu at Sat Apr 6 15:38:43 CEST 2002 176 # pts_fix_shift_tab() should be called. 177 bind $wPath <Key-Tab> "[bind all <Key-Tab>]; break" 178 bind $wPath <Shift-Key-Tab> "[bind all <Shift-Key-Tab>]; break" 179 bind $wPath <Key-ISO_Left_Tab> "[bind all <Shift-Key-Tab>]; break" 180} 181 182proc pts_tag_set_first {w tagName index} { 183 if {[$w tag nextrange $tagName 1.0 end] != ""} { 184 if {[$w compare $index < $tagName.last]} { 185 if {[$w compare $index < $tagName.first]} \ 186 {$w tag add $tagName $index $tagName.first} \ 187 {$w tag remove $tagName $tagName.first $index} 188 } { 189 set tmp [$w index $tagName.last] 190 $w tag remove $tagName 1.0 end 191 $w tag add $tagName $tmp $index 192 } 193 } 194} 195proc pts_tag_set_last {w tagName index} { 196 if {[$w tag nextrange $tagName 1.0 end] != ""} { 197 if {[$w compare $index > $tagName.first]} { 198 if {[$w compare $index > $tagName.last]} \ 199 {$w tag add $tagName $tagName.last $index} \ 200 {$w tag remove $tagName $index $tagName.last} 201 } { 202 set tmp [$w index $tagName.first] 203 $w tag remove $tagName 1.0 end 204 $w tag add $tagName $index $tmp 205 } 206 } 207} 208 209proc pts_paste {w} {catch { 210 set tmp [$w index insert] 211 $w insert insert [selection get -displayof $w -selection CLIPBOARD] 212 $w tag remove sel 0.1 end 213 $w tag add sel $tmp insert 214}} 215 216proc pts_text_insert_newline {w autoindent} { 217 #** Doesn't respect overstrike mode (neither does Turbo Pascal). 218 #** Does auto-indenting of spaces and tabs. 219 if {[$w cget -state] == "disabled"} {return} 220 if $autoindent { 221 if {![string length [set tmp [$w search -regexp "\[^ \t]" {insert linestart} {insert lineend}]]]} {set tmp "insert lineend"} 222 $w insert insert \n[$w get {insert linestart} $tmp] 223 } {$w insert insert \n} 224 $w see insert 225} 226proc pts_text_autoindent {w bool} { 227 if $bool {} ;# early error message if bool is malformed 228 bind $w <Return> "pts_text_insert_newline %W $bool; break" 229} 230 231# vvv Overriding text.tcl, so we won't clobber the visible selection. 232proc tkTextInsert {w s} { 233 if {($s == "") || ([$w cget -state] == "disabled")} {return} 234 if {[string match "* 1" [bind $w <Insert>]]} { 235 # vvv in overstrike mode, overstrike only in the middle of the line 236 if {[$w compare insert != "insert lineend"]} {$w delete insert} 237 } 238 $w insert insert $s; $w see insert 239} 240 241#proc pts_text_insert {w s overstrike} { 242# if {($s == "") || ([$w cget -state] == "disabled")} {return} 243# set tmp [$w index insert] 244# # vvv in overstrike mode, overstrike only in the middle of the line 245# if {$overstrike && [$w compare insert != "insert lineend"]} {$w delete insert} 246# $w insert insert $s; $w see insert 247#} 248proc pts_text_overstrike {w bool} { 249 #puts [$w configure -insertontime] 250 #puts [$w configure -insertofftime] 251 if {$bool} {$w configure -insertofftime 0} \ 252 {$w configure -insertofftime [lindex [$w configure -insertofftime] 3]} 253 # Dat: we cannot override the widget's <KeyPress> method here, because then 254 # we won't be able to receive cursor movement etc. events, see docs in 255 # bindtags(n) and bind(n). So support must be built into tkTextInsert, 256 # since `bind Text <KeyPress> {tkTextInsert %W %A}' is the default. 257 # bind Text <KeyPress> "pts_text_insert %W %A $bool; break ;#alma" 258 focus .; focus $w ;# trick to avoid non-reblinking bug in Tk8.0 Linux. 259} 260proc pts_text_toggle_overstrike {w bool} { 261 if {$bool} {set bool 0} {set bool 1} 262 pts_text_overstrike $w $bool 263 bind $w <Insert> "pts_text_toggle_overstrike %W $bool" 264} 265proc pts_text_auto_overstrike {w bool} { 266 #** Sets overstrike mode, and binds Insert to do the switching. A 267 #** non-blinking cursor indicates overstrike mode. (Tk is too stupid to draw 268 #** a block cursor.) 269 #** @param w a text widget 270 pts_text_overstrike $w $bool 271 bind $w <Key-Insert> "pts_text_toggle_overstrike %W $bool" 272} 273 274# redefine tkScrollButtonDown, so it won't `sunken' the slider 275# (se tcl8.2/scrlbar.tcl) 276proc tkScrollButtonDown {w x y} { 277 global tkPriv 278 set tkPriv(relief) [$w cget -activerelief] 279 if {0==[string compare slider [set element [$w identify $x $y]]]} { 280 tkScrollStartDrag $w $x $y 281 } else { 282 $w configure -activerelief sunken 283 tkScrollSelect $w $element initial 284 } 285} 286proc tkScrollButton2Down {w x y} { 287 global tkPriv 288 set element [$w identify $x $y] 289 if {0==[string compare $element arrow1]||0==[string compare $element arrow2]} { 290 tkScrollButtonDown $w $x $y 291 return 292 } 293 tkScrollToPos $w [$w fraction $x $y] 294 set tkPriv(relief) [$w cget -activerelief] 295 update idletasks 296 # $w configure -activerelief sunken 297 $w activate slider 298 tkScrollStartDrag $w $x $y 299} 300 301option add *Dialog.msg.wrapLength 3i widgetDefault 302proc pts_message_box {args} { 303 global sa_normfont 304 #** similar to tkMessageBox; ignores platform's native MessageBox support. 305 global tkPriv tcl_platform 306 307 set w tkPrivMsgBox 308 upvar #0 $w data 309 310 # 311 # The default value of the title is space (" ") not the empty string 312 # because for some window managers, a 313 # wm title .foo "" 314 # causes the window title to be "foo" instead of the empty string. 315 # 316 set specs { 317 {-default "" "" ""} 318 {-icon "" "" "info"} 319 {-message "" "" ""} 320 {-parent "" "" .} 321 {-title "" "" " "} 322 {-type "" "" "ok"} 323 } 324 325 tclParseConfigSpec $w $specs "" $args 326 327 if {[lsearch {info warning error question} $data(-icon)] == -1} { 328 error "invalid icon \"$data(-icon)\", must be error, info, question or warning" 329 } 330 if {$tcl_platform(platform) == "macintosh"} { 331 if {$data(-icon) == "error"} { 332 set data(-icon) "stop" 333 } elseif {$data(-icon) == "warning"} { 334 set data(-icon) "caution" 335 } elseif {$data(-icon) == "info"} { 336 set data(-icon) "note" 337 } 338 } 339 340 if {![winfo exists $data(-parent)]} { 341 error "bad window path name \"$data(-parent)\"" 342 } 343 344 switch -- $data(-type) { 345 abortretryignore { 346 set buttons { 347 {abort -width 6 -text Abort -under 0} 348 {retry -width 6 -text Retry -under 0} 349 {ignore -width 6 -text Ignore -under 0} 350 } 351 } 352 ok { 353 set buttons { 354 {ok -width 6 -text OK -under 0} 355 } 356 if {$data(-default) == ""} { 357 set data(-default) "ok" 358 } 359 } 360 okcancel { 361 set buttons { 362 {ok -width 6 -text OK -under 0} 363 {cancel -width 6 -text Cancel -under 0} 364 } 365 } 366 retrycancel { 367 set buttons { 368 {retry -width 6 -text Retry -under 0} 369 {cancel -width 6 -text Cancel -under 0} 370 } 371 } 372 yesno { 373 set buttons { 374 {yes -width 6 -text Yes -under 0} 375 {no -width 6 -text No -under 0} 376 } 377 } 378 yesnocancel { 379 set buttons { 380 {yes -width 6 -text Yes -under 0} 381 {no -width 6 -text No -under 0} 382 {cancel -width 6 -text Cancel -under 0} 383 } 384 } 385 default { 386 error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel" 387 } 388 } 389 390 if {[string compare $data(-default) ""]} { 391 set valid 0 392 foreach btn $buttons { 393 if {![string compare [lindex $btn 0] $data(-default)]} { 394 set valid 1 395 break 396 } 397 } 398 if {!$valid} { 399 error "invalid default button \"$data(-default)\"" 400 } 401 } 402 403 # 2. Set the dialog to be a child window of $parent 404 # 405 # 406 if {[string compare $data(-parent) .]} { 407 set w $data(-parent).__tk__messagebox 408 } else { 409 set w .__tk__messagebox 410 } 411 412 # 3. Create the top-level window and divide it into top 413 # and bottom parts. 414 415 catch {destroy $w} 416 toplevel $w -class Dialog 417 wm title $w $data(-title) 418 wm iconname $w Dialog 419 wm protocol $w WM_DELETE_WINDOW { } 420 wm transient $w $data(-parent) 421 if {$tcl_platform(platform) == "macintosh"} { 422 unsupported1 style $w dBoxProc 423 } 424 425 frame $w.bot 426 pack $w.bot -side bottom -fill both 427 frame $w.top 428 pack $w.top -side top -fill both -expand 1 429 if {$tcl_platform(platform) != "macintosh"} { 430 $w.bot configure -relief raised -bd 1 431 $w.top configure -relief raised -bd 1 432 } 433 434 # 4. Fill the top part with bitmap and message (use the option 435 # database for -wraplength so that it can be overridden by 436 # the caller). 437 438 label $w.msg -justify left -text $data(-message) 439 #catch {$w.msg configure -font \ 440 # -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-* 441 #} 442 pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m 443 if {$data(-icon) != ""} { 444 label $w.bitmap -bitmap $data(-icon) 445 pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m 446 } 447 448 # 5. Create a row of buttons at the bottom of the dialog. 449 450 set i 0 451 foreach but $buttons { 452 set name [lindex $but 0] 453 set opts [lrange $but 1 end] 454 if {![string compare $opts {}]} { 455 # Capitalize the first letter of $name 456 set capName \ 457 [string toupper \ 458 [string index $name 0]][string range $name 1 end] 459 set opts [list -text $capName] 460 } 461 462 eval button $w.$name $opts -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 -command [list "set tkPriv(button) $name"] 463 464 if {![string compare $name $data(-default)]} { 465 $w.$name configure -default active 466 } 467 pack $w.$name -in $w.bot -side left -expand 1 \ 468 -padx 3m -pady 2m 469 470 # create the binding for the key accelerator, based on the underline 471 # 472 set underIdx [$w.$name cget -under] 473 if {$underIdx >= 0} { 474 set key [string index [$w.$name cget -text] $underIdx] 475 bind $w <Alt-[string tolower $key]> "$w.$name invoke" 476 bind $w <Alt-[string toupper $key]> "$w.$name invoke" 477 } 478 incr i 479 } 480 481 # 6. Create a binding for <Return> on the dialog if there is a 482 # default button. 483 484 if {[string compare $data(-default) ""]} { 485 bind $w <Return> "tkButtonInvoke $w.$data(-default)" 486 } 487 488 # 7. Withdraw the window, then update all the geometry information 489 # so we know how big it wants to be, then center the window in the 490 # display and de-iconify it. 491 492 wm withdraw $w 493 update idletasks 494 set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \ 495 - [winfo vrootx [winfo parent $w]]}] 496 set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \ 497 - [winfo vrooty [winfo parent $w]]}] 498 wm geom $w +$x+$y 499 wm deiconify $w 500 501 # 8. Set a grab and claim the focus too. 502 503 set oldFocus [focus] 504 set oldGrab [grab current $w] 505 if {$oldGrab != ""} { 506 set grabStatus [grab status $oldGrab] 507 } 508 grab $w 509 if {[string compare $data(-default) ""]} { 510 focus $w.$data(-default) 511 } else { 512 focus $w 513 } 514 515 # 9. Wait for the user to respond, then restore the focus and 516 # return the index of the selected button. Restore the focus 517 # before deleting the window, since otherwise the window manager 518 # may take the focus away so we can't redirect it. Finally, 519 # restore any grab that was in effect. 520 521 tkwait variable tkPriv(button) 522 catch {focus $oldFocus} 523 destroy $w 524 if {$oldGrab != ""} { 525 if {$grabStatus == "global"} { 526 grab -global $oldGrab 527 } else { 528 grab $oldGrab 529 } 530 } 531 return $tkPriv(button) 532} 533 534 535# --- 536 537proc sa_radio {framePath variable value labelCaption args} { 538 global $variable sa_normfont 539 # Imp: use -text 540 set $variable "" 541 frame $framePath 542 lappend args -variable $variable -value $value -indicatoron true -borderwidth 1 543 # lappend args -value $value -indicatoron true -borderwidth 1 544 eval "radiobutton $framePath.r $args" 545 546 $framePath.r configure -activebackground [$framePath.r cget -background] 547 label $framePath.l -text $labelCaption -font $sa_normfont ;# Imp: Why doesn't -anchor work?? 548 bind $framePath.l <ButtonRelease-1> "$framePath.r invoke" 549 pack $framePath.r $framePath.l -side left 550 # bind $framePath.r <Key-ISO_Left_Tab> {tkTabToWindow [tk_focusPrev %W]} 551} 552#proc sa_radio_pack {framePath} {} 553proc sa_check {wPath variable labelCaption args} { 554 global sa_boldfont 555 # Imp: clicking to the right from the caption shouldn't have effect 556 lappend args -font $sa_boldfont -text $labelCaption -anchor w -borderwidth 1 -variable $variable 557 eval "checkbutton $wPath $args" 558 $wPath configure -activebackground [$wPath cget -background] 559} 560 561proc sa_check_update {wPath variable labelCaption} { 562 sa_check $wPath $variable $labelCaption -command "update_check $variable $wPath" 563} 564 565proc sa_int {framePath variable labelCaption entryWidth args} { 566 # Imp: clicking to the right from the caption shouldn't have effect 567 # Imp: check for int... 568 global sa_normfont sa_boldfont 569 frame $framePath ;# may already exist?? 570 label $framePath.l -text $labelCaption -font $sa_boldfont 571 lappend args -relief sunken -width $entryWidth -font $sa_normfont \ 572 -borderwidth 1 -foreground black -background white \ 573 -selectbackground yellow -selectforeground black -selectborderwidth 0 574 eval "entry $framePath.i $args" 575 pack $framePath.l $framePath.i -side left 576 # $framePath configure -activebackground [$framePath cget -background] 577} 578 579proc sa_w_text {args} { 580 lappend args -relief solid -highlightcolor gray30 \ 581 -borderwidth 1 -foreground black -background white \ 582 -selectbackground gray85 -selectforeground black -selectborderwidth 0 583 eval "text $args" 584} 585 586proc sa_w_entry {args} { 587 lappend args -relief sunken -borderwidth 1 -foreground black -background white \ 588 -selectbackground yellow -selectforeground black -selectborderwidth 0 589 eval "entry $args" 590} 591 592set sa_frame 0 593proc sa_vframe {parentPath} { 594 #** Creates and packs vertical frame, which is 5 pixel high 595 global sa_frame 596 set w $parentPath.saf[incr sa_frame] 597 frame $w -height 5 -width 1 598 pack $w -fill x 599} 600 601# vvv The mouse must be used to insert visible selection (of other apps) 602bind Text <Insert> {} 603 604bind Text <B2-Motion> {} 605bind Text <Button-2> {} 606# puts T[bind Text]T 607 608 609# vvv allow the well-known (almost indrustry standard) Windows/Borland/GTK 610# cliboard key bindings on all platforms 611event add <<Cut>> <Control-Key-x> <Shift-Key-Delete> 612event add <<Copy>> <Control-Key-c> <Control-Key-Insert> 613event add <<Paste>> <Control-Key-v> <Shift-Key-Insert> 614# event add <<PasteSelection>> <ButtonRelease-2> 615# Dat: <<Paste>> is normal, <Control-Key-v> paste, which requires prior 616# <Control-Key-c>. Works across applications. 617# Dat: <<PasteSelection>> is xterm/netscape-like paste, which does not 618# require <Control-Key-c>. Also works across applications. 619 620# vvv this <<Paste>> deletes current selection even on UNIX; but we don't like that 621# bind Text <<Paste>> {catch {%W delete sel.first sel.last}; catch {%W insert insert [selection get -displayof %W -selection CLIPBOARD]}} 622# vvv this <<Paste>> leaves visible selection intact 623# bind Text <<Paste>> {catch {%W insert insert [selection get -displayof %W -selection CLIPBOARD]}} 624# vvv this <<Paste>> sets visible selection to the newly pasted data 625bind Text <<Paste>> {pts_paste %W} 626 627# vvv our <<PasteSelection>> doesn't move the cursor (like xterm, unlike Motif) 628bind Text <<PasteSelection>> {pts_text_paste_selection %W %x %y} 629 630bind Text <B2-Motion> {} 631bind Text <Button-2> {} 632 633# bind Text <ButtonRelease-2> {puts evt; pts_text_paste_selection %W %x %y} 634#catch { 635#event delete <<PasteSelection>> <ButtonRelease-2> 636#} 637#catch { 638#event add <<PasteSelection>> <B2-ButtonRelease-2> 639#event add <<PasteSelection>> <Button-2> 640#} 641 642# puts EI[event info <<PasteSelection>>] 643# puts A[event info <<PasteSelection>>]BN 644 645proc pts_text_paste_selection {w x y} { 646 #** If has focus, than pastes visible selection to the unchanged cursor 647 #** position; otherwise claims focus and sets cursor position to mouse. 648 if {0==[string compare $w [focus -displayof $w]]} { 649 catch {$w insert insert [selection get -displayof $w]} 650 if {0==[string compare normal [$w cget -state]]} {focus $w} 651 } {$w mark set insert [tkTextClosestGap $w $x $y]; focus $w} 652} 653 654 655# vvv overrides text.tcl, doesn't clobber the selection. 656bind Text <1> {tkTextButton1 %W %x %y} 657 658proc ptsTextDelLn W { 659 # puts [%W index {insert linestart}]..[%W index {insert lineend + 1 chars}] 660 if {[$W compare {insert lineend + 1 chars} == end]} { 661 # <Control-y> in the last line must not move the cursor 662 $W delete {insert linestart} {insert lineend} 663 } { 664 $W delete {insert linestart} {insert lineend + 1 chars} 665 } 666} 667 668# vvv Overriding text.tcl, so we won't clobber the visible selection when moving 669# the cursor or just inserting 670proc tkTextSetCursor {w pos} { 671 if {[$w compare $pos == end]} {set pos {end - 1 chars}} 672 $w mark set insert $pos 673 # $w tag remove sel 1.0 end 674 $w see insert 675} 676 677# vvv Overriding text.tcl, so PageUp and PageDown will jump within the page. 678proc tkTextScrollPages {w count} { 679 set tmp [expr {([$w cget -height]-1)*$count}] 680 $w yview scroll $tmp units 681 return "insert + $tmp lines" 682} 683 684# vvv Overrides text.tcl with Turbo Pascal-style Shift+Arrow selection: 685# Shift+Movement-key, when moved _from_ either end of the selection, 686# updates that end appropriately. Otherwise, it clobbers the selection, 687# and creates a new selection from the current `insert' position to the 688# position the cursor is moved to. 689proc tkTextKeySelect {w newIndex} { 690 # puts "[$w index insert] -> [$w index $newIndex] ([$w index end])" 691 if {[$w compare end == $newIndex]} {set newIndex "end - 1 char"} 692 $w mark set anchor insert 693 if {[$w tag nextrange sel 1.0 end] == ""} { 694 if {[$w compare $newIndex < insert]} {$w tag add sel $newIndex insert} {$w tag add sel insert $newIndex} 695 } { # already have a selection 696 # puts "a=[$w index sel.first]-[$w index sel.last] i=[$w index insert]" 697 if {[$w compare insert == sel.first]} {pts_tag_set_first $w sel $newIndex} \ 698 elseif {[$w compare insert == sel.last]} {pts_tag_set_last $w sel $newIndex} \ 699 { $w tag remove sel 1.0 end 700 if {[$w compare $newIndex < insert]} {$w tag add sel $newIndex insert} {$w tag add sel insert $newIndex} 701 } 702 } 703 $w mark set insert $newIndex; $w see insert 704 update idletasks 705 # puts "[$w tag ranges sel]" 706 # puts "b=[$w index sel.first]-[$w index sel.last] i=[$w index insert]" 707} 708 709# Imp: ^K B: Control-Space, ^K K: Control-Shift-Space 710 711bind Text <Control-Key-y> {ptsTextDelLn %W} 712bind Text <Control-Key-Y> [bind Text <Control-Key-y>] 713bind Text <Control-Key-d> {if {[%W compare {insert + 1 chars} != end]} {%W delete insert}} 714# ^^^ ensures that pressing `Delete' on the last empty line is a no-op 715bind Text <Key-Delete> [bind Text <Control-Key-d>] 716# ^^^ don't clobber visible selection 717bind Text <Key-BackSpace> {if {[%W compare insert != 1.0]} {%W delete insert-1c; %W see insert}} 718# ^^^ don't clobber visible selection 719 720proc pts_entry_Delete {w} { 721 set i 0 722 set j -1 723 set k -1 724 set i [$w index insert] 725 catch {set j [$w index sel.first]} 726 catch {set k [$w index sel.last]} 727 if {0==[string compare $i $j] || 0==[string compare $i $k]} \ 728 {$w delete sel.first sel.last} \ 729 {$w delete insert} 730} 731 732bind Entry <B2-Motion> {} 733bind Entry <Button-2> {} 734 735# vvv Overrides entry.tcl, so it won't clobber the selection. 736bind Entry <Key-Delete> {pts_entry_Delete %W} 737# vvv Overrides entry.tcl, so it won't clobber the selection. 738bind Entry <Control-Key-d> {pts_entry_Delete %W} 739bind Entry <Control-Key-i> {%W insert insert \t} 740 741# vvv Overrides entry.tcl, so it won't clobber the selection. 742proc tkEntrySetCursor {w pos} {$w icursor $pos; tkEntrySeeInsert $w} 743# vvv Overrides entry.tcl, so it won't clobber the selection. 744proc tkEntryInsert {w s} {if {[string length $s]} { 745 $w insert insert $s 746 tkEntrySeeInsert $w 747}} 748# vvv Overrides entry.tcl with Turbo Pascal look and feel. 749proc tkEntryKeySelect {w new} { 750 if {[$w selection present]} { 751 set i [$w index insert] 752 if {[$w index sel.first]==$i} {$w selection from sel.last} \ 753 elseif {[$w index sel.last]==$i} {$w selection from sel.first} \ 754 {$w selection from insert} 755 } {$w selection from insert} 756 $w selection to $new 757 $w icursor $new 758 # tkEntrySeeInsert will be called by our caller. 759} 760# vvv Overrides entry.tcl, so it won't clobber the selection. 761proc tkEntryBackspace w { 762 set x [expr {[$w index insert] - 1}] 763 if {$x >= 0} {$w delete $x} 764 if {[$w index @0] >= [$w index insert]} { 765 set range [$w xview] 766 set left [lindex $range 0] 767 set right [lindex $range 1] 768 $w xview moveto [expr {$left - ($right - $left)/2.0}] 769 } 770} 771 772proc pts_entry_paste_selection {w x y} { 773 #** If has focus, than pastes visible selection to the unchanged cursor 774 #** position; otherwise claims focus and sets cursor position to mouse. 775 if {0==[string compare $w [focus -displayof $w]]} { 776 catch {$w insert insert [selection get -displayof $w]} 777 if {0==[string compare normal [$w cget -state]]} {focus $w} 778 } {$w icursor [tkEntryClosestGap $w $x]; focus $w} 779} 780bind Entry <<PasteSelection>> {pts_entry_paste_selection %W %x %y} 781bind Entry <Insert> {} ;# <Shift-Insert> already OK. 782 783 784# vvv override tk.tcl, so it won't select the whole Entry when tab is pressed} 785proc tkTabToWindow w {focus $w} 786 787# --- 788 789# vvv Imp: improve this on Windows 790set sa_normfont [pts_last_font \ 791 system variable helvetica \ 792 arial {arial -12 normal} \ 793 -adobe-helvetica-medium-r-normal--11-*-100-100-*-*-iso8859-* \ 794 -adobe-helvetica-medium-r-normal--12-*-75-75-*-*-iso8859-* \ 795 sansserif dialog}] 796set sa_boldfont [pts_last_font \ 797 sansserif system variable helvetica \ 798 arial {arial -12 bold} \ 799 -adobe-helvetica-bold-r-normal--12-*-75-75-*-*-iso8859-1 \ 800 -adobe-helvetica-bold-r-normal--11-80-100-100-p-60-iso8859-1 \ 801 dialogb] 802set sa_fixfont [pts_last_font \ 803 fixed systemfixed fixsedsys monospaced monospace \ 804 -*-fixed-*-*-*--13-*-*-*-*-*-iso8859-1 \ 805 -misc-fixed-medium-r-semicondensed--13-*-75-75-*-*-iso8859-1 \ 806 6x13] 807# puts sa_normfont=$sa_normfont; puts sa_boldfont=$sa_boldfont 808# Dat: 100 DPI, 14-point Helvetica is too large, 11-point is somewhat small 809 810option add *Dialog.msg.font $sa_normfont ;# respected 811option add *Dialog.Button*font $sa_boldfont ;# respected 812 813wm title . {sam2p Job Editor} 814set tk_StrictMotif 0 815pts_fix_shift_tab 816# . configure -bg red 817 818 819frame .gtop 820 821set g .gtop.g0 822frame $g 823 824label $g.lFileFormat -text FileFormat -anchor w -font $sa_boldfont 825sa_radio $g.fPSL1 FileFormat PSL1 "PS L1" -command {update_radio FileFormat PSL1} 826sa_radio $g.fPSLC FileFormat PSLC "PS LC" -command {update_radio FileFormat PSLC} 827sa_radio $g.fPSL2 FileFormat PSL2 "PS L2" -command {update_radio FileFormat PSL2} 828sa_radio $g.fPSL3 FileFormat PSL3 "PS L3" -command {update_radio FileFormat PSL3} 829sa_radio $g.fPDFB10 FileFormat PDFB1.0 "PDF B 1.0" -command {update_radio FileFormat PDFB1.0} 830sa_radio $g.fPDFB12 FileFormat PDFB1.2 "PDF B 1.2" -command {update_radio FileFormat PDFB1.2} 831sa_radio $g.fPDF10 FileFormat PDF1.0 "PDF 1.0" -command {update_radio FileFormat PDF1.0} 832sa_radio $g.fPDF12 FileFormat PDF1.2 "PDF 1.2" -command {update_radio FileFormat PDF1.2} 833sa_radio $g.fGIF89a FileFormat GIF89a "GIF 89a" -command {update_radio FileFormat GIF89a} 834sa_radio $g.fEmpty FileFormat Empty Empty -command {update_radio FileFormat Empty} 835sa_radio $g.fMeta FileFormat Meta Meta -command {update_radio FileFormat Meta} 836sa_radio $g.fPNM FileFormat PNM PNM -command {update_radio FileFormat PNM} 837sa_radio $g.fPAM FileFormat PAM PAM -command {update_radio FileFormat PAM} 838sa_radio $g.fPIP FileFormat PIP PIP -command {update_radio FileFormat PIP} 839sa_radio $g.fJPEG FileFormat JPEG JPEG -command {update_radio FileFormat JPEG} 840sa_radio $g.fTIFF FileFormat TIFF TIFF -command {update_radio FileFormat TIFF} 841sa_radio $g.fPNG FileFormat PNG PNG -command {update_radio FileFormat PNG} 842 843pack $g.lFileFormat -fill x 844pack $g.fPSL1 $g.fPSLC $g.fPSL2 $g.fPSL3 $g.fPDFB10 $g.fPDFB12 $g.fPDF10 $g.fPDF12 $g.fGIF89a \ 845 $g.fEmpty $g.fMeta $g.fPNM $g.fPAM $g.fPIP $g.fJPEG $g.fTIFF $g.fPNG -fill x 846frame $g.pFileFormat -height 5 -width 1 847pack $g.pFileFormat -fill x 848 849 850set g .gtop.g1 851frame $g 852 853label $g.lSampleFormat -text SampleFormat -anchor w -font $sa_boldfont 854sa_radio $g.fOpaque SampleFormat Opaque Opaque -command {update_radio SampleFormat Opaque} 855sa_radio $g.fTransparent SampleFormat Transparent Transparent -command {update_radio SampleFormat Transparent} 856sa_radio $g.fGray1 SampleFormat Gray1 "Gray 1" -command {update_radio SampleFormat Gray1} 857sa_radio $g.fIndexed1 SampleFormat Indexed1 "Indexed 1" -command {update_radio SampleFormat Indexed1} 858sa_radio $g.fMask SampleFormat Mask Mask -command {update_radio SampleFormat Mask} 859sa_radio $g.fTransparent2 SampleFormat Transparent2 "Transparent 2" -command {update_radio SampleFormat Transparent2} 860sa_radio $g.fGray2 SampleFormat Gray2 "Gray 2" -command {update_radio SampleFormat Gray2} 861sa_radio $g.fIndexed2 SampleFormat Indexed2 "Indexed 2" -command {update_radio SampleFormat Indexed2} 862sa_radio $g.fTransparent4 SampleFormat Transparent4 "Transparent 4" -command {update_radio SampleFormat Transparent4} 863sa_radio $g.fRGB1 SampleFormat RGB1 "RGB 1" -command {update_radio SampleFormat Rgb1} 864sa_radio $g.fGray4 SampleFormat Gray4 "Gray 4" -command {update_radio SampleFormat Gray4} 865sa_radio $g.fIndexed4 SampleFormat Indexed4 "Indexed 4" -command {update_radio SampleFormat Indexed4} 866sa_radio $g.fTransparent8 SampleFormat Transparent8 "Transparent 8" -command {update_radio SampleFormat Transparent8} 867sa_radio $g.fRgb2 SampleFormat Rgb2 "RGB 2" -command {update_radio SampleFormat Rgb2} 868sa_radio $g.fGray8 SampleFormat Gray8 "Gray 8" -command {update_radio SampleFormat Gray8} 869sa_radio $g.fIndexed8 SampleFormat Indexed8 "Indexed 8" -command {update_radio SampleFormat Indexed8} 870sa_radio $g.fRgb4 SampleFormat Rgb4 "RGB 4" -command {update_radio SampleFormat Rgb4} 871sa_radio $g.fRgb8 SampleFormat Rgb8 "RGB 8" -command {update_radio SampleFormat Rgb8} 872pack $g.lSampleFormat -fill x 873pack $g.fOpaque $g.fTransparent $g.fGray1 $g.fIndexed1 $g.fMask $g.fTransparent2 $g.fGray2 $g.fIndexed2 $g.fTransparent4 \ 874 $g.fRGB1 $g.fGray4 $g.fIndexed4 $g.fTransparent8 $g.fRgb2 $g.fGray8 \ 875 $g.fIndexed8 $g.fRgb4 $g.fRgb8 -fill x 876frame $g.pSampleFormat -height 5 -width 1 877pack $g.pSampleFormat -fill x 878 879set g .gtop.g2 880frame $g 881 882proc find_val_range {key} { 883 #** @param key for example "/Compression", "/InputFile", of type tKey 884 #** @return "" or [beg end] abs.index of the value associated with that key 885 #** (may span multiple tokens) 886 global jtw ;# text widget containing the tagged job file 887 set end 1.0 888 while {[llength [set lst [$jtw tag nextrange tKey $end]]]} { 889 set beg [lindex $lst 0] 890 set end [lindex $lst 1] 891 ##puts "key=<[$jtw get $beg $end]>" 892 set ikey [$jtw get $beg $end] 893 if {0==[string compare $ikey $key]} { 894 895 ## puts prev=[$jtw tag prevrange tAny $end] 896 set lst [$jtw tag prevrange tAny $end] 897 if {0!=[llength $lst] && [$jtw compare [lindex $lst 0] < $end] 898 && [$jtw compare $end < [lindex $lst 1]]} { 899 set lst [list $end [lindex $lst 1]] 900 } { 901 if {![llength [set lst [$jtw tag nextrange tAny $end]]]} return "" 902 # ^^^ Imp: show error: found, but no value 903 } 904 ##puts "lst=$lst end=$end." 905 ##eval "puts \[$jtw get $lst\]" 906 if {2!=[llength [set tns [$jtw tag names [lindex $lst 0]]]]} return "" 907 # ^^^ Imp: show error: found, but untagged value 908 ##puts LT=[lindex $tns 1]:$tns: 909 if {![llength [set lst [$jtw tag nextrange [lindex $tns 1] $end]]]} return "" 910 # ^^^ This trick is used to find only a single tag. A single tag often 911 # means a single PostScript token, but -- for example `(a)(b)' and 912 # `[]' contain a single tag, but two tokens. 913 # Imp: show better error message 914 set white [$jtw get $end [lindex $lst 0]] 915 ##puts aaa($white) 916 if {[regexp "\[^\\000\011-\015 ]" $white]} return "" 917 # ^^^ Imp: show error: key and value separated by non-whitespace 918 ##puts bbb 919 set beg [lindex $lst 0] 920 set end [lindex $lst 1] 921 set val [$jtw get $beg $end] 922 set openc [expr {2*[string match <<* $val]+[string match \\\[* $val]}] ;# ] 923 ## puts "openc=$openc; val=<$val>" 924 if {$openc} { 925 set end "$beg + $openc chars" 926 set openc 1 927 while {1} { 928 if {![llength [set lst [$jtw tag nextrange tBrac $end]]]} return "" 929 # ^^^ Imp: show error: unclosed >> 930 set val [$jtw get [lindex $lst 0] [lindex $lst 1]] 931 if {[string match <<* $val]} {incr openc; set end 2} \ 932 elseif {[string match \\\[* $val]} {incr openc; set end 1} \ 933 elseif {[string match >>* $val]} {incr openc -1; set end 2} \ 934 elseif {[string match \]* $val]} {incr openc -1; set end 1} \ 935 {return ""} 936 # ^^^ Imp: show error: invalid tBrac 937 set end "[lindex $lst 0] + $end chars" 938 if {!$openc} {return "$beg [$jtw index $end]"} 939 } 940 } 941 # puts "val=<$val>" 942 # return [$jtw get $beg $end] 943 return $lst 944 } 945 } 946 return "" 947} 948 949proc update_psval {key newval} { 950 #** return oldval or "" 951 global jtw 952 if {![llength [set found [find_val_range $key]]]} {return ""} 953 set oldval [eval "$jtw get $found"] 954 eval "$jtw delete $found" 955 set found [lindex $found 0] 956 if {[string match /* $newval]} {$jtw insert $found $newval {tAny tNameval}} \ 957 elseif {[string match (* $newval]} {$jtw insert $found $newval {tAny tString}} \ 958 elseif {[string match \[-0-9\]* $newval]} {$jtw insert $found $newval {tAny tInt}} \ 959 {$jtw insert $found $newval {tAny tSing}} 960 $jtw mark set insert "$found + 1 chars"; $jtw see insert 961 return $oldval 962} 963 964proc update_radio {key newval} { 965 global jtw 966 # puts "got=([find_val_range /Compression])" 967 #set found [find_val_range /Hints] 968 # set found [find_val_range /Profile] 969 #puts "found=$found." 970 #puts "is=([$jtw get [lindex $found 0] [lindex $found 1]])." 971 if {![string length [update_psval /$key /$newval]]} { 972 bell 973 pts_message_box -title Warning -message "Cannot find key /$key. Please verify that the .job file is correct." 974 } 975} 976 977proc update_check {key wPath} { 978 set varname [$wPath cget -variable] 979 global $varname 980 if {[set $varname]} {update_psval /$key true} {update_psval /$key false} 981} 982 983#set psstr_map "" 984#proc psstr_map_init {} { 985# for {set i 0} {$i<32} {incr i} {lappend psstr_map [format %c $i] [format \\%02o $i]} 986# for {set i 127} {$i<256} {incr i} {lappend psstr_map [format %c $i] [format \\%02o $i]} 987#} 988#(\\)' 989#psstr_map_init 990#regexp {^[] -'+-[^]+} str 991 992proc pts_psstr_q {str} { 993 #** This would be <60 chars in Perl. TCL is stupid, lame and sloow. 994 set ret "" 995 while {1} { 996 regexp {^[] -'+-[^-~]*} $str head 997 # ^^^ rejects low-unprintable, >=127, backslash, lparen and rparen 998 set ret $ret$head 999 if {[string length $str]==[set headlen [string length $head]]} break 1000 scan [string index $str $headlen] %c charcode 1001 set ret $ret[format \\%03o [expr {$charcode&255}]] 1002 set str [string range $str [expr {1+$headlen}] end] 1003 } 1004 return $ret 1005} 1006 1007proc update_str {key newval empty} { 1008 # Imp: regsub... 1009 # set newval [string map $psstr_map $newval] 1010 if {[string length $newval]} {set newval ([pts_psstr_q $newval])} {set newval $empty} 1011 if {![string length [update_psval /$key $newval]]} { 1012 bell 1013 pts_message_box -title Warning -message "Cannot find key /$key. Please verify that the .job file is correct." 1014 } 1015} 1016 1017proc update_int {key newval empty} { 1018 if {[catch {set intval [expr {0+$newval}]}] || [string compare $intval $newval]} {set intval $empty} 1019 if {![string length [update_psval /$key $intval]]} { 1020 bell 1021 pts_message_box -title Warning -message "Cannot find key /$key. Please verify that the .job file is correct." 1022 } 1023} 1024 1025proc but_save {} { 1026 global jtw jfn 1027 set f [open [$jfn get] w] 1028 catch {fconfigure $f -encoding binary} ;# TCL 8.2 1029 fconfigure $f -translation binary 1030 puts -nonewline $f [$jtw get 1.0 end] 1031 close $f 1032 # bell 1033} 1034 1035set tmpfnb "sam2p_tmp_[pid]" 1036 1037proc but_relight {} { 1038 # Imp: error checks 1039 # Imp: \n transl 1040 # set f [open |[list tr a-z A-Z >tmp.tmp] w] 1041 global jtw tmpfnb 1042 set f [open "|perl -I. -Msam2ptol -e sam2ptol::highlight $jtw >$tmpfnb.tjb" w] 1043 catch {fconfigure $f -encoding binary} ;# TCL 8.2 1044 fconfigure $f -translation binary 1045 puts -nonewline $f [$jtw get 1.0 end] 1046 close $f 1047 set f [open $tmpfnb.tjb r] 1048 catch {fconfigure $f -encoding binary} ;# TCL 8.2 1049 fconfigure $f -translation binary 1050 # puts [read $f] 1051 eval [read $f] 1052 close $f 1053 file delete -- $tmpfnb.tjb 1054} 1055 1056proc but_load {} { 1057 global jtw jfn tmpfnb 1058 if {[catch {set f [open [$jfn get] r]} err]} { 1059 pts_message_box -message "Load failed: $err" 1060 } { 1061 catch {fconfigure $f -encoding binary} ;# TCL 8.2 1062 fconfigure $f -translation binary 1063 $jtw delete 1.0 end 1064 $jtw insert end [read $f] 1065 close $f 1066 but_relight 1067 # bell 1068 1069 global InputFile InputFileOK 1070 set InputFile "" 1071 if {[llength [set found [find_val_range /InputFile]]]} { 1072 set val [eval "$jtw get $found"] 1073 if {[string match (*) $val]} { 1074 # vvv Imp: real PS backslash interpolation, not TCL 1075 set InputFile [subst -nocommands -novariables [string range $val 1 [expr {[string length $val]-2}]]] 1076 } 1077 } 1078 set InputFileOK [pts_read_ok $InputFile] 1079 1080 global OutputFile OutputFileOK 1081 set OutputFile "" 1082 if {[llength [set found [find_val_range /OutputFile]]]} { 1083 set val [eval "$jtw get $found"] 1084 if {[string match (*) $val]} { 1085 # vvv Imp: real PS backslash interpolation, not TCL 1086 set OutputFile [subst -nocommands -novariables [string range $val 1 [expr {[string length $val]-2}]]] 1087 } 1088 } 1089 set OutputFileOK [pts_write_ok $OutputFile] 1090 1091 global FileFormat 1092 set FileFormat "" 1093 if {[llength [set found [find_val_range /FileFormat]]]} { 1094 set FileFormat [string range [eval "$jtw get $found"] 1 end] 1095 } 1096 1097 global SampleFormat 1098 set SampleFormat "" 1099 if {[llength [set found [find_val_range /SampleFormat]]]} { 1100 set SampleFormat [string range [eval "$jtw get $found"] 1 end] 1101 } 1102 1103 global Compression 1104 set Compression "" 1105 if {[llength [set found [find_val_range /Compression]]]} { 1106 set Compression [string range [eval "$jtw get $found"] 1 end] 1107 } 1108 1109 global TransferEncoding 1110 set TransferEncoding "" 1111 if {[llength [set found [find_val_range /TransferEncoding]]]} { 1112 set TransferEncoding [string range [eval "$jtw get $found"] 1 end] 1113 } 1114 1115 global Predictor 1116 set Predictor "" 1117 if {[llength [set found [find_val_range /Predictor]]]} { 1118 set Predictor [eval "$jtw get $found"] 1119 } 1120 1121 global TransferCPL 1122 set TransferCPL "" 1123 if {[llength [set found [find_val_range /TransferCPL]]]} { 1124 set TransferCPL [eval "$jtw get $found"] 1125 } 1126 1127 global Effort 1128 set Effort "" 1129 if {[llength [set found [find_val_range /Effort]]]} { 1130 set Effort [eval "$jtw get $found"] 1131 } 1132 1133 global RecordSize 1134 set RecordSize "" 1135 if {[llength [set found [find_val_range /RecordSize]]]} { 1136 set RecordSize [eval "$jtw get $found"] 1137 } 1138 1139 global K 1140 set K "" 1141 if {[llength [set found [find_val_range /K]]]} { 1142 set K [eval "$jtw get $found"] 1143 } 1144 1145 global Quality 1146 set Quality "" 1147 if {[llength [set found [find_val_range /Quality]]]} { 1148 set Quality [eval "$jtw get $found"] 1149 } 1150 1151 global WarningOK 1152 set WarningOK "" 1153 if {[llength [set found [find_val_range /WarningOK]]]} { 1154 if {[string compare true [eval "$jtw get $found"]]} {set WarningOK 1} {set WarningOK 1} 1155 } 1156 1157 global TmpRemove 1158 set TmpRemove "" 1159 if {[llength [set found [find_val_range /TmpRemove]]]} { 1160 if {[string compare true [eval "$jtw get $found"]]} {set TmpRemove 1} {set TmpRemove 1} 1161 } 1162 1163 } 1164} 1165 1166proc but_quit {} { 1167 if {0==[string compare yes [pts_message_box -type yesno -title {Confirm quit} -message "Quit now, without saving?"]]} exit 1168} 1169 1170proc but_run {} { 1171 # by pts@fazekas.hu at Fri Apr 26 23:43:17 CEST 2002 1172 global JobFile 1173 sa_debug_append "exec sam2p $JobFile:\n" 1174 # if {[catch {set ret [exec sam2p $JobFile 2>@ stdout]} ret]} {} 1175 if {[catch {set ret [exec sh -c {exec sam2p $1 2>&1} sam2p. $JobFile]} ret]} { 1176 set ret "Error running sam2p:\n$ret" 1177 } 1178 # puts ($ret) 1179 sa_debug_append $ret\n\n 1180} 1181 1182# option add *Dialog*Label*font fixed 1183# option add *Label*Font times 1184#option add *font times 1185#option add *$g*font times 1186#option add *Dialog.msg.background red 1187 1188label $g.lCompression -text Compression -anchor w -font $sa_boldfont 1189sa_radio $g.fNone Compression None None -command {update_radio Compression None} 1190sa_radio $g.fLZW Compression LZW LZW -command {update_radio Compression LZW} 1191sa_radio $g.fZIP Compression ZIP ZIP -command {update_radio Compression ZIP} 1192sa_int $g.fZIP.fEffort Effort Effort 2 -textvariable Effort 1193bind $g.fZIP.fEffort.i <FocusOut> {update_int Effort [%W get] pop} 1194pack $g.fZIP.fEffort -side left 1195sa_radio $g.fRLE Compression RLE RLE -command {update_radio Compression RLE} 1196sa_int $g.fRLE.fRecordSize RecordSize R.S 3 -textvariable RecordSize 1197bind $g.fRLE.fRecordSize.i <FocusOut> {update_int RecordSize [%W get] pop} 1198pack $g.fRLE.fRecordSize -side left 1199sa_radio $g.fFax Compression Fax Fax -command {update_radio Compression Fax} 1200sa_int $g.fFax.fK K K 5 -textvariable K 1201bind $g.fFax.fK.i <FocusOut> {update_int K [%W get] pop} 1202pack $g.fFax.fK -side left 1203sa_radio $g.fDCT Compression DCT DCT -command {update_radio Compression DCT} 1204sa_radio $g.fIJG Compression IJG IJG -command {update_radio Compression IJG} 1205sa_int $g.fIJG.fQuality Quality Q'lty 3 -textvariable Quality 1206bind $g.fIJG.fQuality.i <FocusOut> {update_int Quality [%W get] pop} 1207pack $g.fIJG.fQuality -side left 1208sa_radio $g.fJAI Compression JAI JAI -command {update_radio Compression JAI} 1209#label $g.fJAI.haha -text haha 1210#pack $g.fJAI.haha -side left 1211pack $g.lCompression -fill x 1212pack $g.fNone $g.fLZW $g.fZIP $g.fRLE $g.fFax $g.fDCT $g.fIJG $g.fJAI -fill x 1213sa_vframe $g 1214 1215sa_int $g.lPredictor Predictor Predictor 3 -textvariable Predictor 1216bind $g.lPredictor.i <FocusOut> {update_int Predictor [%W get] pop} 1217pack $g.lPredictor -fill x 1218sa_vframe $g 1219 1220sa_check_update $g.cWarningOK WarningOK WarningOK 1221# -textvariable WarningOK 1222pack $g.cWarningOK -fill x 1223sa_vframe $g 1224 1225label $g.lTransferEncoding -text TransferEncoding -anchor w -font $sa_boldfont 1226sa_radio $g.fBinary TransferEncoding Binary Binary -command {update_radio TransferEncoding Binary} 1227sa_radio $g.fASCII TransferEncoding ASCII ASCII -command {update_radio TransferEncoding ASCII} 1228sa_radio $g.fHex TransferEncoding Hex Hex -command {update_radio TransferEncoding Hex} 1229sa_radio $g.fA85 TransferEncoding A85 A85 -command {update_radio TransferEncoding A85} 1230pack $g.lTransferEncoding -fill x 1231pack $g.fBinary $g.fASCII $g.fHex $g.fA85 -fill x 1232frame $g.pTransferEncoding -height 5 -width 1 1233pack $g.pTransferEncoding -fill x 1234 1235sa_int $g.fTransferCPL TransferCPL TransferCPL 3 -textvariable TransferCPL 1236bind $g.fTransferCPL.i <FocusOut> {update_int TransferCPL [%W get] pop} 1237 1238pack $g.fTransferCPL -fill x 1239sa_vframe $g 1240 1241sa_check_update $g.cTmpRemove TmpRemove {Tmp Remove} 1242pack $g.cTmpRemove -fill x 1243sa_vframe $g 1244 1245 1246set g .gtop.g3 1247frame $g 1248 1249sa_w_text $g.t -width 58 -height 18 -wrap none -font $sa_fixfont 1250pts_fix_one_tab $g.t 1251pts_text_autoindent $g.t 1 1252pts_text_auto_overstrike $g.t 0 1253# $g.t insert end "<<%sam2p job file\n /InputFile (alma)\n /OutputFile (korte)\n /Profile \[\n /Compression /LZW/Predictor 13\n /Hints<</DCT <</a true /b (>>)>> >>\n ]\n>>\n" 1254# $g.t insert end [read [open template.job r]] 1255# Imp: close file... 1256$g.t mark set insert 1.0; $g.t see insert 1257$g.t tag configure tAny; $g.t tag lower tAny sel 1258$g.t tag configure tSing -foreground "#003f7f"; $g.t tag raise tSing sel 1259$g.t tag configure tString -foreground "#007f7f"; $g.t tag raise tString sel 1260$g.t tag configure tKey -foreground "#00007f"; $g.t tag raise tKey sel 1261$g.t tag configure tNameval -foreground "#0000ff"; $g.t tag raise tNameval sel 1262$g.t tag configure tBrac -foreground "#ff0000"; $g.t tag raise tBrac sel 1263$g.t tag configure tComment -foreground "#007f00"; $g.t tag raise tComment sel 1264$g.t tag configure tInt -foreground "#3f0000"; $g.t tag raise tInt sel 1265$g.t tag configure tError -background "#ffdddd"; $g.t tag lower tError sel 1266 1267# puts X[bindtags $g.t]X 1268# puts X[bind $g.t]X 1269# puts XZ[bind all]X 1270 1271set jtw $g.t 1272 1273# Imp: delete tmp.tmp 1274 1275# -font sansserif 1276# puts [$g.t tag ranges tSing] 1277# reground blue 1278 1279# update idletasks; puts [winfo geometry $g.t] ;# not ready, has to be packed first 1280 1281frame $g.f 1282sa_w_text $g.f.td -width 1 -height 13 -wrap char -font $sa_fixfont \ 1283 -yscrollcommand "$g.f.sd set" -spacing3 2 1284$g.f.td configure -selectbackground yellow ;# override 1285scrollbar $g.f.sd -command "$g.f.td yview" -width 11 -elementborderwidth 2 \ 1286 -relief flat -borderwidth 1 -takefocus 0 -troughcolor gray65 1287$g.f.sd configure -activebackground [$g.f.sd cget -background] 1288 1289# OK: non-editable, but not disabled (we need the cursor!) 1290# $g.f.td configure -background [lindex [$g.f.td configure -background] 3] 1291pts_readonly_color $g.f.td 1292# puts $g.f.td 1293# puts TD:[bind .gtop.g3.f.td <Key-Return>] 1294 1295pts_fix_one_tab $g.f.td 1296$g.f.td insert end "Debug messages, sam2p output:\n\n" 1297# $g.f.td insert end "0\n1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n" 1298# $g.f.td insert end "21\n22\n23\n24\n25\n26\n27\n28\n29\n30\n31\n32\n33\n34\n35\n36\n37\n38\n39\n" 1299$g.f.td mark set insert 1.0; $g.f.td see insert 1300set debugtext $g.f.td 1301 1302pack $g.t -expand 0 -fill x 1303pack $g.f.td -expand 1 -fill both -side left 1304pack $g.f.sd -fill both -side left 1305pack $g.f -expand 1 -fill both 1306 1307pack .gtop.g0 .gtop.g1 .gtop.g2 -side left 1308pack .gtop.g3 -expand 1 -fill both -side left 1309 1310frame .gbot 1311frame .gbot.gbl 1312 1313set g .gbot.gbl.fCurdir 1314frame $g 1315label $g.l -text "Current dir" -font $sa_boldfont 1316sa_w_entry $g.e -font $sa_normfont 1317# bind $g.e <FocusOut> {update_str e [%W get] pop} 1318pack $g.l -side left 1319pack $g.e -expand 1 -fill x -side left 1320$g.e insert 0 [pwd] 1321 1322# puts [bind .gbot.gbl.fCurdir.e] 1323 1324bind Text <B2-Motion> {} 1325bind Text <Button-2> {} 1326# puts T[bind Text]T 1327# puts [bind Text <Button-2>] 1328#puts ([bind Entry <Tab>]) 1329 1330#foreach evtseq [bind Entry] { 1331# if {[string match <Key-*> $evtseq] 1332# || [string match <*-Key-*> $evtseq] 1333# || [string match <*-Key> $evtseq] 1334# } { 1335# bind $g.e $evtseq {break} 1336# puts +:$evtseq 1337# } { 1338# #puts -:$evtseq 1339# } 1340#} 1341 1342# Dat: this assumes [lindex [bindtags $g.e] 0] == $g.e 1343#foreach tag [bindtags $g.e] { 1344# foreach evtseq [bind $tag] { 1345# # if {0==[string length [bind $g.e $evtseq]]} {bind $g.e $evtseq [bind $tag $evtseq]} 1346# } 1347#} 1348 1349pts_readonly_color $g.e 1350 1351 1352# event info <<Clear>> 1353#bind $g.e <Key-Tab> {# nothing} 1354#bind $g.e <Key-ISO_Left_Tab> {# nothing} 1355# puts /[bind $g.e] 1356# puts :[bind $g.e <Key-Return>] 1357 1358set g .gbot.gbl.fJobFile 1359frame $g 1360label $g.l -text JobFile -font $sa_boldfont 1361sa_w_entry $g.e -font $sa_normfont -textvariable JobFile 1362label $g.r -text OK -font $sa_normfont -textvariable JobFileOK -width 2 1363bind $g.e <FocusOut> {set JobFileOK [pts_write_ok $JobFile]} 1364set jfn $g.e 1365pack $g.l -side left 1366pack $g.e -expand 1 -fill x -side left 1367pack $g.r -side left 1368 1369 1370set g .gbot.gbl.fInputFile 1371frame $g 1372label $g.l -text InputFile -font $sa_boldfont 1373sa_w_entry $g.e -font $sa_normfont -textvariable InputFile 1374label $g.r -text OK -font $sa_normfont -textvariable InputFileOK -width 2 1375bind $g.e <FocusOut> {update_str InputFile [%W get] pop; set InputFileOK [pts_read_ok $InputFile]} 1376pack $g.l -side left 1377pack $g.e -expand 1 -fill x -side left 1378pack $g.r -side left 1379set InputFileOK [pts_read_ok $InputFile] 1380 1381set g .gbot.gbl.fOutputFile 1382frame $g 1383label $g.l -text OutputFile -font $sa_boldfont 1384sa_w_entry $g.e -font $sa_normfont -textvariable OutputFile 1385label $g.r -text OK -font $sa_normfont -textvariable OutputFileOK -width 2 1386bind $g.e <FocusOut> {update_str OutputFile [%W get] pop; set OutputFileOK [pts_write_ok $OutputFile]} 1387pack $g.l -side left 1388pack $g.e -expand 1 -fill x -side left 1389pack $g.r -side left 1390 1391pack .gbot.gbl.fCurdir .gbot.gbl.fJobFile .gbot.gbl.fInputFile .gbot.gbl.fOutputFile -expand 1 -fill x 1392 1393frame .gbot.ha 1394button .gbot.ha.bLoad -text {Load Job} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \ 1395 -command but_load 1396bind . <Alt-Key-l> but_load 1397button .gbot.ha.bSave -text {Save Job} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \ 1398 -command but_save 1399bind . <Alt-Key-s> but_save 1400 1401frame .gbot.hb 1402button .gbot.hb.bRun -text {Run} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \ 1403 -command but_run 1404bind . <Alt-Key-r> but_run 1405button .gbot.hb.bQuit -text {Quit} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \ 1406 -command but_quit 1407bind . <Alt-Key-q> but_quit 1408pack .gbot.gbl -expand 1 -fill x -side left 1409pack .gbot.ha.bLoad .gbot.ha.bSave 1410pack .gbot.hb.bRun .gbot.hb.bQuit 1411pack .gbot.ha .gbot.hb -side left 1412 1413pack .gtop -expand 1 -fill both 1414pack .gbot -expand 0 -fill x 1415update idletasks ;# a sima [update] helyett, hogy a "geometry" j� legyen 1416scan [wm geometry .] "%dx%d%s" width height tmp 1417wm minsize . $width $height 1418 1419 1420set env(PATH) $env(PATH)[pts_PATH_sep]. 1421#if {[catch {set ret [exec sam2p --help 2>&1]} ret]} {} 1422if {[catch {set ret [exec sh -c {exec sam2p --help 2>&1}]} ret]} { 1423 set ret "Error:\n$ret" 1424} 1425 1426proc sa_debug_append msg { 1427 global debugtext 1428 $debugtext insert end $msg 1429 $debugtext mark set insert end 1430 $debugtext see insert 1431} 1432 1433sa_debug_append $ret\n\n 1434# puts ($ret) 1435 1436 1437$jfn delete 0 end 1438if {[llength $argv]} {$jfn insert 0 [lindex $argv 0]; but_load} { 1439 $jfn insert 0 template.job; but_load; $jfn delete 0 end 1440 set InputFileOK 0 1441 set OutputFileOK 0 1442 set JobFileOK 0 1443} 1444# set InputFile hello 1445# but_load 1446# puts $argv 1447# puts TD:[bind .gtop.g3.f.td <Key-Return>] 1448 1449 1450#__END__ 1451