Hello,
I have a problem with my TK script.
Hope somebody can help me out.
I have wrote a script for GUI for an application.which have a text area with several options for selcting file,opening it and modifying ..etc..
What i need now is ..i have a file which shows some PID values of a decoder.
When i open this file, and when i select a Particular PID,that should be displayed in the text area..
And at the same time when i select a file,it should manipulate it(for example:remultiplexing, demultiplexing fo streams)
Here is the code i m attaching,please kindly need modifications accoridng the above requirement.
proc CreateWindow { } {
wm title . "Test Application"
frame .top -bd 1 -relief raised
frame .left
frame .right
frame .bottom
button .bottom.bottom -text Parse -command init -foreground red -background black -font {-family times -size 12}
pack .bottom.bottom -side right -padx 0p -pady 0 -anchor n
pack .top -side top -fill x
pack .bottom -side bottom -fill x
pack .left -side left -fill both
pack .right -side left -fill both -expand 1
label .top.fn -textvariable fn -bd 1 -relief sunken
menubutton .top.1 -text File -bd 1 -pady 2 -menu .top.1.menu
menubutton .top.2 -text Edit -bd 1 -pady 2 -menu .top.2.menu
menubutton .top.3 -text Search -bd 1 -pady 2 -menu .top.3.menu
menubutton .top.4 -text Preferences -bd 1 -pady 2 -menu .top.4.menu
menu .top.1.menu
menu .top.2.menu
menu .top.3.menu
menu .top.4.menu
.top.1.menu add command -label Open -command Open
.top.1.menu add command -label Save -command {Save $fn}
.top.1.menu add command -label "Save As" -command Save
.top.1.menu add command -label Close -command Close
.top.1.menu add command -label Exit -command exit
.top.2.menu add cascade -label Undo -menu .top.2.menu.undo
menu .top.2.menu.undo -tearoff 0
.top.2.menu add command -label New -command New
.top.2.menu add command -label Delete -command Delete
.top.2.menu add command -label Revert -command Revert
.top.2.menu add command -label "Revert All" -command "Revert all"
.top.2.menu add command -label Rename -command Rename
.top.2.menu add command -label Edit -command Edit
.top.2.menu add command -label Comment -command Comment
.top.3.menu add command -label Search -command Search
.top.4.menu add checkbutton -label Color -variable prefs(color)
# .top.4.menu add checkbutton -label Files -variable prefs(files)
.top.4.menu invoke 1
# .top.4.menu add command -label
pack .top.fn -side right -ipadx 3 -padx 2
pack .top.1 -side left
pack .top.2 -side left
pack .top.3 -side left
pack .top.4 -side left
label .bottom.status -bd 1 -relief sunken -textvariable status -anchor w
pack .bottom.status -side left -padx 3 -pady 2 -fill x -expand 1
scrollbar .left.scrolly -orient v -width 13 -command ".left.procs yview"
scrollbar .left.scrollx -orient h -width 13 -command ".left.procs xview"
listbox .left.procs -width 15 -yscrollcommand ".left.scrolly set" -xscrollcommand ".left.scrollx set" -exportselection 0
frame .left.buttons
button .left.buttons.up -text /\\ -command MoveUp -bd 1
button .left.buttons.down -text \\/ -command MoveDown -bd 1
button .left.buttons.new -text N -command New -bd 1
button .left.buttons.del -text D -command Delete -bd 1
button .left.buttons.ren -text R -command Rename -bd 1
button .left.buttons.edit -text E -command Edit -bd 1
pack .left.buttons -side right
pack .left.scrolly -side right -fill y
pack .left.scrollx -side bottom -fill x
pack .left.procs -fill both -expand 1
pack .left.buttons.up -side top
pack .left.buttons.down -side top -padx 4 -pady 2
pack .left.buttons.new -side top -pady 2
pack .left.buttons.del -side top
pack .left.buttons.ren -side top -pady 2
pack .left.buttons.edit -side top -pady 2
bind .left.procs <ButtonRelease> Display
scrollbar .right.scrolly -orient v -width 13 -command ".right.text yview"
scrollbar .right.scrollx -orient h -width 13 -command ".right.text xview"
text .right.text -wrap none -yscrollcommand ".right.scrolly set" -xscrollcommand ".right.scrollx set" -bg #999999 -font -*-lucidatypewriter-*-r-*-*-*-120-*-*-*-*-iso8859-1
bind .right.text <Return> "after 1 Update"
bind .right.text <BackSpace> BackSpace
bind .right.text <space> Space
bind .right.text <Control-c> "Color all"
bind .right.text <Control-u> "Display"
bind .right.text <Control-e> {.right.text mark set insert "[.right.text index insert] lineend"}
bind .right.text <Control-t> {.right.text mark set insert 0.0}
bind .right.text <Control-g> {.right.text mark set insert "[.right.text index insert] linestart"}
bind .right.text <Control-b> {.right.text mark set insert [.right.text index end]}
pack .right.scrolly -side right -fill y
pack .right.scrollx -side bottom -fill x
pack .right.text -expand 1 -fill both
}
proc Search { } {
global search
catch {destroy .search}
toplevel .search -class Dialog
wm title .search "Search/Replace"
wm iconname .search "Search/Replace"
foreach x "1 2 3 4 5" {
frame .search.$x
pack .search.$x -side top -fill x
}
label .search.1.label -text "Start at:"
label .search.2.label -text "Direction:"
label .search.3.label -text "Search for:"
label .search.4.label -text "Replace with:"
pack .search.1.label -side left -padx 5 -pady 5
pack .search.2.label -side left -padx 5 -pady 5
pack .search.3.label -side left -padx 5 -pady 5
pack .search.4.label -side left -padx 5 -pady 5
radiobutton .search.1.r1 -text "Cursor Position" -variable search(start) -value insert
radiobutton .search.1.r2 -text "Beginning" -variable search(start) -value 0.0
radiobutton .search.1.r3 -text "End" -variable search(start) -value end
if {$search(start) == ""} {
.search.1.r1 select
}
pack .search.1.r1 -side left
pack .search.1.r2 -side left
pack .search.1.r3 -side left
radiobutton .search.2.r1 -text "Forward" -variable search(direction) -value f
radiobutton .search.2.r2 -text "Backward" -variable search(direction) -value b
if {$search(direction) == ""} {
.search.2.r1 select
}
pack .search.2.r1 -side left
pack .search.2.r2 -side left
entry .search.3.e1
pack .search.3.e1 -side left -fill x
entry .search.4.e1
pack .search.4.e1 -side left -fill x
button .search.5.b1 -text "Search" -command {DoSearch 1 [.search.3.e1 get] [.search.4.e1 get]}
button .search.5.b2 -text "Replace" -command {DoSearch 2 [.search.3.e1 get] [.search.4.e1 get]}
# button .search.5.b3 -text "Replace veto" -command {DoSearch 3 [.search.3.e1 get] [.search.4.e1 get]}
button .search.5.b4 -text "Replace all" -command {DoSearch 4 [.search.3.e1 get] [.search.4.e1 get]}
button .search.5.b5 -text "Done" -command {destroy .search}
pack .search.5.b1 -side left -padx 3 -ipadx 4 -pady 4
pack .search.5.b2 -side left -padx 3 -ipadx 4 -pady 4
# pack .search.5.b3 -side left -padx 3 -ipadx 4 -pady 4
pack .search.5.b4 -side left -padx 3 -ipadx 4 -pady 4
pack .search.5.b5 -side left -padx 3 -ipadx 4 -pady 4
bind .search <Escape> {destroy .search}
wm withdraw .search
update idletasks
set x [expr [winfo screenwidth .search]/2 - [winfo reqwidth .search]/2 - [winfo vrootx [winfo parent .search]]]
set y [expr [winfo screenheight .search]/2 - [winfo reqheight .search]/2 - [winfo vrooty [winfo parent .search]]]
wm geom .search +$x+$y
wm deiconify .search
focus .search.3.e1
}
proc Comment { } {
set start [lindex [split [lindex [.right.text tag ranges sel] 0] .] 0]
set end [lindex [split [lindex [.right.text tag ranges sel] 1] .] 0]
if {$start == "" || $end == ""} {
bell
return
}
for {} {$start <= $end} {incr start} {
.right.text insert $start.0 #
}
.right.text tag remove sel 0.0 end
Display
}
proc SearchNext {s} {
global search
if {$search(direction) == "f"} {
set tmp [.right.text search -forward -- "$s" [.right.text index $search(start)] end]
if {$tmp == ""} {
return ""
}
set end [.right.text index $tmp+[string length $s]c]
return "$tmp $end $end"
} elseif {$search(direction) == "b"} {
set tmp [.right.text search -backward -- "$s" [.right.text index $search(start)] 0.0]
if {$tmp == ""} {
return ""
}
return "$tmp [.right.text index $tmp+[string length $s]c] $tmp"
}
return ""
}
proc DoSearch {type s r} {
global search
if {$s == ""} {
return
}
set tmp ""
switch $type {
1 {
set tmp [SearchNext $s]
if {$tmp == ""} {
return
}
.right.text tag remove sel 0.0 end
.right.text tag add sel [lindex $tmp 0] [lindex $tmp 1]
.right.text see [lindex $tmp 2]
.right.text mark set insert [lindex $tmp 2]
}
2 {
set tmp [SearchNext $s]
.right.text delete [lindex $tmp 0] [lindex $tmp 1]
.right.text insert [lindex $tmp 0] "$r"
.right.text mark set insert [lindex $tmp 2]
}
3 {
}
4 {
while {[set tmp [SearchNext $s]] != ""} {
.right.text delete [lindex $tmp 0] [lindex $tmp 1]
.right.text insert [lindex $tmp 0] "$r"
.right.text mark set insert [lindex $tmp 2]
}
}
}
}
proc Revert {args} {
global proc myargs orig origargs cur
if {$args == "all"} {
Open $fn
} elseif {$args == ""} {
set num [.left.procs curselection]
if {$num == ""} {
bell
return
}
set name [.left.procs get $num]
set proc($name) $orig($name)
set myargs($name) $origargs($name)
set cur ""
Display
}
}
proc Close { } {
global fn proc myargs status
set fn ""
catch {unset proc}
catch {unset myargs}
.right.text delete 0.0 end
.left.procs delete 0 end
set status Ready
}
proc Open {args} {
global orig proc myargs origargs status
global errorInfo fn
if {$args == ""} {
set args [tk_getOpenFile -initialdir ~ -parent . -title Open -filetypes {{{All} {*}} {{Tcl} {*.tcl}}}]
}
if {$args == ""} {
return
}
if [catch {open $args} fh] {
tk_dialog .dialog Error [lindex [split $errorInfo "\n"] 0] error 0 "Ok"
return
}
if [catch {read -nonewline $fh} read] {
tk_dialog .dialog Error [lindex [split $errorInfo "\n"] 0] error 0 "Ok"
return
}
Close
close $fh
set fn $args
Parse [split $read "\n"]
set status "loaded [array size proc] procs"
array set orig [array get proc]
array set origargs [array get myargs]
}
proc Rename { } {
global proc myargs
set num [.left.procs curselection]
if {$num == ""} {
bell
return
}
set old [.left.procs get $num]
set new [tk_getString Rename "Rename $old to:"]
if {$new == "0"} {
return
}
set proc($new) $proc($old)
unset proc($old)
set myargs($new) $myargs($old)
unset myargs($old)
.left.procs delete $num
.left.procs insert $num $new
}
proc Edit { } {
global myargs
set num [.left.procs curselection]
if {$num == ""} {
bell
return
}
set name [.left.procs get $num]
set new [tk_getString Rename "Args for $name:"]
if {$new == "0"} {
return
}
set myargs($name) $new
Display
}
proc New { } {
global proc myargs
set num [.left.procs curselection]
if {$num == ""} {
set num 0
}
set new [tk_getString New "Select the PID"]
if {$new == "0"} {
return
}
.left.procs insert $num $new
.left.procs selection clear 0 end
.left.procs selection set $num
set procs($new) ""
set myargs($new) ""
Display
}
proc Save {args} {
global proc myargs
Display
if {$args == ""} {
set args [tk_getSaveFile -initialdir ~ -parent . -title Save]
}
if {$args == ""} {
return
}
if [catch {open $args w} fh] {
tk_dialog .dialog Error [lindex [split $errorInfo "\n"] 0] error 0 "Ok"
return
}
foreach x [.left.procs get 0 end] {
if [string match "Other *" $x] {
puts $fh [string trim $proc($x)]
puts $fh ""
} else {
puts $fh "proc $x \{$myargs($x)\} \{"
foreach a [split [string trim $proc($x)] "\n"] {
puts $fh " $a"
}
puts $fh "\}"
puts $fh ""
}
}
close $fh
}
proc BackSpace { } {
set char [.right.text get [.right.text index insert]-1c]
# set range [.right.text tag ranges sel]
# if {$range != ""} {
# AddUndo "Block delete in [.left.procs get [.left.procs curselection]]" [.left.procs get [.left.procs curselection]] ".right.text insert [lindex $range 0] [.right.text get [lindex $range 0] [lindex $range 1]]"
# }
if {$char == "\}" || $char == "\{"} {
after 1 Update
}
}
proc Space { } {
global prefs
if {$prefs(color) && [.right.text get [.right.text index insert]-1c] != " "} {
after 1 Color [.right.text index insert]
}
}
proc Delete { } {
set num [.left.procs curselection]
if {$num == ""} {
bell
return
}
.left.procs delete $num
}
proc MoveUp { } {
set num [.left.procs curselection]
if {$num == "0" || $num == ""} {
bell
return
}
set name [.left.procs get $num]
.left.procs delete $num
.left.procs insert [expr $num - 1] $name
.left.procs selection set [expr $num - 1]
}
proc MoveDown { } {
set num [.left.procs curselection]
if {[expr $num + 1] == [.left.procs index end] || $num == ""} {
bell
return
}
set name [.left.procs get $num]
.left.procs delete $num
.left.procs insert [expr $num + 1] $name
.left.procs selection set [expr $num + 1]
}
proc tk_getString {title text} {
global tkPriv
catch {destroy .dialog}
toplevel .dialog -class Dialog
wm title .dialog $title
wm iconname .dialog $title
wm protocol .dialog WM_DELETE_WINDOW {set tkPriv(button) 0}
frame .dialog.text
frame .dialog.entry
frame .dialog.buttons
pack .dialog.text -side top -fill x
pack .dialog.entry -side top -fill x
pack .dialog.buttons -side top -fill x
entry .dialog.entry.entry -width 20
pack .dialog.entry.entry -padx 4 -pady 5
focus .dialog.entry.entry
bind .dialog <Return> {set tkPriv(button) [.dialog.entry.entry get]}
button .dialog.buttons.ok -text Ok -command {set tkPriv(button) [.dialog.entry.entry get]}
button .dialog.buttons.cancel -text Cancel -command {set tkPriv(button) 0}
bind .dialog <Destroy> {set tkPriv(button) 0}
bind .dialog <Escape> {set tkPriv(button) 0}
pack .dialog.buttons.ok -side left -padx 3 -pady 3
pack .dialog.buttons.cancel -side right -padx 3 -pady 3
label .dialog.text.label -text $text
pack .dialog.text.label -padx 3 -pady 3
wm withdraw .dialog
update idletasks
set x [expr [winfo screenwidth .dialog]/2 - [winfo reqwidth .dialog]/2 - [winfo vrootx [winfo parent .dialog]]]
set y [expr [winfo screenheight .dialog]/2 - [winfo reqheight .dialog]/2 - [winfo vrooty [winfo parent .dialog]]]
wm geom .dialog +$x+$y
wm deiconify .dialog
tkwait variable tkPriv(button)
bind .dialog <Destroy> {}
destroy .dialog
focus .right.text
return $tkPriv(button)
}
proc Jump {x y} {
set proc [.right.text get "@$x,$y wordstart" "@$x,$y wordend"]
set num [lsearch -exact [.left.procs get 0 end] $proc]
if {$num == "-1"} {
return
}
.left.procs selection clear 0 end
.left.procs selection set $num
.left.procs see $num
Display
after 1 {.right.text tag remove sel 0.0 end}
}
proc Display { } {
global proc cur status myargs prefs
if {[.left.procs curselection] == ""} {
return
}
if {[info exists cur] && $cur != ""} {
set proc($cur) [.right.text get 0.0 end]
}
.right.text delete 0.0 end
set procname [.left.procs get [.left.procs curselection]]
if [info exists proc($procname)] {
.right.text insert 0.0 [string trim $proc($procname)]
set status "[.left.procs get [.left.procs curselection]]: [expr [llength [split $proc($procname) "\n"]] - 1] lines \{$myargs($procname)\}"
}
set cur [.left.procs get [.left.procs curselection]]
.right.text mark set insert 0.0
focus .right.text
if $prefs(color) {
Color all
}
}
proc procname {line} {
set tmp [string range $line [expr [string first " " $line] + 1] end]
set tmp [string range $tmp 0 [expr [string first " " $tmp] - 1]]
return $tmp
}
proc Update { } {
global prefs
set spaces " "
set num [expr [lindex [split [.right.text index insert] .] 0] - 2]
set prev [.right.text get "$num.0 lineend-1c" "$num.0 lineend"]
set end [lindex [split [.right.text index end] .] 0]
set indent [expr ([string length [.right.text get "$num.0 linestart" "$num.0 lineend"]] - [string length [string trimleft [.right.text get "$num.0 linestart" "$num.0 lineend"]]]) / 4]
for {} {$num < $end} {incr num} {
set line [.right.text get 0.0+${num}l "0.0+${num}l lineend"]
if {$prev == "\{"} {
incr indent
}
set trim [string trimleft $line]
if {[string index $trim 0] == "\}"} {
incr indent -1
}
set diff [expr [string length $line] - [string length $trim]]
.right.text delete "0.0+${num}l linestart" "0.0+${num}l+${diff}c"
.right.text insert 0.0+${num}l [string range $spaces 1 [expr $indent * 4]]
set prev [string range $trim end end]
}
if $prefs(color) {
Color $num.0
}
}
proc Color {line} {
global color proc
if {$line == "all"} {
.right.text tag delete [.right.text tag names]
.right.text tag configure proc -foreground #AA00AA
.right.text tag bind proc <Double-Button-1> {Jump %x %y}
.right.text tag configure tcl -foreground #FF0000
.right.text tag configure cond -foreground #00FF00
.right.text tag configure break -foreground #004C00
.right.text tag configure tk -foreground #0000FF
.right.text tag configure brace -foreground #AA6600
.right.text tag configure var -foreground #FFFF00
.right.text tag configure comment -foreground #FFFFFF
set end [.right.text index end]
set start 0.0
} else {
set start [.right.text index "$line linestart"]
set end [.right.text index "$line lineend"]
}
# foreach x [array names proc] {
# set pos $start
# while {[set a [.right.text search -exac -count num $x $pos $end]] != ""} {
# set pos [.right.text index $a+${num}c]
# .right.text tag add proc $a $pos
# }
# }
foreach x "set incr expr string lindex unset lrange lreplace eval global split info after source" {
set pos $start
while {[set a [.right.text search -exact -count num $x $pos $end]] != ""} {
set pos [.right.text index $a+${num}c]
.right.text tag add tcl $a $pos
}
}
foreach x {"if " "for " "foreach " " elseif " " else " "switch " "while " " || " " && " " == " " != " " > " " < " " <= " " >= "} {
set pos $start
while {[set a [.right.text search -exact -count num $x $pos $end]] != ""} {
set pos [.right.text index $a+${num}c]
.right.text tag add cond $a $pos-1c
}
}
foreach x "continue break catch return" {
set pos $start
while {[set a [.right.text search -exact -count num $x $pos $end]] != ""} {
set pos [.right.text index $a+${num}c]
.right.text tag add break $a $pos
}
}
foreach x "bind scrollbar listbox button menu menubutton pack frame wm label entry winfo" {
set pos $start
while {[set a [.right.text search -exact -count num $x $pos $end]] != ""} {
set pos [.right.text index $a+${num}c]
.right.text tag add tk $a $pos
}
}
foreach x "\[ \]" {
set pos $start
while {[set a [.right.text search -exact $x $pos $end]] != ""} {
set pos [.right.text index $a+1c]
.right.text tag add brace $a $a+1c
}
}
set pos $start
while {[set a [.right.text search -exact -exact $ $pos $end]] != ""} {
set pos [.right.text index $a+1c]
.right.text tag add var $a $a+1c
}
set pos $start
while {[set a [.right.text search -exact -regexp "^( +)?#" $pos $end]] != ""} {
set pos [.right.text index "$a lineend"]
.right.text tag add comment $a "$a lineend"
}
}
proc Parse {blah} {
global proc myargs
set inproc 0
set other 0
set othernum 0
foreach x $blah {
set x [string trim $x]
if {[string match "proc *" $x] && !$inproc} {
set procname [procname $x]
set myargs($procname) [lindex [string range $x 0 [expr [string length $x] - 2]] 2]
set proc($procname) "\n"
set inproc 1
set tab ""
set indent 0
set other 0
.left.procs insert end $procname
} elseif $inproc {
if {[string match \}* $x] && ![string match #* $x]} {
set tab [string range $tab 4 end]
incr indent -1
if {$indent == "-1"} {
set inproc 0
continue
}
}
append proc($procname) $tab$x\n
if {[string match *\{ $x] && ![string match #* $x]} {
append tab " "
incr indent 1
}
} elseif {[string trim $x] != "" && !$other} {
incr othernum
set procname "Other $othernum"
set proc($procname) $x\n
set myargs($procname) ""
set other 1
set tab ""
set indent 0
set inproc 0
.left.procs insert end $procname
} elseif $other {
if {[string match \}* $x] && ![string match #* $x]} {
set tab [string range $tab 4 end]
incr indent -1
if {$indent == "-1"} {
set other 0
continue
}
}
append proc($procname) $tab$x\n
if {[string match *\{ $x] && ![string match #* $x]} {
append tab " "
incr indent 1
}
}
}
}
CreateWindow
update idle
if {$argv != ""} {
Open $argv
} else {
set status Ready
}
I have a problem with my TK script.
Hope somebody can help me out.
I have wrote a script for GUI for an application.which have a text area with several options for selcting file,opening it and modifying ..etc..
What i need now is ..i have a file which shows some PID values of a decoder.
When i open this file, and when i select a Particular PID,that should be displayed in the text area..
And at the same time when i select a file,it should manipulate it(for example:remultiplexing, demultiplexing fo streams)
Here is the code i m attaching,please kindly need modifications accoridng the above requirement.
proc CreateWindow { } {
wm title . "Test Application"
frame .top -bd 1 -relief raised
frame .left
frame .right
frame .bottom
button .bottom.bottom -text Parse -command init -foreground red -background black -font {-family times -size 12}
pack .bottom.bottom -side right -padx 0p -pady 0 -anchor n
pack .top -side top -fill x
pack .bottom -side bottom -fill x
pack .left -side left -fill both
pack .right -side left -fill both -expand 1
label .top.fn -textvariable fn -bd 1 -relief sunken
menubutton .top.1 -text File -bd 1 -pady 2 -menu .top.1.menu
menubutton .top.2 -text Edit -bd 1 -pady 2 -menu .top.2.menu
menubutton .top.3 -text Search -bd 1 -pady 2 -menu .top.3.menu
menubutton .top.4 -text Preferences -bd 1 -pady 2 -menu .top.4.menu
menu .top.1.menu
menu .top.2.menu
menu .top.3.menu
menu .top.4.menu
.top.1.menu add command -label Open -command Open
.top.1.menu add command -label Save -command {Save $fn}
.top.1.menu add command -label "Save As" -command Save
.top.1.menu add command -label Close -command Close
.top.1.menu add command -label Exit -command exit
.top.2.menu add cascade -label Undo -menu .top.2.menu.undo
menu .top.2.menu.undo -tearoff 0
.top.2.menu add command -label New -command New
.top.2.menu add command -label Delete -command Delete
.top.2.menu add command -label Revert -command Revert
.top.2.menu add command -label "Revert All" -command "Revert all"
.top.2.menu add command -label Rename -command Rename
.top.2.menu add command -label Edit -command Edit
.top.2.menu add command -label Comment -command Comment
.top.3.menu add command -label Search -command Search
.top.4.menu add checkbutton -label Color -variable prefs(color)
# .top.4.menu add checkbutton -label Files -variable prefs(files)
.top.4.menu invoke 1
# .top.4.menu add command -label
pack .top.fn -side right -ipadx 3 -padx 2
pack .top.1 -side left
pack .top.2 -side left
pack .top.3 -side left
pack .top.4 -side left
label .bottom.status -bd 1 -relief sunken -textvariable status -anchor w
pack .bottom.status -side left -padx 3 -pady 2 -fill x -expand 1
scrollbar .left.scrolly -orient v -width 13 -command ".left.procs yview"
scrollbar .left.scrollx -orient h -width 13 -command ".left.procs xview"
listbox .left.procs -width 15 -yscrollcommand ".left.scrolly set" -xscrollcommand ".left.scrollx set" -exportselection 0
frame .left.buttons
button .left.buttons.up -text /\\ -command MoveUp -bd 1
button .left.buttons.down -text \\/ -command MoveDown -bd 1
button .left.buttons.new -text N -command New -bd 1
button .left.buttons.del -text D -command Delete -bd 1
button .left.buttons.ren -text R -command Rename -bd 1
button .left.buttons.edit -text E -command Edit -bd 1
pack .left.buttons -side right
pack .left.scrolly -side right -fill y
pack .left.scrollx -side bottom -fill x
pack .left.procs -fill both -expand 1
pack .left.buttons.up -side top
pack .left.buttons.down -side top -padx 4 -pady 2
pack .left.buttons.new -side top -pady 2
pack .left.buttons.del -side top
pack .left.buttons.ren -side top -pady 2
pack .left.buttons.edit -side top -pady 2
bind .left.procs <ButtonRelease> Display
scrollbar .right.scrolly -orient v -width 13 -command ".right.text yview"
scrollbar .right.scrollx -orient h -width 13 -command ".right.text xview"
text .right.text -wrap none -yscrollcommand ".right.scrolly set" -xscrollcommand ".right.scrollx set" -bg #999999 -font -*-lucidatypewriter-*-r-*-*-*-120-*-*-*-*-iso8859-1
bind .right.text <Return> "after 1 Update"
bind .right.text <BackSpace> BackSpace
bind .right.text <space> Space
bind .right.text <Control-c> "Color all"
bind .right.text <Control-u> "Display"
bind .right.text <Control-e> {.right.text mark set insert "[.right.text index insert] lineend"}
bind .right.text <Control-t> {.right.text mark set insert 0.0}
bind .right.text <Control-g> {.right.text mark set insert "[.right.text index insert] linestart"}
bind .right.text <Control-b> {.right.text mark set insert [.right.text index end]}
pack .right.scrolly -side right -fill y
pack .right.scrollx -side bottom -fill x
pack .right.text -expand 1 -fill both
}
proc Search { } {
global search
catch {destroy .search}
toplevel .search -class Dialog
wm title .search "Search/Replace"
wm iconname .search "Search/Replace"
foreach x "1 2 3 4 5" {
frame .search.$x
pack .search.$x -side top -fill x
}
label .search.1.label -text "Start at:"
label .search.2.label -text "Direction:"
label .search.3.label -text "Search for:"
label .search.4.label -text "Replace with:"
pack .search.1.label -side left -padx 5 -pady 5
pack .search.2.label -side left -padx 5 -pady 5
pack .search.3.label -side left -padx 5 -pady 5
pack .search.4.label -side left -padx 5 -pady 5
radiobutton .search.1.r1 -text "Cursor Position" -variable search(start) -value insert
radiobutton .search.1.r2 -text "Beginning" -variable search(start) -value 0.0
radiobutton .search.1.r3 -text "End" -variable search(start) -value end
if {$search(start) == ""} {
.search.1.r1 select
}
pack .search.1.r1 -side left
pack .search.1.r2 -side left
pack .search.1.r3 -side left
radiobutton .search.2.r1 -text "Forward" -variable search(direction) -value f
radiobutton .search.2.r2 -text "Backward" -variable search(direction) -value b
if {$search(direction) == ""} {
.search.2.r1 select
}
pack .search.2.r1 -side left
pack .search.2.r2 -side left
entry .search.3.e1
pack .search.3.e1 -side left -fill x
entry .search.4.e1
pack .search.4.e1 -side left -fill x
button .search.5.b1 -text "Search" -command {DoSearch 1 [.search.3.e1 get] [.search.4.e1 get]}
button .search.5.b2 -text "Replace" -command {DoSearch 2 [.search.3.e1 get] [.search.4.e1 get]}
# button .search.5.b3 -text "Replace veto" -command {DoSearch 3 [.search.3.e1 get] [.search.4.e1 get]}
button .search.5.b4 -text "Replace all" -command {DoSearch 4 [.search.3.e1 get] [.search.4.e1 get]}
button .search.5.b5 -text "Done" -command {destroy .search}
pack .search.5.b1 -side left -padx 3 -ipadx 4 -pady 4
pack .search.5.b2 -side left -padx 3 -ipadx 4 -pady 4
# pack .search.5.b3 -side left -padx 3 -ipadx 4 -pady 4
pack .search.5.b4 -side left -padx 3 -ipadx 4 -pady 4
pack .search.5.b5 -side left -padx 3 -ipadx 4 -pady 4
bind .search <Escape> {destroy .search}
wm withdraw .search
update idletasks
set x [expr [winfo screenwidth .search]/2 - [winfo reqwidth .search]/2 - [winfo vrootx [winfo parent .search]]]
set y [expr [winfo screenheight .search]/2 - [winfo reqheight .search]/2 - [winfo vrooty [winfo parent .search]]]
wm geom .search +$x+$y
wm deiconify .search
focus .search.3.e1
}
proc Comment { } {
set start [lindex [split [lindex [.right.text tag ranges sel] 0] .] 0]
set end [lindex [split [lindex [.right.text tag ranges sel] 1] .] 0]
if {$start == "" || $end == ""} {
bell
return
}
for {} {$start <= $end} {incr start} {
.right.text insert $start.0 #
}
.right.text tag remove sel 0.0 end
Display
}
proc SearchNext {s} {
global search
if {$search(direction) == "f"} {
set tmp [.right.text search -forward -- "$s" [.right.text index $search(start)] end]
if {$tmp == ""} {
return ""
}
set end [.right.text index $tmp+[string length $s]c]
return "$tmp $end $end"
} elseif {$search(direction) == "b"} {
set tmp [.right.text search -backward -- "$s" [.right.text index $search(start)] 0.0]
if {$tmp == ""} {
return ""
}
return "$tmp [.right.text index $tmp+[string length $s]c] $tmp"
}
return ""
}
proc DoSearch {type s r} {
global search
if {$s == ""} {
return
}
set tmp ""
switch $type {
1 {
set tmp [SearchNext $s]
if {$tmp == ""} {
return
}
.right.text tag remove sel 0.0 end
.right.text tag add sel [lindex $tmp 0] [lindex $tmp 1]
.right.text see [lindex $tmp 2]
.right.text mark set insert [lindex $tmp 2]
}
2 {
set tmp [SearchNext $s]
.right.text delete [lindex $tmp 0] [lindex $tmp 1]
.right.text insert [lindex $tmp 0] "$r"
.right.text mark set insert [lindex $tmp 2]
}
3 {
}
4 {
while {[set tmp [SearchNext $s]] != ""} {
.right.text delete [lindex $tmp 0] [lindex $tmp 1]
.right.text insert [lindex $tmp 0] "$r"
.right.text mark set insert [lindex $tmp 2]
}
}
}
}
proc Revert {args} {
global proc myargs orig origargs cur
if {$args == "all"} {
Open $fn
} elseif {$args == ""} {
set num [.left.procs curselection]
if {$num == ""} {
bell
return
}
set name [.left.procs get $num]
set proc($name) $orig($name)
set myargs($name) $origargs($name)
set cur ""
Display
}
}
proc Close { } {
global fn proc myargs status
set fn ""
catch {unset proc}
catch {unset myargs}
.right.text delete 0.0 end
.left.procs delete 0 end
set status Ready
}
proc Open {args} {
global orig proc myargs origargs status
global errorInfo fn
if {$args == ""} {
set args [tk_getOpenFile -initialdir ~ -parent . -title Open -filetypes {{{All} {*}} {{Tcl} {*.tcl}}}]
}
if {$args == ""} {
return
}
if [catch {open $args} fh] {
tk_dialog .dialog Error [lindex [split $errorInfo "\n"] 0] error 0 "Ok"
return
}
if [catch {read -nonewline $fh} read] {
tk_dialog .dialog Error [lindex [split $errorInfo "\n"] 0] error 0 "Ok"
return
}
Close
close $fh
set fn $args
Parse [split $read "\n"]
set status "loaded [array size proc] procs"
array set orig [array get proc]
array set origargs [array get myargs]
}
proc Rename { } {
global proc myargs
set num [.left.procs curselection]
if {$num == ""} {
bell
return
}
set old [.left.procs get $num]
set new [tk_getString Rename "Rename $old to:"]
if {$new == "0"} {
return
}
set proc($new) $proc($old)
unset proc($old)
set myargs($new) $myargs($old)
unset myargs($old)
.left.procs delete $num
.left.procs insert $num $new
}
proc Edit { } {
global myargs
set num [.left.procs curselection]
if {$num == ""} {
bell
return
}
set name [.left.procs get $num]
set new [tk_getString Rename "Args for $name:"]
if {$new == "0"} {
return
}
set myargs($name) $new
Display
}
proc New { } {
global proc myargs
set num [.left.procs curselection]
if {$num == ""} {
set num 0
}
set new [tk_getString New "Select the PID"]
if {$new == "0"} {
return
}
.left.procs insert $num $new
.left.procs selection clear 0 end
.left.procs selection set $num
set procs($new) ""
set myargs($new) ""
Display
}
proc Save {args} {
global proc myargs
Display
if {$args == ""} {
set args [tk_getSaveFile -initialdir ~ -parent . -title Save]
}
if {$args == ""} {
return
}
if [catch {open $args w} fh] {
tk_dialog .dialog Error [lindex [split $errorInfo "\n"] 0] error 0 "Ok"
return
}
foreach x [.left.procs get 0 end] {
if [string match "Other *" $x] {
puts $fh [string trim $proc($x)]
puts $fh ""
} else {
puts $fh "proc $x \{$myargs($x)\} \{"
foreach a [split [string trim $proc($x)] "\n"] {
puts $fh " $a"
}
puts $fh "\}"
puts $fh ""
}
}
close $fh
}
proc BackSpace { } {
set char [.right.text get [.right.text index insert]-1c]
# set range [.right.text tag ranges sel]
# if {$range != ""} {
# AddUndo "Block delete in [.left.procs get [.left.procs curselection]]" [.left.procs get [.left.procs curselection]] ".right.text insert [lindex $range 0] [.right.text get [lindex $range 0] [lindex $range 1]]"
# }
if {$char == "\}" || $char == "\{"} {
after 1 Update
}
}
proc Space { } {
global prefs
if {$prefs(color) && [.right.text get [.right.text index insert]-1c] != " "} {
after 1 Color [.right.text index insert]
}
}
proc Delete { } {
set num [.left.procs curselection]
if {$num == ""} {
bell
return
}
.left.procs delete $num
}
proc MoveUp { } {
set num [.left.procs curselection]
if {$num == "0" || $num == ""} {
bell
return
}
set name [.left.procs get $num]
.left.procs delete $num
.left.procs insert [expr $num - 1] $name
.left.procs selection set [expr $num - 1]
}
proc MoveDown { } {
set num [.left.procs curselection]
if {[expr $num + 1] == [.left.procs index end] || $num == ""} {
bell
return
}
set name [.left.procs get $num]
.left.procs delete $num
.left.procs insert [expr $num + 1] $name
.left.procs selection set [expr $num + 1]
}
proc tk_getString {title text} {
global tkPriv
catch {destroy .dialog}
toplevel .dialog -class Dialog
wm title .dialog $title
wm iconname .dialog $title
wm protocol .dialog WM_DELETE_WINDOW {set tkPriv(button) 0}
frame .dialog.text
frame .dialog.entry
frame .dialog.buttons
pack .dialog.text -side top -fill x
pack .dialog.entry -side top -fill x
pack .dialog.buttons -side top -fill x
entry .dialog.entry.entry -width 20
pack .dialog.entry.entry -padx 4 -pady 5
focus .dialog.entry.entry
bind .dialog <Return> {set tkPriv(button) [.dialog.entry.entry get]}
button .dialog.buttons.ok -text Ok -command {set tkPriv(button) [.dialog.entry.entry get]}
button .dialog.buttons.cancel -text Cancel -command {set tkPriv(button) 0}
bind .dialog <Destroy> {set tkPriv(button) 0}
bind .dialog <Escape> {set tkPriv(button) 0}
pack .dialog.buttons.ok -side left -padx 3 -pady 3
pack .dialog.buttons.cancel -side right -padx 3 -pady 3
label .dialog.text.label -text $text
pack .dialog.text.label -padx 3 -pady 3
wm withdraw .dialog
update idletasks
set x [expr [winfo screenwidth .dialog]/2 - [winfo reqwidth .dialog]/2 - [winfo vrootx [winfo parent .dialog]]]
set y [expr [winfo screenheight .dialog]/2 - [winfo reqheight .dialog]/2 - [winfo vrooty [winfo parent .dialog]]]
wm geom .dialog +$x+$y
wm deiconify .dialog
tkwait variable tkPriv(button)
bind .dialog <Destroy> {}
destroy .dialog
focus .right.text
return $tkPriv(button)
}
proc Jump {x y} {
set proc [.right.text get "@$x,$y wordstart" "@$x,$y wordend"]
set num [lsearch -exact [.left.procs get 0 end] $proc]
if {$num == "-1"} {
return
}
.left.procs selection clear 0 end
.left.procs selection set $num
.left.procs see $num
Display
after 1 {.right.text tag remove sel 0.0 end}
}
proc Display { } {
global proc cur status myargs prefs
if {[.left.procs curselection] == ""} {
return
}
if {[info exists cur] && $cur != ""} {
set proc($cur) [.right.text get 0.0 end]
}
.right.text delete 0.0 end
set procname [.left.procs get [.left.procs curselection]]
if [info exists proc($procname)] {
.right.text insert 0.0 [string trim $proc($procname)]
set status "[.left.procs get [.left.procs curselection]]: [expr [llength [split $proc($procname) "\n"]] - 1] lines \{$myargs($procname)\}"
}
set cur [.left.procs get [.left.procs curselection]]
.right.text mark set insert 0.0
focus .right.text
if $prefs(color) {
Color all
}
}
proc procname {line} {
set tmp [string range $line [expr [string first " " $line] + 1] end]
set tmp [string range $tmp 0 [expr [string first " " $tmp] - 1]]
return $tmp
}
proc Update { } {
global prefs
set spaces " "
set num [expr [lindex [split [.right.text index insert] .] 0] - 2]
set prev [.right.text get "$num.0 lineend-1c" "$num.0 lineend"]
set end [lindex [split [.right.text index end] .] 0]
set indent [expr ([string length [.right.text get "$num.0 linestart" "$num.0 lineend"]] - [string length [string trimleft [.right.text get "$num.0 linestart" "$num.0 lineend"]]]) / 4]
for {} {$num < $end} {incr num} {
set line [.right.text get 0.0+${num}l "0.0+${num}l lineend"]
if {$prev == "\{"} {
incr indent
}
set trim [string trimleft $line]
if {[string index $trim 0] == "\}"} {
incr indent -1
}
set diff [expr [string length $line] - [string length $trim]]
.right.text delete "0.0+${num}l linestart" "0.0+${num}l+${diff}c"
.right.text insert 0.0+${num}l [string range $spaces 1 [expr $indent * 4]]
set prev [string range $trim end end]
}
if $prefs(color) {
Color $num.0
}
}
proc Color {line} {
global color proc
if {$line == "all"} {
.right.text tag delete [.right.text tag names]
.right.text tag configure proc -foreground #AA00AA
.right.text tag bind proc <Double-Button-1> {Jump %x %y}
.right.text tag configure tcl -foreground #FF0000
.right.text tag configure cond -foreground #00FF00
.right.text tag configure break -foreground #004C00
.right.text tag configure tk -foreground #0000FF
.right.text tag configure brace -foreground #AA6600
.right.text tag configure var -foreground #FFFF00
.right.text tag configure comment -foreground #FFFFFF
set end [.right.text index end]
set start 0.0
} else {
set start [.right.text index "$line linestart"]
set end [.right.text index "$line lineend"]
}
# foreach x [array names proc] {
# set pos $start
# while {[set a [.right.text search -exac -count num $x $pos $end]] != ""} {
# set pos [.right.text index $a+${num}c]
# .right.text tag add proc $a $pos
# }
# }
foreach x "set incr expr string lindex unset lrange lreplace eval global split info after source" {
set pos $start
while {[set a [.right.text search -exact -count num $x $pos $end]] != ""} {
set pos [.right.text index $a+${num}c]
.right.text tag add tcl $a $pos
}
}
foreach x {"if " "for " "foreach " " elseif " " else " "switch " "while " " || " " && " " == " " != " " > " " < " " <= " " >= "} {
set pos $start
while {[set a [.right.text search -exact -count num $x $pos $end]] != ""} {
set pos [.right.text index $a+${num}c]
.right.text tag add cond $a $pos-1c
}
}
foreach x "continue break catch return" {
set pos $start
while {[set a [.right.text search -exact -count num $x $pos $end]] != ""} {
set pos [.right.text index $a+${num}c]
.right.text tag add break $a $pos
}
}
foreach x "bind scrollbar listbox button menu menubutton pack frame wm label entry winfo" {
set pos $start
while {[set a [.right.text search -exact -count num $x $pos $end]] != ""} {
set pos [.right.text index $a+${num}c]
.right.text tag add tk $a $pos
}
}
foreach x "\[ \]" {
set pos $start
while {[set a [.right.text search -exact $x $pos $end]] != ""} {
set pos [.right.text index $a+1c]
.right.text tag add brace $a $a+1c
}
}
set pos $start
while {[set a [.right.text search -exact -exact $ $pos $end]] != ""} {
set pos [.right.text index $a+1c]
.right.text tag add var $a $a+1c
}
set pos $start
while {[set a [.right.text search -exact -regexp "^( +)?#" $pos $end]] != ""} {
set pos [.right.text index "$a lineend"]
.right.text tag add comment $a "$a lineend"
}
}
proc Parse {blah} {
global proc myargs
set inproc 0
set other 0
set othernum 0
foreach x $blah {
set x [string trim $x]
if {[string match "proc *" $x] && !$inproc} {
set procname [procname $x]
set myargs($procname) [lindex [string range $x 0 [expr [string length $x] - 2]] 2]
set proc($procname) "\n"
set inproc 1
set tab ""
set indent 0
set other 0
.left.procs insert end $procname
} elseif $inproc {
if {[string match \}* $x] && ![string match #* $x]} {
set tab [string range $tab 4 end]
incr indent -1
if {$indent == "-1"} {
set inproc 0
continue
}
}
append proc($procname) $tab$x\n
if {[string match *\{ $x] && ![string match #* $x]} {
append tab " "
incr indent 1
}
} elseif {[string trim $x] != "" && !$other} {
incr othernum
set procname "Other $othernum"
set proc($procname) $x\n
set myargs($procname) ""
set other 1
set tab ""
set indent 0
set inproc 0
.left.procs insert end $procname
} elseif $other {
if {[string match \}* $x] && ![string match #* $x]} {
set tab [string range $tab 4 end]
incr indent -1
if {$indent == "-1"} {
set other 0
continue
}
}
append proc($procname) $tab$x\n
if {[string match *\{ $x] && ![string match #* $x]} {
append tab " "
incr indent 1
}
}
}
}
CreateWindow
update idle
if {$argv != ""} {
Open $argv
} else {
set status Ready
}