summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/history.tcl18
-rw-r--r--library/init.tcl91
-rw-r--r--library/parray.tcl4
-rw-r--r--library/safe.tcl8
-rw-r--r--library/word.tcl24
5 files changed, 90 insertions, 55 deletions
diff --git a/library/history.tcl b/library/history.tcl
index a6beb43..f1516f3 100644
--- a/library/history.tcl
+++ b/library/history.tcl
@@ -19,7 +19,7 @@
namespace eval tcl {
variable history
- if ![info exists history] {
+ if {![info exists history]} {
array set history {
nextid 0
keep 20
@@ -118,7 +118,7 @@ proc history {args} {
return [tcl::HistKeep]
} else {
set limit [lindex $args 1]
- if {[catch {expr $limit}] || ($limit < 0)} {
+ if {[catch {expr {~$limit}}] || ($limit < 0)} {
return -code error "illegal keep count \"$limit\""
}
return [tcl::HistKeep $limit]
@@ -132,7 +132,7 @@ proc history {args} {
if {![string match $key* nextid]} {
return -code error "bad option \"$key\": must be $options"
}
- return [expr $tcl::history(nextid) + 1]
+ return [expr {$tcl::history(nextid) + 1}]
}
r* { # history redo
@@ -196,7 +196,7 @@ proc history {args} {
return $history(keep)
} else {
set oldold $history(oldest)
- set history(oldest) [expr $history(nextid) - $limit]
+ set history(oldest) [expr {$history(nextid) - $limit}]
for {} {$oldold <= $history(oldest)} {incr oldold} {
if {[info exists history($oldold)]} {unset history($oldold)}
}
@@ -241,13 +241,13 @@ proc history {args} {
proc tcl::HistInfo {{num {}}} {
variable history
if {$num == {}} {
- set num [expr $history(keep) + 1]
+ set num [expr {$history(keep) + 1}]
}
set result {}
set newline ""
- for {set i [expr $history(nextid) - $num + 1]} \
+ for {set i [expr {$history(nextid) - $num + 1}]} \
{$i <= $history(nextid)} {incr i} {
- if ![info exists history($i)] {
+ if {![info exists history($i)]} {
continue
}
set cmd [string trimright $history($i) \ \n]
@@ -304,7 +304,7 @@ proc history {args} {
proc tcl::HistIndex {event} {
variable history
- if {[catch {expr $event}]} {
+ if {[catch {expr {~$event}}]} {
for {set i $history(nextid)} {[info exists history($i)]} {incr i -1} {
if {[string match $event* $history($i)]} {
return $i;
@@ -315,7 +315,7 @@ proc history {args} {
}
return -code error "no event matches \"$event\""
} elseif {$event <= 0} {
- set i [expr $history(nextid) + $event]
+ set i [expr {$history(nextid) + $event}]
} else {
set i $event
}
diff --git a/library/init.tcl b/library/init.tcl
index ebf1913..76cec74 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# SCCS: @(#) init.tcl 1.95 97/11/19 17:16:34
+# SCCS: %Z% $Id: init.tcl,v 1.2 1998/06/27 18:11:24 welch Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -21,7 +21,7 @@ package require -exact Tcl 8.0
# (auto_path could be already set, in safe interps for instance)
if {![info exists auto_path]} {
- if [catch {set auto_path $env(TCLLIBPATH)}] {
+ if {[catch {set auto_path $env(TCLLIBPATH)}]} {
set auto_path ""
}
}
@@ -37,6 +37,41 @@ catch {
unset __dir
}
+# Windows specific end of initialization
+
+if {(![interp issafe]) && ($tcl_platform(platform) == "windows")} {
+ namespace eval tcl {
+ proc envTraceProc {lo n1 n2 op} {
+ set x $::env($n2)
+ set ::env($lo) $x
+ set ::env([string toupper $lo]) $x
+ }
+ }
+ foreach p [array names env] {
+ set u [string toupper $p]
+ if {$u != $p} {
+ switch -- $u {
+ COMSPEC -
+ PATH {
+ if {![info exists env($u)]} {
+ set env($u) $env($p)
+ }
+ trace variable env($p) w [list tcl::envTraceProc $p]
+ trace variable env($u) w [list tcl::envTraceProc $p]
+ }
+ }
+ }
+ }
+ if {![info exists env(COMSPEC)]} {
+ if {$tcl_platform(os) == {Windows NT}} {
+ set env(COMSPEC) cmd.exe
+ } else {
+ set env(COMSPEC) command.com
+ }
+ }
+}
+
+
# Setup the unknown package handler
package unknown tclPkgUnknown
@@ -98,11 +133,11 @@ if {[info commands tclLog] == ""} {
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
set name [lindex $args 0]
- if ![info exists auto_noload] {
+ if {![info exists auto_noload]} {
#
# Make sure we're not trying to load the same proc twice.
#
- if [info exists unknown_pending($name)] {
+ if {[info exists unknown_pending($name)]} {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
set unknown_pending($name) pending;
@@ -112,10 +147,10 @@ if {[info commands tclLog] == ""} {
return -code $ret -errorcode $errorCode \
"error while autoloading \"$name\": $msg"
}
- if ![array size unknown_pending] {
+ if {![array size unknown_pending]} {
unset unknown_pending
}
- if $msg {
+ if {$msg} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set code [catch {uplevel 1 $args} msg]
@@ -126,7 +161,7 @@ if {[info commands tclLog] == ""} {
#
set new [split $errorInfo \n]
- set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
+ set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
return -code error -errorcode $errorCode \
-errorinfo $new $msg
} else {
@@ -137,7 +172,7 @@ if {[info commands tclLog] == ""} {
if {([info level] == 1) && ([info script] == "") \
&& [info exists tcl_interactive] && $tcl_interactive} {
- if ![info exists auto_noexec] {
+ if {![info exists auto_noexec]} {
set new [auto_execok $name]
if {$new != ""} {
set errorCode $savedErrorCode
@@ -159,7 +194,7 @@ if {[info commands tclLog] == ""} {
set newcmd [history event -1]
catch {regsub -all -- $old $newcmd $new newcmd}
}
- if [info exists newcmd] {
+ if {[info exists newcmd]} {
tclLog $newcmd
history change $newcmd 0
return [uplevel $newcmd]
@@ -211,15 +246,15 @@ if {[info commands tclLog] == ""} {
# from older auto_mkindex versions
lappend nameList $cmd
foreach name $nameList {
- if [info exists auto_index($name)] {
+ if {[info exists auto_index($name)]} {
uplevel #0 $auto_index($name)
return [expr {[info commands $name] != ""}]
}
}
- if ![info exists auto_path] {
+ if {![info exists auto_path]} {
return 0
}
- if [info exists auto_oldpath] {
+ if {[info exists auto_oldpath]} {
if {$auto_oldpath == $auto_path} {
return 0
}
@@ -230,12 +265,12 @@ if {[info commands tclLog] == ""} {
# newer format tclIndex files.
set issafe [interp issafe]
- for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
+ for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
set dir [lindex $auto_path $i]
set f ""
if {$issafe} {
catch {source [file join $dir tclIndex]}
- } elseif [catch {set f [open [file join $dir tclIndex]]}] {
+ } elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
continue
} else {
set error [catch {
@@ -261,13 +296,13 @@ if {[info commands tclLog] == ""} {
if {$f != ""} {
close $f
}
- if $error {
+ if {$error} {
error $msg $errorInfo $errorCode
}
}
}
foreach name $nameList {
- if [info exists auto_index($name)] {
+ if {[info exists auto_index($name)]} {
uplevel #0 $auto_index($name)
if {[info commands $name] != ""} {
return 1
@@ -359,7 +394,7 @@ if {[string compare $tcl_platform(platform) windows] == 0} {
proc auto_execok name {
global auto_execs env tcl_platform
- if [info exists auto_execs($name)] {
+ if {[info exists auto_execs($name)]} {
return $auto_execs($name)
}
set auto_execs($name) ""
@@ -425,7 +460,7 @@ proc auto_execok name {
proc auto_execok name {
global auto_execs env
- if [info exists auto_execs($name)] {
+ if {[info exists auto_execs($name)]} {
return $auto_execs($name)
}
set auto_execs($name) ""
@@ -506,7 +541,7 @@ proc auto_mkindex {dir args} {
set error [catch {
set f [open $file]
while {[gets $f line] >= 0} {
- if [regexp {^proc[ ]+([^ ]*)} $line match procName] {
+ if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
append index " \[list source \[file join \$dir [list $file]\]\]\n"
@@ -514,7 +549,7 @@ proc auto_mkindex {dir args} {
}
close $f
} msg]
- if $error {
+ if {$error} {
set code $errorCode
set info $errorInfo
catch {close $f}
@@ -529,7 +564,7 @@ proc auto_mkindex {dir args} {
close $f
cd $oldDir
} msg]
- if $error {
+ if {$error} {
set code $errorCode
set info $errorInfo
catch {close $f}
@@ -589,7 +624,7 @@ proc pkg_mkIndex {dir args} {
}
}
$c eval [list set file $file]
- if [catch {
+ if {[catch {
$c eval {
proc dummy args {}
rename package package-orig
@@ -657,7 +692,7 @@ proc pkg_mkIndex {dir args} {
}
}
}
- } msg] {
+ } msg]} {
tclLog "error while loading or sourcing $file: $msg"
}
foreach pkg [$c eval set pkgs] {
@@ -719,7 +754,7 @@ proc tclPkgSetup {dir pkg version files} {
proc tclMacPkgSearch {dir} {
foreach x [glob -nocomplain [file join $dir *.shlb]] {
- if [file isfile $x] {
+ if {[file isfile $x]} {
set res [resource open $x]
foreach y [resource list TEXT $res] {
if {$y == "pkgIndex"} {source -rsrc pkgIndex}
@@ -745,17 +780,17 @@ proc tclMacPkgSearch {dir} {
proc tclPkgUnknown {name version {exact {}}} {
global auto_path tcl_platform env
- if ![info exists auto_path] {
+ if {![info exists auto_path]} {
return
}
- for {set i [expr [llength $auto_path] - 1]} {$i >= 0} {incr i -1} {
+ for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
# we can't use glob in safe interps, so enclose the following
# in a catch statement
catch {
foreach file [glob -nocomplain [file join [lindex $auto_path $i] \
* pkgIndex.tcl]] {
set dir [file dirname $file]
- if [catch {source $file} msg] {
+ if {[catch {source $file} msg]} {
tclLog "error reading package index file $file: $msg"
}
}
@@ -775,7 +810,7 @@ proc tclPkgUnknown {name version {exact {}}} {
set dir [lindex $auto_path $i]
tclMacPkgSearch $dir
foreach x [glob -nocomplain [file join $dir *]] {
- if [file isdirectory $x] {
+ if {[file isdirectory $x]} {
set dir $x
tclMacPkgSearch $dir
}
diff --git a/library/parray.tcl b/library/parray.tcl
index 430e7ff..d80ad8d 100644
--- a/library/parray.tcl
+++ b/library/parray.tcl
@@ -1,7 +1,7 @@
# parray:
# Print the contents of a global array on stdout.
#
-# SCCS: @(#) parray.tcl 1.9 96/02/16 08:56:44
+# SCCS: %Z% $Id: parray.tcl,v 1.2 1998/06/27 18:11:25 welch Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
@@ -12,7 +12,7 @@
proc parray {a {pattern *}} {
upvar 1 $a array
- if ![array exists array] {
+ if {![array exists array]} {
error "\"$a\" isn't an array"
}
set maxl 0
diff --git a/library/safe.tcl b/library/safe.tcl
index 9b93523..9eb9a3f 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) safe.tcl 1.26 97/08/21 11:57:20
+# SCCS: %Z% $Id: safe.tcl,v 1.2 1998/06/27 18:11:25 welch Exp $
#
# The implementation is based on namespaces. These naming conventions
@@ -417,7 +417,7 @@ proc ::safe::interpAddToAccessPath {slave path} {
Lappend [VirtualPathListName $slave] $token;
Lappend [PathListName $slave] $path;
- Set $nname [expr $n+1];
+ Set $nname [expr {$n+1}];
SyncAccessPath $slave;
@@ -528,7 +528,7 @@ proc ::safe::interpDelete {slave} {
# remove the hook now, otherwise if the hook
# calls us somehow, we'll loop
Unset $hookname;
- if {[catch {eval $hook $slave} err]} {
+ if {[catch {eval $hook [list $slave]} err]} {
Log $slave "Delete hook error ($err)";
}
}
@@ -681,7 +681,7 @@ proc ::safe::setLogCmd {args} {
if {[regexp {(::)|(\.\.)} $path]} {
error "invalid characters in path $path";
}
- set n [expr [Set [PathNumberName $slave]]-1];
+ set n [expr {[Set [PathNumberName $slave]]-1}];
for {} {$n>=0} {incr n -1} {
# fill the token virtual names with their real value
set [PathToken $n] [Set [PathToken $n $slave]];
diff --git a/library/word.tcl b/library/word.tcl
index 64639f2..56fca90 100644
--- a/library/word.tcl
+++ b/library/word.tcl
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# SCCS: @(#) word.tcl 1.2 96/11/20 14:07:22
+# SCCS: %Z% $Id: word.tcl,v 1.2 1998/06/27 18:11:26 welch Exp $
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -42,8 +42,8 @@ if {$tcl_platform(platform) == "windows"} {
proc tcl_wordBreakAfter {str start} {
global tcl_nonwordchars tcl_wordchars
set str [string range $str $start end]
- if [regexp -indices "$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars" $str result] {
- return [expr [lindex $result 1] + $start]
+ if {[regexp -indices "$tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars" $str result]} {
+ return [expr {[lindex $result 1] + $start}]
}
return -1
}
@@ -64,7 +64,7 @@ proc tcl_wordBreakBefore {str start} {
if {[string compare $start end] == 0} {
set start [string length $str]
}
- if [regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result] {
+ if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} {
return [lindex $result 1]
}
return -1
@@ -84,9 +84,9 @@ proc tcl_wordBreakBefore {str start} {
proc tcl_endOfWord {str start} {
global tcl_nonwordchars tcl_wordchars
- if [regexp -indices "$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars" \
- [string range $str $start end] result] {
- return [expr [lindex $result 1] + $start]
+ if {[regexp -indices "$tcl_nonwordchars*$tcl_wordchars+$tcl_nonwordchars" \
+ [string range $str $start end] result]} {
+ return [expr {[lindex $result 1] + $start}]
}
return -1
}
@@ -105,9 +105,9 @@ proc tcl_endOfWord {str start} {
proc tcl_startOfNextWord {str start} {
global tcl_nonwordchars tcl_wordchars
- if [regexp -indices "$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars" \
- [string range $str $start end] result] {
- return [expr [lindex $result 1] + $start]
+ if {[regexp -indices "$tcl_wordchars*$tcl_nonwordchars+$tcl_wordchars" \
+ [string range $str $start end] result]} {
+ return [expr {[lindex $result 1] + $start}]
}
return -1
}
@@ -126,9 +126,9 @@ proc tcl_startOfPreviousWord {str start} {
if {[string compare $start end] == 0} {
set start [string length $str]
}
- if [regexp -indices \
+ if {[regexp -indices \
"$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \
- [string range $str 0 [expr $start - 1]] result word] {
+ [string range $str 0 [expr {$start - 1}]] result word]} {
return [lindex $word 0]
}
return -1
generated by cgit v0.12 at 2024-12-02 14:39:53 (GMT)