tkcon.tcl

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

	$tmp alias tkConStateCleanup	tkConStateCleanup
	$tmp alias tkConStateCompare	tkConStateCompare
	$tmp alias tkConStateRevert	tkConStateRevert
	$tmp eval {if [catch {source -rsrc tkcon}] {source $TKCON(SCRIPT)}}
	return $tmp
    }

    ## tkConExit - full exit OR destroy slave console
    ## This proc should only be called in the main interpreter from a slave.
    ## The master determines whether we do a full exit or just kill the slave.
    ## 
    ;proc tkConExit {slave args} {
	global TKCON
	## Slave interpreter exit request
	if {[string match exit $TKCON(slaveexit)]} {
	    ## Only exit if it specifically is stated to do so
	    uplevel 1 exit $args
	}
	## Otherwise we will delete the slave interp and associated data
	set name [tkConInterpEval $slave]
	set TKCON(interps) [lremove $TKCON(interps) [list $name]]
	set TKCON(slaves)  [lremove $TKCON(slaves) [list $slave]]
	interp delete $slave
	tkConStateCleanup $slave
	return
    }

    ## tkConDestroy - destroy console window
    ## This proc should only be called by the main interpreter.  If it is
    ## called from there, it will ask before exiting TkCon.  All others
    ## (slaves) will just have their slave interpreter deleted, closing them.
    ## 
    ;proc tkConDestroy {{slave {}}} {
	global TKCON
	if {[string match {} $slave]} {
	    ## Main interpreter close request
	    if {[tk_dialog $TKCON(base).destroyme {Quit TkCon?} \
		    {Closing the Main console will quit TkCon} \
		    warning 0 "Don't Quit" "Quit TkCon"]} exit
	} else {
	    ## Slave interpreter close request
	    set name [tkConInterpEval $slave]
	    set TKCON(interps) [lremove $TKCON(interps) [list $name]]
	    set TKCON(slaves)  [lremove $TKCON(slaves) [list $slave]]
	    interp delete $slave
	}
	tkConStateCleanup $slave
	return
    }

    ## tkConInterpEval - passes evaluation to another named interpreter
    ## If the interpreter is named, but no args are given, it returns the
    ## [tk appname] of that interps master (not the associated eval slave).
    ##
    ;proc tkConInterpEval {{slave {}} args} {
	if {[string match {} $slave]} {
	    global TKCON
	    return $TKCON(slaves)
	} elseif {[string match {[Mm]ain} $slave]} {
	    set slave {}
	}
	if {[llength $args]} {
	    return [interp eval $slave uplevel \#0 $args]
	} else {
	    return [interp eval $slave tk appname]
	}
    }

    ;proc tkConInterps {{ls {}} {interp {}}} {
	if {[string match {} $interp]} { lappend ls {} [tk appname] }
	foreach i [interp slaves $interp] {
	    if {[string compare {} $interp]} { set i "$interp $i" }
	    if {[string compare {} [interp eval $i package provide Tk]]} {
		lappend ls $i [interp eval $i tk appname]
	    } else {
		lappend ls $i {}
	    }
	    set ls [tkConInterps $ls $i]
	}
	return $ls
    }

    ##
    ## The following state checkpoint/revert procedures are very sketchy
    ## and prone to problems.  They do not track modifications to currently
    ## existing procedures/variables, and they can really screw things up
    ## if you load in libraries (especially Tk) between checkpoint and
    ## revert.  Only with this knowledge in mind should you use these.
    ##

    ## tkConStateCheckpoint - checkpoints the current state of the system
    ## This allows you to return to this state with tkConStateRevert
    # ARGS:
    ##
    ;proc tkConStateCheckpoint {app type} {
	global TKCON
	if {[info exists TKCON($type,$app,cmd)] &&
	[tk_dialog $TKCON(base).warning "Overwrite Previous State?" \
		"Are you sure you want to lose previously checkpointed\
		state of $type \"$app\"?" questhead 1 "Do It" "Cancel"]} return
	set TKCON($type,$app,cmd) [tkConEvalOther $app $type info commands *]
	set TKCON($type,$app,var) [tkConEvalOther $app $type info vars *]
	return
    }

    ## tkConStateCompare - compare two states and output difference
    # ARGS:
    ##
    ;proc tkConStateCompare {app type {verbose 0}} {
	global TKCON
	if {![info exists TKCON($type,$app,cmd)]} {
	    return -code error "No previously checkpointed state for $type \"$app\""
	}
	set w $TKCON(base).compare
	if {[winfo exists $w]} {
	    $w.text config -state normal
	    $w.text delete 1.0 end
	} else {
	    toplevel $w
	    frame $w.btn
	    scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview]
	    text $w.text -yscrollcommand [list $w.sy set] -height 12 \
		    -foreground $TKCON(color,stdin) \
		    -background $TKCON(color,bg) \
		    -insertbackground $TKCON(color,cursor) \
		    -font $TKCON(font)
	    pack $w.btn -side bottom -fill x
	    pack $w.sy -side right -fill y
	    pack $w.text -fill both -expand 1
	    button $w.btn.close -text "Dismiss" -width 11 \
		    -command [list destroy $w]
	    button $w.btn.check  -text "Recheckpoint" -width 11
	    button $w.btn.revert -text "Revert" -width 11
	    button $w.btn.expand -text "Verbose" -width 11
	    button $w.btn.update -text "Update" -width 11
	    pack $w.btn.check $w.btn.revert $w.btn.expand $w.btn.update \
		    $w.btn.close -side left -fill x -padx 4 -pady 2 -expand 1
	    $w.text tag config red -foreground red
	}
	wm title $w "Compare State: $type [list $app]"

	$w.btn.check config -command "tkConStateCheckpoint [list $app] $type; \
		tkConStateCompare [list $app] $type $verbose"
	$w.btn.revert config -command "tkConStateRevert [list $app] $type; \
		tkConStateCompare [list $app] $type $verbose"
	$w.btn.update config -command [info level 0]
	if {$verbose} {
	    $w.btn.expand config -text Brief \
		    -command [list tkConStateCompare $app $type 0]
	} else {
	    $w.btn.expand config -text Verbose \
		    -command [list tkConStateCompare $app $type 1]
	}
	## Don't allow verbose mode unless 'dump' exists in $app
	## We're assuming this is TkCon's dump command
	set hasdump [llength [tkConEvalOther $app $type info commands dump]]
	if {$hasdump} {
	    $w.btn.expand config -state normal
	} else {
	    $w.btn.expand config -state disabled
	}

	set cmds [lremove [tkConEvalOther $app $type info commands *] \
		$TKCON($type,$app,cmd)]
	set vars [lremove [tkConEvalOther $app $type info vars *] \
		$TKCON($type,$app,var)]

	if {$hasdump && $verbose} {
	    set cmds [tkConEvalOther $app $type eval dump c -nocomplain $cmds]
	    set vars [tkConEvalOther $app $type eval dump v -nocomplain $vars]
	}
	$w.text insert 1.0 "NEW COMMANDS IN \"$app\":\n" red \
		$cmds {} "\n\nNEW VARIABLES IN \"$app\":\n" red $vars {}

	raise $w
	$w.text config -state disabled
    }

    ## tkConStateRevert - reverts interpreter to previous state
    # ARGS:
    ##
    ;proc tkConStateRevert {app type} {
	global TKCON
	if {![info exists TKCON($type,$app,cmd)]} {
	    return -code error \
		    "No previously checkpointed state for $type \"$app\""
	}
	if {![tk_dialog $TKCON(base).warning "Revert State?" \
		"Are you sure you want to revert the state in $type \"$app\"?"\
		questhead 1 "Do It" "Cancel"]} {
	    foreach i [lremove [tkConEvalOther $app $type info commands *] \
		    $TKCON($type,$app,cmd)] {
		catch {tkConEvalOther $app $type rename $i {}}
	    }
	    foreach i [lremove [tkConEvalOther $app $type info vars *] \
		    $TKCON($type,$app,var)] {
		catch {tkConEvalOther $app $type unset $i}
	    }
	}
    }

    ## tkConStateCleanup - cleans up state information in master array
    #
    ##
    ;proc tkConStateCleanup {args} {
	global TKCON
	if {![llength $args]} {
	    foreach state [array names TKCON slave,*] {
		if {![interp exists [string range $state 6 end]]} {
		    unset TKCON($state)
		}
	    }
	} else {
	    set app  [lindex $args 0]
	    set type [lindex $args 1]
	    if {[regexp {^(|slave)$} $type]} {
		foreach state [array names TKCON "slave,$app\[, \]*"] {
		    if {![interp exists [string range $state 6 end]]} {
			unset TKCON($state)
		    }
		}
	    } else {
		catch {unset TKCON($type,$app)}
	    }
	}
    }
}

