tkcon.tcl

来自「算断裂的」· TCL 代码 · 共 2,077 行 · 第 1/5 页

    if {$TKCON(A:version) >= 8.0} { tkConAttachNamespace $oldname }
    if {[string compare {} $err]} { return -code error $err }
}

## tkConInitUI - inits UI portion (console) of tkCon
## Creates all elements of the console window and sets up the text tags
# ARGS:	root	- widget pathname of the tkCon console root
#	title	- title for the console root and main (.) windows
# Calls:	tkConInitMenus, tkConPrompt
##
;proc tkConInitUI {title} {
    global TKCON

    set root $TKCON(root)
    if {[string match . $root]} { set w {} } else { set w [toplevel $root] }
    catch {wm withdraw $root}
    set TKCON(base) $w

    ## Text Console
    set TKCON(console) [set con $w.text]
    text $con -wrap char -yscrollcommand [list $w.sy set] \
	    -foreground $TKCON(color,stdin) \
	    -insertbackground $TKCON(color,cursor)
    if {[string compare {} $TKCON(color,bg)]} {
	$con configure -background $TKCON(color,bg)
    }
    set TKCON(color,bg) [$con cget -background]
    if {[string compare {} $TKCON(font)]} {
	## Set user-requested font, if any
	$con configure -font $TKCON(font)
    } elseif {[info tclversion] >= 8.0} {
	## otherwise make sure the font is monospace
	set font [$con cget -font]
	if {![font metrics $font -fixed]} {
	    font create tkconfixed -family Courier -size -12
	    $con configure -font tkconfixed
	}
    } else {
	$con configure -font {*Courier*12*}
    }
    set TKCON(font) [$con cget -font]
    if {!$TKCON(WWW)} {
	$con configure -setgrid 1 -width $TKCON(cols) -height $TKCON(rows)
    }
    bindtags $con [list $con PreCon TkConsole PostCon $root all]
    if {[info tclversion] >= 8.0} {
	## Menus
	## catch against use in plugin
	if {[catch {menu $w.mbar} TKCON(menubar)]} {
	    set TKCON(menubar) [frame $w.mbar -relief raised -bd 1]
	}
    } else {
	set TKCON(menubar) [frame $w.mbar -relief raised -bd 1]
    }
    ## Scrollbar
    set TKCON(scrolly) [scrollbar $w.sy -takefocus 0 -bd 1 \
	    -command [list $con yview]]

    tkConInitMenus $TKCON(menubar) $title
    tkConBindings

    if {$TKCON(showmenu)} {
	if {[info tclversion] >= 8.0} {
	    $root configure -menu $TKCON(menubar)
	} else {
	    pack $TKCON(menubar) -fill x
	}
    }
    pack $w.sy -side $TKCON(scrollypos) -fill y
    pack $con -fill both -expand 1

    tkConPrompt "$title console display active\n"

    foreach col {prompt stdout stderr stdin proc} {
	$con tag configure $col -foreground $TKCON(color,$col)
    }
    $con tag configure var -background $TKCON(color,var)
    $con tag configure blink -background $TKCON(color,blink)
    $con tag configure find -background $TKCON(color,blink)

    if {![catch {wm title $root "TkCon $TKCON(version) $title"}]} {
	bind $con <Configure> {
	    scan [wm geometry [winfo toplevel %W]] "%%dx%%d" \
		    TKCON(cols) TKCON(rows)
	}
    }
    catch {wm deiconify $root}
    focus -force $TKCON(console)
    if {$TKCON(gc-delay)} {
	after $TKCON(gc-delay) tkConGarbageCollect
    }
}

## tkConGarbageCollect - do various cleanup ops periodically to our setup
##
;proc tkConGarbageCollect {} {
    global TKCON
    set w $TKCON(console)
    ## Remove error tags that no longer span anything
    ## Make sure the tag pattern matches the unique tag prefix
    foreach tag [$w tag names] {
	if {[string match _tag* $tag] && ![llength [$w tag ranges $tag]]} {
	    $w tag delete $tag
	}
    }
    if {$TKCON(gc-delay)} {
	after $TKCON(gc-delay) tkConGarbageCollect
    }
}

## tkConEval - evaluates commands input into console window
## This is the first stage of the evaluating commands in the console.
## They need to be broken up into consituent commands (by tkConCmdSep) in
## case a multiple commands were pasted in, then each is eval'ed (by
## tkConEvalCmd) in turn.  Any uncompleted command will not be eval'ed.
# ARGS:	w	- console text widget
# Calls:	tkConCmdGet, tkConCmdSep, tkConEvalCmd
## 
;proc tkConEval {w} {
    set incomplete [tkConCmdSep [tkConCmdGet $w] cmds last]
    $w mark set insert end-1c
    $w insert end \n
    if {[llength $cmds]} {
	foreach c $cmds {tkConEvalCmd $w $c}
	$w insert insert $last {}
    } elseif {!$incomplete} {
	tkConEvalCmd $w $last
    }
    $w see insert
}

