summaryrefslogtreecommitdiff
path: root/graphics/sam2p/contrib/sam2p.tk
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /graphics/sam2p/contrib/sam2p.tk
Initial commit
Diffstat (limited to 'graphics/sam2p/contrib/sam2p.tk')
-rw-r--r--graphics/sam2p/contrib/sam2p.tk1450
1 files changed, 1450 insertions, 0 deletions
diff --git a/graphics/sam2p/contrib/sam2p.tk b/graphics/sam2p/contrib/sam2p.tk
new file mode 100644
index 0000000000..99350f9d68
--- /dev/null
+++ b/graphics/sam2p/contrib/sam2p.tk
@@ -0,0 +1,1450 @@
+#!/usr/bin/wish -f
+#
+# sam2p.tk
+# by pts@fazekas.hu at Sat Apr 6 13:14:37 CEST 2002
+#
+# OK: confirm quit
+# Imp: don't update widgets when error in job file
+# Imp: newline mangling when loading/saving files
+# Imp: /DCT, ability to type literal MiniPS code to an `entry'
+# Imp: Perl parser should signal error on <hex123> etc.
+# Imp: B2Press + Move + B2Release; inserts twice
+# Imp: initial `focus'
+# Imp: default values
+# Imp: tk-start with sh
+# Imp: to center of the resized window
+# Imp: tooltips (mouse button 2, 3)
+# Imp: less vertical padding
+# Imp: really detect what kind of -*-fixed fonts we have
+# Dat: TCL 8.0 doesn't have `string equal'
+# Dat: never do `.text mark set sel.first 1.5', beacuse this will override tag `sel'
+# Dat: `entry' widgets don't accept "insert + 1 chars" as a character index
+# Dat: tag-parser treats comments as legal tokens
+# Dat: <Insert> matches <Shift-Insert>, <Key-Insert> does not.
+# Dat: <Motion> is mouse motion event over the sub-window
+# Dat: <Enter> and <Leave> is an event sent when
+# SUXX: Tcl: 8.0 doesn't have [string map ...]
+# SUXX: Tk: radio and checkbuttons cannot be made smaller or larger
+# SUXX: Tk: color for -relief cannot be specified
+# SUXX: Tk: on UNIX, Tk converts "Times New Roman" to "times" unless specified as "-*-times new roman-*-*-*-*-*-*-*-*-*-*-iso8859-1"
+# SUXX: Tk: .text cursor width cannot be extended to the right only (not to the left)
+# SUXX: Tk: .text cannot show the last line on the top unless first==last
+# SUXX: Tk bug: echo `bind . <ButtonRelease-2> {put got}' | wish
+# Test: 1. press button2 2. move mouse 3. release button 4. move mouse
+# `got' is printed twice. Strange: works fine with button 1 and 3.
+# Even the following doesn't help:
+# echo `bind . <B2-ButtonRelease-2> {put got}' | wish
+# Even event parameters are useless to distinguish normal and duplicate
+# events. This is a bug even on all other X11 clients. May be a GPM bug
+# or an xlib bug??
+
+# puts [file type alma]
+
+proc pts_PATH_sep {} {
+ global tcl_platform
+ if {0==[string compare windows $tcl_platform(platform)]} {return ;}
+ return :
+ # Imp: `macintosh'
+}
+
+proc pts_read_ok {filename} {
+ if {0==[string length $filename]} {return 0}
+ if {[catch {set t [file type $filename]}]} {
+ if {[catch {set t [file type [file dirname $filename]]}]} {return !d}
+ return !e
+ }
+ if {0!=[string compare $t file]} {return !f}
+ if {![file readable $filename]} {return !r}
+ return OK
+}
+
+proc pts_write_ok {filename} {
+ if {0==[string length $filename]} {return 0}
+ if {[catch {set t [file type $filename]}]} {
+ if {[catch {set t [file type [set dir [file dirname $filename]]]}]} {return !d}
+ if {0==[string compare $t directory] && [file writable $dir]} {return ++}
+ return !dw
+ }
+ if {0!=[string compare $t file]} {return !f}
+ if {![file writable $filename]} {return !w}
+ return OK
+}
+
+proc pts_direct_bindtags {w} {
+ #** Moves all binds associated with widget $w to directly widget itself.
+ ## Half idea: bindtags $w "$w [bindtags $w]"
+ # Dat: this assumes [lindex [bindtags $w] 0] == $w
+ foreach tag [bindtags $w] {
+ if {0!=[string compare $tag $w]} {
+ foreach evtseq [bind $tag] {
+ bind $w $evtseq [bind $w $evtseq]\n[bind $tag $evtseq]
+ }
+ }
+ }
+ bindtags $w $w
+}
+
+proc pts_readonly {w} {
+ #** @param $w text or entry
+ #** Makes the specified widget read-only. [$w configure -state disabled]
+ #** is not OK, because it makes the insertion cursor invisible.
+ pts_direct_bindtags $w
+ # SUXX: cannot be avoided. Example: we must disable <Key> (typing letters),
+ # but allow <Key-Left>
+ bind $w <Meta-Key-d> break
+ bind $w <Meta-Key-f> break
+ bind $w <Meta-Key-Delete> break
+ bind $w <Meta-Key-BackSpace> break
+ bind $w <Control-Key-d> break
+ bind $w <Control-Key-i> break
+ bind $w <Control-Key-k> break
+ bind $w <Control-Key-h> break
+ bind $w <Control-Key-t> break
+ bind $w <Key-BackSpace> break
+ bind $w <Key-Delete> break
+ bind $w <Key-Return> break
+ bind $w <Key-KP_Enter> break
+ bind $w <Key> break
+ bind $w <<PasteSelection>> break
+ bind $w <<Paste>> break
+ bind $w <<Cut>> break
+ bind $w <<Clear>> break
+}
+
+proc pts_readonly_color {w} {
+ #** Calls [pts_readonly $w], and sets widget colors etc. to make the user
+ #** see that it's a read-only widget.
+ pts_readonly $w
+ $w configure -background [[winfo toplevel $w] cget -background] -relief sunken
+}
+
+proc pts_listrev {list} {
+ # by pts@fazekas.hu at Sun Apr 21 21:08:20 CEST 2002
+ set i [llength $list]
+ set ret {}
+ while {$i>0} {incr i -1; lappend ret [lindex $list $i]}
+ return $ret
+}
+
+proc pts_listrev1 {list} {
+ #** Chops the 1st element of list, and returns the reverse of the rest.
+ # by pts@fazekas.hu at Sun Apr 21 21:08:20 CEST 2002
+ set i [llength $list]
+ set ret {}
+ while {$i>1} {incr i -1; lappend ret [lindex $list $i]}
+ return $ret
+}
+
+## puts [pts_listrev {1 2 {3 4}}]; exit
+
+set pts_unknown_font [font actual ..unknown..]
+proc pts_has_font {f} {
+ # by pts@fazekas.hu at Sat Apr 6 16:26:24 CEST 2002
+ # This is rather dirty, because there is no clean way to test whether a font
+ # exists in Tk.
+ #** return 1 or 0
+ global pts_unknown_font
+ if {0==[string compare fixed $f]} {return 1}
+ if {[string match -*-fixed-* $f]} {return 1} ;# Imp: first `*' shouldn't contain `-'
+ # Dat: pts_unknown_font is `fixed' on UNIX systems...
+ if {0==[string compare $pts_unknown_font [font actual $f]]} {return 0}
+ return 1
+}
+
+proc pts_last_font {first args} {
+ #** @param first,args list of font names (suitable arg for `-font' of widgets)
+ #** @return the last font name that is available
+ for {set i [llength $args]} {$i>0} {} {
+ incr i -1
+ if {[pts_has_font [set f [lindex $args $i]]]} {return $f}
+ }
+ return $first
+}
+
+proc pts_fix_shift_tab {} {
+ # by pts@fazekas.hu at Sat Apr 6 15:22:58 CEST 2002
+ set tmp [bind all <Shift-Key-Tab>]
+ ## puts $tmp
+ if {[string length $tmp]==0} {set tmp {tkTabToWindow [tk_focusPrev %]}}
+ bind all <Shift-Key-Tab> $tmp
+ catch {bind all <Key-ISO_Left_Tab> $tmp}
+ # ^^^ Dat: catch is here because some systems don't have ISO_Left_Tab
+}
+
+proc pts_fix_one_tab {wPath} {
+ # by pts@fazekas.hu at Sat Apr 6 15:38:43 CEST 2002
+ # pts_fix_shift_tab() should be called.
+ bind $wPath <Key-Tab> "[bind all <Key-Tab>]; break"
+ bind $wPath <Shift-Key-Tab> "[bind all <Shift-Key-Tab>]; break"
+ bind $wPath <Key-ISO_Left_Tab> "[bind all <Shift-Key-Tab>]; break"
+}
+
+proc pts_tag_set_first {w tagName index} {
+ if {[$w tag nextrange $tagName 1.0 end] != ""} {
+ if {[$w compare $index < $tagName.last]} {
+ if {[$w compare $index < $tagName.first]} \
+ {$w tag add $tagName $index $tagName.first} \
+ {$w tag remove $tagName $tagName.first $index}
+ } {
+ set tmp [$w index $tagName.last]
+ $w tag remove $tagName 1.0 end
+ $w tag add $tagName $tmp $index
+ }
+ }
+}
+proc pts_tag_set_last {w tagName index} {
+ if {[$w tag nextrange $tagName 1.0 end] != ""} {
+ if {[$w compare $index > $tagName.first]} {
+ if {[$w compare $index > $tagName.last]} \
+ {$w tag add $tagName $tagName.last $index} \
+ {$w tag remove $tagName $index $tagName.last}
+ } {
+ set tmp [$w index $tagName.first]
+ $w tag remove $tagName 1.0 end
+ $w tag add $tagName $index $tmp
+ }
+ }
+}
+
+proc pts_paste {w} {catch {
+ set tmp [$w index insert]
+ $w insert insert [selection get -displayof $w -selection CLIPBOARD]
+ $w tag remove sel 0.1 end
+ $w tag add sel $tmp insert
+}}
+
+proc pts_text_insert_newline {w autoindent} {
+ #** Doesn't respect overstrike mode (neither does Turbo Pascal).
+ #** Does auto-indenting of spaces and tabs.
+ if {[$w cget -state] == "disabled"} {return}
+ if $autoindent {
+ if {![string length [set tmp [$w search -regexp "\[^ \t]" {insert linestart} {insert lineend}]]]} {set tmp "insert lineend"}
+ $w insert insert \n[$w get {insert linestart} $tmp]
+ } {$w insert insert \n}
+ $w see insert
+}
+proc pts_text_autoindent {w bool} {
+ if $bool {} ;# early error message if bool is malformed
+ bind $w <Return> "pts_text_insert_newline %W $bool; break"
+}
+
+# vvv Overriding text.tcl, so we won't clobber the visible selection.
+proc tkTextInsert {w s} {
+ if {($s == "") || ([$w cget -state] == "disabled")} {return}
+ if {[string match "* 1" [bind $w <Insert>]]} {
+ # vvv in overstrike mode, overstrike only in the middle of the line
+ if {[$w compare insert != "insert lineend"]} {$w delete insert}
+ }
+ $w insert insert $s; $w see insert
+}
+
+#proc pts_text_insert {w s overstrike} {
+# if {($s == "") || ([$w cget -state] == "disabled")} {return}
+# set tmp [$w index insert]
+# # vvv in overstrike mode, overstrike only in the middle of the line
+# if {$overstrike && [$w compare insert != "insert lineend"]} {$w delete insert}
+# $w insert insert $s; $w see insert
+#}
+proc pts_text_overstrike {w bool} {
+ #puts [$w configure -insertontime]
+ #puts [$w configure -insertofftime]
+ if {$bool} {$w configure -insertofftime 0} \
+ {$w configure -insertofftime [lindex [$w configure -insertofftime] 3]}
+ # Dat: we cannot override the widget's <KeyPress> method here, because then
+ # we won't be able to receive cursor movement etc. events, see docs in
+ # bindtags(n) and bind(n). So support must be built into tkTextInsert,
+ # since `bind Text <KeyPress> {tkTextInsert %W %A}' is the default.
+ # bind Text <KeyPress> "pts_text_insert %W %A $bool; break ;#alma"
+ focus .; focus $w ;# trick to avoid non-reblinking bug in Tk8.0 Linux.
+}
+proc pts_text_toggle_overstrike {w bool} {
+ if {$bool} {set bool 0} {set bool 1}
+ pts_text_overstrike $w $bool
+ bind $w <Insert> "pts_text_toggle_overstrike %W $bool"
+}
+proc pts_text_auto_overstrike {w bool} {
+ #** Sets overstrike mode, and binds Insert to do the switching. A
+ #** non-blinking cursor indicates overstrike mode. (Tk is too stupid to draw
+ #** a block cursor.)
+ #** @param w a text widget
+ pts_text_overstrike $w $bool
+ bind $w <Key-Insert> "pts_text_toggle_overstrike %W $bool"
+}
+
+# redefine tkScrollButtonDown, so it won't `sunken' the slider
+# (se tcl8.2/scrlbar.tcl)
+proc tkScrollButtonDown {w x y} {
+ global tkPriv
+ set tkPriv(relief) [$w cget -activerelief]
+ if {0==[string compare slider [set element [$w identify $x $y]]]} {
+ tkScrollStartDrag $w $x $y
+ } else {
+ $w configure -activerelief sunken
+ tkScrollSelect $w $element initial
+ }
+}
+proc tkScrollButton2Down {w x y} {
+ global tkPriv
+ set element [$w identify $x $y]
+ if {0==[string compare $element arrow1]||0==[string compare $element arrow2]} {
+ tkScrollButtonDown $w $x $y
+ return
+ }
+ tkScrollToPos $w [$w fraction $x $y]
+ set tkPriv(relief) [$w cget -activerelief]
+ update idletasks
+ # $w configure -activerelief sunken
+ $w activate slider
+ tkScrollStartDrag $w $x $y
+}
+
+option add *Dialog.msg.wrapLength 3i widgetDefault
+proc pts_message_box {args} {
+ global sa_normfont
+ #** similar to tkMessageBox; ignores platform's native MessageBox support.
+ global tkPriv tcl_platform
+
+ set w tkPrivMsgBox
+ upvar #0 $w data
+
+ #
+ # The default value of the title is space (" ") not the empty string
+ # because for some window managers, a
+ # wm title .foo ""
+ # causes the window title to be "foo" instead of the empty string.
+ #
+ set specs {
+ {-default "" "" ""}
+ {-icon "" "" "info"}
+ {-message "" "" ""}
+ {-parent "" "" .}
+ {-title "" "" " "}
+ {-type "" "" "ok"}
+ }
+
+ tclParseConfigSpec $w $specs "" $args
+
+ if {[lsearch {info warning error question} $data(-icon)] == -1} {
+ error "invalid icon \"$data(-icon)\", must be error, info, question or warning"
+ }
+ if {$tcl_platform(platform) == "macintosh"} {
+ if {$data(-icon) == "error"} {
+ set data(-icon) "stop"
+ } elseif {$data(-icon) == "warning"} {
+ set data(-icon) "caution"
+ } elseif {$data(-icon) == "info"} {
+ set data(-icon) "note"
+ }
+ }
+
+ if {![winfo exists $data(-parent)]} {
+ error "bad window path name \"$data(-parent)\""
+ }
+
+ switch -- $data(-type) {
+ abortretryignore {
+ set buttons {
+ {abort -width 6 -text Abort -under 0}
+ {retry -width 6 -text Retry -under 0}
+ {ignore -width 6 -text Ignore -under 0}
+ }
+ }
+ ok {
+ set buttons {
+ {ok -width 6 -text OK -under 0}
+ }
+ if {$data(-default) == ""} {
+ set data(-default) "ok"
+ }
+ }
+ okcancel {
+ set buttons {
+ {ok -width 6 -text OK -under 0}
+ {cancel -width 6 -text Cancel -under 0}
+ }
+ }
+ retrycancel {
+ set buttons {
+ {retry -width 6 -text Retry -under 0}
+ {cancel -width 6 -text Cancel -under 0}
+ }
+ }
+ yesno {
+ set buttons {
+ {yes -width 6 -text Yes -under 0}
+ {no -width 6 -text No -under 0}
+ }
+ }
+ yesnocancel {
+ set buttons {
+ {yes -width 6 -text Yes -under 0}
+ {no -width 6 -text No -under 0}
+ {cancel -width 6 -text Cancel -under 0}
+ }
+ }
+ default {
+ error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel"
+ }
+ }
+
+ if {[string compare $data(-default) ""]} {
+ set valid 0
+ foreach btn $buttons {
+ if {![string compare [lindex $btn 0] $data(-default)]} {
+ set valid 1
+ break
+ }
+ }
+ if {!$valid} {
+ error "invalid default button \"$data(-default)\""
+ }
+ }
+
+ # 2. Set the dialog to be a child window of $parent
+ #
+ #
+ if {[string compare $data(-parent) .]} {
+ set w $data(-parent).__tk__messagebox
+ } else {
+ set w .__tk__messagebox
+ }
+
+ # 3. Create the top-level window and divide it into top
+ # and bottom parts.
+
+ catch {destroy $w}
+ toplevel $w -class Dialog
+ wm title $w $data(-title)
+ wm iconname $w Dialog
+ wm protocol $w WM_DELETE_WINDOW { }
+ wm transient $w $data(-parent)
+ if {$tcl_platform(platform) == "macintosh"} {
+ unsupported1 style $w dBoxProc
+ }
+
+ frame $w.bot
+ pack $w.bot -side bottom -fill both
+ frame $w.top
+ pack $w.top -side top -fill both -expand 1
+ if {$tcl_platform(platform) != "macintosh"} {
+ $w.bot configure -relief raised -bd 1
+ $w.top configure -relief raised -bd 1
+ }
+
+ # 4. Fill the top part with bitmap and message (use the option
+ # database for -wraplength so that it can be overridden by
+ # the caller).
+
+ label $w.msg -justify left -text $data(-message)
+ #catch {$w.msg configure -font \
+ # -Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*
+ #}
+ pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
+ if {$data(-icon) != ""} {
+ label $w.bitmap -bitmap $data(-icon)
+ pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
+ }
+
+ # 5. Create a row of buttons at the bottom of the dialog.
+
+ set i 0
+ foreach but $buttons {
+ set name [lindex $but 0]
+ set opts [lrange $but 1 end]
+ if {![string compare $opts {}]} {
+ # Capitalize the first letter of $name
+ set capName \
+ [string toupper \
+ [string index $name 0]][string range $name 1 end]
+ set opts [list -text $capName]
+ }
+
+ eval button $w.$name $opts -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 -command [list "set tkPriv(button) $name"]
+
+ if {![string compare $name $data(-default)]} {
+ $w.$name configure -default active
+ }
+ pack $w.$name -in $w.bot -side left -expand 1 \
+ -padx 3m -pady 2m
+
+ # create the binding for the key accelerator, based on the underline
+ #
+ set underIdx [$w.$name cget -under]
+ if {$underIdx >= 0} {
+ set key [string index [$w.$name cget -text] $underIdx]
+ bind $w <Alt-[string tolower $key]> "$w.$name invoke"
+ bind $w <Alt-[string toupper $key]> "$w.$name invoke"
+ }
+ incr i
+ }
+
+ # 6. Create a binding for <Return> on the dialog if there is a
+ # default button.
+
+ if {[string compare $data(-default) ""]} {
+ bind $w <Return> "tkButtonInvoke $w.$data(-default)"
+ }
+
+ # 7. Withdraw the window, then update all the geometry information
+ # so we know how big it wants to be, then center the window in the
+ # display and de-iconify it.
+
+ wm withdraw $w
+ update idletasks
+ set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
+ - [winfo vrootx [winfo parent $w]]}]
+ set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
+ - [winfo vrooty [winfo parent $w]]}]
+ wm geom $w +$x+$y
+ wm deiconify $w
+
+ # 8. Set a grab and claim the focus too.
+
+ set oldFocus [focus]
+ set oldGrab [grab current $w]
+ if {$oldGrab != ""} {
+ set grabStatus [grab status $oldGrab]
+ }
+ grab $w
+ if {[string compare $data(-default) ""]} {
+ focus $w.$data(-default)
+ } else {
+ focus $w
+ }
+
+ # 9. Wait for the user to respond, then restore the focus and
+ # return the index of the selected button. Restore the focus
+ # before deleting the window, since otherwise the window manager
+ # may take the focus away so we can't redirect it. Finally,
+ # restore any grab that was in effect.
+
+ tkwait variable tkPriv(button)
+ catch {focus $oldFocus}
+ destroy $w
+ if {$oldGrab != ""} {
+ if {$grabStatus == "global"} {
+ grab -global $oldGrab
+ } else {
+ grab $oldGrab
+ }
+ }
+ return $tkPriv(button)
+}
+
+
+# ---
+
+proc sa_radio {framePath variable value labelCaption args} {
+ global $variable sa_normfont
+ # Imp: use -text
+ set $variable ""
+ frame $framePath
+ lappend args -variable $variable -value $value -indicatoron true -borderwidth 1
+ # lappend args -value $value -indicatoron true -borderwidth 1
+ eval "radiobutton $framePath.r $args"
+
+ $framePath.r configure -activebackground [$framePath.r cget -background]
+ label $framePath.l -text $labelCaption -font $sa_normfont ;# Imp: Why doesn't -anchor work??
+ bind $framePath.l <ButtonRelease-1> "$framePath.r invoke"
+ pack $framePath.r $framePath.l -side left
+ # bind $framePath.r <Key-ISO_Left_Tab> {tkTabToWindow [tk_focusPrev %W]}
+}
+#proc sa_radio_pack {framePath} {}
+proc sa_check {wPath variable labelCaption args} {
+ global sa_boldfont
+ # Imp: clicking to the right from the caption shouldn't have effect
+ lappend args -font $sa_boldfont -text $labelCaption -anchor w -borderwidth 1 -variable $variable
+ eval "checkbutton $wPath $args"
+ $wPath configure -activebackground [$wPath cget -background]
+}
+
+proc sa_check_update {wPath variable labelCaption} {
+ sa_check $wPath $variable $labelCaption -command "update_check $variable $wPath"
+}
+
+proc sa_int {framePath variable labelCaption entryWidth args} {
+ # Imp: clicking to the right from the caption shouldn't have effect
+ # Imp: check for int...
+ global sa_normfont sa_boldfont
+ frame $framePath ;# may already exist??
+ label $framePath.l -text $labelCaption -font $sa_boldfont
+ lappend args -relief sunken -width $entryWidth -font $sa_normfont \
+ -borderwidth 1 -foreground black -background white \
+ -selectbackground yellow -selectforeground black -selectborderwidth 0
+ eval "entry $framePath.i $args"
+ pack $framePath.l $framePath.i -side left
+ # $framePath configure -activebackground [$framePath cget -background]
+}
+
+proc sa_w_text {args} {
+ lappend args -relief solid -highlightcolor gray30 \
+ -borderwidth 1 -foreground black -background white \
+ -selectbackground gray85 -selectforeground black -selectborderwidth 0
+ eval "text $args"
+}
+
+proc sa_w_entry {args} {
+ lappend args -relief sunken -borderwidth 1 -foreground black -background white \
+ -selectbackground yellow -selectforeground black -selectborderwidth 0
+ eval "entry $args"
+}
+
+set sa_frame 0
+proc sa_vframe {parentPath} {
+ #** Creates and packs vertical frame, which is 5 pixel high
+ global sa_frame
+ set w $parentPath.saf[incr sa_frame]
+ frame $w -height 5 -width 1
+ pack $w -fill x
+}
+
+# vvv The mouse must be used to insert visible selection (of other apps)
+bind Text <Insert> {}
+
+bind Text <B2-Motion> {}
+bind Text <Button-2> {}
+# puts T[bind Text]T
+
+
+# vvv allow the well-known (almost indrustry standard) Windows/Borland/GTK
+# cliboard key bindings on all platforms
+event add <<Cut>> <Control-Key-x> <Shift-Key-Delete>
+event add <<Copy>> <Control-Key-c> <Control-Key-Insert>
+event add <<Paste>> <Control-Key-v> <Shift-Key-Insert>
+# event add <<PasteSelection>> <ButtonRelease-2>
+# Dat: <<Paste>> is normal, <Control-Key-v> paste, which requires prior
+# <Control-Key-c>. Works across applications.
+# Dat: <<PasteSelection>> is xterm/netscape-like paste, which does not
+# require <Control-Key-c>. Also works across applications.
+
+# vvv this <<Paste>> deletes current selection even on UNIX; but we don't like that
+# bind Text <<Paste>> {catch {%W delete sel.first sel.last}; catch {%W insert insert [selection get -displayof %W -selection CLIPBOARD]}}
+# vvv this <<Paste>> leaves visible selection intact
+# bind Text <<Paste>> {catch {%W insert insert [selection get -displayof %W -selection CLIPBOARD]}}
+# vvv this <<Paste>> sets visible selection to the newly pasted data
+bind Text <<Paste>> {pts_paste %W}
+
+# vvv our <<PasteSelection>> doesn't move the cursor (like xterm, unlike Motif)
+bind Text <<PasteSelection>> {pts_text_paste_selection %W %x %y}
+
+bind Text <B2-Motion> {}
+bind Text <Button-2> {}
+
+# bind Text <ButtonRelease-2> {puts evt; pts_text_paste_selection %W %x %y}
+#catch {
+#event delete <<PasteSelection>> <ButtonRelease-2>
+#}
+#catch {
+#event add <<PasteSelection>> <B2-ButtonRelease-2>
+#event add <<PasteSelection>> <Button-2>
+#}
+
+# puts EI[event info <<PasteSelection>>]
+# puts A[event info <<PasteSelection>>]BN
+
+proc pts_text_paste_selection {w x y} {
+ #** If has focus, than pastes visible selection to the unchanged cursor
+ #** position; otherwise claims focus and sets cursor position to mouse.
+ if {0==[string compare $w [focus -displayof $w]]} {
+ catch {$w insert insert [selection get -displayof $w]}
+ if {0==[string compare normal [$w cget -state]]} {focus $w}
+ } {$w mark set insert [tkTextClosestGap $w $x $y]; focus $w}
+}
+
+
+# vvv overrides text.tcl, doesn't clobber the selection.
+bind Text <1> {tkTextButton1 %W %x %y}
+
+proc ptsTextDelLn W {
+ # puts [%W index {insert linestart}]..[%W index {insert lineend + 1 chars}]
+ if {[$W compare {insert lineend + 1 chars} == end]} {
+ # <Control-y> in the last line must not move the cursor
+ $W delete {insert linestart} {insert lineend}
+ } {
+ $W delete {insert linestart} {insert lineend + 1 chars}
+ }
+}
+
+# vvv Overriding text.tcl, so we won't clobber the visible selection when moving
+# the cursor or just inserting
+proc tkTextSetCursor {w pos} {
+ if {[$w compare $pos == end]} {set pos {end - 1 chars}}
+ $w mark set insert $pos
+ # $w tag remove sel 1.0 end
+ $w see insert
+}
+
+# vvv Overriding text.tcl, so PageUp and PageDown will jump within the page.
+proc tkTextScrollPages {w count} {
+ set tmp [expr {([$w cget -height]-1)*$count}]
+ $w yview scroll $tmp units
+ return "insert + $tmp lines"
+}
+
+# vvv Overrides text.tcl with Turbo Pascal-style Shift+Arrow selection:
+# Shift+Movement-key, when moved _from_ either end of the selection,
+# updates that end appropriately. Otherwise, it clobbers the selection,
+# and creates a new selection from the current `insert' position to the
+# position the cursor is moved to.
+proc tkTextKeySelect {w newIndex} {
+ # puts "[$w index insert] -> [$w index $newIndex] ([$w index end])"
+ if {[$w compare end == $newIndex]} {set newIndex "end - 1 char"}
+ $w mark set anchor insert
+ if {[$w tag nextrange sel 1.0 end] == ""} {
+ if {[$w compare $newIndex < insert]} {$w tag add sel $newIndex insert} {$w tag add sel insert $newIndex}
+ } { # already have a selection
+ # puts "a=[$w index sel.first]-[$w index sel.last] i=[$w index insert]"
+ if {[$w compare insert == sel.first]} {pts_tag_set_first $w sel $newIndex} \
+ elseif {[$w compare insert == sel.last]} {pts_tag_set_last $w sel $newIndex} \
+ { $w tag remove sel 1.0 end
+ if {[$w compare $newIndex < insert]} {$w tag add sel $newIndex insert} {$w tag add sel insert $newIndex}
+ }
+ }
+ $w mark set insert $newIndex; $w see insert
+ update idletasks
+ # puts "[$w tag ranges sel]"
+ # puts "b=[$w index sel.first]-[$w index sel.last] i=[$w index insert]"
+}
+
+# Imp: ^K B: Control-Space, ^K K: Control-Shift-Space
+
+bind Text <Control-Key-y> {ptsTextDelLn %W}
+bind Text <Control-Key-Y> [bind Text <Control-Key-y>]
+bind Text <Control-Key-d> {if {[%W compare {insert + 1 chars} != end]} {%W delete insert}}
+# ^^^ ensures that pressing `Delete' on the last empty line is a no-op
+bind Text <Key-Delete> [bind Text <Control-Key-d>]
+# ^^^ don't clobber visible selection
+bind Text <Key-BackSpace> {if {[%W compare insert != 1.0]} {%W delete insert-1c; %W see insert}}
+# ^^^ don't clobber visible selection
+
+proc pts_entry_Delete {w} {
+ set i 0
+ set j -1
+ set k -1
+ set i [$w index insert]
+ catch {set j [$w index sel.first]}
+ catch {set k [$w index sel.last]}
+ if {0==[string compare $i $j] || 0==[string compare $i $k]} \
+ {$w delete sel.first sel.last} \
+ {$w delete insert}
+}
+
+bind Entry <B2-Motion> {}
+bind Entry <Button-2> {}
+
+# vvv Overrides entry.tcl, so it won't clobber the selection.
+bind Entry <Key-Delete> {pts_entry_Delete %W}
+# vvv Overrides entry.tcl, so it won't clobber the selection.
+bind Entry <Control-Key-d> {pts_entry_Delete %W}
+bind Entry <Control-Key-i> {%W insert insert \t}
+
+# vvv Overrides entry.tcl, so it won't clobber the selection.
+proc tkEntrySetCursor {w pos} {$w icursor $pos; tkEntrySeeInsert $w}
+# vvv Overrides entry.tcl, so it won't clobber the selection.
+proc tkEntryInsert {w s} {if {[string length $s]} {
+ $w insert insert $s
+ tkEntrySeeInsert $w
+}}
+# vvv Overrides entry.tcl with Turbo Pascal look and feel.
+proc tkEntryKeySelect {w new} {
+ if {[$w selection present]} {
+ set i [$w index insert]
+ if {[$w index sel.first]==$i} {$w selection from sel.last} \
+ elseif {[$w index sel.last]==$i} {$w selection from sel.first} \
+ {$w selection from insert}
+ } {$w selection from insert}
+ $w selection to $new
+ $w icursor $new
+ # tkEntrySeeInsert will be called by our caller.
+}
+# vvv Overrides entry.tcl, so it won't clobber the selection.
+proc tkEntryBackspace w {
+ set x [expr {[$w index insert] - 1}]
+ if {$x >= 0} {$w delete $x}
+ if {[$w index @0] >= [$w index insert]} {
+ set range [$w xview]
+ set left [lindex $range 0]
+ set right [lindex $range 1]
+ $w xview moveto [expr {$left - ($right - $left)/2.0}]
+ }
+}
+
+proc pts_entry_paste_selection {w x y} {
+ #** If has focus, than pastes visible selection to the unchanged cursor
+ #** position; otherwise claims focus and sets cursor position to mouse.
+ if {0==[string compare $w [focus -displayof $w]]} {
+ catch {$w insert insert [selection get -displayof $w]}
+ if {0==[string compare normal [$w cget -state]]} {focus $w}
+ } {$w icursor [tkEntryClosestGap $w $x]; focus $w}
+}
+bind Entry <<PasteSelection>> {pts_entry_paste_selection %W %x %y}
+bind Entry <Insert> {} ;# <Shift-Insert> already OK.
+
+
+# vvv override tk.tcl, so it won't select the whole Entry when tab is pressed}
+proc tkTabToWindow w {focus $w}
+
+# ---
+
+# vvv Imp: improve this on Windows
+set sa_normfont [pts_last_font \
+ system variable helvetica \
+ arial {arial -12 normal} \
+ -adobe-helvetica-medium-r-normal--11-*-100-100-*-*-iso8859-* \
+ -adobe-helvetica-medium-r-normal--12-*-75-75-*-*-iso8859-* \
+ sansserif dialog}]
+set sa_boldfont [pts_last_font \
+ sansserif system variable helvetica \
+ arial {arial -12 bold} \
+ -adobe-helvetica-bold-r-normal--12-*-75-75-*-*-iso8859-1 \
+ -adobe-helvetica-bold-r-normal--11-80-100-100-p-60-iso8859-1 \
+ dialogb]
+set sa_fixfont [pts_last_font \
+ fixed systemfixed fixsedsys monospaced monospace \
+ -*-fixed-*-*-*--13-*-*-*-*-*-iso8859-1 \
+ -misc-fixed-medium-r-semicondensed--13-*-75-75-*-*-iso8859-1 \
+ 6x13]
+# puts sa_normfont=$sa_normfont; puts sa_boldfont=$sa_boldfont
+# Dat: 100 DPI, 14-point Helvetica is too large, 11-point is somewhat small
+
+option add *Dialog.msg.font $sa_normfont ;# respected
+option add *Dialog.Button*font $sa_boldfont ;# respected
+
+wm title . {sam2p Job Editor}
+set tk_StrictMotif 0
+pts_fix_shift_tab
+# . configure -bg red
+
+
+frame .gtop
+
+set g .gtop.g0
+frame $g
+
+label $g.lFileFormat -text FileFormat -anchor w -font $sa_boldfont
+sa_radio $g.fPSL1 FileFormat PSL1 "PS L1" -command {update_radio FileFormat PSL1}
+sa_radio $g.fPSLC FileFormat PSLC "PS LC" -command {update_radio FileFormat PSLC}
+sa_radio $g.fPSL2 FileFormat PSL2 "PS L2" -command {update_radio FileFormat PSL2}
+sa_radio $g.fPSL3 FileFormat PSL3 "PS L3" -command {update_radio FileFormat PSL3}
+sa_radio $g.fPDFB10 FileFormat PDFB1.0 "PDF B 1.0" -command {update_radio FileFormat PDFB1.0}
+sa_radio $g.fPDFB12 FileFormat PDFB1.2 "PDF B 1.2" -command {update_radio FileFormat PDFB1.2}
+sa_radio $g.fPDF10 FileFormat PDF1.0 "PDF 1.0" -command {update_radio FileFormat PDF1.0}
+sa_radio $g.fPDF12 FileFormat PDF1.2 "PDF 1.2" -command {update_radio FileFormat PDF1.2}
+sa_radio $g.fGIF89a FileFormat GIF89a "GIF 89a" -command {update_radio FileFormat GIF89a}
+sa_radio $g.fEmpty FileFormat Empty Empty -command {update_radio FileFormat Empty}
+sa_radio $g.fMeta FileFormat Meta Meta -command {update_radio FileFormat Meta}
+sa_radio $g.fPNM FileFormat PNM PNM -command {update_radio FileFormat PNM}
+sa_radio $g.fPAM FileFormat PAM PAM -command {update_radio FileFormat PAM}
+sa_radio $g.fPIP FileFormat PIP PIP -command {update_radio FileFormat PIP}
+sa_radio $g.fJPEG FileFormat JPEG JPEG -command {update_radio FileFormat JPEG}
+sa_radio $g.fTIFF FileFormat TIFF TIFF -command {update_radio FileFormat TIFF}
+sa_radio $g.fPNG FileFormat PNG PNG -command {update_radio FileFormat PNG}
+
+pack $g.lFileFormat -fill x
+pack $g.fPSL1 $g.fPSLC $g.fPSL2 $g.fPSL3 $g.fPDFB10 $g.fPDFB12 $g.fPDF10 $g.fPDF12 $g.fGIF89a \
+ $g.fEmpty $g.fMeta $g.fPNM $g.fPAM $g.fPIP $g.fJPEG $g.fTIFF $g.fPNG -fill x
+frame $g.pFileFormat -height 5 -width 1
+pack $g.pFileFormat -fill x
+
+
+set g .gtop.g1
+frame $g
+
+label $g.lSampleFormat -text SampleFormat -anchor w -font $sa_boldfont
+sa_radio $g.fOpaque SampleFormat Opaque Opaque -command {update_radio SampleFormat Opaque}
+sa_radio $g.fTransparent SampleFormat Transparent Transparent -command {update_radio SampleFormat Transparent}
+sa_radio $g.fGray1 SampleFormat Gray1 "Gray 1" -command {update_radio SampleFormat Gray1}
+sa_radio $g.fIndexed1 SampleFormat Indexed1 "Indexed 1" -command {update_radio SampleFormat Indexed1}
+sa_radio $g.fMask SampleFormat Mask Mask -command {update_radio SampleFormat Mask}
+sa_radio $g.fTransparent2 SampleFormat Transparent2 "Transparent 2" -command {update_radio SampleFormat Transparent2}
+sa_radio $g.fGray2 SampleFormat Gray2 "Gray 2" -command {update_radio SampleFormat Gray2}
+sa_radio $g.fIndexed2 SampleFormat Indexed2 "Indexed 2" -command {update_radio SampleFormat Indexed2}
+sa_radio $g.fTransparent4 SampleFormat Transparent4 "Transparent 4" -command {update_radio SampleFormat Transparent4}
+sa_radio $g.fRGB1 SampleFormat RGB1 "RGB 1" -command {update_radio SampleFormat Rgb1}
+sa_radio $g.fGray4 SampleFormat Gray4 "Gray 4" -command {update_radio SampleFormat Gray4}
+sa_radio $g.fIndexed4 SampleFormat Indexed4 "Indexed 4" -command {update_radio SampleFormat Indexed4}
+sa_radio $g.fTransparent8 SampleFormat Transparent8 "Transparent 8" -command {update_radio SampleFormat Transparent8}
+sa_radio $g.fRgb2 SampleFormat Rgb2 "RGB 2" -command {update_radio SampleFormat Rgb2}
+sa_radio $g.fGray8 SampleFormat Gray8 "Gray 8" -command {update_radio SampleFormat Gray8}
+sa_radio $g.fIndexed8 SampleFormat Indexed8 "Indexed 8" -command {update_radio SampleFormat Indexed8}
+sa_radio $g.fRgb4 SampleFormat Rgb4 "RGB 4" -command {update_radio SampleFormat Rgb4}
+sa_radio $g.fRgb8 SampleFormat Rgb8 "RGB 8" -command {update_radio SampleFormat Rgb8}
+pack $g.lSampleFormat -fill x
+pack $g.fOpaque $g.fTransparent $g.fGray1 $g.fIndexed1 $g.fMask $g.fTransparent2 $g.fGray2 $g.fIndexed2 $g.fTransparent4 \
+ $g.fRGB1 $g.fGray4 $g.fIndexed4 $g.fTransparent8 $g.fRgb2 $g.fGray8 \
+ $g.fIndexed8 $g.fRgb4 $g.fRgb8 -fill x
+frame $g.pSampleFormat -height 5 -width 1
+pack $g.pSampleFormat -fill x
+
+set g .gtop.g2
+frame $g
+
+proc find_val_range {key} {
+ #** @param key for example "/Compression", "/InputFile", of type tKey
+ #** @return "" or [beg end] abs.index of the value associated with that key
+ #** (may span multiple tokens)
+ global jtw ;# text widget containing the tagged job file
+ set end 1.0
+ while {[llength [set lst [$jtw tag nextrange tKey $end]]]} {
+ set beg [lindex $lst 0]
+ set end [lindex $lst 1]
+ ##puts "key=<[$jtw get $beg $end]>"
+ set ikey [$jtw get $beg $end]
+ if {0==[string compare $ikey $key]} {
+
+ ## puts prev=[$jtw tag prevrange tAny $end]
+ set lst [$jtw tag prevrange tAny $end]
+ if {0!=[llength $lst] && [$jtw compare [lindex $lst 0] < $end]
+ && [$jtw compare $end < [lindex $lst 1]]} {
+ set lst [list $end [lindex $lst 1]]
+ } {
+ if {![llength [set lst [$jtw tag nextrange tAny $end]]]} return ""
+ # ^^^ Imp: show error: found, but no value
+ }
+ ##puts "lst=$lst end=$end."
+ ##eval "puts \[$jtw get $lst\]"
+ if {2!=[llength [set tns [$jtw tag names [lindex $lst 0]]]]} return ""
+ # ^^^ Imp: show error: found, but untagged value
+ ##puts LT=[lindex $tns 1]:$tns:
+ if {![llength [set lst [$jtw tag nextrange [lindex $tns 1] $end]]]} return ""
+ # ^^^ This trick is used to find only a single tag. A single tag often
+ # means a single PostScript token, but -- for example `(a)(b)' and
+ # `[]' contain a single tag, but two tokens.
+ # Imp: show better error message
+ set white [$jtw get $end [lindex $lst 0]]
+ ##puts aaa($white)
+ if {[regexp "\[^\\000\011-\015 ]" $white]} return ""
+ # ^^^ Imp: show error: key and value separated by non-whitespace
+ ##puts bbb
+ set beg [lindex $lst 0]
+ set end [lindex $lst 1]
+ set val [$jtw get $beg $end]
+ set openc [expr {2*[string match <<* $val]+[string match \\\[* $val]}] ;# ]
+ ## puts "openc=$openc; val=<$val>"
+ if {$openc} {
+ set end "$beg + $openc chars"
+ set openc 1
+ while {1} {
+ if {![llength [set lst [$jtw tag nextrange tBrac $end]]]} return ""
+ # ^^^ Imp: show error: unclosed >>
+ set val [$jtw get [lindex $lst 0] [lindex $lst 1]]
+ if {[string match <<* $val]} {incr openc; set end 2} \
+ elseif {[string match \\\[* $val]} {incr openc; set end 1} \
+ elseif {[string match >>* $val]} {incr openc -1; set end 2} \
+ elseif {[string match \]* $val]} {incr openc -1; set end 1} \
+ {return ""}
+ # ^^^ Imp: show error: invalid tBrac
+ set end "[lindex $lst 0] + $end chars"
+ if {!$openc} {return "$beg [$jtw index $end]"}
+ }
+ }
+ # puts "val=<$val>"
+ # return [$jtw get $beg $end]
+ return $lst
+ }
+ }
+ return ""
+}
+
+proc update_psval {key newval} {
+ #** return oldval or ""
+ global jtw
+ if {![llength [set found [find_val_range $key]]]} {return ""}
+ set oldval [eval "$jtw get $found"]
+ eval "$jtw delete $found"
+ set found [lindex $found 0]
+ if {[string match /* $newval]} {$jtw insert $found $newval {tAny tNameval}} \
+ elseif {[string match (* $newval]} {$jtw insert $found $newval {tAny tString}} \
+ elseif {[string match \[-0-9\]* $newval]} {$jtw insert $found $newval {tAny tInt}} \
+ {$jtw insert $found $newval {tAny tSing}}
+ $jtw mark set insert "$found + 1 chars"; $jtw see insert
+ return $oldval
+}
+
+proc update_radio {key newval} {
+ global jtw
+ # puts "got=([find_val_range /Compression])"
+ #set found [find_val_range /Hints]
+ # set found [find_val_range /Profile]
+ #puts "found=$found."
+ #puts "is=([$jtw get [lindex $found 0] [lindex $found 1]])."
+ if {![string length [update_psval /$key /$newval]]} {
+ bell
+ pts_message_box -title Warning -message "Cannot find key /$key. Please verify that the .job file is correct."
+ }
+}
+
+proc update_check {key wPath} {
+ set varname [$wPath cget -variable]
+ global $varname
+ if {[set $varname]} {update_psval /$key true} {update_psval /$key false}
+}
+
+#set psstr_map ""
+#proc psstr_map_init {} {
+# for {set i 0} {$i<32} {incr i} {lappend psstr_map [format %c $i] [format \\%02o $i]}
+# for {set i 127} {$i<256} {incr i} {lappend psstr_map [format %c $i] [format \\%02o $i]}
+#}
+#(\\)'
+#psstr_map_init
+#regexp {^[] -'+-[^]+} str
+
+proc pts_psstr_q {str} {
+ #** This would be <60 chars in Perl. TCL is stupid, lame and sloow.
+ set ret ""
+ while {1} {
+ regexp {^[] -'+-[^-~]*} $str head
+ # ^^^ rejects low-unprintable, >=127, backslash, lparen and rparen
+ set ret $ret$head
+ if {[string length $str]==[set headlen [string length $head]]} break
+ scan [string index $str $headlen] %c charcode
+ set ret $ret[format \\%03o [expr {$charcode&255}]]
+ set str [string range $str [expr {1+$headlen}] end]
+ }
+ return $ret
+}
+
+proc update_str {key newval empty} {
+ # Imp: regsub...
+ # set newval [string map $psstr_map $newval]
+ if {[string length $newval]} {set newval ([pts_psstr_q $newval])} {set newval $empty}
+ if {![string length [update_psval /$key $newval]]} {
+ bell
+ pts_message_box -title Warning -message "Cannot find key /$key. Please verify that the .job file is correct."
+ }
+}
+
+proc update_int {key newval empty} {
+ if {[catch {set intval [expr {0+$newval}]}] || [string compare $intval $newval]} {set intval $empty}
+ if {![string length [update_psval /$key $intval]]} {
+ bell
+ pts_message_box -title Warning -message "Cannot find key /$key. Please verify that the .job file is correct."
+ }
+}
+
+proc but_save {} {
+ global jtw jfn
+ set f [open [$jfn get] w]
+ catch {fconfigure $f -encoding binary} ;# TCL 8.2
+ fconfigure $f -translation binary
+ puts -nonewline $f [$jtw get 1.0 end]
+ close $f
+ # bell
+}
+
+set tmpfnb "sam2p_tmp_[pid]"
+
+proc but_relight {} {
+ # Imp: error checks
+ # Imp: \n transl
+ # set f [open |[list tr a-z A-Z >tmp.tmp] w]
+ global jtw tmpfnb
+ set f [open "|perl -I. -Msam2ptol -e sam2ptol::highlight $jtw >$tmpfnb.tjb" w]
+ catch {fconfigure $f -encoding binary} ;# TCL 8.2
+ fconfigure $f -translation binary
+ puts -nonewline $f [$jtw get 1.0 end]
+ close $f
+ set f [open $tmpfnb.tjb r]
+ catch {fconfigure $f -encoding binary} ;# TCL 8.2
+ fconfigure $f -translation binary
+ # puts [read $f]
+ eval [read $f]
+ close $f
+ file delete -- $tmpfnb.tjb
+}
+
+proc but_load {} {
+ global jtw jfn tmpfnb
+ if {[catch {set f [open [$jfn get] r]} err]} {
+ pts_message_box -message "Load failed: $err"
+ } {
+ catch {fconfigure $f -encoding binary} ;# TCL 8.2
+ fconfigure $f -translation binary
+ $jtw delete 1.0 end
+ $jtw insert end [read $f]
+ close $f
+ but_relight
+ # bell
+
+ global InputFile InputFileOK
+ set InputFile ""
+ if {[llength [set found [find_val_range /InputFile]]]} {
+ set val [eval "$jtw get $found"]
+ if {[string match (*) $val]} {
+ # vvv Imp: real PS backslash interpolation, not TCL
+ set InputFile [subst -nocommands -novariables [string range $val 1 [expr {[string length $val]-2}]]]
+ }
+ }
+ set InputFileOK [pts_read_ok $InputFile]
+
+ global OutputFile OutputFileOK
+ set OutputFile ""
+ if {[llength [set found [find_val_range /OutputFile]]]} {
+ set val [eval "$jtw get $found"]
+ if {[string match (*) $val]} {
+ # vvv Imp: real PS backslash interpolation, not TCL
+ set OutputFile [subst -nocommands -novariables [string range $val 1 [expr {[string length $val]-2}]]]
+ }
+ }
+ set OutputFileOK [pts_write_ok $OutputFile]
+
+ global FileFormat
+ set FileFormat ""
+ if {[llength [set found [find_val_range /FileFormat]]]} {
+ set FileFormat [string range [eval "$jtw get $found"] 1 end]
+ }
+
+ global SampleFormat
+ set SampleFormat ""
+ if {[llength [set found [find_val_range /SampleFormat]]]} {
+ set SampleFormat [string range [eval "$jtw get $found"] 1 end]
+ }
+
+ global Compression
+ set Compression ""
+ if {[llength [set found [find_val_range /Compression]]]} {
+ set Compression [string range [eval "$jtw get $found"] 1 end]
+ }
+
+ global TransferEncoding
+ set TransferEncoding ""
+ if {[llength [set found [find_val_range /TransferEncoding]]]} {
+ set TransferEncoding [string range [eval "$jtw get $found"] 1 end]
+ }
+
+ global Predictor
+ set Predictor ""
+ if {[llength [set found [find_val_range /Predictor]]]} {
+ set Predictor [eval "$jtw get $found"]
+ }
+
+ global TransferCPL
+ set TransferCPL ""
+ if {[llength [set found [find_val_range /TransferCPL]]]} {
+ set TransferCPL [eval "$jtw get $found"]
+ }
+
+ global Effort
+ set Effort ""
+ if {[llength [set found [find_val_range /Effort]]]} {
+ set Effort [eval "$jtw get $found"]
+ }
+
+ global RecordSize
+ set RecordSize ""
+ if {[llength [set found [find_val_range /RecordSize]]]} {
+ set RecordSize [eval "$jtw get $found"]
+ }
+
+ global K
+ set K ""
+ if {[llength [set found [find_val_range /K]]]} {
+ set K [eval "$jtw get $found"]
+ }
+
+ global Quality
+ set Quality ""
+ if {[llength [set found [find_val_range /Quality]]]} {
+ set Quality [eval "$jtw get $found"]
+ }
+
+ global WarningOK
+ set WarningOK ""
+ if {[llength [set found [find_val_range /WarningOK]]]} {
+ if {[string compare true [eval "$jtw get $found"]]} {set WarningOK 1} {set WarningOK 1}
+ }
+
+ global TmpRemove
+ set TmpRemove ""
+ if {[llength [set found [find_val_range /TmpRemove]]]} {
+ if {[string compare true [eval "$jtw get $found"]]} {set TmpRemove 1} {set TmpRemove 1}
+ }
+
+ }
+}
+
+proc but_quit {} {
+ if {0==[string compare yes [pts_message_box -type yesno -title {Confirm quit} -message "Quit now, without saving?"]]} exit
+}
+
+proc but_run {} {
+ # by pts@fazekas.hu at Fri Apr 26 23:43:17 CEST 2002
+ global JobFile
+ sa_debug_append "exec sam2p $JobFile:\n"
+ # if {[catch {set ret [exec sam2p $JobFile 2>@ stdout]} ret]} {}
+ if {[catch {set ret [exec sh -c {exec sam2p $1 2>&1} sam2p. $JobFile]} ret]} {
+ set ret "Error running sam2p:\n$ret"
+ }
+ # puts ($ret)
+ sa_debug_append $ret\n\n
+}
+
+# option add *Dialog*Label*font fixed
+# option add *Label*Font times
+#option add *font times
+#option add *$g*font times
+#option add *Dialog.msg.background red
+
+label $g.lCompression -text Compression -anchor w -font $sa_boldfont
+sa_radio $g.fNone Compression None None -command {update_radio Compression None}
+sa_radio $g.fLZW Compression LZW LZW -command {update_radio Compression LZW}
+sa_radio $g.fZIP Compression ZIP ZIP -command {update_radio Compression ZIP}
+sa_int $g.fZIP.fEffort Effort Effort 2 -textvariable Effort
+bind $g.fZIP.fEffort.i <FocusOut> {update_int Effort [%W get] pop}
+pack $g.fZIP.fEffort -side left
+sa_radio $g.fRLE Compression RLE RLE -command {update_radio Compression RLE}
+sa_int $g.fRLE.fRecordSize RecordSize R.S 3 -textvariable RecordSize
+bind $g.fRLE.fRecordSize.i <FocusOut> {update_int RecordSize [%W get] pop}
+pack $g.fRLE.fRecordSize -side left
+sa_radio $g.fFax Compression Fax Fax -command {update_radio Compression Fax}
+sa_int $g.fFax.fK K K 5 -textvariable K
+bind $g.fFax.fK.i <FocusOut> {update_int K [%W get] pop}
+pack $g.fFax.fK -side left
+sa_radio $g.fDCT Compression DCT DCT -command {update_radio Compression DCT}
+sa_radio $g.fIJG Compression IJG IJG -command {update_radio Compression IJG}
+sa_int $g.fIJG.fQuality Quality Q'lty 3 -textvariable Quality
+bind $g.fIJG.fQuality.i <FocusOut> {update_int Quality [%W get] pop}
+pack $g.fIJG.fQuality -side left
+sa_radio $g.fJAI Compression JAI JAI -command {update_radio Compression JAI}
+#label $g.fJAI.haha -text haha
+#pack $g.fJAI.haha -side left
+pack $g.lCompression -fill x
+pack $g.fNone $g.fLZW $g.fZIP $g.fRLE $g.fFax $g.fDCT $g.fIJG $g.fJAI -fill x
+sa_vframe $g
+
+sa_int $g.lPredictor Predictor Predictor 3 -textvariable Predictor
+bind $g.lPredictor.i <FocusOut> {update_int Predictor [%W get] pop}
+pack $g.lPredictor -fill x
+sa_vframe $g
+
+sa_check_update $g.cWarningOK WarningOK WarningOK
+# -textvariable WarningOK
+pack $g.cWarningOK -fill x
+sa_vframe $g
+
+label $g.lTransferEncoding -text TransferEncoding -anchor w -font $sa_boldfont
+sa_radio $g.fBinary TransferEncoding Binary Binary -command {update_radio TransferEncoding Binary}
+sa_radio $g.fASCII TransferEncoding ASCII ASCII -command {update_radio TransferEncoding ASCII}
+sa_radio $g.fHex TransferEncoding Hex Hex -command {update_radio TransferEncoding Hex}
+sa_radio $g.fA85 TransferEncoding A85 A85 -command {update_radio TransferEncoding A85}
+pack $g.lTransferEncoding -fill x
+pack $g.fBinary $g.fASCII $g.fHex $g.fA85 -fill x
+frame $g.pTransferEncoding -height 5 -width 1
+pack $g.pTransferEncoding -fill x
+
+sa_int $g.fTransferCPL TransferCPL TransferCPL 3 -textvariable TransferCPL
+bind $g.fTransferCPL.i <FocusOut> {update_int TransferCPL [%W get] pop}
+
+pack $g.fTransferCPL -fill x
+sa_vframe $g
+
+sa_check_update $g.cTmpRemove TmpRemove {Tmp Remove}
+pack $g.cTmpRemove -fill x
+sa_vframe $g
+
+
+set g .gtop.g3
+frame $g
+
+sa_w_text $g.t -width 58 -height 18 -wrap none -font $sa_fixfont
+pts_fix_one_tab $g.t
+pts_text_autoindent $g.t 1
+pts_text_auto_overstrike $g.t 0
+# $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"
+# $g.t insert end [read [open template.job r]]
+# Imp: close file...
+$g.t mark set insert 1.0; $g.t see insert
+$g.t tag configure tAny; $g.t tag lower tAny sel
+$g.t tag configure tSing -foreground "#003f7f"; $g.t tag raise tSing sel
+$g.t tag configure tString -foreground "#007f7f"; $g.t tag raise tString sel
+$g.t tag configure tKey -foreground "#00007f"; $g.t tag raise tKey sel
+$g.t tag configure tNameval -foreground "#0000ff"; $g.t tag raise tNameval sel
+$g.t tag configure tBrac -foreground "#ff0000"; $g.t tag raise tBrac sel
+$g.t tag configure tComment -foreground "#007f00"; $g.t tag raise tComment sel
+$g.t tag configure tInt -foreground "#3f0000"; $g.t tag raise tInt sel
+$g.t tag configure tError -background "#ffdddd"; $g.t tag lower tError sel
+
+# puts X[bindtags $g.t]X
+# puts X[bind $g.t]X
+# puts XZ[bind all]X
+
+set jtw $g.t
+
+# Imp: delete tmp.tmp
+
+# -font sansserif
+# puts [$g.t tag ranges tSing]
+# reground blue
+
+# update idletasks; puts [winfo geometry $g.t] ;# not ready, has to be packed first
+
+frame $g.f
+sa_w_text $g.f.td -width 1 -height 13 -wrap char -font $sa_fixfont \
+ -yscrollcommand "$g.f.sd set" -spacing3 2
+$g.f.td configure -selectbackground yellow ;# override
+scrollbar $g.f.sd -command "$g.f.td yview" -width 11 -elementborderwidth 2 \
+ -relief flat -borderwidth 1 -takefocus 0 -troughcolor gray65
+$g.f.sd configure -activebackground [$g.f.sd cget -background]
+
+# OK: non-editable, but not disabled (we need the cursor!)
+# $g.f.td configure -background [lindex [$g.f.td configure -background] 3]
+pts_readonly_color $g.f.td
+# puts $g.f.td
+# puts TD:[bind .gtop.g3.f.td <Key-Return>]
+
+pts_fix_one_tab $g.f.td
+$g.f.td insert end "Debug messages, sam2p output:\n\n"
+# $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"
+# $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"
+$g.f.td mark set insert 1.0; $g.f.td see insert
+set debugtext $g.f.td
+
+pack $g.t -expand 0 -fill x
+pack $g.f.td -expand 1 -fill both -side left
+pack $g.f.sd -fill both -side left
+pack $g.f -expand 1 -fill both
+
+pack .gtop.g0 .gtop.g1 .gtop.g2 -side left
+pack .gtop.g3 -expand 1 -fill both -side left
+
+frame .gbot
+frame .gbot.gbl
+
+set g .gbot.gbl.fCurdir
+frame $g
+label $g.l -text "Current dir" -font $sa_boldfont
+sa_w_entry $g.e -font $sa_normfont
+# bind $g.e <FocusOut> {update_str e [%W get] pop}
+pack $g.l -side left
+pack $g.e -expand 1 -fill x -side left
+$g.e insert 0 [pwd]
+
+# puts [bind .gbot.gbl.fCurdir.e]
+
+bind Text <B2-Motion> {}
+bind Text <Button-2> {}
+# puts T[bind Text]T
+# puts [bind Text <Button-2>]
+#puts ([bind Entry <Tab>])
+
+#foreach evtseq [bind Entry] {
+# if {[string match <Key-*> $evtseq]
+# || [string match <*-Key-*> $evtseq]
+# || [string match <*-Key> $evtseq]
+# } {
+# bind $g.e $evtseq {break}
+# puts +:$evtseq
+# } {
+# #puts -:$evtseq
+# }
+#}
+
+# Dat: this assumes [lindex [bindtags $g.e] 0] == $g.e
+#foreach tag [bindtags $g.e] {
+# foreach evtseq [bind $tag] {
+# # if {0==[string length [bind $g.e $evtseq]]} {bind $g.e $evtseq [bind $tag $evtseq]}
+# }
+#}
+
+pts_readonly_color $g.e
+
+
+# event info <<Clear>>
+#bind $g.e <Key-Tab> {# nothing}
+#bind $g.e <Key-ISO_Left_Tab> {# nothing}
+# puts /[bind $g.e]
+# puts :[bind $g.e <Key-Return>]
+
+set g .gbot.gbl.fJobFile
+frame $g
+label $g.l -text JobFile -font $sa_boldfont
+sa_w_entry $g.e -font $sa_normfont -textvariable JobFile
+label $g.r -text OK -font $sa_normfont -textvariable JobFileOK -width 2
+bind $g.e <FocusOut> {set JobFileOK [pts_write_ok $JobFile]}
+set jfn $g.e
+pack $g.l -side left
+pack $g.e -expand 1 -fill x -side left
+pack $g.r -side left
+
+
+set g .gbot.gbl.fInputFile
+frame $g
+label $g.l -text InputFile -font $sa_boldfont
+sa_w_entry $g.e -font $sa_normfont -textvariable InputFile
+label $g.r -text OK -font $sa_normfont -textvariable InputFileOK -width 2
+bind $g.e <FocusOut> {update_str InputFile [%W get] pop; set InputFileOK [pts_read_ok $InputFile]}
+pack $g.l -side left
+pack $g.e -expand 1 -fill x -side left
+pack $g.r -side left
+set InputFileOK [pts_read_ok $InputFile]
+
+set g .gbot.gbl.fOutputFile
+frame $g
+label $g.l -text OutputFile -font $sa_boldfont
+sa_w_entry $g.e -font $sa_normfont -textvariable OutputFile
+label $g.r -text OK -font $sa_normfont -textvariable OutputFileOK -width 2
+bind $g.e <FocusOut> {update_str OutputFile [%W get] pop; set OutputFileOK [pts_write_ok $OutputFile]}
+pack $g.l -side left
+pack $g.e -expand 1 -fill x -side left
+pack $g.r -side left
+
+pack .gbot.gbl.fCurdir .gbot.gbl.fJobFile .gbot.gbl.fInputFile .gbot.gbl.fOutputFile -expand 1 -fill x
+
+frame .gbot.ha
+button .gbot.ha.bLoad -text {Load Job} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \
+ -command but_load
+bind . <Alt-Key-l> but_load
+button .gbot.ha.bSave -text {Save Job} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \
+ -command but_save
+bind . <Alt-Key-s> but_save
+
+frame .gbot.hb
+button .gbot.hb.bRun -text {Run} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \
+ -command but_run
+bind . <Alt-Key-r> but_run
+button .gbot.hb.bQuit -text {Quit} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \
+ -command but_quit
+bind . <Alt-Key-q> but_quit
+pack .gbot.gbl -expand 1 -fill x -side left
+pack .gbot.ha.bLoad .gbot.ha.bSave
+pack .gbot.hb.bRun .gbot.hb.bQuit
+pack .gbot.ha .gbot.hb -side left
+
+pack .gtop -expand 1 -fill both
+pack .gbot -expand 0 -fill x
+update idletasks ;# a sima [update] helyett, hogy a "geometry" jó legyen
+scan [wm geometry .] "%dx%d%s" width height tmp
+wm minsize . $width $height
+
+
+set env(PATH) $env(PATH)[pts_PATH_sep].
+#if {[catch {set ret [exec sam2p --help 2>&1]} ret]} {}
+if {[catch {set ret [exec sh -c {exec sam2p --help 2>&1}]} ret]} {
+ set ret "Error:\n$ret"
+}
+
+proc sa_debug_append msg {
+ global debugtext
+ $debugtext insert end $msg
+ $debugtext mark set insert end
+ $debugtext see insert
+}
+
+sa_debug_append $ret\n\n
+# puts ($ret)
+
+
+$jfn delete 0 end
+if {[llength $argv]} {$jfn insert 0 [lindex $argv 0]; but_load} {
+ $jfn insert 0 template.job; but_load; $jfn delete 0 end
+ set InputFileOK 0
+ set OutputFileOK 0
+ set JobFileOK 0
+}
+# set InputFile hello
+# but_load
+# puts $argv
+# puts TD:[bind .gtop.g3.f.td <Key-Return>]
+
+
+#__END__