## tkConEvent - get history event, search if string != {}
## look forward (next) if $int>0, otherwise look back (prev)
# ARGS:	W	- console widget
##
;proc tkConEvent {int {str {}}} {
    if {!$int} return

    global TKCON
    set w $TKCON(console)

    set nextid [tkConEvalSlave history nextid]
    if {[string compare {} $str]} {
	## String is not empty, do an event search
	set event $TKCON(event)
	if {$int < 0 && $event == $nextid} { set TKCON(cmdbuf) $str }
	set len [string len $TKCON(cmdbuf)]
	incr len -1
	if {$int > 0} {
	    ## Search history forward
	    while {$event < $nextid} {
		if {[incr event] == $nextid} {
		    $w delete limit end
		    $w insert limit $TKCON(cmdbuf)
		    break
		} elseif {
		    ![catch {tkConEvalSlave history event $event} res] &&
		    ![string compare $TKCON(cmdbuf) [string range $res 0 $len]]
		} {
		    $w delete limit end
		    $w insert limit $res
		    break
		}
	    }
	    set TKCON(event) $event
	} else {
	    ## Search history reverse
	    while {![catch {tkConEvalSlave \
		    history event [incr event -1]} res]} {
		if {![string compare $TKCON(cmdbuf) \
			[string range $res 0 $len]]} {
		    $w delete limit end
		    $w insert limit $res
		    set TKCON(event) $event
		    break
		}
	    }
	} 
    } else {
	## String is empty, just get next/prev event
	if {$int > 0} {
	    ## Goto next command in history
	    if {$TKCON(event) < $nextid} {
		$w delete limit end
		if {[incr TKCON(event)] == $nextid} {
		    $w insert limit $TKCON(cmdbuf)
		} else {
		    $w insert limit [tkConEvalSlave \
			    history event $TKCON(event)]
		}
	    }
	} else {
	    ## Goto previous command in history
	    if {$TKCON(event) == $nextid} {
		set TKCON(cmdbuf) [tkConCmdGet $w]
	    }
	    if {[catch {tkConEvalSlave \
		    history event [incr TKCON(event) -1]} res]} {
		incr TKCON(event)
	    } else {
		$w delete limit end
		$w insert limit $res
	    }
	}
    }
    $w mark set insert end
    $w see end
}

