summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/auto.tcl12
-rw-r--r--library/http/http.tcl24
-rw-r--r--library/http2.1/http.tcl24
-rw-r--r--library/http2.3/http.tcl24
-rw-r--r--library/init.tcl69
-rw-r--r--library/ldAout.tcl367
-rw-r--r--library/msgcat/msgcat.tcl7
-rw-r--r--library/msgcat1.0/msgcat.tcl7
-rw-r--r--library/package.tcl33
-rw-r--r--library/safe.tcl333
-rw-r--r--library/word.tcl8
11 files changed, 436 insertions, 472 deletions
diff --git a/library/auto.tcl b/library/auto.tcl
index 7e43aaf..2a035fd 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -3,7 +3,7 @@
# utility procs formerly in init.tcl dealing with auto execution
# of commands and can be auto loaded themselves.
#
-# RCS: @(#) $Id: auto.tcl,v 1.2 1999/04/16 00:46:56 stanton Exp $
+# RCS: @(#) $Id: auto.tcl,v 1.3 1999/08/19 02:59:40 hobbs Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
@@ -202,7 +202,7 @@ proc auto_mkindex_old {dir args} {
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
- if {$args == ""} {
+ if {[string equal $args ""]} {
set args *.tcl
}
foreach file [eval glob $args] {
@@ -398,7 +398,7 @@ proc auto_mkindex_parser::commandInit {name arglist body} {
set ns [namespace qualifiers $name]
set tail [namespace tail $name]
- if {$ns == ""} {
+ if {[string equal $ns ""]} {
set fakeName "[namespace current]::_%@fake_$tail"
} else {
set fakeName "_%@fake_$name"
@@ -462,7 +462,7 @@ proc auto_mkindex_parser::fullname {name} {
}
}
- if {[namespace qualifiers $name] == ""} {
+ if {[string equal [namespace qualifiers $name] ""]} {
return [namespace tail $name]
} elseif {![string match ::* $name]} {
return "::$name"
@@ -494,7 +494,7 @@ auto_mkindex_parser::command proc {name args} {
auto_mkindex_parser::hook {
if {![catch {package require tbcload}]} {
- if {[info commands tbcload::bcproc] == ""} {
+ if {[llength [info commands tbcload::bcproc]] == 0} {
auto_load tbcload::bcproc
}
load {} tbcload $auto_mkindex_parser::parser
@@ -541,7 +541,7 @@ auto_mkindex_parser::command namespace {op args} {
variable parser
variable imports
foreach pattern $args {
- if {$pattern != "-force"} {
+ if {[string compare $pattern "-force"]} {
lappend imports $pattern
}
}
diff --git a/library/http/http.tcl b/library/http/http.tcl
index f448077..c59f4a5 100644
--- a/library/http/http.tcl
+++ b/library/http/http.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.
#
-# RCS: @(#) $Id: http.tcl,v 1.9 1999/08/05 16:57:48 hobbs Exp $
+# RCS: @(#) $Id: http.tcl,v 1.10 1999/08/19 02:59:45 hobbs Exp $
package provide http 2.1 ;# This uses Tcl namespaces
@@ -179,12 +179,10 @@ proc http::geturl { url args } {
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]} {
+ [string is integer -strict $state($flag)] && \
+ ![string is integer -strict $value]} {
return -code error "Bad value for $flag ($value), must be integer"
}
set state($flag) $value
@@ -192,7 +190,7 @@ proc http::geturl { url args } {
return -code error "Unknown option $flag, can be: $usage"
}
}
- if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
+ if {![regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
x proto host y port srvurl]} {
error "Unsupported URL: $url"
}
@@ -239,7 +237,7 @@ proc http::geturl { url args } {
#fileevent $s writable [list set $token\(status) connect]
fileevent $s writable [list http::Connect $token]
http::wait $token
- if {[string compare $state(status) "timeout"] == 0} {
+ if {[string equal $state(status) "timeout"]} {
return
}
fileevent $s writable {}
@@ -351,7 +349,7 @@ proc http::cleanup {token} {
Eof $token
return
}
- if {$state(state) == "header"} {
+ if {[string equal $state(state) "header"]} {
set n [gets $s line]
if {$n == 0} {
set state(state) body
@@ -423,7 +421,7 @@ proc http::cleanup {token} {
eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
}
# At this point the token may have been reset
- if {([string length $error] != 0)} {
+ if {[string length $error]} {
Finish $token $error
} elseif {[catch {::eof $s} iseof] || $iseof} {
Eof $token
@@ -434,7 +432,7 @@ proc http::cleanup {token} {
proc http::Eof {token} {
variable $token
upvar 0 $token state
- if {$state(state) == "header"} {
+ if {[string equal $state(state) "header"]} {
# Premature eof
set state(status) eof
} else {
@@ -458,9 +456,7 @@ proc http::wait {token} {
upvar 0 $token state
if {![info exists state(status)] || [string length $state(status)] == 0} {
-
# We must wait on the original variable name, not the upvar alias
-
vwait $token\(status)
}
if {[info exists state(error)]} {
@@ -487,8 +483,8 @@ proc http::formatQuery {args} {
set result ""
set sep ""
foreach i $args {
- append result $sep [mapReply $i]
- if {$sep != "="} {
+ append result $sep [mapReply $i]
+ if {[string compare $sep "="]} {
set sep =
} else {
set sep &
diff --git a/library/http2.1/http.tcl b/library/http2.1/http.tcl
index f448077..c59f4a5 100644
--- a/library/http2.1/http.tcl
+++ b/library/http2.1/http.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.
#
-# RCS: @(#) $Id: http.tcl,v 1.9 1999/08/05 16:57:48 hobbs Exp $
+# RCS: @(#) $Id: http.tcl,v 1.10 1999/08/19 02:59:45 hobbs Exp $
package provide http 2.1 ;# This uses Tcl namespaces
@@ -179,12 +179,10 @@ proc http::geturl { url args } {
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]} {
+ [string is integer -strict $state($flag)] && \
+ ![string is integer -strict $value]} {
return -code error "Bad value for $flag ($value), must be integer"
}
set state($flag) $value
@@ -192,7 +190,7 @@ proc http::geturl { url args } {
return -code error "Unknown option $flag, can be: $usage"
}
}
- if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
+ if {![regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
x proto host y port srvurl]} {
error "Unsupported URL: $url"
}
@@ -239,7 +237,7 @@ proc http::geturl { url args } {
#fileevent $s writable [list set $token\(status) connect]
fileevent $s writable [list http::Connect $token]
http::wait $token
- if {[string compare $state(status) "timeout"] == 0} {
+ if {[string equal $state(status) "timeout"]} {
return
}
fileevent $s writable {}
@@ -351,7 +349,7 @@ proc http::cleanup {token} {
Eof $token
return
}
- if {$state(state) == "header"} {
+ if {[string equal $state(state) "header"]} {
set n [gets $s line]
if {$n == 0} {
set state(state) body
@@ -423,7 +421,7 @@ proc http::cleanup {token} {
eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
}
# At this point the token may have been reset
- if {([string length $error] != 0)} {
+ if {[string length $error]} {
Finish $token $error
} elseif {[catch {::eof $s} iseof] || $iseof} {
Eof $token
@@ -434,7 +432,7 @@ proc http::cleanup {token} {
proc http::Eof {token} {
variable $token
upvar 0 $token state
- if {$state(state) == "header"} {
+ if {[string equal $state(state) "header"]} {
# Premature eof
set state(status) eof
} else {
@@ -458,9 +456,7 @@ proc http::wait {token} {
upvar 0 $token state
if {![info exists state(status)] || [string length $state(status)] == 0} {
-
# We must wait on the original variable name, not the upvar alias
-
vwait $token\(status)
}
if {[info exists state(error)]} {
@@ -487,8 +483,8 @@ proc http::formatQuery {args} {
set result ""
set sep ""
foreach i $args {
- append result $sep [mapReply $i]
- if {$sep != "="} {
+ append result $sep [mapReply $i]
+ if {[string compare $sep "="]} {
set sep =
} else {
set sep &
diff --git a/library/http2.3/http.tcl b/library/http2.3/http.tcl
index f448077..c59f4a5 100644
--- a/library/http2.3/http.tcl
+++ b/library/http2.3/http.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.
#
-# RCS: @(#) $Id: http.tcl,v 1.9 1999/08/05 16:57:48 hobbs Exp $
+# RCS: @(#) $Id: http.tcl,v 1.10 1999/08/19 02:59:45 hobbs Exp $
package provide http 2.1 ;# This uses Tcl namespaces
@@ -179,12 +179,10 @@ proc http::geturl { url args } {
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]} {
+ [string is integer -strict $state($flag)] && \
+ ![string is integer -strict $value]} {
return -code error "Bad value for $flag ($value), must be integer"
}
set state($flag) $value
@@ -192,7 +190,7 @@ proc http::geturl { url args } {
return -code error "Unknown option $flag, can be: $usage"
}
}
- if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
+ if {![regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
x proto host y port srvurl]} {
error "Unsupported URL: $url"
}
@@ -239,7 +237,7 @@ proc http::geturl { url args } {
#fileevent $s writable [list set $token\(status) connect]
fileevent $s writable [list http::Connect $token]
http::wait $token
- if {[string compare $state(status) "timeout"] == 0} {
+ if {[string equal $state(status) "timeout"]} {
return
}
fileevent $s writable {}
@@ -351,7 +349,7 @@ proc http::cleanup {token} {
Eof $token
return
}
- if {$state(state) == "header"} {
+ if {[string equal $state(state) "header"]} {
set n [gets $s line]
if {$n == 0} {
set state(state) body
@@ -423,7 +421,7 @@ proc http::cleanup {token} {
eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
}
# At this point the token may have been reset
- if {([string length $error] != 0)} {
+ if {[string length $error]} {
Finish $token $error
} elseif {[catch {::eof $s} iseof] || $iseof} {
Eof $token
@@ -434,7 +432,7 @@ proc http::cleanup {token} {
proc http::Eof {token} {
variable $token
upvar 0 $token state
- if {$state(state) == "header"} {
+ if {[string equal $state(state) "header"]} {
# Premature eof
set state(status) eof
} else {
@@ -458,9 +456,7 @@ proc http::wait {token} {
upvar 0 $token state
if {![info exists state(status)] || [string length $state(status)] == 0} {
-
# We must wait on the original variable name, not the upvar alias
-
vwait $token\(status)
}
if {[info exists state(error)]} {
@@ -487,8 +483,8 @@ proc http::formatQuery {args} {
set result ""
set sep ""
foreach i $args {
- append result $sep [mapReply $i]
- if {$sep != "="} {
+ append result $sep [mapReply $i]
+ if {[string compare $sep "="]} {
set sep =
} else {
set sep &
diff --git a/library/init.tcl b/library/init.tcl
index 7287398..e188329 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.
#
-# RCS: @(#) $Id: init.tcl,v 1.32 1999/08/09 16:30:50 hobbs Exp $
+# RCS: @(#) $Id: init.tcl,v 1.33 1999/08/19 02:59:40 hobbs Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -72,7 +72,7 @@ if {[info exists __dir]} {
# Windows specific end of initialization
-if {(![interp issafe]) && ($tcl_platform(platform) == "windows")} {
+if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} {
namespace eval tcl {
proc envTraceProc {lo n1 n2 op} {
set x $::env($n2)
@@ -82,7 +82,7 @@ if {(![interp issafe]) && ($tcl_platform(platform) == "windows")} {
}
foreach p [array names env] {
set u [string toupper $p]
- if {$u != $p} {
+ if {[string compare $u $p]} {
switch -- $u {
COMSPEC -
PATH {
@@ -102,7 +102,7 @@ if {(![interp issafe]) && ($tcl_platform(platform) == "windows")} {
unset u
}
if {![info exists env(COMSPEC)]} {
- if {$tcl_platform(os) == {Windows NT}} {
+ if {[string equal $tcl_platform(os) "Windows NT"]} {
set env(COMSPEC) cmd.exe
} else {
set env(COMSPEC) command.com
@@ -116,7 +116,7 @@ package unknown tclPkgUnknown
# Conditionalize for presence of exec.
-if {[info commands exec] == ""} {
+if {[llength [info commands exec]] == 0} {
# Some machines, such as the Macintosh, do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
@@ -129,7 +129,7 @@ set errorInfo ""
# Define a log command (which can be overwitten to log errors
# differently, specially when stderr is not available)
-if {[info commands tclLog] == ""} {
+if {[llength [info commands tclLog]] == 0} {
proc tclLog {string} {
catch {puts stderr $string}
}
@@ -219,7 +219,7 @@ proc unknown args {
}
}
- if {([info level] == 1) && ([info script] == "") \
+ if {([info level] == 1) && [string equal [info script] ""] \
&& [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
@@ -227,7 +227,7 @@ proc unknown args {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set redir ""
- if {[info commands console] == ""} {
+ if {[string equal [info commands console] ""]} {
set redir ">&@stdout <@stdin"
}
return [uplevel exec $redir $new [lrange $args 1 end]]
@@ -235,7 +235,7 @@ proc unknown args {
}
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
- if {$name == "!!"} {
+ if {[string equal $name "!!"]} {
set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name dummy event]} {
set newcmd [history event $event]
@@ -250,7 +250,7 @@ proc unknown args {
}
set ret [catch {set cmds [info commands $name*]} msg]
- if {[string compare $name "::"] == 0} {
+ if {[string equal $name "::"]} {
set name ""
}
if {$ret != 0} {
@@ -260,8 +260,8 @@ proc unknown args {
if {[llength $cmds] == 1} {
return [uplevel [lreplace $args 0 0 $cmds]]
}
- if {[llength $cmds] != 0} {
- if {$name == ""} {
+ if {[llength $cmds]} {
+ if {[string equal $name ""]} {
return -code error "empty command name \"\""
} else {
return -code error \
@@ -311,7 +311,7 @@ proc auto_load {cmd {namespace {}}} {
foreach name $nameList {
if {[info exists auto_index($name)]} {
uplevel #0 $auto_index($name)
- if {[info commands $name] != ""} {
+ if {[string compare [info commands $name] ""]} {
return 1
}
}
@@ -331,10 +331,9 @@ proc auto_load {cmd {namespace {}}} {
proc auto_load_index {} {
global auto_index auto_oldpath auto_path errorInfo errorCode
- if {[info exists auto_oldpath]} {
- if {$auto_oldpath == $auto_path} {
- return 0
- }
+ if {[info exists auto_oldpath] && \
+ [string equal $auto_oldpath $auto_path]} {
+ return 0
}
set auto_oldpath $auto_path
@@ -352,25 +351,24 @@ proc auto_load_index {} {
} else {
set error [catch {
set id [gets $f]
- if {$id == "# Tcl autoload index file, version 2.0"} {
+ if {[string equal $id \
+ "# Tcl autoload index file, version 2.0"]} {
eval [read $f]
- } elseif {$id == \
- "# Tcl autoload index file: each line identifies a Tcl"} {
+ } elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} {
while {[gets $f line] >= 0} {
- if {([string index $line 0] == "#")
+ if {[string equal [string index $line 0] "#"] \
|| ([llength $line] != 2)} {
continue
}
set name [lindex $line 0]
set auto_index($name) \
- "source [file join $dir [lindex $line 1]]"
+ "source [file join $dir [lindex $line 1]]"
}
} else {
- error \
- "[file join $dir tclIndex] isn't a proper Tcl index file"
+ error "[file join $dir tclIndex] isn't a proper Tcl index file"
}
} msg]
- if {$f != ""} {
+ if {[string compare $f ""]} {
close $f
}
if {$error} {
@@ -423,21 +421,19 @@ proc auto_qualify {cmd namespace} {
# (if the current namespace is not the global one)
if {$n == 0} {
- if {[string compare $namespace ::] == 0} {
+ if {[string equal $namespace ::]} {
# ( nocolons , :: ) -> nocolons
return [list $cmd]
} else {
# ( nocolons , ::sub ) -> ::sub::nocolons nocolons
return [list ${namespace}::$cmd $cmd]
}
+ } elseif {[string equal $namespace ::]} {
+ # ( foo::bar , :: ) -> ::foo::bar
+ return [list ::$cmd]
} else {
- if {[string compare $namespace ::] == 0} {
- # ( foo::bar , :: ) -> ::foo::bar
- return [list ::$cmd]
- } else {
- # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
- return [list ${namespace}::$cmd ::$cmd]
- }
+ # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
+ return [list ${namespace}::$cmd ::$cmd]
}
}
@@ -462,7 +458,8 @@ proc auto_import {pattern} {
foreach pattern $patternList {
foreach name [array names auto_index] {
- if {[string match $pattern $name] && "" == [info commands $name]} {
+ if {[string match $pattern $name] && \
+ [string equal "" [info commands $name]]} {
uplevel #0 $auto_index($name)
}
}
@@ -516,7 +513,7 @@ proc auto_execok name {
set windir $env(WINDIR)
}
if {[info exists windir]} {
- if {$tcl_platform(os) == "Windows NT"} {
+ if {[string equal $tcl_platform(os) "Windows NT"]} {
append path "$windir/system32;"
}
append path "$windir/system;$windir;"
@@ -559,7 +556,7 @@ proc auto_execok name {
return $auto_execs($name)
}
foreach dir [split $env(PATH) :] {
- if {$dir == ""} {
+ if {[string equal $dir ""]} {
set dir .
}
set file [file join $dir $name]
diff --git a/library/ldAout.tcl b/library/ldAout.tcl
index ad12624..e602e3a 100644
--- a/library/ldAout.tcl
+++ b/library/ldAout.tcl
@@ -18,7 +18,7 @@
# its .o file placed before all others in the command; then
# "ld" is executed to bind the objects together.
#
-# RCS: @(#) $Id: ldAout.tcl,v 1.3 1998/11/11 02:39:31 welch Exp $
+# RCS: @(#) $Id: ldAout.tcl,v 1.4 1999/08/19 02:59:40 hobbs Exp $
#
# Copyright (c) 1995, by General Electric Company. All rights reserved.
#
@@ -30,211 +30,204 @@
# F33615-94-C-4400.
proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
- global env
- global argv
-
- if {$cc==""} {
- set cc $env(CC)
- }
-
- # if only two parameters are supplied there is assumed that the
- # only shlib_suffix is missing. This parameter is anyway available
- # as "info sharedlibextension" too, so there is no need to transfer
- # 3 parameters to the function tclLdAout. For compatibility, this
- # function now accepts both 2 and 3 parameters.
-
- if {$shlib_suffix==""} {
- set shlib_cflags $env(SHLIB_CFLAGS)
- } else {
- if {$shlib_cflags=="none"} {
- set shlib_cflags $shlib_suffix
+ global env
+ global argv
+
+ if {[string equal $cc ""]} {
+ set cc $env(CC)
}
- }
- # seenDotO is nonzero if a .o or .a file has been seen
+ # if only two parameters are supplied there is assumed that the
+ # only shlib_suffix is missing. This parameter is anyway available
+ # as "info sharedlibextension" too, so there is no need to transfer
+ # 3 parameters to the function tclLdAout. For compatibility, this
+ # function now accepts both 2 and 3 parameters.
- set seenDotO 0
+ if {[string equal $shlib_suffix ""]} {
+ set shlib_cflags $env(SHLIB_CFLAGS)
+ } elseif {[string equal $shlib_cflags "none"]} {
+ set shlib_cflags $shlib_suffix
+ }
- # minusO is nonzero if the last command line argument was "-o".
+ # seenDotO is nonzero if a .o or .a file has been seen
+ set seenDotO 0
- set minusO 0
+ # minusO is nonzero if the last command line argument was "-o".
+ set minusO 0
- # head has command line arguments up to but not including the first
- # .o or .a file. tail has the rest of the arguments.
+ # head has command line arguments up to but not including the first
+ # .o or .a file. tail has the rest of the arguments.
+ set head {}
+ set tail {}
- set head {}
- set tail {}
+ # nmCommand is the "nm" command that lists global symbols from the
+ # object files.
+ set nmCommand {|nm -g}
- # nmCommand is the "nm" command that lists global symbols from the
- # object files.
+ # entryProtos is the table of _Init and _SafeInit prototypes found in the
+ # module.
+ set entryProtos {}
- set nmCommand {|nm -g}
+ # entryPoints is the table of _Init and _SafeInit entries found in the
+ # module.
+ set entryPoints {}
- # entryProtos is the table of _Init and _SafeInit prototypes found in the
- # module.
+ # libraries is the list of -L and -l flags to the linker.
+ set libraries {}
+ set libdirs {}
- set entryProtos {}
+ # Process command line arguments
+ foreach a $argv {
+ if {!$minusO && [regexp {\.[ao]$} $a]} {
+ set seenDotO 1
+ lappend nmCommand $a
+ }
+ if {$minusO} {
+ set outputFile $a
+ set minusO 0
+ } elseif {![string compare $a -o]} {
+ set minusO 1
+ }
+ if {[regexp {^-[lL]} $a]} {
+ lappend libraries $a
+ if {[regexp {^-L} $a]} {
+ lappend libdirs [string range $a 2 end]
+ }
+ } elseif {$seenDotO} {
+ lappend tail $a
+ } else {
+ lappend head $a
+ }
+ }
+ lappend libdirs /lib /usr/lib
+
+ # MIPS -- If there are corresponding G0 libraries, replace the
+ # ordinary ones with the G0 ones.
+
+ set libs {}
+ foreach lib $libraries {
+ if {[regexp {^-l} $lib]} {
+ set lname [string range $lib 2 end]
+ foreach dir $libdirs {
+ if {[file exists [file join $dir lib${lname}_G0.a]]} {
+ set lname ${lname}_G0
+ break
+ }
+ }
+ lappend libs -l$lname
+ } else {
+ lappend libs $lib
+ }
+ }
+ set libraries $libs
- # entryPoints is the table of _Init and _SafeInit entries found in the
- # module.
+ # Extract the module name from the "-o" option
- set entryPoints {}
+ if {![info exists outputFile]} {
+ error "-o option must be supplied to link a Tcl load module"
+ }
+ set m [file tail $outputFile]
+ if {[regexp {\.a$} $outputFile]} {
+ set shlib_suffix .a
+ } else {
+ set shlib_suffix ""
+ }
+ if {[regexp {\..*$} $outputFile match]} {
+ set l [expr {[string length $m] - [string length $match]}]
+ } else {
+ error "Output file does not appear to have a suffix"
+ }
+ set modName [string tolower $m 0 [expr {$l-1}]]
+ if {[regexp {^lib} $modName]} {
+ set modName [string range $modName 3 end]
+ }
+ if {[regexp {[0-9\.]*(_g0)?$} $modName match]} {
+ set modName [string range $modName 0 [expr {[string length $modName]-[string length $match]-1}]]
+ }
+ set modName [string totitle $modName]
+
+ # Catalog initialization entry points found in the module
+
+ set f [open $nmCommand r]
+ while {[gets $f l] >= 0} {
+ if {[regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol]} {
+ if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} {
+ set s $symbol
+ }
+ append entryProtos {extern int } $symbol { (); } \n
+ append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n
+ }
+ }
+ close $f
- # libraries is the list of -L and -l flags to the linker.
+ if {[string equal $entryPoints ""]} {
+ error "No entry point found in objects"
+ }
- set libraries {}
- set libdirs {}
+ # Compose a C function that resolves the initialization entry points and
+ # embeds the required libraries in the object code.
+
+ set C {#include <string.h>}
+ append C \n
+ append C {char TclLoadLibraries_} $modName { [] =} \n
+ append C { "@LIBS: } $libraries {";} \n
+ append C $entryProtos
+ append C {static struct } \{ \n
+ append C { char * name;} \n
+ append C { int (*value)();} \n
+ append C \} {dictionary [] = } \{ \n
+ append C $entryPoints
+ append C { 0, 0 } \n \} \; \n
+ append C {typedef struct Tcl_Interp Tcl_Interp;} \n
+ append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n
+ append C {Tcl_PackageInitProc *} \n
+ append C TclLoadDictionary_ $modName { (symbol)} \n
+ append C { char * symbol;} \n
+ append C {
+ {
+ int i;
+ for (i = 0; dictionary [i] . name != 0; ++i) {
+ if (!strcmp (symbol, dictionary [i] . name)) {
+ return dictionary [i].value;
+ }
+ }
+ return 0;
+ }
+ }
+ append C \n
- # Process command line arguments
- foreach a $argv {
- if {!$minusO && [regexp {\.[ao]$} $a]} {
- set seenDotO 1
- lappend nmCommand $a
- }
- if {$minusO} {
- set outputFile $a
- set minusO 0
- } elseif {![string compare $a -o]} {
- set minusO 1
- }
- if {[regexp {^-[lL]} $a]} {
- lappend libraries $a
- if {[regexp {^-L} $a]} {
- lappend libdirs [string range $a 2 end]
- }
- } elseif {$seenDotO} {
- lappend tail $a
+ # Write the C module and compile it
+
+ set cFile tcl$modName.c
+ set f [open $cFile w]
+ puts -nonewline $f $C
+ close $f
+ set ccCommand "$cc -c $shlib_cflags $cFile"
+ puts stderr $ccCommand
+ eval exec $ccCommand
+
+ # Now compose and execute the ld command that packages the module
+
+ if {[string equal $shlib_suffix ".a"]} {
+ set ldCommand "ar cr $outputFile"
+ regsub { -o} $tail {} tail
} else {
- lappend head $a
- }
- }
- lappend libdirs /lib /usr/lib
-
- # MIPS -- If there are corresponding G0 libraries, replace the
- # ordinary ones with the G0 ones.
-
- set libs {}
- foreach lib $libraries {
- if {[regexp {^-l} $lib]} {
- set lname [string range $lib 2 end]
- foreach dir $libdirs {
- if {[file exists [file join $dir lib${lname}_G0.a]]} {
- set lname ${lname}_G0
- break
- }
- }
- lappend libs -l$lname
- } else {
- lappend libs $lib
- }
- }
- set libraries $libs
-
- # Extract the module name from the "-o" option
-
- if {![info exists outputFile]} {
- error "-o option must be supplied to link a Tcl load module"
- }
- set m [file tail $outputFile]
- if {[regexp {\.a$} $outputFile]} {
- set shlib_suffix .a
- } else {
- set shlib_suffix ""
- }
- if {[regexp {\..*$} $outputFile match]} {
- set l [expr {[string length $m] - [string length $match]}]
- } else {
- error "Output file does not appear to have a suffix"
- }
- set modName [string tolower [string range $m 0 [expr {$l-1}]]]
- if {[regexp {^lib} $modName]} {
- set modName [string range $modName 3 end]
- }
- if {[regexp {[0-9\.]*(_g0)?$} $modName match]} {
- set modName [string range $modName 0 [expr {[string length $modName]-[string length $match]-1}]]
- }
- set modName "[string toupper [string index $modName 0]][string range $modName 1 end]"
-
- # Catalog initialization entry points found in the module
-
- set f [open $nmCommand r]
- while {[gets $f l] >= 0} {
- if {[regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol]} {
- if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} {
- set s $symbol
- }
- append entryProtos {extern int } $symbol { (); } \n
- append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n
+ set ldCommand ld
+ foreach item $head {
+ lappend ldCommand $item
+ }
}
- }
- close $f
-
- if {$entryPoints==""} {
- error "No entry point found in objects"
- }
-
- # Compose a C function that resolves the initialization entry points and
- # embeds the required libraries in the object code.
-
- set C {#include <string.h>}
- append C \n
- append C {char TclLoadLibraries_} $modName { [] =} \n
- append C { "@LIBS: } $libraries {";} \n
- append C $entryProtos
- append C {static struct } \{ \n
- append C { char * name;} \n
- append C { int (*value)();} \n
- append C \} {dictionary [] = } \{ \n
- append C $entryPoints
- append C { 0, 0 } \n \} \; \n
- append C {typedef struct Tcl_Interp Tcl_Interp;} \n
- append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n
- append C {Tcl_PackageInitProc *} \n
- append C TclLoadDictionary_ $modName { (symbol)} \n
- append C { char * symbol;} \n
- append C {{
- int i;
- for (i = 0; dictionary [i] . name != 0; ++i) {
- if (!strcmp (symbol, dictionary [i] . name)) {
- return dictionary [i].value;
- }
+ lappend ldCommand tcl$modName.o
+ foreach item $tail {
+ lappend ldCommand $item
}
- return 0;
-}} \n
-
- # Write the C module and compile it
-
- set cFile tcl$modName.c
- set f [open $cFile w]
- puts -nonewline $f $C
- close $f
- set ccCommand "$cc -c $shlib_cflags $cFile"
- puts stderr $ccCommand
- eval exec $ccCommand
-
- # Now compose and execute the ld command that packages the module
-
- if {$shlib_suffix == ".a"} {
- set ldCommand "ar cr $outputFile"
- regsub { -o} $tail {} tail
- } else {
- set ldCommand ld
- foreach item $head {
- lappend ldCommand $item
+ puts stderr $ldCommand
+ eval exec $ldCommand
+ if {[string equal $shlib_suffix ".a"]} {
+ exec ranlib $outputFile
}
- }
- lappend ldCommand tcl$modName.o
- foreach item $tail {
- lappend ldCommand $item
- }
- puts stderr $ldCommand
- eval exec $ldCommand
- if {$shlib_suffix == ".a"} {
- exec ranlib $outputFile
- }
-
- # Clean up working files
-
- exec /bin/rm $cFile [file rootname $cFile].o
+
+ # Clean up working files
+ exec /bin/rm $cFile [file rootname $cFile].o
}
diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl
index 37676da..7eb1f90 100644
--- a/library/msgcat/msgcat.tcl
+++ b/library/msgcat/msgcat.tcl
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: msgcat.tcl,v 1.2 1999/04/16 00:47:17 stanton Exp $
+# RCS: @(#) $Id: msgcat.tcl,v 1.3 1999/08/19 02:59:49 hobbs Exp $
package provide msgcat 1.0
@@ -78,8 +78,7 @@ proc msgcat::mclocale {args} {
set word ""
foreach part [split $args _] {
set word [string trimleft "${word}_${part}" _]
- set ::msgcat::loclist \
- [linsert $::msgcat::loclist 0 $word]
+ set ::msgcat::loclist [linsert $::msgcat::loclist 0 $word]
}
}
return $::msgcat::locale
@@ -137,7 +136,7 @@ proc msgcat::mcload {langdir} {
# Returns the new locale.
proc msgcat::mcset {locale src {dest ""}} {
- if {$dest == ""} {
+ if {[string equal $dest ""]} {
set dest $src
}
diff --git a/library/msgcat1.0/msgcat.tcl b/library/msgcat1.0/msgcat.tcl
index 37676da..7eb1f90 100644
--- a/library/msgcat1.0/msgcat.tcl
+++ b/library/msgcat1.0/msgcat.tcl
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: msgcat.tcl,v 1.2 1999/04/16 00:47:17 stanton Exp $
+# RCS: @(#) $Id: msgcat.tcl,v 1.3 1999/08/19 02:59:49 hobbs Exp $
package provide msgcat 1.0
@@ -78,8 +78,7 @@ proc msgcat::mclocale {args} {
set word ""
foreach part [split $args _] {
set word [string trimleft "${word}_${part}" _]
- set ::msgcat::loclist \
- [linsert $::msgcat::loclist 0 $word]
+ set ::msgcat::loclist [linsert $::msgcat::loclist 0 $word]
}
}
return $::msgcat::locale
@@ -137,7 +136,7 @@ proc msgcat::mcload {langdir} {
# Returns the new locale.
proc msgcat::mcset {locale src {dest ""}} {
- if {$dest == ""} {
+ if {[string equal $dest ""]} {
set dest $src
}
diff --git a/library/package.tcl b/library/package.tcl
index 29b7627..22b46d1 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -3,7 +3,7 @@
# utility procs formerly in init.tcl which can be loaded on demand
# for package management.
#
-# RCS: @(#) $Id: package.tcl,v 1.5 1999/04/21 21:50:29 rjohnson Exp $
+# RCS: @(#) $Id: package.tcl,v 1.6 1999/08/19 02:59:40 hobbs Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
@@ -32,12 +32,10 @@ proc pkg_compareExtension { fileName {ext {}} } {
if {[string length $ext] == 0} {
set ext [info sharedlibextension]
}
- if {[string compare $tcl_platform(platform) "windows"] == 0} {
- return [expr {[string compare \
- [string tolower [file extension $fileName]] \
- [string tolower $ext]] == 0}]
+ if {[string equal $tcl_platform(platform) "windows"]} {
+ return [string equal -nocase [file extension $fileName] $ext]
} else {
- return [expr {[string compare [file extension $fileName] $ext] == 0}]
+ return [string equal [file extension $fileName] $ext]
}
}
@@ -138,7 +136,7 @@ proc pkg_mkIndex {args} {
# interpreter, and get a list of the new commands and packages
# that are defined.
- if {[string compare $file "pkgIndex.tcl"] == 0} {
+ if {[string equal $file "pkgIndex.tcl"]} {
continue
}
@@ -156,7 +154,7 @@ proc pkg_mkIndex {args} {
if {! [string match $loadPat [lindex $pkg 1]]} {
continue
}
- if {[lindex $pkg 1] == "Tk"} {
+ if {[string equal [lindex $pkg 1] "Tk"]} {
$c eval {set argv {-geometry +0+0}}
}
if {[catch {
@@ -165,10 +163,8 @@ proc pkg_mkIndex {args} {
if {$doVerbose} {
tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
}
- } else {
- if {$doVerbose} {
- tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
- }
+ } elseif {$doVerbose} {
+ tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
}
}
cd $dir
@@ -241,7 +237,7 @@ proc pkg_mkIndex {args} {
return $list
}
- # initialize the list of existing namespaces, packages, commands
+ # init the list of existing namespaces, packages, commands
foreach ::tcl::x [::tcl::GetAllNamespaces] {
set ::tcl::namespaces($::tcl::x) 1
@@ -300,7 +296,7 @@ proc pkg_mkIndex {args} {
set ::tcl::abs [auto_qualify $::tcl::abs ::]
- if {[string compare $::tcl::x $::tcl::abs] != 0} {
+ if {[string compare $::tcl::x $::tcl::abs]} {
# Name changed during qualification
set ::tcl::newCmds($::tcl::abs) 1
@@ -312,7 +308,7 @@ proc pkg_mkIndex {args} {
# a version provided, then record it
foreach ::tcl::x [package names] {
- if {([string compare [package provide $::tcl::x] ""] != 0) \
+ if {[string compare [package provide $::tcl::x] ""] \
&& ![info exists ::tcl::packages($::tcl::x)]} {
lappend ::tcl::newPkgs \
[list $::tcl::x [package provide $::tcl::x]]
@@ -391,7 +387,7 @@ proc tclPkgSetup {dir pkg version files} {
set f [lindex $fileInfo 0]
set type [lindex $fileInfo 1]
foreach cmd [lindex $fileInfo 2] {
- if {$type == "load"} {
+ if {[string equal $type "load"]} {
set auto_index($cmd) [list load [file join $dir $f] $pkg]
} else {
set auto_index($cmd) [list source [file join $dir $f]]
@@ -410,7 +406,7 @@ proc tclMacPkgSearch {dir} {
if {[file isfile $x]} {
set res [resource open $x]
foreach y [resource list TEXT $res] {
- if {$y == "pkgIndex"} {source -rsrc pkgIndex}
+ if {[string equal $y "pkgIndex"]} {source -rsrc pkgIndex}
}
catch {resource close $res}
}
@@ -461,7 +457,8 @@ proc tclPkgUnknown {name version {exact {}}} {
# On the Macintosh we also look in the resource fork
# of shared libraries
# We can't use tclMacPkgSearch in safe interps because it uses glob
- if {(![interp issafe]) && ($tcl_platform(platform) == "macintosh")} {
+ if {(![interp issafe]) && \
+ [string equal $tcl_platform(platform) "macintosh"]} {
set dir [lindex $auto_path $i]
tclMacPkgSearch $dir
foreach x [glob -nocomplain [file join $dir *]] {
diff --git a/library/safe.tcl b/library/safe.tcl
index 3be7739..a929653 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.
#
-# RCS: @(#) $Id: safe.tcl,v 1.5 1999/04/16 00:46:57 stanton Exp $
+# RCS: @(#) $Id: safe.tcl,v 1.6 1999/08/19 02:59:40 hobbs Exp $
#
# The implementation is based on namespaces. These naming conventions
@@ -29,8 +29,7 @@ namespace eval ::safe {
# Exported API:
namespace export interpCreate interpInit interpConfigure interpDelete \
- interpAddToAccessPath interpFindInAccessPath \
- setLogCmd ;
+ interpAddToAccessPath interpFindInAccessPath setLogCmd
####
#
@@ -51,20 +50,20 @@ namespace eval ::safe {
# create case (slave is optional)
::tcl::OptKeyRegister {
{?slave? -name {} "name of the slave (optional)"}
- } ::safe::interpCreate ;
+ } ::safe::interpCreate
# adding the flags sub programs to the command program
# (relying on Opt's internal implementation details)
- lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp);
+ lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp)
# init and configure (slave is needed)
::tcl::OptKeyRegister {
{slave -name {} "name of the slave"}
- } ::safe::interpIC;
+ } ::safe::interpIC
# adding the flags sub programs to the command program
# (relying on Opt's internal implementation details)
- lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp);
+ lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp)
# temp not needed anymore
- ::tcl::OptKeyDelete $temp;
+ ::tcl::OptKeyDelete $temp
# Helper function to resolve the dual way of specifying staticsok
@@ -77,10 +76,10 @@ namespace eval ::safe {
if {$flag && ($noStatics == $statics)
&& ([::tcl::OptProcArgGiven -statics])} {
return -code error\
- "conflicting values given for -statics and -noStatics";
+ "conflicting values given for -statics and -noStatics"
}
if {$flag} {
- return [expr {!$noStatics}];
+ return [expr {!$noStatics}]
} else {
return $statics
}
@@ -98,7 +97,7 @@ namespace eval ::safe {
if {$flag && ($nestedLoadOk != $nested)
&& ([::tcl::OptProcArgGiven -nested])} {
return -code error\
- "conflicting values given for -nested and -nestedLoadOk";
+ "conflicting values given for -nested and -nestedLoadOk"
}
if {$flag} {
# another difference with "InterpStatics"
@@ -119,14 +118,13 @@ namespace eval ::safe {
proc interpCreate {args} {
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
InterpCreate $slave $accessPath \
- [InterpStatics] [InterpNested] $deleteHook;
+ [InterpStatics] [InterpNested] $deleteHook
}
proc interpInit {args} {
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
if {![::interp exists $slave]} {
- return -code error \
- "\"$slave\" is not an interpreter";
+ return -code error "\"$slave\" is not an interpreter"
}
InterpInit $slave $accessPath \
[InterpStatics] [InterpNested] $deleteHook;
@@ -135,7 +133,7 @@ namespace eval ::safe {
proc CheckInterp {slave} {
if {![IsInterp $slave]} {
return -code error \
- "\"$slave\" is not an interpreter managed by ::safe::" ;
+ "\"$slave\" is not an interpreter managed by ::safe::"
}
}
@@ -160,8 +158,8 @@ namespace eval ::safe {
# We still call OptKeyParse though we know that "slave"
# is our given argument because it also checks
# for the "-help" option.
- set Args [::tcl::OptKeyParse ::safe::interpIC $args];
- CheckInterp $slave;
+ set Args [::tcl::OptKeyParse ::safe::interpIC $args]
+ CheckInterp $slave
set res {}
lappend res [list -accessPath [Set [PathListName $slave]]]
lappend res [list -statics [Set [StaticsOkName $slave]]]
@@ -172,19 +170,19 @@ namespace eval ::safe {
2 {
# If we have exactly 2 arguments
# the semantic is a "configure get"
- ::tcl::Lassign $args slave arg;
+ ::tcl::Lassign $args slave arg
# get the flag sub program (we 'know' about Opt's internal
# representation of data)
set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2]
- set hits [::tcl::OptHits desc $arg];
+ set hits [::tcl::OptHits desc $arg]
if {$hits > 1} {
return -code error [::tcl::OptAmbigous $desc $arg]
} elseif {$hits == 0} {
return -code error [::tcl::OptFlagUsage $desc $arg]
}
- CheckInterp $slave;
- set item [::tcl::OptCurDesc $desc];
- set name [::tcl::OptName $item];
+ CheckInterp $slave
+ set item [::tcl::OptCurDesc $desc]
+ set name [::tcl::OptName $item]
switch -exact -- $name {
-accessPath {
return [list -accessPath [Set [PathListName $slave]]]
@@ -206,23 +204,23 @@ namespace eval ::safe {
# unambigous -statics ?value? instead:
return -code error\
"ambigous query (get or set -noStatics ?)\
- use -statics instead";
+ use -statics instead"
}
-nestedLoadOk {
return -code error\
"ambigous query (get or set -nestedLoadOk ?)\
- use -nested instead";
+ use -nested instead"
}
default {
- return -code error "unknown flag $name (bug)";
+ return -code error "unknown flag $name (bug)"
}
}
}
default {
# Otherwise we want to parse the arguments like init and create
# did
- set Args [::tcl::OptKeyParse ::safe::interpIC $args];
- CheckInterp $slave;
+ set Args [::tcl::OptKeyParse ::safe::interpIC $args]
+ CheckInterp $slave
# Get the current (and not the default) values of
# whatever has not been given:
if {![::tcl::OptProcArgGiven -accessPath]} {
@@ -231,14 +229,14 @@ namespace eval ::safe {
} else {
set doreset 0
}
- if { (![::tcl::OptProcArgGiven -statics])
- && (![::tcl::OptProcArgGiven -noStatics]) } {
+ if {(![::tcl::OptProcArgGiven -statics]) \
+ && (![::tcl::OptProcArgGiven -noStatics]) } {
set statics [Set [StaticsOkName $slave]]
} else {
set statics [InterpStatics]
}
- if { ([::tcl::OptProcArgGiven -nested])
- || ([::tcl::OptProcArgGiven -nestedLoadOk]) } {
+ if {([::tcl::OptProcArgGiven -nested]) \
+ || ([::tcl::OptProcArgGiven -nestedLoadOk]) } {
set nested [InterpNested]
} else {
set nested [Set [NestedOkName $slave]]
@@ -247,14 +245,13 @@ namespace eval ::safe {
set deleteHook [Set [DeleteHookName $slave]]
}
# we can now reconfigure :
- InterpSetConfig $slave $accessPath \
- $statics $nested $deleteHook;
+ InterpSetConfig $slave $accessPath $statics $nested $deleteHook
# auto_reset the slave (to completly synch the new access_path)
if {$doreset} {
if {[catch {::interp eval $slave {auto_reset}} msg]} {
- Log $slave "auto_reset failed: $msg";
+ Log $slave "auto_reset failed: $msg"
} else {
- Log $slave "successful auto_reset" NOTICE;
+ Log $slave "successful auto_reset" NOTICE
}
}
}
@@ -298,15 +295,15 @@ namespace eval ::safe {
} {
# Create the slave.
if {[string compare "" $slave]} {
- ::interp create -safe $slave;
+ ::interp create -safe $slave
} else {
# empty argument: generate slave name
- set slave [::interp create -safe];
+ set slave [::interp create -safe]
}
- Log $slave "Created" NOTICE;
+ Log $slave "Created" NOTICE
# Initialize it. (returns slave name)
- InterpInit $slave $access_path $staticsok $nestedok $deletehook;
+ InterpInit $slave $access_path $staticsok $nestedok $deletehook
}
@@ -323,60 +320,60 @@ namespace eval ::safe {
nestedok deletehook} {
# determine and store the access path if empty
- if {[string match "" $access_path]} {
- set access_path [uplevel #0 set auto_path];
+ if {[string equal "" $access_path]} {
+ set access_path [uplevel #0 set auto_path]
# Make sure that tcl_library is in auto_path
# and at the first position (needed by setAccessPath)
- set where [lsearch -exact $access_path [info library]];
+ set where [lsearch -exact $access_path [info library]]
if {$where == -1} {
# not found, add it.
- set access_path [concat [list [info library]] $access_path];
+ set access_path [concat [list [info library]] $access_path]
Log $slave "tcl_library was not in auto_path,\
- added it to slave's access_path" NOTICE;
+ added it to slave's access_path" NOTICE
} elseif {$where != 0} {
# not first, move it first
set access_path [concat [list [info library]]\
- [lreplace $access_path $where $where]];
+ [lreplace $access_path $where $where]]
Log $slave "tcl_libray was not in first in auto_path,\
- moved it to front of slave's access_path" NOTICE;
+ moved it to front of slave's access_path" NOTICE
}
# Add 1st level sub dirs (will searched by auto loading from tcl
# code in the slave using glob and thus fail, so we add them
# here so by default it works the same).
- set access_path [AddSubDirs $access_path];
+ set access_path [AddSubDirs $access_path]
}
Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\
- nestedok=$nestedok deletehook=($deletehook)" NOTICE;
+ nestedok=$nestedok deletehook=($deletehook)" NOTICE
# clear old autopath if it existed
- set nname [PathNumberName $slave];
+ set nname [PathNumberName $slave]
if {[Exists $nname]} {
- set n [Set $nname];
+ set n [Set $nname]
for {set i 0} {$i<$n} {incr i} {
- Unset [PathToken $i $slave];
+ Unset [PathToken $i $slave]
}
}
# build new one
set slave_auto_path {}
- set i 0;
+ set i 0
foreach dir $access_path {
- Set [PathToken $i $slave] $dir;
- lappend slave_auto_path "\$[PathToken $i]";
- incr i;
+ Set [PathToken $i $slave] $dir
+ lappend slave_auto_path "\$[PathToken $i]"
+ incr i
}
- Set $nname $i;
- Set [PathListName $slave] $access_path;
- Set [VirtualPathListName $slave] $slave_auto_path;
+ Set $nname $i
+ Set [PathListName $slave] $access_path
+ Set [VirtualPathListName $slave] $slave_auto_path
Set [StaticsOkName $slave] $staticsok
Set [NestedOkName $slave] $nestedok
Set [DeleteHookName $slave] $deletehook
- SyncAccessPath $slave;
+ SyncAccessPath $slave
}
#
@@ -385,12 +382,12 @@ namespace eval ::safe {
# Search for a real directory and returns its virtual Id
# (including the "$")
proc ::safe::interpFindInAccessPath {slave path} {
- set access_path [GetAccessPath $slave];
- set where [lsearch -exact $access_path $path];
+ set access_path [GetAccessPath $slave]
+ set where [lsearch -exact $access_path $path]
if {$where == -1} {
- return -code error "$path not found in access path $access_path";
+ return -code error "$path not found in access path $access_path"
}
- return "\$[PathToken $where]";
+ return "\$[PathToken $where]"
}
#
@@ -400,22 +397,22 @@ proc ::safe::interpFindInAccessPath {slave path} {
proc ::safe::interpAddToAccessPath {slave path} {
# first check if the directory is already in there
if {![catch {interpFindInAccessPath $slave $path} res]} {
- return $res;
+ return $res
}
# new one, add it:
- set nname [PathNumberName $slave];
- set n [Set $nname];
- Set [PathToken $n $slave] $path;
+ set nname [PathNumberName $slave]
+ set n [Set $nname]
+ Set [PathToken $n $slave] $path
- set token "\$[PathToken $n]";
+ set token "\$[PathToken $n]"
- Lappend [VirtualPathListName $slave] $token;
- Lappend [PathListName $slave] $path;
- Set $nname [expr {$n+1}];
+ Lappend [VirtualPathListName $slave] $token
+ Lappend [PathListName $slave] $path
+ Set $nname [expr {$n+1}]
- SyncAccessPath $slave;
+ SyncAccessPath $slave
- return $token;
+ return $token
}
# This procedure applies the initializations to an already existing
@@ -431,7 +428,7 @@ proc ::safe::interpAddToAccessPath {slave path} {
# Configure will generate an access_path when access_path is
# empty.
- InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook;
+ InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook
# These aliases let the slave load files to define new commands
@@ -478,9 +475,8 @@ proc ::safe::interpAddToAccessPath {slave path} {
# model platform dependant and thus more error prone.
if {[catch {::interp eval $slave\
- {source [file join $tcl_library init.tcl]}}\
- msg]} {
- Log $slave "can't source init.tcl ($msg)";
+ {source [file join $tcl_library init.tcl]}} msg]} {
+ Log $slave "can't source init.tcl ($msg)"
error "can't source init.tcl into slave $slave ($msg)"
}
@@ -498,18 +494,18 @@ proc ::safe::interpAddToAccessPath {slave path} {
# check that we don't have it yet as a children
# of a previous dir
if {[lsearch -exact $res $dir]<0} {
- lappend res $dir;
+ lappend res $dir
}
foreach sub [glob -nocomplain -- [file join $dir *]] {
- if { ([file isdirectory $sub])
- && ([lsearch -exact $res $sub]<0) } {
+ if {([file isdirectory $sub]) \
+ && ([lsearch -exact $res $sub]<0) } {
# new sub dir, add it !
- lappend res $sub;
+ lappend res $sub
}
}
}
}
- return $res;
+ return $res
}
# This procedure deletes a safe slave managed by Safe Tcl and
@@ -517,20 +513,20 @@ proc ::safe::interpAddToAccessPath {slave path} {
proc ::safe::interpDelete {slave} {
- Log $slave "About to delete" NOTICE;
+ Log $slave "About to delete" NOTICE
# If the slave has a cleanup hook registered, call it.
# check the existance because we might be called to delete an interp
# which has not been registered with us at all
- set hookname [DeleteHookName $slave];
+ set hookname [DeleteHookName $slave]
if {[Exists $hookname]} {
- set hook [Set $hookname];
+ set hook [Set $hookname]
if {![::tcl::Lempty $hook]} {
# remove the hook now, otherwise if the hook
# calls us somehow, we'll loop
- Unset $hookname;
+ Unset $hookname
if {[catch {eval $hook [list $slave]} err]} {
- Log $slave "Delete hook error ($err)";
+ Log $slave "Delete hook error ($err)"
}
}
}
@@ -538,16 +534,16 @@ proc ::safe::interpDelete {slave} {
# Discard the global array of state associated with the slave, and
# delete the interpreter.
- set statename [InterpStateName $slave];
+ set statename [InterpStateName $slave]
if {[Exists $statename]} {
- Unset $statename;
+ Unset $statename
}
# if we have been called twice, the interp might have been deleted
# already
if {[::interp exists $slave]} {
- ::interp delete $slave;
- Log $slave "Deleted" NOTICE;
+ ::interp delete $slave
+ Log $slave "Deleted" NOTICE
}
return
@@ -556,12 +552,12 @@ proc ::safe::interpDelete {slave} {
# Set (or get) the loging mecanism
proc ::safe::setLogCmd {args} {
- variable Log;
+ variable Log
if {[llength $args] == 0} {
- return $Log;
+ return $Log
} else {
if {[llength $args] == 1} {
- set Log [lindex $args 0];
+ set Log [lindex $args 0]
} else {
set Log $args
}
@@ -579,12 +575,11 @@ proc ::safe::setLogCmd {args} {
# also sets tcl_library to the first token of the virtual path.
#
proc SyncAccessPath {slave} {
- set slave_auto_path [Set [VirtualPathListName $slave]];
- ::interp eval $slave [list set auto_path $slave_auto_path];
- Log $slave \
- "auto_path in $slave has been set to $slave_auto_path"\
- NOTICE;
- ::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]];
+ set slave_auto_path [Set [VirtualPathListName $slave]]
+ ::interp eval $slave [list set auto_path $slave_auto_path]
+ Log $slave "auto_path in $slave has been set to $slave_auto_path"\
+ NOTICE
+ ::interp eval $slave [list set tcl_library [lindex $slave_auto_path 0]]
}
# base name for storing all the slave states
@@ -594,13 +589,12 @@ proc ::safe::setLogCmd {args} {
# We add the S prefix to avoid that a slave interp called "Log"
# would smash our "Log" variable.
proc InterpStateName {slave} {
- return "S$slave";
+ return "S$slave"
}
# Check that the given slave is "one of us"
proc IsInterp {slave} {
- expr { ([Exists [InterpStateName $slave]])
- && ([::interp exists $slave])}
+ expr {[Exists [InterpStateName $slave]] && [::interp exists $slave]}
}
# returns the virtual token for directory number N
@@ -608,53 +602,53 @@ proc ::safe::setLogCmd {args} {
# it will return the corresponding master global variable name
proc PathToken {n {slave ""}} {
if {[string compare "" $slave]} {
- return "[InterpStateName $slave](access_path,$n)";
+ return "[InterpStateName $slave](access_path,$n)"
} else {
# We need to have a ":" in the token string so
# [file join] on the mac won't turn it into a relative
# path.
- return "p(:$n:)";
+ return "p(:$n:)"
}
}
# returns the variable name of the complete path list
proc PathListName {slave} {
- return "[InterpStateName $slave](access_path)";
+ return "[InterpStateName $slave](access_path)"
}
# returns the variable name of the complete path list
proc VirtualPathListName {slave} {
- return "[InterpStateName $slave](access_path_slave)";
+ return "[InterpStateName $slave](access_path_slave)"
}
# returns the variable name of the number of items
proc PathNumberName {slave} {
- return "[InterpStateName $slave](access_path,n)";
+ return "[InterpStateName $slave](access_path,n)"
}
# returns the staticsok flag var name
proc StaticsOkName {slave} {
- return "[InterpStateName $slave](staticsok)";
+ return "[InterpStateName $slave](staticsok)"
}
# returns the nestedok flag var name
proc NestedOkName {slave} {
- return "[InterpStateName $slave](nestedok)";
+ return "[InterpStateName $slave](nestedok)"
}
# Run some code at the namespace toplevel
proc Toplevel {args} {
- namespace eval [namespace current] $args;
+ namespace eval [namespace current] $args
}
# set/get values
proc Set {args} {
- eval Toplevel set $args;
+ eval Toplevel set $args
}
# lappend on toplevel vars
proc Lappend {args} {
- eval Toplevel lappend $args;
+ eval Toplevel lappend $args
}
# unset a var/token (currently just an global level eval)
proc Unset {args} {
- eval Toplevel unset $args;
+ eval Toplevel unset $args
}
# test existance
proc Exists {varname} {
- Toplevel info exists $varname;
+ Toplevel info exists $varname
}
# short cut for access path getting
proc GetAccessPath {slave} {
@@ -680,24 +674,24 @@ proc ::safe::setLogCmd {args} {
# somehow strip the namespaces 'functionality' out (the danger
# is that we would strip valid macintosh "../" queries... :
if {[regexp {(::)|(\.\.)} $path]} {
- error "invalid characters in path $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]];
+ set [PathToken $n] [Set [PathToken $n $slave]]
}
# replaces the token by their value
- subst -nobackslashes -nocommands $path;
+ subst -nobackslashes -nocommands $path
}
# Log eventually log an error
# to enable error logging, set Log to {puts stderr} for instance
proc Log {slave msg {type ERROR}} {
- variable Log;
+ variable Log
if {[info exists Log] && [llength $Log]} {
- eval $Log [list "$type for slave $slave : $msg"];
+ eval $Log [list "$type for slave $slave : $msg"]
}
}
@@ -708,29 +702,27 @@ proc ::safe::setLogCmd {args} {
# limit what can be sourced to .tcl
# and forbid files with more than 1 dot and
# longer than 14 chars
- set ftail [file tail $file];
+ set ftail [file tail $file]
if {[string length $ftail]>14} {
- error "$ftail: filename too long";
+ error "$ftail: filename too long"
}
if {[regexp {\..*\.} $ftail]} {
- error "$ftail: more than one dot is forbidden";
+ error "$ftail: more than one dot is forbidden"
}
if {[string compare $ftail "tclIndex"] && \
- [string compare [string tolower [file extension $ftail]]\
- ".tcl"]} {
- error "$ftail: must be a *.tcl or tclIndex";
+ [string compare -nocase [file extension $ftail] ".tcl"]} {
+ error "$ftail: must be a *.tcl or tclIndex"
}
if {![file exists $file]} {
# don't tell the file path
- error "no such file or directory";
+ error "no such file or directory"
}
if {![file readable $file]} {
# don't tell the file path
- error "not readable";
+ error "not readable"
}
-
}
@@ -738,39 +730,39 @@ proc ::safe::setLogCmd {args} {
proc AliasSource {slave args} {
- set argc [llength $args];
+ set argc [llength $args]
# Allow only "source filename"
# (and not mac specific -rsrc for instance - see comment in ::init
# for current rationale)
if {$argc != 1} {
set msg "wrong # args: should be \"source fileName\""
- Log $slave "$msg ($args)";
- return -code error $msg;
+ Log $slave "$msg ($args)"
+ return -code error $msg
}
set file [lindex $args 0]
# get the real path from the virtual one.
if {[catch {set file [TranslatePath $slave $file]} msg]} {
- Log $slave $msg;
+ Log $slave $msg
return -code error "permission denied"
}
# check that the path is in the access path of that slave
if {[catch {FileInAccessPath $slave $file} msg]} {
- Log $slave $msg;
+ Log $slave $msg
return -code error "permission denied"
}
# do the checks on the filename :
if {[catch {CheckFileName $slave $file} msg]} {
- Log $slave "$file:$msg";
- return -code error $msg;
+ Log $slave "$file:$msg"
+ return -code error $msg
}
# passed all the tests , lets source it:
if {[catch {::interp invokehidden $slave source $file} msg]} {
- Log $slave $msg;
- return -code error "script error";
+ Log $slave $msg
+ return -code error "script error"
}
return $msg
}
@@ -779,26 +771,26 @@ proc ::safe::setLogCmd {args} {
proc AliasLoad {slave file args} {
- set argc [llength $args];
+ set argc [llength $args]
if {$argc > 2} {
- set msg "load error: too many arguments";
- Log $slave "$msg ($argc) {$file $args}";
- return -code error $msg;
+ set msg "load error: too many arguments"
+ Log $slave "$msg ($argc) {$file $args}"
+ return -code error $msg
}
# package name (can be empty if file is not).
- set package [lindex $args 0];
+ set package [lindex $args 0]
# Determine where to load. load use a relative interp path
# and {} means self, so we can directly and safely use passed arg.
- set target [lindex $args 1];
+ set target [lindex $args 1]
if {[string length $target]} {
# we will try to load into a sub sub interp
# check that we want to authorize that.
if {![NestedOk $slave]} {
Log $slave "loading to a sub interp (nestedok)\
- disabled (trying to load $package to $target)";
- return -code error "permission denied (nested load)";
+ disabled (trying to load $package to $target)"
+ return -code error "permission denied (nested load)"
}
}
@@ -807,34 +799,34 @@ proc ::safe::setLogCmd {args} {
if {[string length $file] == 0} {
# static package loading
if {[string length $package] == 0} {
- set msg "load error: empty filename and no package name";
- Log $slave $msg;
- return -code error $msg;
+ set msg "load error: empty filename and no package name"
+ Log $slave $msg
+ return -code error $msg
}
if {![StaticsOk $slave]} {
Log $slave "static packages loading disabled\
- (trying to load $package to $target)";
- return -code error "permission denied (static package)";
+ (trying to load $package to $target)"
+ return -code error "permission denied (static package)"
}
} else {
# file loading
# get the real path from the virtual one.
if {[catch {set file [TranslatePath $slave $file]} msg]} {
- Log $slave $msg;
+ Log $slave $msg
return -code error "permission denied"
}
# check the translated path
if {[catch {FileInAccessPath $slave $file} msg]} {
- Log $slave $msg;
+ Log $slave $msg
return -code error "permission denied (path)"
}
}
if {[catch {::interp invokehidden\
$slave load $file $package $target} msg]} {
- Log $slave $msg;
+ Log $slave $msg
return -code error $msg
}
@@ -849,14 +841,14 @@ proc ::safe::setLogCmd {args} {
# result.... needs checking ?
proc FileInAccessPath {slave file} {
- set access_path [GetAccessPath $slave];
+ set access_path [GetAccessPath $slave]
if {[file isdirectory $file]} {
error "\"$file\": is a directory"
}
set parent [file dirname $file]
if {[lsearch -exact $access_path $parent] == -1} {
- error "\"$file\": not in access_path";
+ error "\"$file\": not in access_path"
}
}
@@ -868,9 +860,9 @@ proc ::safe::setLogCmd {args} {
if {[regexp $okpat $subcommand]} {
return [eval {$command $subcommand} [lrange $args 1 end]]
}
- set msg "not allowed to invoke subcommand $subcommand of $command";
- Log $slave $msg;
- error $msg;
+ set msg "not allowed to invoke subcommand $subcommand of $command"
+ Log $slave $msg
+ error $msg
}
# This procedure installs an alias in a slave that invokes "safesubset"
@@ -895,7 +887,7 @@ proc ::safe::setLogCmd {args} {
proc AliasEncoding {slave args} {
- set argc [llength $args];
+ set argc [llength $args]
set okpat "^(name.*|convert.*)\$"
set subcommand [lindex $args 0]
@@ -910,21 +902,20 @@ proc ::safe::setLogCmd {args} {
# passed all the tests , lets source it:
if {[catch {::interp invokehidden \
$slave encoding system} msg]} {
- Log $slave $msg;
- return -code error "script error";
+ Log $slave $msg
+ return -code error "script error"
}
} else {
- set msg "wrong # args: should be \"encoding system\"";
- Log $slave $msg;
- error $msg;
+ set msg "wrong # args: should be \"encoding system\""
+ Log $slave $msg
+ error $msg
}
} else {
- set msg "wrong # args: should be \"encoding option ?arg ...?\"";
- Log $slave $msg;
- error $msg;
+ set msg "wrong # args: should be \"encoding option ?arg ...?\""
+ Log $slave $msg
+ error $msg
}
-
-
+
return $msg
}
diff --git a/library/word.tcl b/library/word.tcl
index 0c8d576..d0d8a60 100644
--- a/library/word.tcl
+++ b/library/word.tcl
@@ -10,12 +10,12 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: word.tcl,v 1.4 1999/04/16 00:46:57 stanton Exp $
+# RCS: @(#) $Id: word.tcl,v 1.5 1999/08/19 02:59:40 hobbs Exp $
# The following variables are used to determine which characters are
# interpreted as white space.
-if {$tcl_platform(platform) == "windows"} {
+if {[string equal $tcl_platform(platform) "windows"]} {
# Windows style - any but space, tab, or newline
set tcl_wordchars "\[^ \t\n\]"
set tcl_nonwordchars "\[ \t\n\]"
@@ -58,7 +58,7 @@ proc tcl_wordBreakAfter {str start} {
proc tcl_wordBreakBefore {str start} {
global tcl_nonwordchars tcl_wordchars
- if {[string compare $start end] == 0} {
+ if {[string equal $start end]} {
set start [string length $str]
}
if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} {
@@ -120,7 +120,7 @@ proc tcl_startOfNextWord {str start} {
proc tcl_startOfPreviousWord {str start} {
global tcl_nonwordchars tcl_wordchars
- if {[string compare $start end] == 0} {
+ if {[string equal $start end]} {
set start [string length $str]
}
if {[regexp -indices \
generated by cgit v0.12 at 2024-11-02 16:35:35 (GMT)