tkcon.tcl

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

## 
;proc tkConPrompt {{pre {}} {post {}} {prompt {}}} {
    global TKCON
    set w $TKCON(console)
    if {[string compare {} $pre]} { $w insert end $pre stdout }
    set i [$w index end-1c]
    if {[string compare {} $TKCON(appname)]} {
	$w insert end ">$TKCON(appname)< " prompt
    }
    if {[string compare :: $TKCON(namesp)]} {
	$w insert end "<$TKCON(namesp)> " prompt
    }
    if {[string compare {} $prompt]} {
	$w insert end $prompt prompt
    } else {
	$w insert end [tkConEvalSlave subst $TKCON(prompt1)] prompt
    }
    $w mark set output $i
    $w mark set insert end
    $w mark set limit insert
    $w mark gravity limit left
    if {[string compare {} $post]} { $w insert end $post stdin }
    tkConConstrainBuffer $w $TKCON(buffer)
    $w see end
}

## tkConAbout - gives about info for tkCon
## 
;proc tkConAbout {} {
    global TKCON
    set w $TKCON(base).about
    if {[winfo exists $w]} {
	wm deiconify $w
    } else {
	global tk_patchLevel tcl_patchLevel tcl_platform
	toplevel $w
	wm title $w "About TkCon v$TKCON(version)"
	button $w.b -text Dismiss -command [list wm withdraw $w]
	text $w.text -height 9 -bd 1 -width 60 \
		-foreground $TKCON(color,stdin) \
		-background $TKCON(color,bg) \
		-font $TKCON(font)
	pack $w.b -fill x -side bottom
	pack $w.text -fill both -side left -expand 1
	$w.text tag config center -justify center
	if {[string compare unix $tcl_platform(platform)] \
		|| [info tclversion] >= 8} {
	    $w.text tag config title -justify center -font {Courier -18 bold}
	} else {
	    $w.text tag config title -justify center -font *Courier*Bold*18*
	}
	$w.text insert 1.0 "About TkCon v$TKCON(version)" title \
		"\n\nCopyright 1995-1999 Jeffrey Hobbs, $TKCON(email)\
		\nRelease Date: v$TKCON(version), $TKCON(release)\
		\nDocumentation available at:\n$TKCON(docs)\
		\nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center
	$w.text config -state disabled
    }
}