## tkConErrorHighlight - magic error highlighting
## beware: voodoo included
# ARGS:
##
;proc tkConErrorHighlight w {
    global TKCON
    ## do voodoo here
    set app [tkConAttach]
    # we have to pull the text out, because text regexps are screwed on \n's.
    set info [$w get 1.0 end-1c]
    # Check for specific line error in a proc
    set exp(proc) "\"(\[^\"\]+)\"\n\[\t \]+\\\(procedure \"(\[^\"\]+)\""
    # Check for too few args to a proc
    set exp(param) "parameter \"(\[^\"\]+)\" to \"(\[^\"\]+)\""
    set start 1.0
    while {
	[regexp -indices -- $exp(proc) $info junk what cmd] ||
	[regexp -indices -- $exp(param) $info junk what cmd]
    } {
	foreach {w0 w1} $what {c0 c1} $cmd {break}
	set what [string range $info $w0 $w1]
	set cmd  [string range $info $c0 $c1]
	if {$TKCON(A:namespace) && [string match *::* $cmd]} {
	    set res [uplevel 1 tkConEvalOther $app namespace eval \
		    [list [namespace qualifiers $cmd] \
		    [list info procs [namespace tail $cmd]]]]
	} else {
	    set res [uplevel 1 tkConEvalOther $app info procs [list $cmd]]
	}
	if {[llength $res]==1} {
	    set tag [tkConUniqueTag $w]
	    $w tag add $tag $start+${c0}c $start+1c+${c1}c
	    $w tag configure $tag -foreground $TKCON(color,stdout)
	    $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 $app -type proc -find $what -- $cmd]}"
	}
	set info [string range $info $c1 end]
	set start [$w index $start+${c1}c]
    }
    ## Next stage, check for procs that start a line
    set start 1.0
    set exp(cmd) "^\"\[^\" \t\n\]+"
    while {
	[string compare {} [set ix \
		[$w search -regexp -count numc -- $exp(cmd) $start end]]]
    } {
	set start [$w index $ix+${numc}c]
	# +1c to avoid the first quote
	set cmd [$w get $ix+1c $start]
	if {$TKCON(A:namespace) && [string match *::* $cmd]} {
	    set res [uplevel 1 tkConEvalOther $app namespace eval \
		    [list [namespace qualifiers $cmd] \
		    [list info procs [namespace tail $cmd]]]]
	} else {
	    set res [uplevel 1 tkConEvalOther $app info procs [list $cmd]]
	}
	if {[llength $res]==1} {
	    set tag [tkConUniqueTag $w]
	    $w tag add $tag $ix+1c $start
	    $w tag configure $tag -foreground $TKCON(color,proc)
	    $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 $app -type proc -- $cmd]}"
	}
    }
}

## tkcon - command that allows control over the console
# ARGS:	totally variable, see internal comments
## 
proc tkcon {cmd args} {
    global TKCON errorInfo
    switch -glob -- $cmd {
	buf* {
	    ## 'buffer' Sets/Query the buffer size
	    if {[llength $args]} {
		if {[regexp {^[1-9][0-9]*$} $args]} {
		    set TKCON(buffer) $args
		    tkConConstrainBuffer $TKCON(console) $TKCON(buffer)
		} else {
		    return -code error "buffer must be a valid integer"
		}
	    }
	    return $TKCON(buffer)
	}
	bg* {
	    ## 'bgerror' Brings up an error dialog
	    set errorInfo [lindex $args 1]
	    bgerror [lindex $args 0]
	}
	cl* {
	    ## 'close' Closes the console
	    tkConDestroy
	}
	cons* {
	    ## 'console' - passes the args to the text widget of the console.
	    uplevel 1 $TKCON(console) $args
	    tkConConstrainBuffer $TKCON(console) $TKCON(buffer)
	}
	congets {
	    ## 'congets' a replacement for [gets stdin varname]
	    ## This forces a complete command to be input though
	    set old [bind TkConsole <<TkCon_Eval>>]
	    bind TkConsole <<