- License: BSD
- Requirements: Tcl and Tk >= 8.4
- Author: George Peter Staplin
- Optional: tile05.kit or a later version
- Useful with: memory file system
(URL is 404 on 2011-07-26)This is an older version:
proc add.procedure {name} {
save.script
save.plan
if {![file exists $name.proc]} {
puts [set fd [open $name.proc w]] "proc $name {} {}"
close $fd
load.directory
}
load.file $name.proc
load.plan $name.proc.plan}
proc copy.entry.selection {w} {
if {![$w selection present]} return
clipboard clear -displayof $w
clipboard append -displayof $w \
[string range [$w get] [$w index sel.first] [$w index sel.last]]
}
proc create.gui {} {
panedwindow .pw -orient vertical
frame .pw.ftop
frame .pw.ftext
panedwindow .pw.ftop.pw -orient horizontal
frame .pw.ftop.pw.flist
listbox .pw.ftop.pw.flist.l \
-yscrollcommand {.pw.ftop.pw.flist.yview set}
set ::file_listbox .pw.ftop.pw.flist.l
scrollbar .pw.ftop.pw.flist.yview \
-command {.pw.ftop.pw.flist.l yview}
set ::procedure_to_add ""
frame .pw.ftop.pw.flist.fadd
entry .pw.ftop.pw.flist.fadd.eadd -textvariable ::procedure_to_add
button .pw.ftop.pw.flist.fadd.badd \
-text Add \
-padx 1 \
-pady 1 \
-command {
add.procedure $::procedure_to_add
set ::procedure_to_add ""
}
frame .pw.ftop.pw.fattr
label .pw.ftop.pw.fattr.lname \
-textvariable ::procedure \
-font {Helvetica 18}
label .pw.ftop.pw.fattr.larg -text Arguments:
text .pw.ftop.pw.fattr.targ -height 1
label .pw.ftop.pw.fattr.lplan -text Plan:
set ::plan [text .pw.ftop.pw.fattr.plan]
text .pw.ftext.t \
-yscrollcommand {.pw.ftext.yview set}
scrollbar .pw.ftext.yview \
-command {.pw.ftext.t yview}
}
proc cut.entry.selection {w} {
copy.entry.selection $w
$w delete sel.first sel.last
}
proc display.entry.selection.menu {w x y} {
set m $w._menu
if {[winfo exists $m]} {
tk_popup $m $x $y
return
}
menu $m -tearoff 0
$m add command -label "Select All" -command [list $w selection range 0 end]
$m add separator
$m add command -label Cut -command [list cut.entry.selection $w]
$m add command -label Copy -command [list copy.entry.selection $w]
$m add command -label Paste -command [list paste.into.entry $w]
tk_popup $m $x $y
}
proc display.text.selection.menu {w x y} {
if {[winfo exists $w.m]} {
tk_popup $w.m $x $y
return
}
menu $w.m -tearoff 0
$w.m add command \
-label "Select All" \
-command [list $w tag add sel 1.0 end]
$w.m add separator
$w.m add command \
-label Cut \
-command [list tk_textCut $w]
$w.m add command \
-label Copy \
-command [list tk_textCopy $w]
$w.m add command \
-label Paste \
-command [list tk_textPaste $w]
tk_popup $w.m $x $y
}
proc every {t body} {
uplevel #0 $body
after $t [list every $t $body]
}
proc get.token {s i_ptr} {
upvar $i_ptr i
set s_len [string length $s]
set brace_count 0
set tok ""
set escaped 0
for {} {$i < $s_len} {incr i} {
set c [string index $s $i]
if {"\\" == $c} {
set escaped 1
append tok $c
continue
} elseif {!$escaped && "\{" == $c} {
if {$brace_count > 0} {
append tok $c
}
incr brace_count
} elseif {!$escaped && "\}" == $c} {
incr brace_count -1
if {$brace_count > 0} {
append tok $c
} elseif {!$brace_count} {
incr i
return $tok
}
} elseif {[string is space $c]} {
if {!$brace_count && [string length $tok]} {
incr i
return $tok
}
append tok $c
} else {
append tok $c
}
set escaped 0
}
if {0 != $brace_count} {
return -code error "brace_count is: $brace_count ... expected 0"
} elseif {[string length $tok]} {
return $tok
}
}
proc load.directory {} {
$::file_listbox delete 0 end
foreach f [lsort -dictionary [glob *.proc]] {
$::file_listbox insert end $f
}}
proc load.file {f} {
parse.script ar [read [set fd [open $f r]]]
close $fd
set ::procedure $ar(name)
.pw.ftop.pw.fattr.targ delete 1.0 end
.pw.ftop.pw.fattr.targ insert end $ar(args)
.pw.ftext.t delete 1.0 end
.pw.ftext.t insert end $ar(body)
}
proc load.plan {f} {
$::plan delete 1.0 end
$::plan insert end [read [set fd [open $f "CREAT RDONLY"]]]
close $fd}
proc main {argc argv} {
if {$argc > 0} {
cd [lindex $argv 0]
}
set.widget.defaults
create.gui
manage.gui
load.directory
every 1000 save.script
every 1000 save.plan
wm title . "ProcMeUp: [pwd]"}
proc manage.gui {} {
grid .pw \
-row 0 \
-column 0 \
-sticky news
grid rowconfigure . 0 -weight 100
grid columnconfigure . 0 -weight 100
grid .pw.ftop.pw \
-row 0 \
-column 0 \
-sticky news
grid rowconfigure .pw.ftop 0 -weight 100
grid columnconfigure .pw.ftop 0 -weight 100
grid .pw.ftop.pw.flist.yview \
-row 0 \
-column 0 \
-sticky ns
grid .pw.ftop.pw.flist.l \
-row 0 \
-column 1 \
-sticky news
grid .pw.ftop.pw.flist.fadd \
-row 1 \
-column 0 \
-columnspan 2 \
-sticky we
grid .pw.ftop.pw.flist.fadd.eadd \
-row 0 \
-column 0 -sticky we
grid .pw.ftop.pw.flist.fadd.badd \
-row 0 \
-column 1 -sticky e
grid columnconfigure .pw.ftop.pw.flist.fadd 0 -weight 100
grid rowconfigure .pw.ftop.pw.flist 0 -weight 100
grid columnconfigure .pw.ftop.pw.flist 1 -weight 100
grid .pw.ftop.pw.fattr.lname \
-row 0 \
-column 0 \
-sticky w
grid .pw.ftop.pw.fattr.larg \
-row 1 \
-column 0 \
-sticky w
grid .pw.ftop.pw.fattr.targ \
-row 2 \
-column 0 \
-sticky we
grid .pw.ftop.pw.fattr.lplan \
-row 3 \
-column 0 \
-sticky w
grid .pw.ftop.pw.fattr.plan \
-row 4 \
-column 0 \
-sticky news
grid columnconfigure .pw.ftop.pw.fattr 0 -weight 100
grid rowconfigure .pw.ftop.pw.fattr 4 -weight 100
.pw.ftop.pw add .pw.ftop.pw.flist -width 220
.pw.ftop.pw add .pw.ftop.pw.fattr -width 100
grid .pw.ftext.yview \
-row 0 \
-column 0 \
-sticky ns
grid .pw.ftext.t \
-row 0 \
-column 1 \
-sticky news
grid rowconfigure .pw.ftext 0 -weight 100
grid columnconfigure .pw.ftext 1 -weight 100
.pw add .pw.ftop -height 200
.pw add .pw.ftext -height 300
bind .pw.ftop.pw.flist.l <<ListboxSelect>> {selected.file %W}
bind .pw.ftop.pw.fattr.targ <ButtonPress-3> \
{display.text.selection.menu %W %X %Y}
bind .pw.ftop.pw.fattr.plan <ButtonPress-3> \
{display.text.selection.menu %W %X %Y}
bind .pw.ftext.t <ButtonPress-3> \
{display.text.selection.menu %W %X %Y}
bind .pw.ftop.pw.flist.fadd.eadd <ButtonPress-3> \
{display.entry.selection.menu %W %X %Y}
bind $::file_listbox <ButtonPress-3> load.directory}
proc parse.script {ar_ptr s} {
upvar $ar_ptr ar
set i 0
get.token $s i ;# throw away "proc"
set ar(name) [get.token $s i]
set ar(args) [get.token $s i]
set ar(body) [get.token $s i]
if {[regexp -indices {[ \t]*\n} $ar(body) m] > 0} {
set ar(body) [string range $ar(body) [expr {[lindex $m 1] + 1}] end]
}
}
proc paste.into.entry {w} {
if {[catch {selection get -displayof $w -selection CLIPBOARD} data]} {
return
}
$w insert insert $data}
proc save.plan {} {
if {![$::plan edit modified] || "" == $::procedure} return
write \
[set fd [open $::procedure.proc.plan w]] \
[$::plan get 1.0 end-1c]
close $fd
$::plan edit modified 0
}
proc save.script {} {
if {"" == $::procedure} return
if {![.pw.ftext.t edit modified] && \
![.pw.ftop.pw.fattr.targ edit modified]} return
set args [.pw.ftop.pw.fattr.targ get 1.0 end-1c]
set body [.pw.ftext.t get 1.0 end-1c]
write \
[set fd [open $::procedure.proc w]] \
"proc $::procedure \{[set args]\} \{\n[set body]\}"
close $fd
.pw.ftext.t edit modified 0
.pw.ftop.pw.fattr.targ edit modified 0
}
proc selected.file {w} {
save.plan
save.script
load.file [set f [$w get [$w curselection]]]
load.plan $f.plan
}
proc set.widget.defaults {} {
set frame_bg #ccccba
set text_bg white
set text_fg black
set label_fg black
set label_bg $frame_bg
option add *font -*-lucidatypewriter-medium-*-*-*-14-*-*-*-*-*-*-*
option add *highlightThickness 0
option add *borderWidth 1
option add *background $frame_bg
option add *foreground black
option add *Entry.background $text_bg
option add *Entry.foreground $text_fg
option add *Label.borderWidth 0
option add *Label.highlightThickness 0
option add *Label.padX 1
option add *Label.padY 1
option add *Listbox.background $text_bg
option add *Listbox.foreground $text_fg
option add *Text.background $text_bg
option add *Text.foreground $text_fg
}
proc write {fd data} {
puts -nonewline $fd $data
}
main $::argc $::argvClever! [responds one casual reader, with no time to comment more deeply]George Peter Staplin: Thanks :)rdt likes this too. Now if we can just get color syntax highlighting (like in vim) for tcl/tk then we're all set.George Peter Staplin: Thank you. I may add my next version of Ctext to it for highlighting. The next ctext is far off at the moment though (as of Mar 21, 2005). I'm exploring different ways of solving the problems.
See also: memory file system
