Intial commit
This commit is contained in:
Mario Fetka
99
tcl-dp/tekilib/debug.tcl
Normal file
99
tcl-dp/tekilib/debug.tcl
Normal file
@@ -0,0 +1,99 @@
|
||||
#!/usr/local/bin/wish -f
|
||||
# debug.tcl --
|
||||
|
||||
package provide Debug 1.0
|
||||
|
||||
#
|
||||
# Debugging support. This section contains some elementary debugging
|
||||
# support. It is used as a sort of sophisticated puts statement.
|
||||
# It assumes the following conventions:
|
||||
# o when a procedure is entered, Debug_Enter is called.
|
||||
# o when a procedure is left, Debug_Leave is called.
|
||||
# o To print a message, Debug_Print is called.
|
||||
# o Fatal errors can be logged with Debug_FatalError
|
||||
#
|
||||
|
||||
# Global variables used in debugging:
|
||||
|
||||
set DebugInfo(DebugOn) 1;
|
||||
set DebugInfo(DebugLevel) 5;
|
||||
set DebugInfo(DebugProc) Global;
|
||||
set DebugInfo(DebugStack) Global;
|
||||
|
||||
#
|
||||
# Debugging stuff:
|
||||
# o Debug_Enter is called when a procedure is entered
|
||||
# o Debug_Leave when it's left, and
|
||||
# o Debug_Print to print a message (with formatting)
|
||||
# o Debug_FatalError prints a message an exits
|
||||
#
|
||||
|
||||
#
|
||||
# Debug_FatalError
|
||||
# Called when all hope is lost. Just prints an error and
|
||||
# exits.
|
||||
#
|
||||
# Arguments:
|
||||
# message Message to print before exiting
|
||||
#
|
||||
proc Debug_FatalError message {
|
||||
global DebugInfo errorCode errorInfo
|
||||
puts stderr "Fatal error: $message"
|
||||
puts stderr "errorCode = $errorCode"
|
||||
puts stderr "errorInfo = $errorInfo"
|
||||
puts stderr "Stack: $DebugInfo(DebugStack)"
|
||||
puts stderr "exiting..."
|
||||
exit
|
||||
}
|
||||
|
||||
#
|
||||
# Debug
|
||||
# Called to print a debugging message. Indents it, too!
|
||||
#
|
||||
# Arguments:
|
||||
# args Message to print
|
||||
#
|
||||
proc Debug_Print args {
|
||||
global DebugInfo
|
||||
if $DebugInfo(DebugOn) {
|
||||
set level $DebugInfo(DebugLevel)
|
||||
puts [format "%24s: %${level}s%s" $DebugInfo(DebugProc) {} $args]
|
||||
}
|
||||
}
|
||||
|
||||
#
|
||||
# Debug_Enter
|
||||
# Should be called when we enter a routine. Updates the call stack,
|
||||
# increments the stack depth variable (DebugLevel), and prints the
|
||||
# name of the procedure.
|
||||
#
|
||||
# Arguments:
|
||||
# procName Name of procedure being entered.
|
||||
#
|
||||
proc Debug_Enter procName {
|
||||
global DebugInfo
|
||||
set DebugInfo(DebugStack) [concat $procName $DebugInfo(DebugStack)]
|
||||
set DebugInfo(DebugProc) $procName
|
||||
incr DebugInfo(DebugLevel) 2
|
||||
Debug_Print "Entering $procName"
|
||||
}
|
||||
|
||||
#
|
||||
# Debug_Leave
|
||||
# Counterpart of Debug_Enter. Should be called when we leave a routine.
|
||||
# Updates the call stack, decrements the stack depth variable (DebugLevel),
|
||||
# and prints the name of the procedure.
|
||||
#
|
||||
# Arguments:
|
||||
# none
|
||||
#
|
||||
proc Debug_Leave {} {
|
||||
global DebugInfo
|
||||
set procName [lrange $DebugInfo(DebugStack) 0 0]
|
||||
set DebugInfo(DebugStack) [lrange $DebugInfo(DebugStack) 1 end]
|
||||
set DebugInfo(DebugProc) [lrange $DebugInfo(DebugStack) 0 0]
|
||||
Debug_Print Leaving $procName
|
||||
incr DebugInfo(DebugLevel) -2
|
||||
}
|
||||
|
||||
|
||||
377
tcl-dp/tekilib/http.tcl
Normal file
377
tcl-dp/tekilib/http.tcl
Normal file
@@ -0,0 +1,377 @@
|
||||
# http.tcl
|
||||
# Client-side HTTP for GET, POST, and HEAD commands.
|
||||
# These routines can be used in untrusted code that uses the Safesock
|
||||
# security policy.
|
||||
# These procedures use a callback interface to avoid using vwait,
|
||||
# which is not defined in the safe base.
|
||||
#
|
||||
# SCCS: @(#) http.tcl 1.6 97/05/20 18:09:27
|
||||
#
|
||||
# See the http.n man page for documentation
|
||||
|
||||
package provide http 1.0
|
||||
|
||||
if {$tcl_version < 8.0} {
|
||||
proc fcopy args {
|
||||
eval unsupported0 $args
|
||||
}
|
||||
}
|
||||
array set http {
|
||||
-accept */*
|
||||
-proxyhost {}
|
||||
-proxyport {}
|
||||
-useragent {Tcl http client package 1.0}
|
||||
-proxyfilter httpProxyRequired
|
||||
}
|
||||
proc http_config {args} {
|
||||
global http
|
||||
set options [lsort [array names http -*]]
|
||||
set usage [join $options ", "]
|
||||
if {[llength $args] == 0} {
|
||||
set result {}
|
||||
foreach name $options {
|
||||
lappend result $name $http($name)
|
||||
}
|
||||
return $result
|
||||
}
|
||||
regsub -all -- - $options {} options
|
||||
set pat ^-([join $options |])$
|
||||
if {[llength $args] == 1} {
|
||||
set flag [lindex $args 0]
|
||||
if {[regexp -- $pat $flag]} {
|
||||
return $http($flag)
|
||||
} else {
|
||||
return -code error "Unknown option $flag, must be: $usage"
|
||||
}
|
||||
} else {
|
||||
foreach {flag value} $args {
|
||||
if [regexp -- $pat $flag] {
|
||||
set http($flag) $value
|
||||
} else {
|
||||
return -code error "Unknown option $flag, must be: $usage"
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc httpFinish { token {errormsg ""} } {
|
||||
upvar #0 $token state
|
||||
global errorInfo errorCode
|
||||
if {[string length $errormsg] != 0} {
|
||||
set state(error) [list $errormsg $errorInfo $errorCode]
|
||||
set state(status) error
|
||||
}
|
||||
catch {close $state(sock)}
|
||||
catch {after cancel $state(after)}
|
||||
if {[info exists state(-command)]} {
|
||||
if {[catch {eval $state(-command) {$token}} err]} {
|
||||
if {[string length $errormsg] == 0} {
|
||||
set state(error) [list $err $errorInfo $errorCode]
|
||||
set state(status) error
|
||||
}
|
||||
}
|
||||
unset state(-command)
|
||||
}
|
||||
}
|
||||
proc http_reset { token {why reset} } {
|
||||
upvar #0 $token state
|
||||
set state(status) $why
|
||||
catch {fileevent $state(sock) readable {}}
|
||||
httpFinish $token
|
||||
if {[info exists state(error)]} {
|
||||
set errorlist $state(error)
|
||||
unset state(error)
|
||||
eval error $errorlist
|
||||
}
|
||||
}
|
||||
proc http_get { url args } {
|
||||
global http
|
||||
if ![info exists http(uid)] {
|
||||
set http(uid) 0
|
||||
}
|
||||
set token http#[incr http(uid)]
|
||||
upvar #0 $token state
|
||||
http_reset $token
|
||||
array set state {
|
||||
-blocksize 8192
|
||||
-validate 0
|
||||
-headers {}
|
||||
-timeout 0
|
||||
state header
|
||||
meta {}
|
||||
currentsize 0
|
||||
totalsize 0
|
||||
type text/html
|
||||
body {}
|
||||
status ""
|
||||
}
|
||||
set options {-blocksize -channel -command -handler -headers \
|
||||
-progress -query -validate -timeout}
|
||||
set usage [join $options ", "]
|
||||
regsub -all -- - $options {} options
|
||||
set pat ^-([join $options |])$
|
||||
foreach {flag value} $args {
|
||||
if [regexp $pat $flag] {
|
||||
# Validate numbers
|
||||
if {[info exists state($flag)] && \
|
||||
[regexp {^[0-9]+$} $state($flag)] && \
|
||||
![regexp {^[0-9]+$} $value]} {
|
||||
return -code error "Bad value for $flag ($value), must be integer"
|
||||
}
|
||||
set state($flag) $value
|
||||
} else {
|
||||
return -code error "Unknown option $flag, can be: $usage"
|
||||
}
|
||||
}
|
||||
if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)} $url \
|
||||
x proto host y port srvurl]} {
|
||||
error "Unsupported URL: $url"
|
||||
}
|
||||
if {[string length $port] == 0} {
|
||||
set port 80
|
||||
}
|
||||
if {[string length $proto] == 0} {
|
||||
set url http://$url
|
||||
}
|
||||
set state(url) $url
|
||||
if {![catch {$http(-proxyfilter) $host} proxy]} {
|
||||
set phost [lindex $proxy 0]
|
||||
set pport [lindex $proxy 1]
|
||||
}
|
||||
if {$state(-timeout) > 0} {
|
||||
set state(after) [after $state(-timeout) [list http_reset $token timeout]]
|
||||
}
|
||||
if {[info exists phost] && [string length $phost]} {
|
||||
set srvurl $url
|
||||
set s [socket $phost $pport]
|
||||
} else {
|
||||
set s [socket $host $port]
|
||||
}
|
||||
set state(sock) $s
|
||||
|
||||
# Send data in cr-lf format, but accept any line terminators
|
||||
|
||||
fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
|
||||
|
||||
# The following is disallowed in safe interpreters, but the socket
|
||||
# is already in non-blocking mode in that case.
|
||||
|
||||
catch {fconfigure $s -blocking off}
|
||||
set len 0
|
||||
set how GET
|
||||
if {[info exists state(-query)]} {
|
||||
set len [string length $state(-query)]
|
||||
if {$len > 0} {
|
||||
set how POST
|
||||
}
|
||||
} elseif {$state(-validate)} {
|
||||
set how HEAD
|
||||
}
|
||||
puts $s "$how $srvurl HTTP/1.0"
|
||||
puts $s "Accept: $http(-accept)"
|
||||
puts $s "Host: $host"
|
||||
puts $s "User-Agent: $http(-useragent)"
|
||||
foreach {key value} $state(-headers) {
|
||||
regsub -all \[\n\r\] $value {} value
|
||||
set key [string trim $key]
|
||||
if {[string length $key]} {
|
||||
puts $s "$key: $value"
|
||||
}
|
||||
}
|
||||
if {$len > 0} {
|
||||
puts $s "Content-Length: $len"
|
||||
puts $s "Content-Type: application/x-www-form-urlencoded"
|
||||
puts $s ""
|
||||
fconfigure $s -translation {auto binary}
|
||||
puts $s $state(-query)
|
||||
} else {
|
||||
puts $s ""
|
||||
}
|
||||
flush $s
|
||||
fileevent $s readable [list httpEvent $token]
|
||||
if {! [info exists state(-command)]} {
|
||||
http_wait $token
|
||||
}
|
||||
return $token
|
||||
}
|
||||
proc http_data {token} {
|
||||
upvar #0 $token state
|
||||
return $state(body)
|
||||
}
|
||||
proc http_status {token} {
|
||||
upvar #0 $token state
|
||||
return $state(status)
|
||||
}
|
||||
proc http_code {token} {
|
||||
upvar #0 $token state
|
||||
return $state(http)
|
||||
}
|
||||
proc http_size {token} {
|
||||
upvar #0 $token state
|
||||
return $state(currentsize)
|
||||
}
|
||||
|
||||
proc httpEvent {token} {
|
||||
upvar #0 $token state
|
||||
set s $state(sock)
|
||||
|
||||
if [eof $s] then {
|
||||
httpEof $token
|
||||
return
|
||||
}
|
||||
if {$state(state) == "header"} {
|
||||
set n [gets $s line]
|
||||
if {$n == 0} {
|
||||
set state(state) body
|
||||
if ![regexp -nocase ^text $state(type)] {
|
||||
# Turn off conversions for non-text data
|
||||
fconfigure $s -translation binary
|
||||
}
|
||||
if {[info exists state(-channel)] &&
|
||||
![info exists state(-handler)]} {
|
||||
# Initiate a sequence of background fcopies
|
||||
fileevent $s readable {}
|
||||
httpCopyStart $s $token
|
||||
}
|
||||
} elseif {$n > 0} {
|
||||
if [regexp -nocase {^content-type:(.+)$} $line x type] {
|
||||
set state(type) [string trim $type]
|
||||
}
|
||||
if [regexp -nocase {^content-length:(.+)$} $line x length] {
|
||||
set state(totalsize) [string trim $length]
|
||||
}
|
||||
if [regexp -nocase {^([^:]+):(.+)$} $line x key value] {
|
||||
lappend state(meta) $key $value
|
||||
} elseif {[regexp ^HTTP $line]} {
|
||||
set state(http) $line
|
||||
}
|
||||
}
|
||||
} else {
|
||||
if [catch {
|
||||
if {[info exists state(-handler)]} {
|
||||
set n [eval $state(-handler) {$s $token}]
|
||||
} else {
|
||||
set block [read $s $state(-blocksize)]
|
||||
set n [string length $block]
|
||||
if {$n >= 0} {
|
||||
append state(body) $block
|
||||
}
|
||||
}
|
||||
if {$n >= 0} {
|
||||
incr state(currentsize) $n
|
||||
}
|
||||
} err] {
|
||||
httpFinish $token $err
|
||||
} else {
|
||||
if [info exists state(-progress)] {
|
||||
eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
proc httpCopyStart {s token} {
|
||||
upvar #0 $token state
|
||||
if [catch {
|
||||
fcopy $s $state(-channel) -size $state(-blocksize) -command \
|
||||
[list httpCopyDone $token]
|
||||
} err] {
|
||||
httpFinish $token $err
|
||||
}
|
||||
}
|
||||
proc httpCopyDone {token count} {
|
||||
upvar #0 $token state
|
||||
set s $state(sock)
|
||||
incr state(currentsize) $count
|
||||
if [info exists state(-progress)] {
|
||||
eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
|
||||
}
|
||||
if [eof $s] {
|
||||
httpEof $token
|
||||
} else {
|
||||
httpCopyStart $s $token
|
||||
}
|
||||
}
|
||||
proc httpEof {token} {
|
||||
upvar #0 $token state
|
||||
if {$state(state) == "header"} {
|
||||
# Premature eof
|
||||
set state(status) eof
|
||||
} else {
|
||||
set state(status) ok
|
||||
}
|
||||
set state(state) eof
|
||||
httpFinish $token
|
||||
}
|
||||
proc http_wait {token} {
|
||||
upvar #0 $token state
|
||||
if {![info exists state(status)] || [string length $state(status)] == 0} {
|
||||
vwait $token\(status)
|
||||
}
|
||||
if {[info exists state(error)]} {
|
||||
set errorlist $state(error)
|
||||
unset state(error)
|
||||
eval error $errorlist
|
||||
}
|
||||
return $state(status)
|
||||
}
|
||||
|
||||
# Call http_formatQuery with an even number of arguments, where the first is
|
||||
# a name, the second is a value, the third is another name, and so on.
|
||||
|
||||
proc http_formatQuery {args} {
|
||||
set result ""
|
||||
set sep ""
|
||||
foreach i $args {
|
||||
append result $sep [httpMapReply $i]
|
||||
if {$sep != "="} {
|
||||
set sep =
|
||||
} else {
|
||||
set sep &
|
||||
}
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
# do x-www-urlencoded character mapping
|
||||
# The spec says: "non-alphanumeric characters are replaced by '%HH'"
|
||||
# 1 leave alphanumerics characters alone
|
||||
# 2 Convert every other character to an array lookup
|
||||
# 3 Escape constructs that are "special" to the tcl parser
|
||||
# 4 "subst" the result, doing all the array substitutions
|
||||
|
||||
proc httpMapReply {string} {
|
||||
global httpFormMap
|
||||
set alphanumeric a-zA-Z0-9
|
||||
if ![info exists httpFormMap] {
|
||||
|
||||
for {set i 1} {$i <= 256} {incr i} {
|
||||
set c [format %c $i]
|
||||
if {![string match \[$alphanumeric\] $c]} {
|
||||
set httpFormMap($c) %[format %.2x $i]
|
||||
}
|
||||
}
|
||||
# These are handled specially
|
||||
array set httpFormMap {
|
||||
" " + \n %0d%0a
|
||||
}
|
||||
}
|
||||
regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string
|
||||
regsub -all \n $string {\\n} string
|
||||
regsub -all \t $string {\\t} string
|
||||
regsub -all {[][{})\\]\)} $string {\\&} string
|
||||
return [subst $string]
|
||||
}
|
||||
|
||||
# Default proxy filter.
|
||||
proc httpProxyRequired {host} {
|
||||
global http
|
||||
if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
|
||||
if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} {
|
||||
set http(-proxyport) 8080
|
||||
}
|
||||
return [list $http(-proxyhost) $http(-proxyport)]
|
||||
} else {
|
||||
return {}
|
||||
}
|
||||
}
|
||||
|
||||
BIN
tcl-dp/tekilib/logo.gif
Normal file
BIN
tcl-dp/tekilib/logo.gif
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 2.5 KiB |
17
tcl-dp/tekilib/pkgIndex.tcl
Normal file
17
tcl-dp/tekilib/pkgIndex.tcl
Normal file
@@ -0,0 +1,17 @@
|
||||
# Tcl package index file, version 1.0
|
||||
# This file is generated by the "pkg_mkIndex" command
|
||||
# and sourced either when an application starts up or
|
||||
# by a "package unknown" script. It invokes the
|
||||
# "package ifneeded" command to set up package-related
|
||||
# information so that packages will be loaded automatically
|
||||
# in response to "package require" commands. When this
|
||||
# script is sourced, the variable $dir must contain the
|
||||
# full path name of this file's directory.
|
||||
|
||||
package ifneeded Debug 1.0 [list tclPkgSetup $dir Debug 1.0 {{debug.tcl source {Debug_Enter Debug_FatalError Debug_Leave Debug_Print}}}]
|
||||
package ifneeded Progress-Tcl 1.0 [list tclPkgSetup $dir Progress-Tcl 1.0 {{progress-tcl.tcl source {Progress_StepEnd Progress_StepInit Progress_StepPrint}}}]
|
||||
package ifneeded Progress-Tk 1.0 [list tclPkgSetup $dir Progress-Tk 1.0 {{progress-tk.tcl source {ProgressCenterWindow Progress_StepEnd Progress_StepInit Progress_StepPrint}}}]
|
||||
package ifneeded Undo 1.0 [list tclPkgSetup $dir Undo 1.0 {{undo.tcl source {Undo_Add Undo_All Undo_Clear}}}]
|
||||
package ifneeded Wise 1.0 [list tclPkgSetup $dir Wise 1.0 {{wise.tcl source {WiseCreateLogo WiseMakeWizard Wise_CenterWindow Wise_Checklist Wise_GetDirName Wise_Message Wise_Radiolist}}}]
|
||||
# package ifneeded http 1.0 [list tclPkgSetup $dir http 1.0 {{http.tcl source {httpCopyDone httpCopyStart httpEof httpEvent httpFinish httpMapReply httpProxyRequired http_code http_config http_data http_formatQuery http_get http_reset http_size http_status http_wait}}}]
|
||||
|
||||
27
tcl-dp/tekilib/progress-tcl.tcl
Normal file
27
tcl-dp/tekilib/progress-tcl.tcl
Normal file
@@ -0,0 +1,27 @@
|
||||
package provide Progress-Tcl 1.0
|
||||
|
||||
# This set of routines is used to give feedback to the user that
|
||||
# a series of steps is completing.
|
||||
#
|
||||
# Progress_StepInit is called to start the process. You pass it a header
|
||||
# message and a list of steps (each a message)
|
||||
# Progress_StepPrint is called when a step is completed.
|
||||
# Progress_StepEnd is to terminate the process
|
||||
|
||||
proc Progress_StepInit {msg steps} {
|
||||
global ProgressInfo
|
||||
puts stderr $msg
|
||||
set ProgressInfo(steps) $steps
|
||||
}
|
||||
|
||||
proc Progress_StepPrint {} {
|
||||
global ProgressInfo
|
||||
puts stderr " [lindex $ProgressInfo(steps) 0]"
|
||||
set ProgressInfo(steps) [lrange $ProgressInfo(steps) 1 end]
|
||||
}
|
||||
|
||||
proc Progress_StepEnd {} {
|
||||
global ProgressInfo
|
||||
catch {unset ProgressInfo(steps)}
|
||||
}
|
||||
|
||||
76
tcl-dp/tekilib/progress-tk.tcl
Normal file
76
tcl-dp/tekilib/progress-tk.tcl
Normal file
@@ -0,0 +1,76 @@
|
||||
package provide Progress-Tk 1.0
|
||||
|
||||
# This set of routines is used to give feedback to the user that
|
||||
# a series of steps is completing.
|
||||
#
|
||||
# Progress_StepInit is called to start the process. You pass it a header
|
||||
# message and a list of steps (each a message)
|
||||
# Progress_StepPrint is called when a step is completed.
|
||||
# Progress_StepEnd is to terminate the process
|
||||
|
||||
# Define some fonts
|
||||
|
||||
set majorversion [lindex [split $tk_version .] 0]
|
||||
if {$majorversion >= 8} {
|
||||
set ProgressInfo(font) [font create -family Times -weight bold -size 18]
|
||||
} else {
|
||||
set ProgressInfo(font) *-Times-Bold-R-Normal--*-240-*-*-*-*-*-*
|
||||
}
|
||||
unset majorversion
|
||||
|
||||
|
||||
# Utility to center a window on the screen.
|
||||
|
||||
proc ProgressCenterWindow {w} {
|
||||
update idletasks
|
||||
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
|
||||
- [winfo vrootx [winfo parent $w]]]
|
||||
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
|
||||
- [winfo vrooty [winfo parent $w]]]
|
||||
wm geom $w +$x+$y
|
||||
wm deiconify $w
|
||||
wm transient $w .
|
||||
}
|
||||
|
||||
proc Progress_StepInit {msg items} {
|
||||
global ProgressInfo
|
||||
set ProgressInfo(progress) 0
|
||||
if {[info commands .progress] == ""} {
|
||||
toplevel .progress
|
||||
label .progress.title -text $msg -font $ProgressInfo(font)
|
||||
grid .progress.title -column 0 -row 0 -sticky new
|
||||
}
|
||||
wm title .progress $msg
|
||||
.progress.title configure -text $msg
|
||||
set i 0
|
||||
foreach item $items {
|
||||
set ProgressInfo(progress,$i) 0
|
||||
set w .progress.item$i
|
||||
checkbutton $w -variable ProgressInfo(progress,$i) -text $item
|
||||
incr i
|
||||
grid $w -row $i -sticky nw
|
||||
}
|
||||
set ProgressInfo(progressItemCount) $i
|
||||
ProgressCenterWindow .progress
|
||||
update
|
||||
}
|
||||
|
||||
proc Progress_StepPrint {} {
|
||||
global ProgressInfo
|
||||
set i $ProgressInfo(progress)
|
||||
set ProgressInfo(progress,$i) 1
|
||||
incr ProgressInfo(progress)
|
||||
update
|
||||
}
|
||||
|
||||
proc Progress_StepEnd {} {
|
||||
global ProgressInfo
|
||||
wm withdraw .progress
|
||||
for {set i 0} {$i < $ProgressInfo(progressItemCount) } {incr i} {
|
||||
destroy .progress.item$i
|
||||
}
|
||||
catch {unset ProgressInfo(progress)}
|
||||
catch {unset ProgressInfo(progressItemCount)}
|
||||
update
|
||||
}
|
||||
|
||||
68
tcl-dp/tekilib/undo.tcl
Normal file
68
tcl-dp/tekilib/undo.tcl
Normal file
@@ -0,0 +1,68 @@
|
||||
#!/usr/local/bin/wish -f
|
||||
# undo.tcl
|
||||
|
||||
package provide Undo 1.0
|
||||
|
||||
#
|
||||
# Undo commands
|
||||
#
|
||||
# This section contains the commands to support a general "Undo"
|
||||
# facility. The basic structure is a stack of commands. Each element
|
||||
# of the stack contains a command that can Undo a previous action.
|
||||
# For example, to "undo" a file copy, you would delete the file.
|
||||
# The "file delete" command would then go on the stack.
|
||||
#
|
||||
# You can have several undo stack, each with an associated tag
|
||||
#
|
||||
# Three functions are provided:
|
||||
# o Undo_Add -- adds a command to the stack
|
||||
# o Undo_All -- execute the stack
|
||||
# o Undo_Clear -- clear the stack
|
||||
#
|
||||
|
||||
#
|
||||
# Undo_Add --
|
||||
# Adds to the Undo stack
|
||||
#
|
||||
# Arguments:
|
||||
# cmd
|
||||
# The command to execute to undo the current command.
|
||||
#
|
||||
proc Undo_Add {{tag all} cmd} {
|
||||
global UndoInfo
|
||||
if ![info exists UndoInfo($tag,UndoStack)] {
|
||||
set UndoInfo($tag,UndoStack) {}
|
||||
}
|
||||
set UndoInfo($tag,UndoStack) [concat [list $cmd] $UndoInfo($tag,UndoStack)]
|
||||
}
|
||||
|
||||
#
|
||||
# Undo_All --
|
||||
# Execute the Undo stack
|
||||
#
|
||||
# Arguments:
|
||||
# none
|
||||
#
|
||||
proc Undo_All {{tag all}} {
|
||||
global UndoInfo
|
||||
if ![info exists UndoInfo($tag,UndoStack)] {
|
||||
error "Invalid undo stack $tag"
|
||||
}
|
||||
foreach cmd $UndoInfo($tag,UndoStack) {
|
||||
catch {eval $cmd}
|
||||
}
|
||||
set UndoInfo(UndoStack) {}
|
||||
}
|
||||
|
||||
#
|
||||
# Undo_Clear --
|
||||
# Clear the Undo stack
|
||||
#
|
||||
# Arguments:
|
||||
# none
|
||||
#
|
||||
proc Undo_Clear {{tag all}} {
|
||||
global UndoInfo
|
||||
unset UndoInfo($tag,UndoStack)
|
||||
}
|
||||
|
||||
288
tcl-dp/tekilib/wise.tcl
Normal file
288
tcl-dp/tekilib/wise.tcl
Normal file
@@ -0,0 +1,288 @@
|
||||
package provide Wise 1.0
|
||||
|
||||
#
|
||||
# WISE user interface support
|
||||
#
|
||||
# The following procedures support the WISE style user interface.
|
||||
# There are 4 exported functions:
|
||||
#
|
||||
# Wise_Checklist and Wise_RadioList display a list of check buttons
|
||||
# (or radio buttons) for the user to select. Both these routines
|
||||
# display next/back/finish/cancel buttons.
|
||||
# Wise_Message displays a long message, such as a copyright notice,
|
||||
# along with a set of buttons
|
||||
# Wise_GetDirName gets a directory name from the user
|
||||
|
||||
|
||||
|
||||
# Center the window on the screen.
|
||||
|
||||
proc Wise_CenterWindow {w} {
|
||||
update idletasks
|
||||
set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
|
||||
- [winfo vrootx [winfo parent $w]]]
|
||||
set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
|
||||
- [winfo vrooty [winfo parent $w]]]
|
||||
wm geom $w +$x+$y
|
||||
wm deiconify $w
|
||||
wm transient $w .
|
||||
raise $w
|
||||
}
|
||||
|
||||
# Create the logo image (once)
|
||||
|
||||
proc WiseCreateLogo {} {
|
||||
global TekiInfo WiseInfo
|
||||
if {[info commands logoImage] == ""} {
|
||||
set WiseInfo(photo) [image create photo logoImage]
|
||||
logoImage read [file join $TekiInfo(library) logo.gif]
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Create and display the WISE wizard window, centered on the screen.
|
||||
# Cache the window for better performance
|
||||
|
||||
proc WiseMakeWizard {} {
|
||||
global WiseInfo TekiInfo
|
||||
if {[info commands .wise] == ""} {
|
||||
toplevel .wise
|
||||
WiseCreateLogo
|
||||
label .wise.logo -image logoImage
|
||||
grid .wise.logo -row 0 -column 0 -rowspan 2 -sticky n
|
||||
|
||||
label .wise.title -font $TekiInfo(varfont)
|
||||
grid .wise.title -column 1 -row 0 -columnspan 5 -sticky ew
|
||||
grid rowconfigure .wise 1 -weight 1
|
||||
|
||||
listbox .wise.list
|
||||
grid .wise.list -row 1 -column 1 -columnspan 5 -sticky nesw
|
||||
button .wise.back -text {< Back} -command "set WiseInfo(done) back"
|
||||
button .wise.next -text {Next >} -command "set WiseInfo(done) next"
|
||||
button .wise.finish -text {Finish} -command "set WiseInfo(done) finish"
|
||||
button .wise.cancel -text {Cancel} -command "set WiseInfo(done) cancel"
|
||||
grid .wise.back -row 2 -column 2 -sticky nsew
|
||||
grid .wise.next -row 2 -column 3 -sticky nsew
|
||||
grid .wise.finish -row 2 -column 4 -sticky nsew
|
||||
grid .wise.cancel -row 2 -column 5 -padx 10
|
||||
Wise_CenterWindow .wise
|
||||
} else {
|
||||
wm deiconify .wise
|
||||
}
|
||||
}
|
||||
|
||||
# Display a checklist for the user in the WISE window.
|
||||
#
|
||||
# title is the window title
|
||||
# items is list {label value on?}
|
||||
# One checkbox is created for each item, with the label as specified
|
||||
#
|
||||
# The return value depends on which button (next, back, finish, or cancel)
|
||||
# the user presses. It is one of the following:
|
||||
# back
|
||||
# cancel
|
||||
# {next list-of-selected-items}
|
||||
# {finish list-of-selected-items}
|
||||
# where list-of-selected-items is the value part from the "items" list
|
||||
|
||||
proc Wise_Checklist {title items} {
|
||||
global WiseInfo
|
||||
|
||||
WiseMakeWizard
|
||||
wm title .wise $title
|
||||
.wise.title configure -text $title
|
||||
|
||||
set count 0
|
||||
foreach i $items {
|
||||
set name [lindex $i 0]
|
||||
set on [lindex $i 2]
|
||||
set w .wise.list.b$count
|
||||
set WiseInfo($count) $on
|
||||
checkbutton $w -variable WiseInfo($count) -text $name -anchor w
|
||||
pack $w -side top -fill x
|
||||
# grid $w -row $count -sticky nsw
|
||||
incr count
|
||||
}
|
||||
|
||||
set WiseInfo(done) 0
|
||||
vwait WiseInfo(done)
|
||||
set rv $WiseInfo(done)
|
||||
|
||||
if {[lsearch "next finish" $rv] != -1} {
|
||||
set count 0
|
||||
foreach i $items {
|
||||
set value [lindex $i 1]
|
||||
if $WiseInfo($count) {
|
||||
lappend rv $value
|
||||
}
|
||||
incr count
|
||||
}
|
||||
}
|
||||
|
||||
wm withdraw .wise
|
||||
set count 0
|
||||
foreach i $items {
|
||||
destroy .wise.list.b$count
|
||||
incr count
|
||||
}
|
||||
unset WiseInfo
|
||||
return $rv
|
||||
}
|
||||
|
||||
# Display a radio-button list for the user in the WISE window.
|
||||
#
|
||||
# title is the window title
|
||||
# items is list {label value on?}
|
||||
# One checkbox is created for each item, with the label as specified
|
||||
#
|
||||
# The return value depends on which button (next, back, finish, or cancel)
|
||||
# the user presses. It is one of the following:
|
||||
# back
|
||||
# cancel
|
||||
# {next selected-item}
|
||||
# {finish selected-item}
|
||||
# where selected-item is the value part (from the "items" list) of the
|
||||
# radio-button the user selected
|
||||
|
||||
proc Wise_Radiolist {title items {backDisabled 0}} {
|
||||
global WiseInfo
|
||||
|
||||
WiseMakeWizard
|
||||
wm title .wise $title
|
||||
.wise.title configure -text $title
|
||||
|
||||
set count 0
|
||||
set WiseInfo(radio) {}
|
||||
foreach i $items {
|
||||
set name [lindex $i 0]
|
||||
set value [lindex $i 1]
|
||||
set on [lindex $i 2]
|
||||
set w .wise.list.b$count
|
||||
if {$on} {
|
||||
set WiseInfo(radio) $value
|
||||
}
|
||||
radiobutton $w -variable WiseInfo(radio) -text $name -anchor w -value $value
|
||||
pack $w -side top -fill x
|
||||
incr count
|
||||
}
|
||||
|
||||
set WiseInfo(done) 0
|
||||
if {$backDisabled} {
|
||||
.wise.back configure -state disabled
|
||||
}
|
||||
vwait WiseInfo(done)
|
||||
set rv $WiseInfo(done)
|
||||
|
||||
wm withdraw .wise
|
||||
.wise.back configure -state normal
|
||||
|
||||
set count 0
|
||||
foreach i $items {
|
||||
destroy .wise.list.b$count
|
||||
incr count
|
||||
}
|
||||
|
||||
if {[lsearch "next finish" $rv] != -1} {
|
||||
set rv [concat $rv $WiseInfo(radio)]
|
||||
}
|
||||
unset WiseInfo
|
||||
return $rv
|
||||
}
|
||||
|
||||
#
|
||||
# Display a long message, such as a copyright notice, to the user
|
||||
# in a textbox.
|
||||
#
|
||||
# title is the window title
|
||||
# msg is the text of the message
|
||||
# items is a list of labels. One button is created for each label.
|
||||
#
|
||||
# The return value is the index of the button pressed
|
||||
|
||||
proc Wise_Message {title msg items {dispLogo 1}} {
|
||||
global WiseInfo
|
||||
|
||||
if {[info commands .wisemsg] == ""} {
|
||||
toplevel .wisemsg
|
||||
wm title .wisemsg $title
|
||||
WiseCreateLogo
|
||||
label .wisemsg.logo -image logoImage
|
||||
scrollbar .wisemsg.scroll -command ".wisemsg.text yview"
|
||||
text .wisemsg.text -relief sunken -bd 2 -yscrollcommand ".wisemsg.scroll set" -setgrid 1 -height 10
|
||||
Wise_CenterWindow .wisemsg
|
||||
}
|
||||
|
||||
set WiseInfo(done) -1
|
||||
set count 1
|
||||
foreach i $items {
|
||||
button .wisemsg.b$count -text $i -command "set WiseInfo(done) $count"
|
||||
grid .wisemsg.b$count -row 2 -column $count
|
||||
incr count
|
||||
}
|
||||
|
||||
.wisemsg.text delete 1.0 end
|
||||
.wisemsg.text insert end $msg
|
||||
grid .wisemsg.text -column 1 -row 0 -columnspan [expr $count-1] -sticky nsew
|
||||
grid .wisemsg.scroll -column $count -row 0 -sticky ns
|
||||
grid rowconfigure .wisemsg 0 -weight 1
|
||||
|
||||
if {$dispLogo} {
|
||||
grid .wisemsg.logo -row 0 -column 0 -sticky n
|
||||
} else {
|
||||
grid forget .wisemsg.logo
|
||||
}
|
||||
|
||||
Wise_CenterWindow .wisemsg
|
||||
vwait WiseInfo(done)
|
||||
set rv [expr $WiseInfo(done)-1]
|
||||
wm withdraw .wisemsg
|
||||
|
||||
set count 1
|
||||
foreach i $items {
|
||||
destroy .wisemsg.b$count
|
||||
incr count
|
||||
}
|
||||
unset WiseInfo
|
||||
return $rv
|
||||
}
|
||||
|
||||
# Ask the user to enter a directory name. Return either the
|
||||
# directory name, or the empty string if they hit "cancel". Right
|
||||
# now, the "Browse..." option is funky, since it requires the user
|
||||
# to select a file in the directory where they want to install...
|
||||
#
|
||||
# XXX: need to fix this...
|
||||
|
||||
proc Wise_GetDirName {default} {
|
||||
global WiseInfo
|
||||
catch {destroy .d}
|
||||
toplevel .d
|
||||
wm title .d "Select directory"
|
||||
|
||||
set WiseInfo(done) 0
|
||||
set WiseInfo(value) $default
|
||||
label .d.label -text "Enter directory name"
|
||||
entry .d.entry -textvariable WiseInfo(value)
|
||||
button .d.ok -text OK -command "set WiseInfo(done) ok"
|
||||
button .d.browse -text Browse... -command {
|
||||
set WiseInfo(value) [file dirname [tk_getOpenFile -title "Select file in directory"]]
|
||||
}
|
||||
button .d.cancel -text Cancel -command "set WiseInfo(done) cancel"
|
||||
grid .d.label -row 0 -column 0 -sticky e
|
||||
grid .d.entry -row 0 -column 1 -columnspan 2 -sticky ew
|
||||
grid .d.ok -row 1 -column 0
|
||||
grid .d.browse -row 1 -column 1
|
||||
grid .d.cancel -row 1 -column 2
|
||||
grid columnconfigure .d 1 -weight 1
|
||||
Wise_CenterWindow .d
|
||||
vwait WiseInfo(done)
|
||||
if {$WiseInfo(done) == "ok"} {
|
||||
set rv $WiseInfo(value)
|
||||
} else {
|
||||
set rv {}
|
||||
}
|
||||
destroy .d
|
||||
unset WiseInfo
|
||||
return $rv
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user