## tkConInitMenus - inits the menubar and popup for the console
# ARGS:	w	- console text widget
## 
;proc tkConInitMenus {w title} {
    global TKCON tcl_platform

    if {[catch {menu $w.pop -tearoff 0}]} {
	label $w.label -text "Menus not available in plugin mode"
	pack $w.label
	return
    }
    menu $w.context -tearoff 0 -disabledforeground $TKCON(color,disabled)
    set TKCON(context) $w.context
    set TKCON(popup) $w.pop

    if {[info tclversion] >= 8.0} {
 	proc tkConMenuButton {w m l} {
 	    $w add cascade -label $m -underline 0 -menu $w.$l
	    return $w.$l
 	}
 	set x {}
    } else {
 	proc tkConMenuButton {w m l} {
 	    pack [menubutton $w.$l -text $m -underline 0 \
		    -padx 6p -pady 6p -menu $w.$l.m] -side left
	    return $w.$l.m
 	}
 	set x .m
    }
    foreach m [list File Console Edit Interp Prefs History Help] {
 	set l [string tolower $m]
 	tkConMenuButton $w $m $l
 	$w.pop add cascade -label $m -underline 0 -menu $w.pop.$l
    }
    if {[info tclversion] < 8.0} {
	pack $w.help -side right
    }

    ## File Menu
    ##
    foreach m [list [menu $w.file$x -disabledforeground $TKCON(color,disabled)] \
	    [menu $w.pop.file -disabledforeground $TKCON(color,disabled)]] {
	$m add command -label "Load File" -underline 0 -command tkConLoad
	$m add cascade -label "Save ..."  -underline 0 -menu $m.save
	$m add separator
	$m add command -label "Quit" -underline 0 -accel Ctrl-q -command exit

	## Save Menu
	##
	set s $m.save
	menu $s -disabledforeground $TKCON(color,disabled) -tearoff 0
	$s add command -label "All"	-und 0 -command {tkConSave {} all}
	$s add command -label "History"	-und 0 -command {tkConSave {} history}
	$s add command -label "Stdin"	-und 3 -command {tkConSave {} stdin}
	$s add command -label "Stdout"	-und 3 -command {tkConSave {} stdout}
	$s add command -label "Stderr"	-und 3 -command {tkConSave {} stderr}
    }

    ## Console Menu
    ##
    foreach m [list [menu $w.console$x -disabledfore $TKCON(color,disabled)] \
	    [menu $w.pop.console -disabledfore $TKCON(color,disabled)]] {
	$m add command -label "$title Console"	-state disabled
	$m add command -label "New Console"	-und 0 -accel Ctrl-N \
		-command tkConNew
	$m add command -label "Close Console"	-und 0 -accel Ctrl-w \
		-command tkConDestroy
	$m add command -label "Clear Console"	-und 1 -accel Ctrl-l \
		-command { clear; tkConPrompt }
	if {[string match unix $tcl_platform(platform)]} {
	    $m add separator
	    $m add command -label "Make Xauth Secure" -und 5 \
		    -command tkConXauthSecure
	}
	$m add separator
	$m add cascade -label "Attach To ..."	-und 0 -menu $m.attach

	## Attach Console Menu
	##
	set sub [menu $m.attach -disabledforeground $TKCON(color,disabled)]
	$sub add cascade -label "Interpreter"   -und 0 -menu $sub.apps
	$sub add cascade -label "Namespace" -und 1 -menu $sub.name

	## Attach Console Menu
	##
	menu $sub.apps -disabledforeground $TKCON(color,disabled) \
		-postcommand [list tkConAttachMenu $sub.apps]

	## Attach Namespace Menu
	##
	menu $sub.name -disabledforeground $TKCON(color,disabled) -tearoff 0 \
		-postcommand [list tkConNamespaceMenu $sub.name]
    }

    ## Edit Menu
    ##
    set text $TKCON(console)
    foreach m [list [menu $w.edit$x] [menu $w.pop.edit]] {
	$m add command -label "Cut"   -underline 2 -accel Ctrl-x \
		-command [list tkConCut $text]
	$m add command -label "Copy"  -underline 0 -accel Ctrl-c \
		-command [list tkConCopy $text]
	$m add command -label "Paste" -underline 0 -accel Ctrl-v \
		 -command [list tkConPaste $text]
	$m add separator
	$m add command -label "Find"  -underline 0 -accel Ctrl-F \
		-command [list tkConFindBox $text]
    }

    ## Interp Menu
    ##
    foreach m [list $w.interp$x $w.pop.interp] {
	menu $m -disabledforeground $TKCON(color,disabled) \
		-postcommand [list tkConInterpMenu $m]
    }

    ## Prefs Menu
    ##
    foreach m [list [menu $w.prefs$x] [menu $w.pop.prefs]] {
	$m add check -label "Brace Highlighting" \
		-underline 0 -variable TKCON(lightbrace)
	$m add check -label "Command Highlighting" \
		-underline 0 -variable TKCON(lightcmd)
	$m add check -label "History Substitution" \
		-underline 0 -variable TKCON(subhistory)
	$m add check -label "Hot Errors" \
		-underline 0 -variable TKCON(hoterrors)
	$m add check -label "Non-Tcl Attachments" \
		-underline 0 -variable TKCON(nontcl)
	$m add check -label "Calculator Mode" \
		-underline 1 -variable TKCON(calcmode)
	$m add check -label "Show Multiple Matches" \
		-underline 0 -variable TKCON(showmultiple)
	$m add check -label "Show Menubar" \
		-underline 5 -variable TKCON(showmenu) \
		-command "if {\$TKCON(showmenu)} { \
		pack $w -fill x -before $TKCON(console) \
		-before $TKCON(scrolly) \
	    } else { pack forget $w }"
	$m add cascade -label "Scrollbar" -underline 2 -menu $m.scroll

	## Scrollbar Menu
	##
	set m [menu $m.scroll -tearoff 0]
	$m add radio -label "Left" -variable TKCON(scrollypos) -value left \
		-command { pack config $TKCON(scrolly) -side left }
	$m add radio -label "Right" -variable TKCON(scrollypos) -value right \
		-command { pack config $TKCON(scrolly) -side right }
    }

    ## History Menu
    ##
    foreach m [list $w.history$x $w.pop.history] {
	menu $m -disabledforeground $TKCON(color,disabled) \
		-postcommand [list tkConHistoryMenu $m]
    }

    ## Help Menu
    ##
    foreach m [list [menu $w.help$x] [menu $w.pop.help]] {
	$m add command -label "About " -und 0 -accel Ctrl-A -command tkConAbout
    }
}

