tkcon.tcl

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

    } else {
	foreach i $names {
	    if {[string match :: $i]} {
		$m add radio -label "Main" -variable TKCON(namesp) -value $i \
			-command "tkConAttachNamespace [list $i]; $cmd"
	    } else {
		$m add radio -label $i -variable TKCON(namesp) -value $i \
			-command "tkConAttachNamespace [list $i]; $cmd"
	    }
	}
    }
}

## Namepaces List 
##
;proc tkConNamespacesList {names} {
    global TKCON
    
    set f $TKCON(base).tkConNamespaces
    catch {destroy $f}
    toplevel $f
    listbox $f.names -width 30 -height 15 -selectmode single \
	    -yscrollcommand [list $f.scrollv set] \
	    -xscrollcommand [list $f.scrollh set]
    scrollbar $f.scrollv -command [list $f.names yview]
    scrollbar $f.scrollh -command [list $f.names xview] -orient horizontal
    frame $f.buttons
    button $f.cancel -text "Cancel" -command [list destroy $f]

    grid $f.names $f.scrollv -sticky nesw
    grid $f.scrollh -sticky ew
    grid $f.buttons -sticky nesw
    grid $f.cancel -in $f.buttons -pady 6

    grid columnconfigure $f 0 -weight 1
    grid rowconfigure $f  0 -weight 1
    #fill the listbox
    foreach i $names {
	if {[string match :: $i]} {
	    $f.names insert 0 Main
	} else {
	    $f.names insert end $i
	}
    }
    #Bindings
    bind $f.names <Double-1> {
	## Catch in case the namespace disappeared on us
	catch { tkConAttachNamespace [%W get [%W nearest %y]] }
	tkConPrompt "\n" [tkConCmdGet $TKCON(console)]
	destroy [winfo toplevel %W]
    }
}

# tkConXauthSecure --
#
#   This removes all the names in the xhost list, and secures
#   the display for Tk send commands.  Of course, this prevents
#   what might have been otherwise allowable X connections
#
# Arguments:
#   none
# Results:
#   Returns nothing
#
proc tkConXauthSecure {} {
    global tcl_platform
    if {[string compare unix $tcl_platform(platform)]} {
	# This makes no sense outside of Unix
	return
    }
    set hosts [exec xhost]
    # the first line is info only
    foreach host [lrange [split $hosts \n] 1 end] {
	exec xhost -$host
    }
    exec xhost -
    tk_messageBox -title "Xhost secured" -message "Xhost secured" -icon info
}

## tkConFindBox - creates minimal dialog interface to tkConFind
# ARGS:	w	- text widget
#	str	- optional seed string for TKCON(find)
##
;proc tkConFindBox {w {str {}}} {
    global TKCON

    set base $TKCON(base).find
    if {![winfo exists $base]} {
	toplevel $base
	wm withdraw $base
	wm title $base "TkCon Find"

	pack [frame $base.f] -fill x -expand 1
	label $base.f.l -text "Find:"
	entry $base.f.e -textvar TKCON(find)
	pack [frame $base.opt] -fill x
	checkbutton $base.opt.c -text "Case Sensitive" \
		-variable TKCON(find,case)
	checkbutton $base.opt.r -text "Use Regexp" -variable TKCON(find,reg)
	pack $base.f.l -side left
	pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
	pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
	pack [frame $base.btn] -fill both
	button $base.btn.fnd -text "Find" -width 6
	button $base.btn.clr -text "Clear" -width 6
	button $base.btn.dis -text "Dismiss" -width 6
	eval pack [winfo children $base.btn] -padx 4 -pady 2 \
		-side left -fill both

	focus $base.f.e

	bind $base.f.e <Return> [list $base.btn.fnd invoke]
	bind $base.f.e <Escape> [list $base.btn.dis invoke]
    }
    $base.btn.fnd config -command "tkConFind [list $w] \$TKCON(find) \
	    -case \$TKCON(find,case) -reg \$TKCON(find,reg)"
    $base.btn.clr config -command "
    [list $w] tag remove find 1.0 end
    set TKCON(find) {}
    "
    $base.btn.dis config -command "
    [list $w] tag remove find 1.0 end
    wm withdraw [list $base]
    "
    if {[string compare {} $str]} {
	set TKCON(find) $str
	$base.btn.fnd invoke
    }

    if {[string compare normal [wm state $base]]} {
	wm deiconify $base
    } else { raise $base }
    $base.f.e select range 0 end
}

