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

namespace eval shell {
    variable fd [open ~/.tkcon/pipe [list RDONLY NONBLOCK]]
    variable dir $::env(HOME)/.tkcon
    fconfigure $fd -blocking 0 -buffering none
    fileevent $fd readable eval_from_pipe
}

proc eval_from_pipe {} {
    variable ::shell::fd
    if {"" == $fd} {
        return {}
    }
    if [eof $fd] {
        close $fd
        set fd [open ~/.tkcon/pipe [list RDONLY NONBLOCK]]
        fconfigure $fd -blocking 0 -buffering none
        fileevent $fd readable eval_from_pipe
        return {}
    }
    set text [read $fd]
    if {"" == $text} {
        return {}
    }
    set text [string trim $text]
    puts "source {$text} #[info level]"
#    uplevel #0 [list source $text]
    namespace eval :: [list source $text]
}

proc tofile {{fn {}} text} {
    if {{} == $fn} {
        set fn [exec mktemp]
    }
    set fd [open $fn w]
    puts -nonewline $fd $text
    close $fd
    return $fn
}
proc fromfile {fn} {
    set fd [open $fn r]
    set text [read $fd]
    close $fd
    file delete $fn
    return $text
}

proc old_ed {text} {
    variable ::shell::dir
    exec echo "$text" | gvim --remote "~/.tkcon/pipe" -S vimrc &
}

proc edfile {fn} {
    exec gvim --remote $fn &
}

proc edtclfile {fn} {
    variable ::shell::dir
    exec gvim --remote "+autocmd BufWrite ${dir}/* !echo % > ~/.tkcon/pipe" $fn &
}

proc edftp {fn text} {
    variable ::shell::dir
    set fn ${dir}/${fn}.tcl
    tofile $fn $text
    exec gvim --remote {+call NetUserPass("ftp", "passwd")} {+e $fn} &
}

proc edvar {name} {
    variable ::shell::dir
    upvar $name var
	set fn [file join $dir var-${name}.tcl]
    set def "set $name {$var}"
	tofile $fn $def
    uplevel 1 [list edtclfile $fn]
}

proc edarray {name} {
    variable ::shell::dir
    upvar $name var
	set fn [file join $dir var-${name}.tcl]
	set fd [open $fn w]
	puts $fd array unset foo
	foreach pair [array get $name] {
		set k [lindex $pair 0]
		set v [lindex $pair 1]
		puts $fd "set ${name}($k) {$v}"
	}
	close $fd
    uplevel 1 [list edtclfile $fn]
}

proc edproc {name} {
    variable ::shell::dir
	set fn [file join $dir var-${name}.tcl]
	set def [list proc $name]
	set args {}
	foreach arg [uplevel 1 "info args $name"] {
		if {[uplevel 1 "info default $name $arg def"]} {
			lappend args [list $arg $def]
		} else {
			lappend args [list $arg]
		}
	}
	lappend def $args [uplevel 1 "info body $name"]
	tofile $fn $def
    uplevel 1 [list edtclfile $fn]
}

proc ed {name} {
#    set procs [uplevel 1 {info procs}]
	if {"" != [uplevel 1 "info proc $name"]} {
        edproc $name
    } elseif {1 == [uplevel 1 "array exists $name"]} {
        edarray $name
    } elseif {1 == [uplevel 1 "info exists $name"]} {
        edvar $name
    } else {
        edfile $name
    }
}

#namespace export ed

package provide shell 0.2