## tkConHistoryMenu - dynamically build the menu for attached interpreters
##
# ARGS:	m	- menu widget
##
;proc tkConHistoryMenu m {
    global TKCON

    if {![winfo exists $m]} return
    set id [tkConEvalSlave history nextid]
    if {$TKCON(histid)==$id} return
    set TKCON(histid) $id
    $m delete 0 end
    while {$id && ($id>$TKCON(histid)-10) && \
	    ![catch {tkConEvalSlave history event [incr id -1]} tmp]} {
	set lbl [lindex [split $tmp "\n"] 0]
	if {[string len $lbl]>32} { set lbl [string range $tmp 0 28]... }
	$m add command -label "$id: $lbl" -command "
	$TKCON(console) delete limit end
	$TKCON(console) insert limit [list $tmp]
	$TKCON(console) see end
	tkConEval $TKCON(console)"
    }
}

## tkConInterpMenu - dynamically build the menu for attached interpreters
##
# ARGS:	w	- menu widget
##
;proc tkConInterpMenu w {
    global TKCON

    if {![winfo exists $w]} return
    $w delete 0 end
    foreach {app type} [tkConAttach] break
    $w add command -label "[string toupper $type]: $app" -state disabled
    if {($TKCON(nontcl) && [string match interp $type]) || $TKCON(deadapp)} {
	$w add separator
	$w add command -state disabled -label "Communication disabled to"
	$w add command -state disabled -label "dead or non-Tcl interps"
	return
    }

    ## Show Last Error
    ##
    $w add separator
    $w add command -label "Show Last Error" \
	    -command [list tkcon error $app $type]

    ## Packages Cascaded Menu
    ##
    if {$TKCON(A:version) > 7.4} {
	$w add separator
	$w add cascade -label Packages -underline 0 -menu $w.pkg
	set m $w.pkg
	if {![winfo exists $m]} {
	    menu $m -tearoff no -disabledforeground $TKCON(color,disabled) \
		    -postcommand [list tkConPkgMenu $m $app $type]
	}
    }

    ## State Checkpoint/Revert
    ##
    $w add separator
    $w add command -label "Checkpoint State" \
	    -command [list tkConStateCheckpoint $app $type]
    $w add command -label "Revert State" \
	    -command [list tkConStateRevert $app $type]
    $w add command -label "View State Change" \
	    -command [list tkConStateCompare $app $type]

    ## Init Interp
    ##
    $w add separator
    $w add command -label "Send TkCon Commands" \
	    -command [list tkConInitInterp $app $type]
}