## tkConFind - searches in text widget $w for $str and highlights it
## If $str is empty, it just deletes any highlighting
# ARGS: w	- text widget
#	str	- string to search for
#	-case	TCL_BOOLEAN	whether to be case sensitive	DEFAULT: 0
#	-regexp	TCL_BOOLEAN	whether to use $str as pattern	DEFAULT: 0
##
;proc tkConFind {w str args} {
    $w tag remove find 1.0 end
    set truth {^(1|yes|true|on)$}
    set opts  {}
    foreach {key val} $args {
	switch -glob -- $key {
	    -c* { if {[regexp -nocase $truth $val]} { set case 1 } }
	    -r* { if {[regexp -nocase $truth $val]} { lappend opts -regexp } }
	    default { return -code error "Unknown option $key" }
	}
    }
    if {![info exists case]} { lappend opts -nocase }
    if {[string match {} $str]} return
    $w mark set findmark 1.0
    while {[string compare {} [set ix [eval $w search $opts -count numc -- \
	    [list $str] findmark end]]]} {
	$w tag add find $ix ${ix}+${numc}c
	$w mark set findmark ${ix}+1c
    }
    global TKCON
    $w tag configure find -background $TKCON(color,blink)
    catch {$w see find.first}
    return [expr {[llength [$w tag ranges find]]/2}]
}

