Version 5 of ProcMeUp

Updated 2004-05-28 23:31:56 by GPS

http://www.xmission.com/~georgeps/implementation/software/ProcMeUp/ProcMeUp-6.png


License: OLL Author: GPS/George Peter Staplin


 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 $::argv

Clever! [responds one casual reader, with no time to comment more deeply]


Category Application