## tkConEvalCmd - evaluates a single command, adding it to history
# ARGS:	w	- console text widget
# 	cmd	- the command to evaluate
# Calls:	tkConPrompt
# Outputs:	result of command to stdout (or stderr if error occured)
# Returns:	next event number
## 
;proc tkConEvalCmd {w cmd} {
    global TKCON
    $w mark set output end
    if {[string compare {} $cmd]} {
	set code 0
	if {$TKCON(subhistory)} {
	    set ev [tkConEvalSlave history nextid]
	    incr ev -1
	    if {[string match !! $cmd]} {
		set code [catch {tkConEvalSlave history event $ev} cmd]
		if {!$code} {$w insert output $cmd\n stdin}
	    } elseif {[regexp {^!(.+)$} $cmd dummy event]} {
		## Check last event because history event is broken
		set code [catch {tkConEvalSlave history event $ev} cmd]
		if {!$code && ![string match ${event}* $cmd]} {
		    set code [catch {tkConEvalSlave history event $event} cmd]
		}
		if {!$code} {$w insert output $cmd\n stdin}
	    } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} {
		set code [catch {tkConEvalSlave history event $ev} cmd]
		if {!$code} {
		    regsub -all -- $old $cmd $new cmd
		    $w insert output $cmd\n stdin
		}
	    } elseif {$TKCON(calcmode) && ![catch {expr $cmd} err]} {
		tkConEvalSlave history add $cmd
		set cmd $err
		set code -1
	    }
	}
	if {$code} {
	    $w insert output $cmd\n stderr
	} else {
	    ## We are about to evaluate the command, so move the limit
	    ## mark to ensure that further <Return>s don't cause double
	    ## evaluation of this command - for cases like the command
	    ## has a vwait or something in it
	    $w mark set limit end
	    if {$TKCON(nontcl) && [string match interp $TKCON(apptype)]} {
		set code [catch "tkConEvalSend $cmd" res]
		if {$code == 1} {
		    set TKCON(errorInfo) "Non-Tcl errorInfo not available"
		}
	    } else {
		set code [catch {tkConEvalAttached $cmd} res]
		if {$code == 1} {
		    if {[catch {tkConEvalAttached set errorInfo} err]} {
			set TKCON(errorInfo) "Error getting errorInfo:\n$err"
		    } else {
			set TKCON(errorInfo) $err
		    }
		}
	    }
	    tkConEvalSlave history add $cmd
	    if {$code} {
		if {$TKCON(hoterrors)} {
		    set tag [tkConUniqueTag $w]
		    $w insert output $res [list stderr $tag] \n stderr
		    $w tag bind $tag <Enter> \
			    [list $w tag configure $tag -under 1]
		    $w tag bind $tag <Leave> \
			    [list $w tag configure $tag -under 0]
		    $w tag bind $tag <ButtonRelease-1> \
			    "if {!\$tkPriv(mouseMoved)} \
			    {[list edit -attach [tkConAttach] -type error -- $TKCON(errorInfo)]}"
		} else {
		    $w insert output $res\n stderr
		}
	    } elseif {[string compare {} $res]} {
		$w insert output $res\n stdout
	    }
	}
    }
    tkConPrompt
    set TKCON(event) [tkConEvalSlave history nextid]
}

## tkConEvalSlave - evaluates the args in the associated slave
## args should be passed to this procedure like they would be at
## the command line (not like to 'eval').
# ARGS:	args	- the command and args to evaluate
##
;proc tkConEvalSlave args {
    global TKCON
    interp eval $TKCON(exec) $args
}

## tkConEvalOther - evaluate a command in a foreign interp or slave
## without attaching to it.  No check for existence is made.
# ARGS:	app	- interp/slave name
#	type	- (slave|interp)
##
;proc tkConEvalOther { app type args } {
    if {[string compare slave $type]==0} {
	return [tkConSlave $app $args]
    } else {
	return [uplevel 1 send [list $app] $args]
    }
}

## tkConEvalSend - sends the args to the attached interpreter
## Varies from 'send' by determining whether attachment is dead
## when an error is received
# ARGS:	args	- the args to send across
# Returns:	the result of the command
##
;proc tkConEvalSend args {
    global TKCON
    if {$TKCON(deadapp)} {
	if {[lsearch -exact [winfo interps] $TKCON(app)]<0} {
	    return
	} else {
	    set TKCON(appname) [string range $TKCON(appname) 5 end]
	    set TKCON(deadapp) 0
	    tkConPrompt "\n\"$TKCON(app)\" alive\n" \
		    [tkConCmdGet $TKCON(console)]
	}
    }
    set code [catch {uplevel 1 send [list $TKCON(app)] $args} result]
    if {$code && [lsearch -exact [winfo interps] $TKCON(app)]<0} {
	## Interpreter disappeared
	if {[string compare leave $TKCON(dead)] && \
		([string match ignore $TKCON(dead)] || \
		[tk_dialog $TKCON(base).dead "Dead Attachment" \
		"\"$TKCON(app)\" appears to have died.\
		\nReturn to primary slave interpreter?" questhead 0 OK No])} {
	    set TKCON(appname) "DEAD:$TKCON(appname)"
	    set TKCON(deadapp) 1
	} else {
	    set err "Attached Tk interpreter \"$TKCON(app)\" died."
	    tkConAttach {}
	    set TKCON(deadapp) 0
	    tkConEvalSlave set errorInfo $err
	}
	tkConPrompt \n [tkConCmdGet $TKCON(console)]
    }
    return -code $code $result
}

