diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | generic/tclBasic.c | 6 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 41 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | generic/tclInterp.c | 68 | ||||
| -rw-r--r-- | library/init.tcl | 84 |
6 files changed, 105 insertions, 108 deletions
@@ -1,3 +1,12 @@ +2005-04-19 Don Porter <dgp@users.sourceforge.net> + + * generic/tclBasic.c: Added unsupported command + * generic/tclCmdAH.c: [::tcl::unsupported::EncodingDirs] to permit + * generic/tclInt.h: query/set of the encoding search path at + * generic/tclInterp.c: the script level. Updated init.tcl to make + * library/init.tcl: use of the new command. Also updated several + coding practices in init.tcl ("eq" for [string equal], etc.) + 2005-04-19 Kevin B. Kenny <kennykb@acm.org> * library/clock.tcl (Initialize): Put initialization code into a diff --git a/generic/tclBasic.c b/generic/tclBasic.c index be75a52..17da494 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.144 2005/04/10 23:07:36 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.145 2005/04/19 16:32:53 dgp Exp $ */ #include "tclInt.h" @@ -405,6 +405,10 @@ Tcl_CreateInterp() TclDefaultBgErrorHandlerObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL ); + /* Register the unsupported encoding search path command */ + Tcl_CreateObjCommand (interp, "::tcl::unsupported::EncodingDirs", + TclEncodingDirsObjCmd, NULL, NULL); + /* * Register the builtin math functions. */ diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 1ef0dcf..eb57690 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.59 2005/04/08 20:04:03 dgp Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.60 2005/04/19 16:32:55 dgp Exp $ */ #include "tclInt.h" @@ -530,6 +530,45 @@ Tcl_EncodingObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * TclEncodingDirsObjCmd -- + * + * This command manipulates the encoding search path. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Can set the encoding search path. + * + *---------------------------------------------------------------------- + */ + +int +TclEncodingDirsObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?dirList?"); + } + if (objc == 1) { + Tcl_SetObjResult(interp, TclGetEncodingSearchPath()); + return TCL_OK; + } + if (TclSetEncodingSearchPath(objv[1]) == TCL_ERROR) { + Tcl_AppendResult(interp, "expected directory list but got \"", + Tcl_GetString(objv[1]), "\"", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ErrorObjCmd -- * * This procedure is invoked to process the "error" Tcl command. diff --git a/generic/tclInt.h b/generic/tclInt.h index 13a266a..7777cfd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.222 2005/04/16 07:58:45 vasiljevic Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.223 2005/04/19 16:32:55 dgp Exp $ */ #ifndef _TCLINT @@ -2137,6 +2137,9 @@ MODULE_SCOPE int Tcl_DictObjCmd _ANSI_ARGS_((ClientData clientData, MODULE_SCOPE int Tcl_EncodingObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +MODULE_SCOPE int TclEncodingDirsObjCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); MODULE_SCOPE int Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 0a1e346..74d4006 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -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: tclInterp.c,v 1.57 2005/04/15 22:41:43 dgp Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.58 2005/04/19 16:32:56 dgp Exp $ */ #include "tclInt.h" @@ -298,10 +298,6 @@ int Tcl_Init(interp) Tcl_Interp *interp; /* Interpreter to initialize. */ { - int code; - Tcl_DString script, encodingName; - Tcl_Obj *path; - if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { return (TCL_ERROR); @@ -347,7 +343,7 @@ Tcl_Init(interp) * Note that this entire search mechanism can be bypassed by defining an * alternate tclInit procedure before calling Tcl_Init(). */ - code = Tcl_Eval(interp, + return Tcl_Eval(interp, "if {[info proc tclInit]==\"\"} {\n" " proc tclInit {} {\n" " global tcl_libPath tcl_library env tclDefaultLibrary\n" @@ -410,66 +406,6 @@ Tcl_Init(interp) " }\n" "}\n" "tclInit"); - - if (code != TCL_OK) { - return code; - } - - /* - * Now that [info library] is initialized, make sure that - * [file join [info library] encoding] is on the encoding - * search path. - * - * Relying on use of original built-in commands. - * Should be a safe assumption during interp initialization. - * More robust would be to use C-coded equivalents, but that's such - * a pain... - */ - - Tcl_DStringInit(&script); - Tcl_DStringAppend(&script, "lsearch -exact", -1); - path = Tcl_DuplicateObj(TclGetEncodingSearchPath()); - Tcl_IncrRefCount(path); - Tcl_DStringAppendElement(&script, Tcl_GetString(path)); - Tcl_DStringAppend(&script, " [file join [info library] encoding]", -1); - code = Tcl_EvalEx(interp, Tcl_DStringValue(&script), - Tcl_DStringLength(&script), TCL_EVAL_GLOBAL); - Tcl_DStringFree(&script); - if (code == TCL_OK) { - int index; - Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &index); - if (index != -1) { - /* [info library]/encoding already on the encoding search path */ - goto done; - } - } - Tcl_DStringInit(&script); - Tcl_DStringAppend(&script, "file join [info library] encoding", -1); - code = Tcl_EvalEx(interp, Tcl_DStringValue(&script), - Tcl_DStringLength(&script), TCL_EVAL_GLOBAL); - Tcl_DStringFree(&script); - if (code == TCL_OK) { - Tcl_ListObjAppendElement(NULL, path, Tcl_GetObjResult(interp)); - TclSetEncodingSearchPath(path); - } -done: - /* - * Now that we know the distributed *.enc files are on the encoding - * search path, check whether the [encoding system] matches that - * specified by the environment, and if not, attempt to correct it - */ - TclpGetEncodingNameFromEnvironment(&encodingName); - if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) { - code = Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName)); - if (code == TCL_ERROR) { - Tcl_Panic("system encoding \"%s\" not available", - Tcl_DStringValue(&encodingName)); - } - } - Tcl_DStringFree(&encodingName); - Tcl_DecrRefCount(path); - Tcl_ResetResult(interp); - return TCL_OK; } /* diff --git a/library/init.tcl b/library/init.tcl index 2f6e51c..a959beb 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.70 2005/04/15 15:50:35 dgp Exp $ +# RCS: @(#) $Id: init.tcl,v 1.71 2005/04/19 16:32:57 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -48,11 +48,9 @@ if {![info exists auto_path]} { } namespace eval tcl { variable Dir - if {$::tcl_library != ""} { - foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { - if {[lsearch -exact $::auto_path $Dir] < 0} { - lappend ::auto_path $Dir - } + foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { + if {[lsearch -exact $::auto_path $Dir] < 0} { + lappend ::auto_path $Dir } } set Dir [file join [file dirname [file dirname \ @@ -60,18 +58,25 @@ namespace eval tcl { if {[lsearch -exact $::auto_path $Dir] < 0} { lappend ::auto_path $Dir } - if {[info exists ::tcl_pkgPath]} { + catch { foreach Dir $::tcl_pkgPath { if {[lsearch -exact $::auto_path $Dir] < 0} { lappend ::auto_path $Dir } } } + + variable Path [unsupported::EncodingDirs] + set Dir [file join $::tcl_library encoding] + if {[lsearch -exact $Path $Dir] < 0} { + lappend Path $Dir + unsupported::EncodingDirs $Path + } } - + # Windows specific end of initialization -if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} { +if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { namespace eval tcl { proc EnvTraceProc {lo n1 n2 op} { set x $::env($n2) @@ -82,7 +87,7 @@ if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} { global env tcl_platform foreach p [array names env] { set u [string toupper $p] - if {![string equal $u $p]} { + if {$u ne $p]} { switch -- $u { COMSPEC - PATH { @@ -98,7 +103,7 @@ if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} { } } if {![info exists env(COMSPEC)]} { - if {[string equal $tcl_platform(os) "Windows NT"]} { + if {$tcl_platform(os) eq "Windows NT"} { set env(COMSPEC) cmd.exe } else { set env(COMSPEC) command.com @@ -111,16 +116,19 @@ if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} { # Setup the unknown package handler -package unknown tclPkgUnknown -if {![interp issafe]} { - # setup platform specific unknown package handlers - if {[string equal $::tcl_platform(platform) "unix"] && \ - [string equal $::tcl_platform(os) "Darwin"]} { - package unknown [list tcl::MacOSXPkgUnknown [package unknown]] - } +if {[interp issafe]} { + package unknown ::tclPkgUnknown +} else { # Set up search for Tcl Modules (TIP #189). - package unknown [list ::tcl::tm::UnknownHandler [package unknown]] + # and setup platform specific unknown package handlers + if {$::tcl_platform(os) eq "Darwin" + && $::tcl_platform(platform) eq "unix"} { + package unknown {::tcl::tm::UnknownHandler \ + {::tcl::MacOSXPkgUnknown ::tclPkgUnknown}} + } else { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} + } # Set up the 'clock' ensemble @@ -290,19 +298,19 @@ proc unknown args { } } - if {([info level] == 1) && [string equal [info script] ""] \ + if {([info level] == 1) && ([info script] eq "") \ && [info exists tcl_interactive] && $tcl_interactive} { if {![info exists auto_noexec]} { set new [auto_execok $name] if {$new != ""} { set redir "" - if {[string equal [info commands console] ""]} { + if {[info commands console] eq ""} { set redir ">&@stdout <@stdin" } return [uplevel 1 exec $redir $new [lrange $args 1 end]] } } - if {[string equal $name "!!"]} { + if {$name eq "!!"} { set newcmd [history event] } elseif {[regexp {^!(.+)$} $name dummy event]} { set newcmd [history event $event] @@ -317,7 +325,7 @@ proc unknown args { } set ret [catch {set candidates [info commands $name*]} msg] - if {[string equal $name "::"]} { + if {$name eq "::"} { set name "" } if {$ret != 0} { @@ -337,7 +345,7 @@ proc unknown args { return [uplevel 1 [lreplace $args 0 0 $cmds]] } if {[llength $cmds]} { - if {[string equal $name ""]} { + if {$name eq ""} { return -code error "empty command name \"\"" } else { return -code error \ @@ -416,8 +424,7 @@ proc auto_load_index {} { variable ::tcl::auto_oldpath global auto_index auto_path - if {[info exists auto_oldpath] && \ - [string equal $auto_oldpath $auto_path]} { + if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} { return 0 } set auto_oldpath $auto_path @@ -436,12 +443,11 @@ proc auto_load_index {} { } else { set error [catch { set id [gets $f] - if {[string equal $id \ - "# Tcl autoload index file, version 2.0"]} { + if {$id eq "# Tcl autoload index file, version 2.0"} { eval [read $f] - } elseif {[string equal $id "# Tcl autoload index file: each line identifies a Tcl"]} { + } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"]} { while {[gets $f line] >= 0} { - if {[string equal [string index $line 0] "#"] \ + if {([string index $line 0] eq "#") \ || ([llength $line] != 2)} { continue } @@ -506,14 +512,14 @@ proc auto_qualify {cmd namespace} { # (if the current namespace is not the global one) if {$n == 0} { - if {[string equal $namespace ::]} { + if {$namespace eq "::"} { # ( nocolons , :: ) -> nocolons return [list $cmd] } else { # ( nocolons , ::sub ) -> ::sub::nocolons nocolons return [list ${namespace}::$cmd $cmd] } - } elseif {[string equal $namespace ::]} { + } elseif {$namespace eq "::"} { # ( foo::bar , :: ) -> ::foo::bar return [list ::$cmd] } else { @@ -568,7 +574,7 @@ proc auto_import {pattern} { # Arguments: # name - Name of a command. -if {[string equal windows $tcl_platform(platform)]} { +if {$tcl_platform(platform) eq "windows"} { # Windows version. # # Note that info executable doesn't work under Windows, so we have to @@ -586,7 +592,7 @@ proc auto_execok name { set shellBuiltins [list cls copy date del erase dir echo mkdir \ md rename ren rmdir rd time type ver vol] - if {[string equal $tcl_platform(os) "Windows NT"]} { + if {$tcl_platform(os) eq "Windows NT"} { # NT includes the 'start' built-in lappend shellBuiltins "start" } @@ -623,7 +629,7 @@ proc auto_execok name { set windir $env(WINDIR) } if {[info exists windir]} { - if {[string equal $tcl_platform(os) "Windows NT"]} { + if {$tcl_platform(os) eq "Windows NT"} { append path "$windir/system32;" } append path "$windir/system;$windir;" @@ -637,7 +643,7 @@ proc auto_execok name { foreach dir [split $path {;}] { # Skip already checked directories - if {[info exists checked($dir)] || [string equal {} $dir]} { continue } + if {[info exists checked($dir)] || ($dir eq {})} { continue } set checked($dir) {} foreach ext $execExtensions { set file [file join $dir ${name}${ext}] @@ -666,7 +672,7 @@ proc auto_execok name { return $auto_execs($name) } foreach dir [split $env(PATH) :] { - if {[string equal $dir ""]} { + if {$dir eq ""} { set dir . } set file [file join $dir $name] @@ -698,7 +704,7 @@ proc tcl::CopyDirectory {action src dest} { set nsrc [file normalize $src] set ndest [file normalize $dest] - if {[string equal $action "renaming"]} { + if {$action eq "renaming"} { # Can't rename volumes. We could give a more precise # error message here, but that would break the test suite. if {[lsearch -exact [file volumes] $nsrc] != -1} { @@ -713,7 +719,7 @@ proc tcl::CopyDirectory {action src dest} { \"$dest\": trying to rename a volume or move a directory\ into itself" } - if {[string equal $action "copying"]} { + if {$action eq "copying"} { # We used to throw an error here, but, looking more closely # at the core copy code in tclFCmd.c, if the destination # exists, then we should only call this function if -force |