## tkConPkgMenu - fill in  in the applications sub-menu
## with a list of all the applications that currently exist.
##
;proc tkConPkgMenu {m app type} {
    global TKCON

    set lopt [expr {([info tclversion] >= 8.0)?"-dictionary":"-ascii"}]

    # just in case stuff has been added to the auto_path
    # we have to make sure that the errorInfo doesn't get screwed up
    tkConEvalAttached {
	set __tkcon_error $errorInfo
	catch {package require bogus-package-name}
	set errorInfo ${__tkcon_error}
	unset __tkcon_error
    }
    $m delete 0 end
    foreach pkg [tkConEvalAttached [list info loaded {}]] {
	set loaded([lindex $pkg 1]) [package provide $pkg]
    }
    foreach pkg [lremove [tkConEvalAttached {package names}] Tcl] {
	set version [tkConEvalAttached [list package provide $pkg]]
	if {[string compare {} $version]} {
	    set loaded($pkg) $version
	} elseif {![info exists loaded($pkg)]} {
	    set loadable($pkg) [list package require $pkg]
	}
    }
    foreach pkg [tkConEvalAttached {info loaded}] {
	set pkg [lindex $pkg 1]
	if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} {
	    set loadable($pkg) [list load {} $pkg]
	}
    }
    foreach pkg [lsort $lopt [array names loadable]] {
	foreach v [tkConEvalAttached [list package version $pkg]] {
	    $m add command -label "Load $pkg ($v)" -command \
		    "tkConEvalOther [list $app] $type $loadable($pkg) $v"
	}
    }
    if {[info exists loaded] && [info exists loadable]} {
	$m add separator
    }
    foreach pkg [lsort $lopt [array names loaded]] {
	$m add command -label "${pkg}$loaded($pkg) Loaded" -state disabled
    }
}

## tkConAttachMenu - fill in  in the applications sub-menu
## with a list of all the applications that currently exist.
##
;proc tkConAttachMenu m {
    global TKCON

    array set interps [set tmp [tkConInterps]]
    foreach {i j} $tmp { set tknames($j) {} }

    $m delete 0 end
    set cmd {tkConPrompt \n [tkConCmdGet $TKCON(console)]}
    $m add radio -label {None (use local slave) } -variable TKCON(app) \
	    -value [concat $TKCON(name) $TKCON(exec)] -accel Ctrl-1 \
	    -command "tkConAttach {}; $cmd"
    $m add separator
    $m add command -label "Foreign Tk Interpreters" -state disabled
    foreach i [lsort [lremove [winfo interps] [array names tknames]]] {
	$m add radio -label $i -variable TKCON(app) -value $i \
		-command "tkConAttach [list $i] interp; $cmd"
    }
    $m add separator

    $m add command -label "TkCon Interpreters" -state disabled
    foreach i [lsort [array names interps]] {
	if {[string match {} $interps($i)]} { set interps($i) "no Tk" }
	if {[regexp {^Slave[0-9]+} $i]} {
	    set opts [list -label "$i ($interps($i))" -variable TKCON(app) \
		    -value $i -command "tkConAttach [list $i] slave; $cmd"]
	    if {[string match $TKCON(name) $i]} {
		append opts " -accel Ctrl-2"
	    }
	    eval $m add radio $opts
	} else {
	    set name [concat Main $i]
	    if {[string match Main $name]} {
		$m add radio -label "$name ($interps($i))" \
			-variable TKCON(app) -value Main -accel Ctrl-3 \
			-command "tkConAttach [list $name] slave; $cmd"
	    } else {
		$m add radio -label "$name ($interps($i))" \
			-variable TKCON(app) -value $i \
			-command "tkConAttach [list $name] slave; $cmd"
	    }
	}
    }
}

## Namepaces Cascaded Menu
##
;proc tkConNamespaceMenu m {
    global TKCON

    $m delete 0 end
    if {!$TKCON(A:namespace) || ($TKCON(deadapp) || \
	    ($TKCON(nontcl) && [string match interp $TKCON(apptype)]))} {
	$m add command -label "No Namespaces" -state disabled
	return
    }

    ## Same command as for tkConAttachMenu items
    set cmd {tkConPrompt \n [tkConCmdGet $TKCON(console)]}

    set names [lsort [tkConNamespaces ::]]
    if {[llength $names] > $TKCON(maxmenu)} {
	$m add command -label "Attached to $TKCON(namesp)" -state disabled
	$m add command -label "List Namespaces" \
		-command [list tkConNamespacesList $names]