## tkConEvalNamespace - evaluates the args in a particular namespace
## This is an override for tkConEvalAttached for when the user wants
## to attach to a particular namespace of the attached interp
# ARGS:	attached	
#	namespace	the namespace to evaluate in
#	args		the args to evaluate
# RETURNS:	the result of the command
##
;proc tkConEvalNamespace { attached namespace args } {
    global TKCON
    if {[llength $args]} {
	if {$TKCON(A:itcl2)} {
	    uplevel \#0 $attached namespace [list $namespace $args]
	} else {
	    uplevel \#0 $attached namespace eval [list $namespace $args]
	}
    }
}


## tkConNamespaces - return all the namespaces descendent from $ns
##
#
##
;proc tkConNamespaces { {ns ::} } {
    global TKCON
    if {$TKCON(A:itcl2)} {
	return [tkConNamespacesItcl $ns]
    } else {
	return [tkConNamespacesTcl8 $ns]
    }
}

;proc tkConNamespacesTcl8 { ns {l {}} } {
    if {[string compare {} $ns]} { lappend l $ns }
    foreach i [tkConEvalAttached [list namespace children $ns]] {
	set l [tkConNamespacesTcl8 $i $l]
    }
    return $l
}

;proc tkConNamespacesItcl { ns {l {}} } {
    if {[string compare {} $ns]} { lappend l $ns }
    set names [tkConEvalAttached [list info namespace children $ns]]
    foreach i $names { set l [tkConNamespacesItcl $i $l] }
    return $l
}

## tkConCmdGet - gets the current command from the console widget
# ARGS:	w	- console text widget
# Returns:	text which compromises current command line
## 
;proc tkConCmdGet w {
    if {![llength [$w tag nextrange prompt limit end]]} {
	$w tag add stdin limit end-1c
	return [$w get limit end-1c]
    }
}

## tkConCmdSep - separates multiple commands into a list and remainder
# ARGS:	cmd	- (possible) multiple command to separate
# 	list	- varname for the list of commands that were separated.
#	last	- varname of any remainder (like an incomplete final command).
#		If there is only one command, it's placed in this var.
# Returns:	constituent command info in varnames specified by list & rmd.
## 
;proc tkConCmdSep {cmd list last} {
    upvar 1 $list cmds $last inc
    set inc {}
    set cmds {}
    foreach c [split [string trimleft $cmd] \n] {
	if {[string compare $inc {}]} {
	    append inc \n$c
	} else {
	    append inc [string trimleft $c]
	}
	if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} {
	    if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
	    set inc {}
	}
    }
    set i [string compare $inc {}]
    if {!$i && [string compare $cmds {}] && ![string match *\n $cmd]} {
	set inc [lindex $cmds end]
	set cmds [lreplace $cmds end end]
    }
    return $i
}

## tkConCmdSplit - splits multiple commands into a list
# ARGS:	cmd	- (possible) multiple command to separate
# Returns:	constituent commands in a list
## 
;proc tkConCmdSplit {cmd} {
    set inc {}
    set cmds {}
    foreach cmd [split [string trimleft $cmd] \n] {
	if {[string compare {} $inc]} {
	    append inc \n$cmd
	} else {
	    append inc [string trimleft $cmd]
	}
	if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} {
	    #set inc [string trimright $inc]
	    if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
	    set inc {}
	}
    }
    if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
    return $cmds
}

## tkConUniqueTag - creates a uniquely named tag, reusing names
## Called by tkConEvalCmd
# ARGS:	w	- text widget
# Outputs:	tag name guaranteed unique in the widget
## 
;proc tkConUniqueTag {w} {
    set tags [$w tag names]
    set idx 0
    while {[lsearch -exact $tags _tag[incr idx]] != -1} {}
    return _tag$idx
}

## tkConConstrainBuffer - This limits the amount of data in the text widget
## Called by tkConPrompt and in tkcon proc buffer/console switch cases
# ARGS:	w	- console text widget
#	size	- # of lines to constrain to
# Outputs:	may delete data in console widget
## 
;proc tkConConstrainBuffer {w size} {
    if {[$w index end] > $size} {
	$w delete 1.0 [expr {int([$w index end])-$size}].0
    }
}

## tkConPrompt - displays the prompt in the console widget
# ARGS:	w	- console text widget
# Outputs:	prompt (specified in TKCON(prompt1)) to console