## tkConAttach - called to attach tkCon to an interpreter
# ARGS:	name	- application name to which tkCon sends commands
#		  This is either a slave interperter name or tk appname.
#	type	- (slave|interp) type of interpreter we're attaching to
#		  slave means it's a TkCon interpreter
#		  interp means we'll need to 'send' to it.
# Results:	tkConEvalAttached is recreated to evaluate in the
#		appropriate interpreter
##
;proc tkConAttach {{name <NONE>} {type slave}} {
    global TKCON
    if {[string match <NONE> $name]} {
	if {[string match {} $TKCON(appname)]} {
	    return [list [concat $TKCON(name) $TKCON(exec)] $TKCON(apptype)]
	} else {
	    return [list $TKCON(appname) $TKCON(apptype)]
	}
    }
    set path [concat $TKCON(name) $TKCON(exec)]

    if {[string match namespace $type]} {
	return [uplevel tkConAttachNamespace $name]
    } elseif {[string compare {} $name]} {
	array set interps [tkConInterps]
	if {[string match {[Mm]ain} [lindex $name 0]]} {
	    set name [lrange $name 1 end]
	}
	if {[string match $path $name]} {
	    set name {}
	    set app $path
	    set type slave
	} elseif {[info exists interps($name)]} {
	    if {[string match {} $name]} { set name Main; set app Main }
	    set type slave
	} elseif {[interp exists $name]} {
	    set name [concat $TKCON(name) $name]
	    set type slave
	} elseif {[interp exists [concat $TKCON(exec) $name]]} {
	    set name [concat $path $name]
	    set type slave
	} elseif {[lsearch -exact [winfo interps] $name] > -1} {
	    if {[tkConEvalSlave info exists tk_library] \
		    && [string match $name [tkConEvalSlave tk appname]]} {
		set name {}
		set app $path
		set type slave
	    } elseif {[set i [lsearch -exact \
		    [tkConMain set TKCON(interps)] $name]] != -1} {
		set name [lindex [tkConMain set TKCON(slaves)] $i]
		if {[string match {[Mm]ain} $name]} { set app Main }
		set type slave
	    } else {
		set type interp
	    }
	} else {
	    return -code error "No known interpreter \"$name\""
	}
    } else {
	set app $path
    }
    if {![info exists app]} { set app $name }
    array set TKCON [list app $app appname $name apptype $type deadapp 0]

    ## tkConEvalAttached - evaluates the args in the attached interp
    ## args should be passed to this procedure as if they were being
    ## passed to the 'eval' procedure.  This procedure is dynamic to
    ## ensure evaluation occurs in the right interp.
    # ARGS:	args	- the command and args to evaluate
    ##
    switch $type {
	slave {
	    if {[string match {} $name]} {
		interp alias {} tkConEvalAttached {} tkConEvalSlave uplevel \#0
	    } elseif {[string match Main $TKCON(app)]} {
		interp alias {} tkConEvalAttached {} tkConMain
	    } elseif {[string match $TKCON(name) $TKCON(app)]} {
		interp alias {} tkConEvalAttached {} uplevel \#0
	    } else {
		interp alias {} tkConEvalAttached {} tkConSlave $TKCON(app)
	    }
	}
	interp {
	    if {$TKCON(nontcl)} {
		interp alias {} tkConEvalAttached {} tkConEvalSlave
		array set TKCON {A:version 0 A:namespace 0 A:itcl2 0 namesp ::}
	    } else {
		interp alias {} tkConEvalAttached {} tkConEvalSend
	    }
	}
	default {
	    return -code error "[lindex [info level 0] 0] did not specify\
		    a valid type: must be slave or interp"
	}
    }
    if {[string match slave $type] || \
	    (!$TKCON(nontcl) && [string match interp $type])} {
	set TKCON(A:version)   [tkConEvalAttached {info tclversion}]
	set TKCON(A:namespace) [llength \
		[tkConEvalAttached {info commands namespace}]]
	# Itcl3.0 for Tcl8.0 should have Tcl8 namespace semantics
	# and not effect the patchlevel
	set TKCON(A:itcl2) [string match *i* \
		[tkConEvalAttached {info patchlevel}]]
	set TKCON(namesp) ::
    }
    return
}

## tkConAttachNamespace - called to attach tkCon to a namespace
# ARGS:	name	- namespace name in which tkCon should eval commands
# Results:	tkConEvalAttached will be modified
##
;proc tkConAttachNamespace { name } {
    global TKCON
    if {($TKCON(nontcl) && [string match interp $TKCON(apptype)]) \
	    || $TKCON(deadapp)} {
	return -code error "can't attach to namespace in bad environment"
    }
    if {[string match Main $name]} {set name ::}
    if {[string compare {} $name] && \
	    [lsearch [tkConNamespaces ::] $name] == -1} {
	return -code error "No known namespace \"$name\""
    }
    if {[regexp {^(|::)$} $name]} {
	## If name=={} || ::, we want the primary namespace
	set alias [interp alias {} tkConEvalAttached]
	if {[string match tkConEvalNamespace* $alias]} {
	    eval [list interp alias {} tkConEvalAttached {}] [lindex $alias 1]
	}
	set name ::
    } else {
	interp alias {} tkConEvalAttached {} tkConEvalNamespace \
		[interp alias {} tkConEvalAttached] [list $name]
    }
    set TKCON(namesp) $name
}

## tkConLoad - sources a file into the console
## The file is actually sourced in the currently attached's interp
# ARGS:	fn	- (optional) filename to source in
# Returns:	selected filename ({} if nothing was selected)
## 
;proc tkConLoad { {fn ""} } {
    global TKCON
    set types {
	{{Tcl Files}	{.tcl .tk}}
	{{Text Files}	{.txt}}
	{{All Files}	*}
    }
    if {
	[string match {} $fn] &&
	([catch {tk_getOpenFile -filetypes $types \
	    -title "Source File"} fn] || [string match {} $fn])
    } { return }
    tkConEvalAttached [list source $fn]
}

