Posted to tcl by aspect at Sat May 10 12:06:36 GMT 2008view raw

  1. namespace eval shell {
  2. variable fd [open ~/.tkcon/pipe [list RDONLY NONBLOCK]]
  3. variable dir $::env(HOME)/.tkcon
  4. fconfigure $fd -blocking 0 -buffering none
  5. fileevent $fd readable eval_from_pipe
  6. }
  7.  
  8. proc eval_from_pipe {} {
  9. variable ::shell::fd
  10. if {"" == $fd} {
  11. return {}
  12. }
  13. if [eof $fd] {
  14. close $fd
  15. set fd [open ~/.tkcon/pipe [list RDONLY NONBLOCK]]
  16. fconfigure $fd -blocking 0 -buffering none
  17. fileevent $fd readable eval_from_pipe
  18. return {}
  19. }
  20. set text [read $fd]
  21. if {"" == $text} {
  22. return {}
  23. }
  24. set text [string trim $text]
  25. puts "source {$text} #[info level]"
  26. # uplevel #0 [list source $text]
  27. namespace eval :: [list source $text]
  28. }
  29.  
  30. proc tofile {{fn {}} text} {
  31. if {{} == $fn} {
  32. set fn [exec mktemp]
  33. }
  34. set fd [open $fn w]
  35. puts -nonewline $fd $text
  36. close $fd
  37. return $fn
  38. }
  39. proc fromfile {fn} {
  40. set fd [open $fn r]
  41. set text [read $fd]
  42. close $fd
  43. file delete $fn
  44. return $text
  45. }
  46.  
  47. proc old_ed {text} {
  48. variable ::shell::dir
  49. exec echo "$text" | gvim --remote "~/.tkcon/pipe" -S vimrc &
  50. }
  51.  
  52. proc edfile {fn} {
  53. exec gvim --remote $fn &
  54. }
  55.  
  56. proc edtclfile {fn} {
  57. variable ::shell::dir
  58. exec gvim --remote "+autocmd BufWrite ${dir}/* !echo % > ~/.tkcon/pipe" $fn &
  59. }
  60.  
  61. proc edftp {fn text} {
  62. variable ::shell::dir
  63. set fn ${dir}/${fn}.tcl
  64. tofile $fn $text
  65. exec gvim --remote {+call NetUserPass("ftp", "passwd")} {+e $fn} &
  66. }
  67.  
  68. proc edvar {name} {
  69. variable ::shell::dir
  70. upvar $name var
  71. set fn [file join $dir var-${name}.tcl]
  72. set def "set $name {$var}"
  73. tofile $fn $def
  74. uplevel 1 [list edtclfile $fn]
  75. }
  76.  
  77. proc edarray {name} {
  78. variable ::shell::dir
  79. upvar $name var
  80. set fn [file join $dir var-${name}.tcl]
  81. set fd [open $fn w]
  82. puts $fd array unset foo
  83. foreach pair [array get $name] {
  84. set k [lindex $pair 0]
  85. set v [lindex $pair 1]
  86. puts $fd "set ${name}($k) {$v}"
  87. }
  88. close $fd
  89. uplevel 1 [list edtclfile $fn]
  90. }
  91.  
  92. proc edproc {name} {
  93. variable ::shell::dir
  94. set fn [file join $dir var-${name}.tcl]
  95. set def [list proc $name]
  96. set args {}
  97. foreach arg [uplevel 1 "info args $name"] {
  98. if {[uplevel 1 "info default $name $arg def"]} {
  99. lappend args [list $arg $def]
  100. } else {
  101. lappend args [list $arg]
  102. }
  103. }
  104. lappend def $args [uplevel 1 "info body $name"]
  105. tofile $fn $def
  106. uplevel 1 [list edtclfile $fn]
  107. }
  108.  
  109. proc ed {name} {
  110. # set procs [uplevel 1 {info procs}]
  111. if {"" != [uplevel 1 "info proc $name"]} {
  112. edproc $name
  113. } elseif {1 == [uplevel 1 "array exists $name"]} {
  114. edarray $name
  115. } elseif {1 == [uplevel 1 "info exists $name"]} {
  116. edvar $name
  117. } else {
  118. edfile $name
  119. }
  120. }
  121.  
  122. #namespace export ed
  123.  
  124. package provide shell 0.2
  125.