## tkConSave - saves the console or other widget buffer to a file
## This does not eval in a slave because it's not necessary
# ARGS:	w	- console text widget
# 	fn	- (optional) filename to save to
## 
;proc tkConSave { {fn ""} {type ""} {widget ""} {mode w} } {
    global TKCON
    if {![regexp -nocase {^(all|history|stdin|stdout|stderr|widget)$} $type]} {
	array set s { 0 All 1 History 2 Stdin 3 Stdout 4 Stderr 5 Cancel }
	## Allow user to specify what kind of stuff to save
	set type [tk_dialog $TKCON(base).savetype "Save Type" \
		"What part of the text do you want to save?" \
		questhead 0 $s(0) $s(1) $s(2) $s(3) $s(4) $s(5)]
	if {$type == 5 || $type == -1} return
	set type $s($type)
    }
    if {[string match {} $fn]} {
	set types {
	    {{Tcl Files}	{.tcl .tk}}
	    {{Text Files}	{.txt}}
	    {{All Files}	*}
	}
	if {[catch {tk_getSaveFile -defaultextension .tcl -filetypes $types \
		-title "Save $type"} fn] || [string match {} $fn]} return
    }
    set type [string tolower $type]
    switch $type {
	stdin -	stdout - stderr {
	    set data {}
	    foreach {first last} [$TKCON(console) tag ranges $type] {
		lappend data [$TKCON(console) get $first $last]
	    }
	    set data [join $data \n]
	}
	history		{ set data [tkcon history] }
	all - default	{ set data [$TKCON(console) get 1.0 end-1c] }
	widget		{
	    set data [$widget get 1.0 end-1c]
	}
    }
    if {[catch {open $fn $mode} fid]} {
	return -code error "Save Error: Unable to open '$fn' for writing\n$fid"
    }
    puts $fid $data
    close $fid
}

## tkConMainInit
## This is only called for the main interpreter to include certain procs
## that we don't want to include (or rather, just alias) in slave interps.
##
;proc tkConMainInit {} {
    global TKCON

    if {![info exists TKCON(slaves)]} {
	array set TKCON [list slave 0 slaves Main name {} \
		interps [list [tk appname]]]
    }
    interp alias {} tkConMain {} tkConInterpEval Main
    interp alias {} tkConSlave {} tkConInterpEval

    ;proc tkConGetSlaveNum {} {
	global TKCON
	set i -1
	while {[interp exists Slave[incr i]]} {
	    # oh my god, an empty loop!
	}
	return $i
    }

    ## tkConNew - create new console window
    ## Creates a slave interpreter and sources in this script.
    ## All other interpreters also get a command to eval function in the
    ## new interpreter.
    ## 
    ;proc tkConNew {} {
	global argv0 argc argv TKCON
	set tmp [interp create Slave[tkConGetSlaveNum]]
	lappend TKCON(slaves) $tmp
	load {} Tk $tmp
	lappend TKCON(interps) [$tmp eval [list tk appname \
		"[tk appname] $tmp"]]
	if {[info exist argv0]} {$tmp eval [list set argv0 $argv0]}
	$tmp eval set argc $argc \; set argv [list $argv] \; \
		set TKCON(name) $tmp \; set TKCON(SCRIPT) [list $TKCON(SCRIPT)]
	$tmp alias exit			tkConExit $tmp
	$tmp alias tkConDestroy		tkConDestroy $tmp
	$tmp alias tkConNew		tkConNew
	$tmp alias tkConMain		tkConInterpEval Main
	$tmp alias tkConSlave		tkConInterpEval
	$tmp alias tkConInterps		tkConInterps
	$tmp alias tkConStateCheckpoint	tkConStateCheckpoint